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-2020, 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 Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Debug_A; use Debug_A; 31with Einfo; use Einfo; 32with Errout; use Errout; 33with Expander; use Expander; 34with Exp_Ch6; use Exp_Ch6; 35with Exp_Ch7; use Exp_Ch7; 36with Exp_Disp; use Exp_Disp; 37with Exp_Tss; use Exp_Tss; 38with Exp_Util; use Exp_Util; 39with Freeze; use Freeze; 40with Ghost; use Ghost; 41with Inline; use Inline; 42with Itypes; use Itypes; 43with Lib; use Lib; 44with Lib.Xref; use Lib.Xref; 45with Namet; use Namet; 46with Nmake; use Nmake; 47with Nlists; use Nlists; 48with Opt; use Opt; 49with Output; use Output; 50with Par_SCO; use Par_SCO; 51with Restrict; use Restrict; 52with Rident; use Rident; 53with Rtsfind; use Rtsfind; 54with Sem; use Sem; 55with Sem_Aggr; use Sem_Aggr; 56with Sem_Attr; use Sem_Attr; 57with Sem_Aux; use Sem_Aux; 58with Sem_Cat; use Sem_Cat; 59with Sem_Ch3; use Sem_Ch3; 60with Sem_Ch4; use Sem_Ch4; 61with Sem_Ch6; use Sem_Ch6; 62with Sem_Ch8; use Sem_Ch8; 63with Sem_Ch13; use Sem_Ch13; 64with Sem_Dim; use Sem_Dim; 65with Sem_Disp; use Sem_Disp; 66with Sem_Dist; use Sem_Dist; 67with Sem_Elab; use Sem_Elab; 68with Sem_Elim; use Sem_Elim; 69with Sem_Eval; use Sem_Eval; 70with Sem_Intr; use Sem_Intr; 71with Sem_Mech; use Sem_Mech; 72with Sem_Type; use Sem_Type; 73with Sem_Util; use Sem_Util; 74with Sem_Warn; use Sem_Warn; 75with Sinfo; use Sinfo; 76with Sinfo.CN; use Sinfo.CN; 77with Snames; use Snames; 78with Stand; use Stand; 79with Stringt; use Stringt; 80with Style; use Style; 81with Targparm; use Targparm; 82with Tbuild; use Tbuild; 83with Uintp; use Uintp; 84with Urealp; use Urealp; 85 86package body Sem_Res is 87 88 ----------------------- 89 -- Local Subprograms -- 90 ----------------------- 91 92 -- Second pass (top-down) type checking and overload resolution procedures 93 -- Typ is the type required by context. These procedures propagate the 94 -- type information recursively to the descendants of N. If the node is not 95 -- overloaded, its Etype is established in the first pass. If overloaded, 96 -- the Resolve routines set the correct type. For arithmetic operators, the 97 -- Etype is the base type of the context. 98 99 -- Note that Resolve_Attribute is separated off in Sem_Attr 100 101 procedure Check_Discriminant_Use (N : Node_Id); 102 -- Enforce the restrictions on the use of discriminants when constraining 103 -- a component of a discriminated type (record or concurrent type). 104 105 procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id); 106 -- Given a node for an operator associated with type T, check that the 107 -- operator is visible. Operators all of whose operands are universal must 108 -- be checked for visibility during resolution because their type is not 109 -- determinable based on their operands. 110 111 procedure Check_Fully_Declared_Prefix 112 (Typ : Entity_Id; 113 Pref : Node_Id); 114 -- Check that the type of the prefix of a dereference is not incomplete 115 116 function Check_Infinite_Recursion (Call : Node_Id) return Boolean; 117 -- Given a call node, Call, which is known to occur immediately within the 118 -- subprogram being called, determines whether it is a detectable case of 119 -- an infinite recursion, and if so, outputs appropriate messages. Returns 120 -- True if an infinite recursion is detected, and False otherwise. 121 122 procedure Check_No_Direct_Boolean_Operators (N : Node_Id); 123 -- N is the node for a logical operator. If the operator is predefined, and 124 -- the root type of the operands is Standard.Boolean, then a check is made 125 -- for restriction No_Direct_Boolean_Operators. This procedure also handles 126 -- the style check for Style_Check_Boolean_And_Or. 127 128 function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean; 129 -- N is either an indexed component or a selected component. This function 130 -- returns true if the prefix refers to an object that has an address 131 -- clause (the case in which we may want to issue a warning). 132 133 function Is_Definite_Access_Type (E : Entity_Id) return Boolean; 134 -- Determine whether E is an access type declared by an access declaration, 135 -- and not an (anonymous) allocator type. 136 137 function Is_Predefined_Op (Nam : Entity_Id) return Boolean; 138 -- Utility to check whether the entity for an operator is a predefined 139 -- operator, in which case the expression is left as an operator in the 140 -- tree (else it is rewritten into a call). An instance of an intrinsic 141 -- conversion operation may be given an operator name, but is not treated 142 -- like an operator. Note that an operator that is an imported back-end 143 -- builtin has convention Intrinsic, but is expected to be rewritten into 144 -- a call, so such an operator is not treated as predefined by this 145 -- predicate. 146 147 procedure Preanalyze_And_Resolve 148 (N : Node_Id; 149 T : Entity_Id; 150 With_Freezing : Boolean); 151 -- Subsidiary of public versions of Preanalyze_And_Resolve. 152 153 procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); 154 -- If a default expression in entry call N depends on the discriminants 155 -- of the task, it must be replaced with a reference to the discriminant 156 -- of the task being called. 157 158 procedure Resolve_Op_Concat_Arg 159 (N : Node_Id; 160 Arg : Node_Id; 161 Typ : Entity_Id; 162 Is_Comp : Boolean); 163 -- Internal procedure for Resolve_Op_Concat to resolve one operand of 164 -- concatenation operator. The operand is either of the array type or of 165 -- the component type. If the operand is an aggregate, and the component 166 -- type is composite, this is ambiguous if component type has aggregates. 167 168 procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id); 169 -- Does the first part of the work of Resolve_Op_Concat 170 171 procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id); 172 -- Does the "rest" of the work of Resolve_Op_Concat, after the left operand 173 -- has been resolved. See Resolve_Op_Concat for details. 174 175 procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); 176 procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); 177 procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); 178 procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id); 179 procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); 180 procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); 181 procedure Resolve_Declare_Expression (N : Node_Id; Typ : Entity_Id); 182 procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); 183 procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); 184 procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); 185 procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id); 186 procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id); 187 procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id); 188 procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); 189 procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); 190 procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); 191 procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id); 192 procedure Resolve_Null (N : Node_Id; Typ : Entity_Id); 193 procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id); 194 procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id); 195 procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); 196 procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); 197 procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); 198 procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id); 199 procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); 200 procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); 201 procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); 202 procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id); 203 procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id); 204 procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id); 205 procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id); 206 procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id); 207 procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id); 208 procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id); 209 procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id); 210 procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id); 211 procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id); 212 213 function Operator_Kind 214 (Op_Name : Name_Id; 215 Is_Binary : Boolean) return Node_Kind; 216 -- Utility to map the name of an operator into the corresponding Node. Used 217 -- by other node rewriting procedures. 218 219 procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); 220 -- Resolve actuals of call, and add default expressions for missing ones. 221 -- N is the Node_Id for the subprogram call, and Nam is the entity of the 222 -- called subprogram. 223 224 procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id); 225 -- Called from Resolve_Call, when the prefix denotes an entry or element 226 -- of entry family. Actuals are resolved as for subprograms, and the node 227 -- is rebuilt as an entry call. Also called for protected operations. Typ 228 -- is the context type, which is used when the operation is a protected 229 -- function with no arguments, and the return value is indexed. 230 231 procedure Resolve_Implicit_Dereference (P : Node_Id); 232 -- Called when P is the prefix of an indexed component, or of a selected 233 -- component, or of a slice. If P is of an access type, we unconditionally 234 -- rewrite it as an explicit dereference. This ensures that the expander 235 -- and the code generator have a fully explicit tree to work with. 236 237 procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); 238 -- A call to a user-defined intrinsic operator is rewritten as a call to 239 -- the corresponding predefined operator, with suitable conversions. Note 240 -- that this applies only for intrinsic operators that denote predefined 241 -- operators, not ones that are intrinsic imports of back-end builtins. 242 243 procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); 244 -- Ditto, for arithmetic unary operators 245 246 procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); 247 -- If an operator node resolves to a call to a user-defined operator, 248 -- rewrite the node as a function call. 249 250 procedure Make_Call_Into_Operator 251 (N : Node_Id; 252 Typ : Entity_Id; 253 Op_Id : Entity_Id); 254 -- Inverse transformation: if an operator is given in functional notation, 255 -- then after resolving the node, transform into an operator node, so that 256 -- operands are resolved properly. Recall that predefined operators do not 257 -- have a full signature and special resolution rules apply. 258 259 procedure Rewrite_Renamed_Operator 260 (N : Node_Id; 261 Op : Entity_Id; 262 Typ : Entity_Id); 263 -- An operator can rename another, e.g. in an instantiation. In that 264 -- case, the proper operator node must be constructed and resolved. 265 266 procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); 267 -- The String_Literal_Subtype is built for all strings that are not 268 -- operands of a static concatenation operation. If the argument is not 269 -- a N_String_Literal node, then the call has no effect. 270 271 procedure Set_Slice_Subtype (N : Node_Id); 272 -- Build subtype of array type, with the range specified by the slice 273 274 procedure Simplify_Type_Conversion (N : Node_Id); 275 -- Called after N has been resolved and evaluated, but before range checks 276 -- have been applied. This rewrites the conversion into a simpler form. 277 278 function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; 279 -- A universal_fixed expression in an universal context is unambiguous if 280 -- there is only one applicable fixed point type. Determining whether there 281 -- is only one requires a search over all visible entities, and happens 282 -- only in very pathological cases (see 6115-006). 283 284 ------------------------- 285 -- Ambiguous_Character -- 286 ------------------------- 287 288 procedure Ambiguous_Character (C : Node_Id) is 289 E : Entity_Id; 290 291 begin 292 if Nkind (C) = N_Character_Literal then 293 Error_Msg_N ("ambiguous character literal", C); 294 295 -- First the ones in Standard 296 297 Error_Msg_N ("\\possible interpretation: Character!", C); 298 Error_Msg_N ("\\possible interpretation: Wide_Character!", C); 299 300 -- Include Wide_Wide_Character in Ada 2005 mode 301 302 if Ada_Version >= Ada_2005 then 303 Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C); 304 end if; 305 306 -- Now any other types that match 307 308 E := Current_Entity (C); 309 while Present (E) loop 310 Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E)); 311 E := Homonym (E); 312 end loop; 313 end if; 314 end Ambiguous_Character; 315 316 ------------------------- 317 -- Analyze_And_Resolve -- 318 ------------------------- 319 320 procedure Analyze_And_Resolve (N : Node_Id) is 321 begin 322 Analyze (N); 323 Resolve (N); 324 end Analyze_And_Resolve; 325 326 procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is 327 begin 328 Analyze (N); 329 Resolve (N, Typ); 330 end Analyze_And_Resolve; 331 332 -- Versions with check(s) suppressed 333 334 procedure Analyze_And_Resolve 335 (N : Node_Id; 336 Typ : Entity_Id; 337 Suppress : Check_Id) 338 is 339 Scop : constant Entity_Id := Current_Scope; 340 341 begin 342 if Suppress = All_Checks then 343 declare 344 Sva : constant Suppress_Array := Scope_Suppress.Suppress; 345 begin 346 Scope_Suppress.Suppress := (others => True); 347 Analyze_And_Resolve (N, Typ); 348 Scope_Suppress.Suppress := Sva; 349 end; 350 351 else 352 declare 353 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 354 begin 355 Scope_Suppress.Suppress (Suppress) := True; 356 Analyze_And_Resolve (N, Typ); 357 Scope_Suppress.Suppress (Suppress) := Svg; 358 end; 359 end if; 360 361 if Current_Scope /= Scop 362 and then Scope_Is_Transient 363 then 364 -- This can only happen if a transient scope was created for an inner 365 -- expression, which will be removed upon completion of the analysis 366 -- of an enclosing construct. The transient scope must have the 367 -- suppress status of the enclosing environment, not of this Analyze 368 -- call. 369 370 Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := 371 Scope_Suppress; 372 end if; 373 end Analyze_And_Resolve; 374 375 procedure Analyze_And_Resolve 376 (N : Node_Id; 377 Suppress : Check_Id) 378 is 379 Scop : constant Entity_Id := Current_Scope; 380 381 begin 382 if Suppress = All_Checks then 383 declare 384 Sva : constant Suppress_Array := Scope_Suppress.Suppress; 385 begin 386 Scope_Suppress.Suppress := (others => True); 387 Analyze_And_Resolve (N); 388 Scope_Suppress.Suppress := Sva; 389 end; 390 391 else 392 declare 393 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 394 begin 395 Scope_Suppress.Suppress (Suppress) := True; 396 Analyze_And_Resolve (N); 397 Scope_Suppress.Suppress (Suppress) := Svg; 398 end; 399 end if; 400 401 if Current_Scope /= Scop and then Scope_Is_Transient then 402 Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := 403 Scope_Suppress; 404 end if; 405 end Analyze_And_Resolve; 406 407 ---------------------------- 408 -- Check_Discriminant_Use -- 409 ---------------------------- 410 411 procedure Check_Discriminant_Use (N : Node_Id) is 412 PN : constant Node_Id := Parent (N); 413 Disc : constant Entity_Id := Entity (N); 414 P : Node_Id; 415 D : Node_Id; 416 417 begin 418 -- Any use in a spec-expression is legal 419 420 if In_Spec_Expression then 421 null; 422 423 elsif Nkind (PN) = N_Range then 424 425 -- Discriminant cannot be used to constrain a scalar type 426 427 P := Parent (PN); 428 429 if Nkind (P) = N_Range_Constraint 430 and then Nkind (Parent (P)) = N_Subtype_Indication 431 and then Nkind (Parent (Parent (P))) = N_Component_Definition 432 then 433 Error_Msg_N ("discriminant cannot constrain scalar type", N); 434 435 elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then 436 437 -- The following check catches the unusual case where a 438 -- discriminant appears within an index constraint that is part 439 -- of a larger expression within a constraint on a component, 440 -- e.g. "C : Int range 1 .. F (new A(1 .. D))". For now we only 441 -- check case of record components, and note that a similar check 442 -- should also apply in the case of discriminant constraints 443 -- below. ??? 444 445 -- Note that the check for N_Subtype_Declaration below is to 446 -- detect the valid use of discriminants in the constraints of a 447 -- subtype declaration when this subtype declaration appears 448 -- inside the scope of a record type (which is syntactically 449 -- illegal, but which may be created as part of derived type 450 -- processing for records). See Sem_Ch3.Build_Derived_Record_Type 451 -- for more info. 452 453 if Ekind (Current_Scope) = E_Record_Type 454 and then Scope (Disc) = Current_Scope 455 and then not 456 (Nkind (Parent (P)) = N_Subtype_Indication 457 and then 458 Nkind (Parent (Parent (P))) in N_Component_Definition 459 | N_Subtype_Declaration 460 and then Paren_Count (N) = 0) 461 then 462 Error_Msg_N 463 ("discriminant must appear alone in component constraint", N); 464 return; 465 end if; 466 467 -- Detect a common error: 468 469 -- type R (D : Positive := 100) is record 470 -- Name : String (1 .. D); 471 -- end record; 472 473 -- The default value causes an object of type R to be allocated 474 -- with room for Positive'Last characters. The RM does not mandate 475 -- the allocation of the maximum size, but that is what GNAT does 476 -- so we should warn the programmer that there is a problem. 477 478 Check_Large : declare 479 SI : Node_Id; 480 T : Entity_Id; 481 TB : Node_Id; 482 CB : Entity_Id; 483 484 function Large_Storage_Type (T : Entity_Id) return Boolean; 485 -- Return True if type T has a large enough range that any 486 -- array whose index type covered the whole range of the type 487 -- would likely raise Storage_Error. 488 489 ------------------------ 490 -- Large_Storage_Type -- 491 ------------------------ 492 493 function Large_Storage_Type (T : Entity_Id) return Boolean is 494 begin 495 -- The type is considered large if its bounds are known at 496 -- compile time and if it requires at least as many bits as 497 -- a Positive to store the possible values. 498 499 return Compile_Time_Known_Value (Type_Low_Bound (T)) 500 and then Compile_Time_Known_Value (Type_High_Bound (T)) 501 and then 502 Minimum_Size (T, Biased => True) >= 503 RM_Size (Standard_Positive); 504 end Large_Storage_Type; 505 506 -- Start of processing for Check_Large 507 508 begin 509 -- Check that the Disc has a large range 510 511 if not Large_Storage_Type (Etype (Disc)) then 512 goto No_Danger; 513 end if; 514 515 -- If the enclosing type is limited, we allocate only the 516 -- default value, not the maximum, and there is no need for 517 -- a warning. 518 519 if Is_Limited_Type (Scope (Disc)) then 520 goto No_Danger; 521 end if; 522 523 -- Check that it is the high bound 524 525 if N /= High_Bound (PN) 526 or else No (Discriminant_Default_Value (Disc)) 527 then 528 goto No_Danger; 529 end if; 530 531 -- Check the array allows a large range at this bound. First 532 -- find the array 533 534 SI := Parent (P); 535 536 if Nkind (SI) /= N_Subtype_Indication then 537 goto No_Danger; 538 end if; 539 540 T := Entity (Subtype_Mark (SI)); 541 542 if not Is_Array_Type (T) then 543 goto No_Danger; 544 end if; 545 546 -- Next, find the dimension 547 548 TB := First_Index (T); 549 CB := First (Constraints (P)); 550 while True 551 and then Present (TB) 552 and then Present (CB) 553 and then CB /= PN 554 loop 555 Next_Index (TB); 556 Next (CB); 557 end loop; 558 559 if CB /= PN then 560 goto No_Danger; 561 end if; 562 563 -- Now, check the dimension has a large range 564 565 if not Large_Storage_Type (Etype (TB)) then 566 goto No_Danger; 567 end if; 568 569 -- Warn about the danger 570 571 Error_Msg_N 572 ("??creation of & object may raise Storage_Error!", 573 Scope (Disc)); 574 575 <<No_Danger>> 576 null; 577 578 end Check_Large; 579 end if; 580 581 -- Legal case is in index or discriminant constraint 582 583 elsif Nkind (PN) in N_Index_Or_Discriminant_Constraint 584 | N_Discriminant_Association 585 then 586 if Paren_Count (N) > 0 then 587 Error_Msg_N 588 ("discriminant in constraint must appear alone", N); 589 590 elsif Nkind (N) = N_Expanded_Name 591 and then Comes_From_Source (N) 592 then 593 Error_Msg_N 594 ("discriminant must appear alone as a direct name", N); 595 end if; 596 597 return; 598 599 -- Otherwise, context is an expression. It should not be within (i.e. a 600 -- subexpression of) a constraint for a component. 601 602 else 603 D := PN; 604 P := Parent (PN); 605 while Nkind (P) not in 606 N_Component_Declaration | N_Subtype_Indication | N_Entry_Declaration 607 loop 608 D := P; 609 P := Parent (P); 610 exit when No (P); 611 end loop; 612 613 -- If the discriminant is used in an expression that is a bound of a 614 -- scalar type, an Itype is created and the bounds are attached to 615 -- its range, not to the original subtype indication. Such use is of 616 -- course a double fault. 617 618 if (Nkind (P) = N_Subtype_Indication 619 and then Nkind (Parent (P)) in N_Component_Definition 620 | N_Derived_Type_Definition 621 and then D = Constraint (P)) 622 623 -- The constraint itself may be given by a subtype indication, 624 -- rather than by a more common discrete range. 625 626 or else (Nkind (P) = N_Subtype_Indication 627 and then 628 Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) 629 or else Nkind (P) = N_Entry_Declaration 630 or else Nkind (D) = N_Defining_Identifier 631 then 632 Error_Msg_N 633 ("discriminant in constraint must appear alone", N); 634 end if; 635 end if; 636 end Check_Discriminant_Use; 637 638 -------------------------------- 639 -- Check_For_Visible_Operator -- 640 -------------------------------- 641 642 procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is 643 begin 644 if Is_Invisible_Operator (N, T) then 645 Error_Msg_NE -- CODEFIX 646 ("operator for} is not directly visible!", N, First_Subtype (T)); 647 Error_Msg_N -- CODEFIX 648 ("use clause would make operation legal!", N); 649 end if; 650 end Check_For_Visible_Operator; 651 652 ---------------------------------- 653 -- Check_Fully_Declared_Prefix -- 654 ---------------------------------- 655 656 procedure Check_Fully_Declared_Prefix 657 (Typ : Entity_Id; 658 Pref : Node_Id) 659 is 660 begin 661 -- Check that the designated type of the prefix of a dereference is 662 -- not an incomplete type. This cannot be done unconditionally, because 663 -- dereferences of private types are legal in default expressions. This 664 -- case is taken care of in Check_Fully_Declared, called below. There 665 -- are also 2005 cases where it is legal for the prefix to be unfrozen. 666 667 -- This consideration also applies to similar checks for allocators, 668 -- qualified expressions, and type conversions. 669 670 -- An additional exception concerns other per-object expressions that 671 -- are not directly related to component declarations, in particular 672 -- representation pragmas for tasks. These will be per-object 673 -- expressions if they depend on discriminants or some global entity. 674 -- If the task has access discriminants, the designated type may be 675 -- incomplete at the point the expression is resolved. This resolution 676 -- takes place within the body of the initialization procedure, where 677 -- the discriminant is replaced by its discriminal. 678 679 if Is_Entity_Name (Pref) 680 and then Ekind (Entity (Pref)) = E_In_Parameter 681 then 682 null; 683 684 -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages 685 -- are handled by Analyze_Access_Attribute, Analyze_Assignment, 686 -- Analyze_Object_Renaming, and Freeze_Entity. 687 688 elsif Ada_Version >= Ada_2005 689 and then Is_Entity_Name (Pref) 690 and then Is_Access_Type (Etype (Pref)) 691 and then Ekind (Directly_Designated_Type (Etype (Pref))) = 692 E_Incomplete_Type 693 and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref))) 694 then 695 null; 696 else 697 Check_Fully_Declared (Typ, Parent (Pref)); 698 end if; 699 end Check_Fully_Declared_Prefix; 700 701 ------------------------------ 702 -- Check_Infinite_Recursion -- 703 ------------------------------ 704 705 function Check_Infinite_Recursion (Call : Node_Id) return Boolean is 706 function Enclosing_Declaration_Or_Statement (N : Node_Id) return Node_Id; 707 -- Return the nearest enclosing declaration or statement that houses 708 -- arbitrary node N. 709 710 function Invoked_With_Different_Arguments (N : Node_Id) return Boolean; 711 -- Determine whether call N invokes the related enclosing subprogram 712 -- with actuals that differ from the subprogram's formals. 713 714 function Is_Conditional_Statement (N : Node_Id) return Boolean; 715 -- Determine whether arbitrary node N denotes a conditional construct 716 717 function Is_Control_Flow_Statement (N : Node_Id) return Boolean; 718 -- Determine whether arbitrary node N denotes a control flow statement 719 -- or a construct that may contains such a statement. 720 721 function Is_Immediately_Within_Body (N : Node_Id) return Boolean; 722 -- Determine whether arbitrary node N appears immediately within the 723 -- statements of an entry or subprogram body. 724 725 function Is_Raise_Idiom (N : Node_Id) return Boolean; 726 -- Determine whether arbitrary node N appears immediately within the 727 -- body of an entry or subprogram, and is preceded by a single raise 728 -- statement. 729 730 function Is_Raise_Statement (N : Node_Id) return Boolean; 731 -- Determine whether arbitrary node N denotes a raise statement 732 733 function Is_Sole_Statement (N : Node_Id) return Boolean; 734 -- Determine whether arbitrary node N is the sole source statement in 735 -- the body of the enclosing subprogram. 736 737 function Preceded_By_Control_Flow_Statement (N : Node_Id) return Boolean; 738 -- Determine whether arbitrary node N is preceded by a control flow 739 -- statement. 740 741 function Within_Conditional_Statement (N : Node_Id) return Boolean; 742 -- Determine whether arbitrary node N appears within a conditional 743 -- construct. 744 745 ---------------------------------------- 746 -- Enclosing_Declaration_Or_Statement -- 747 ---------------------------------------- 748 749 function Enclosing_Declaration_Or_Statement 750 (N : Node_Id) return Node_Id 751 is 752 Par : Node_Id; 753 754 begin 755 Par := N; 756 while Present (Par) loop 757 if Is_Declaration (Par) or else Is_Statement (Par) then 758 return Par; 759 760 -- Prevent the search from going too far 761 762 elsif Is_Body_Or_Package_Declaration (Par) then 763 exit; 764 end if; 765 766 Par := Parent (Par); 767 end loop; 768 769 return N; 770 end Enclosing_Declaration_Or_Statement; 771 772 -------------------------------------- 773 -- Invoked_With_Different_Arguments -- 774 -------------------------------------- 775 776 function Invoked_With_Different_Arguments (N : Node_Id) return Boolean is 777 Subp : constant Entity_Id := Entity (Name (N)); 778 779 Actual : Node_Id; 780 Formal : Entity_Id; 781 782 begin 783 -- Determine whether the formals of the invoked subprogram are not 784 -- used as actuals in the call. 785 786 Actual := First_Actual (Call); 787 Formal := First_Formal (Subp); 788 while Present (Actual) and then Present (Formal) loop 789 790 -- The current actual does not match the current formal 791 792 if not (Is_Entity_Name (Actual) 793 and then Entity (Actual) = Formal) 794 then 795 return True; 796 end if; 797 798 Next_Actual (Actual); 799 Next_Formal (Formal); 800 end loop; 801 802 return False; 803 end Invoked_With_Different_Arguments; 804 805 ------------------------------ 806 -- Is_Conditional_Statement -- 807 ------------------------------ 808 809 function Is_Conditional_Statement (N : Node_Id) return Boolean is 810 begin 811 return 812 Nkind (N) in N_And_Then 813 | N_Case_Expression 814 | N_Case_Statement 815 | N_If_Expression 816 | N_If_Statement 817 | N_Or_Else; 818 end Is_Conditional_Statement; 819 820 ------------------------------- 821 -- Is_Control_Flow_Statement -- 822 ------------------------------- 823 824 function Is_Control_Flow_Statement (N : Node_Id) return Boolean is 825 begin 826 -- It is assumed that all statements may affect the control flow in 827 -- some way. A raise statement may be expanded into a non-statement 828 -- node. 829 830 return Is_Statement (N) or else Is_Raise_Statement (N); 831 end Is_Control_Flow_Statement; 832 833 -------------------------------- 834 -- Is_Immediately_Within_Body -- 835 -------------------------------- 836 837 function Is_Immediately_Within_Body (N : Node_Id) return Boolean is 838 HSS : constant Node_Id := Parent (N); 839 840 begin 841 return 842 Nkind (HSS) = N_Handled_Sequence_Of_Statements 843 and then Nkind (Parent (HSS)) in N_Entry_Body | N_Subprogram_Body 844 and then Is_List_Member (N) 845 and then List_Containing (N) = Statements (HSS); 846 end Is_Immediately_Within_Body; 847 848 -------------------- 849 -- Is_Raise_Idiom -- 850 -------------------- 851 852 function Is_Raise_Idiom (N : Node_Id) return Boolean is 853 Raise_Stmt : Node_Id; 854 Stmt : Node_Id; 855 856 begin 857 if Is_Immediately_Within_Body (N) then 858 859 -- Assume that no raise statement has been seen yet 860 861 Raise_Stmt := Empty; 862 863 -- Examine the statements preceding the input node, skipping 864 -- internally-generated constructs. 865 866 Stmt := Prev (N); 867 while Present (Stmt) loop 868 869 -- Multiple raise statements violate the idiom 870 871 if Is_Raise_Statement (Stmt) then 872 if Present (Raise_Stmt) then 873 return False; 874 end if; 875 876 Raise_Stmt := Stmt; 877 878 elsif Comes_From_Source (Stmt) then 879 exit; 880 end if; 881 882 Stmt := Prev (Stmt); 883 end loop; 884 885 -- At this point the node must be preceded by a raise statement, 886 -- and the raise statement has to be the sole statement within 887 -- the enclosing entry or subprogram body. 888 889 return 890 Present (Raise_Stmt) and then Is_Sole_Statement (Raise_Stmt); 891 end if; 892 893 return False; 894 end Is_Raise_Idiom; 895 896 ------------------------ 897 -- Is_Raise_Statement -- 898 ------------------------ 899 900 function Is_Raise_Statement (N : Node_Id) return Boolean is 901 begin 902 -- A raise statement may be transfomed into a Raise_xxx_Error node 903 904 return 905 Nkind (N) = N_Raise_Statement 906 or else Nkind (N) in N_Raise_xxx_Error; 907 end Is_Raise_Statement; 908 909 ----------------------- 910 -- Is_Sole_Statement -- 911 ----------------------- 912 913 function Is_Sole_Statement (N : Node_Id) return Boolean is 914 Stmt : Node_Id; 915 916 begin 917 -- The input node appears within the statements of an entry or 918 -- subprogram body. Examine the statements preceding the node. 919 920 if Is_Immediately_Within_Body (N) then 921 Stmt := Prev (N); 922 923 while Present (Stmt) loop 924 925 -- The statement is preceded by another statement or a source 926 -- construct. This indicates that the node does not appear by 927 -- itself. 928 929 if Is_Control_Flow_Statement (Stmt) 930 or else Comes_From_Source (Stmt) 931 then 932 return False; 933 end if; 934 935 Stmt := Prev (Stmt); 936 end loop; 937 938 return True; 939 end if; 940 941 -- The input node is within a construct nested inside the entry or 942 -- subprogram body. 943 944 return False; 945 end Is_Sole_Statement; 946 947 ---------------------------------------- 948 -- Preceded_By_Control_Flow_Statement -- 949 ---------------------------------------- 950 951 function Preceded_By_Control_Flow_Statement 952 (N : Node_Id) return Boolean 953 is 954 Stmt : Node_Id; 955 956 begin 957 if Is_List_Member (N) then 958 Stmt := Prev (N); 959 960 -- Examine the statements preceding the input node 961 962 while Present (Stmt) loop 963 if Is_Control_Flow_Statement (Stmt) then 964 return True; 965 end if; 966 967 Stmt := Prev (Stmt); 968 end loop; 969 970 return False; 971 end if; 972 973 -- Assume that the node is part of some control flow statement 974 975 return True; 976 end Preceded_By_Control_Flow_Statement; 977 978 ---------------------------------- 979 -- Within_Conditional_Statement -- 980 ---------------------------------- 981 982 function Within_Conditional_Statement (N : Node_Id) return Boolean is 983 Stmt : Node_Id; 984 985 begin 986 Stmt := Parent (N); 987 while Present (Stmt) loop 988 if Is_Conditional_Statement (Stmt) then 989 return True; 990 991 -- Prevent the search from going too far 992 993 elsif Is_Body_Or_Package_Declaration (Stmt) then 994 exit; 995 end if; 996 997 Stmt := Parent (Stmt); 998 end loop; 999 1000 return False; 1001 end Within_Conditional_Statement; 1002 1003 -- Local variables 1004 1005 Call_Context : constant Node_Id := 1006 Enclosing_Declaration_Or_Statement (Call); 1007 1008 -- Start of processing for Check_Infinite_Recursion 1009 1010 begin 1011 -- The call is assumed to be safe when the enclosing subprogram is 1012 -- invoked with actuals other than its formals. 1013 -- 1014 -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is 1015 -- begin 1016 -- ... 1017 -- Proc (A1, A2, ..., AN); 1018 -- ... 1019 -- end Proc; 1020 1021 if Invoked_With_Different_Arguments (Call) then 1022 return False; 1023 1024 -- The call is assumed to be safe when the invocation of the enclosing 1025 -- subprogram depends on a conditional statement. 1026 -- 1027 -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is 1028 -- begin 1029 -- ... 1030 -- if Some_Condition then 1031 -- Proc (F1, F2, ..., FN); 1032 -- end if; 1033 -- ... 1034 -- end Proc; 1035 1036 elsif Within_Conditional_Statement (Call) then 1037 return False; 1038 1039 -- The context of the call is assumed to be safe when the invocation of 1040 -- the enclosing subprogram is preceded by some control flow statement. 1041 -- 1042 -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is 1043 -- begin 1044 -- ... 1045 -- if Some_Condition then 1046 -- ... 1047 -- end if; 1048 -- ... 1049 -- Proc (F1, F2, ..., FN); 1050 -- ... 1051 -- end Proc; 1052 1053 elsif Preceded_By_Control_Flow_Statement (Call_Context) then 1054 return False; 1055 1056 -- Detect an idiom where the context of the call is preceded by a single 1057 -- raise statement. 1058 -- 1059 -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is 1060 -- begin 1061 -- raise ...; 1062 -- Proc (F1, F2, ..., FN); 1063 -- end Proc; 1064 1065 elsif Is_Raise_Idiom (Call_Context) then 1066 return False; 1067 end if; 1068 1069 -- At this point it is certain that infinite recursion will take place 1070 -- as long as the call is executed. Detect a case where the context of 1071 -- the call is the sole source statement within the subprogram body. 1072 -- 1073 -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is 1074 -- begin 1075 -- Proc (F1, F2, ..., FN); 1076 -- end Proc; 1077 -- 1078 -- Install an explicit raise to prevent the infinite recursion. 1079 1080 if Is_Sole_Statement (Call_Context) then 1081 Error_Msg_Warn := SPARK_Mode /= On; 1082 Error_Msg_N ("!infinite recursion<<", Call); 1083 Error_Msg_N ("\!Storage_Error [<<", Call); 1084 1085 Insert_Action (Call, 1086 Make_Raise_Storage_Error (Sloc (Call), 1087 Reason => SE_Infinite_Recursion)); 1088 1089 -- Otherwise infinite recursion could take place, considering other flow 1090 -- control constructs such as gotos, exit statements, etc. 1091 1092 else 1093 Error_Msg_Warn := SPARK_Mode /= On; 1094 Error_Msg_N ("!possible infinite recursion<<", Call); 1095 Error_Msg_N ("\!??Storage_Error ]<<", Call); 1096 end if; 1097 1098 return True; 1099 end Check_Infinite_Recursion; 1100 1101 --------------------------------------- 1102 -- Check_No_Direct_Boolean_Operators -- 1103 --------------------------------------- 1104 1105 procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is 1106 begin 1107 if Scope (Entity (N)) = Standard_Standard 1108 and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean 1109 then 1110 -- Restriction only applies to original source code 1111 1112 if Comes_From_Source (N) then 1113 Check_Restriction (No_Direct_Boolean_Operators, N); 1114 end if; 1115 end if; 1116 1117 -- Do style check (but skip if in instance, error is on template) 1118 1119 if Style_Check then 1120 if not In_Instance then 1121 Check_Boolean_Operator (N); 1122 end if; 1123 end if; 1124 end Check_No_Direct_Boolean_Operators; 1125 1126 ------------------------------ 1127 -- Check_Parameterless_Call -- 1128 ------------------------------ 1129 1130 procedure Check_Parameterless_Call (N : Node_Id) is 1131 Nam : Node_Id; 1132 1133 function Prefix_Is_Access_Subp return Boolean; 1134 -- If the prefix is of an access_to_subprogram type, the node must be 1135 -- rewritten as a call. Ditto if the prefix is overloaded and all its 1136 -- interpretations are access to subprograms. 1137 1138 --------------------------- 1139 -- Prefix_Is_Access_Subp -- 1140 --------------------------- 1141 1142 function Prefix_Is_Access_Subp return Boolean is 1143 I : Interp_Index; 1144 It : Interp; 1145 1146 begin 1147 -- If the context is an attribute reference that can apply to 1148 -- functions, this is never a parameterless call (RM 4.1.4(6)). 1149 1150 if Nkind (Parent (N)) = N_Attribute_Reference 1151 and then Attribute_Name (Parent (N)) 1152 in Name_Address | Name_Code_Address | Name_Access 1153 then 1154 return False; 1155 end if; 1156 1157 if not Is_Overloaded (N) then 1158 return 1159 Ekind (Etype (N)) = E_Subprogram_Type 1160 and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type; 1161 else 1162 Get_First_Interp (N, I, It); 1163 while Present (It.Typ) loop 1164 if Ekind (It.Typ) /= E_Subprogram_Type 1165 or else Base_Type (Etype (It.Typ)) = Standard_Void_Type 1166 then 1167 return False; 1168 end if; 1169 1170 Get_Next_Interp (I, It); 1171 end loop; 1172 1173 return True; 1174 end if; 1175 end Prefix_Is_Access_Subp; 1176 1177 -- Start of processing for Check_Parameterless_Call 1178 1179 begin 1180 -- Defend against junk stuff if errors already detected 1181 1182 if Total_Errors_Detected /= 0 then 1183 if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then 1184 return; 1185 elsif Nkind (N) in N_Has_Chars 1186 and then not Is_Valid_Name (Chars (N)) 1187 then 1188 return; 1189 end if; 1190 1191 Require_Entity (N); 1192 end if; 1193 1194 -- If the context expects a value, and the name is a procedure, this is 1195 -- most likely a missing 'Access. Don't try to resolve the parameterless 1196 -- call, error will be caught when the outer call is analyzed. 1197 1198 if Is_Entity_Name (N) 1199 and then Ekind (Entity (N)) = E_Procedure 1200 and then not Is_Overloaded (N) 1201 and then 1202 Nkind (Parent (N)) in N_Parameter_Association 1203 | N_Function_Call 1204 | N_Procedure_Call_Statement 1205 then 1206 return; 1207 end if; 1208 1209 -- Rewrite as call if overloadable entity that is (or could be, in the 1210 -- overloaded case) a function call. If we know for sure that the entity 1211 -- is an enumeration literal, we do not rewrite it. 1212 1213 -- If the entity is the name of an operator, it cannot be a call because 1214 -- operators cannot have default parameters. In this case, this must be 1215 -- a string whose contents coincide with an operator name. Set the kind 1216 -- of the node appropriately. 1217 1218 if (Is_Entity_Name (N) 1219 and then Nkind (N) /= N_Operator_Symbol 1220 and then Is_Overloadable (Entity (N)) 1221 and then (Ekind (Entity (N)) /= E_Enumeration_Literal 1222 or else Is_Overloaded (N))) 1223 1224 -- Rewrite as call if it is an explicit dereference of an expression of 1225 -- a subprogram access type, and the subprogram type is not that of a 1226 -- procedure or entry. 1227 1228 or else 1229 (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp) 1230 1231 -- Rewrite as call if it is a selected component which is a function, 1232 -- this is the case of a call to a protected function (which may be 1233 -- overloaded with other protected operations). 1234 1235 or else 1236 (Nkind (N) = N_Selected_Component 1237 and then (Ekind (Entity (Selector_Name (N))) = E_Function 1238 or else 1239 (Ekind (Entity (Selector_Name (N))) in 1240 E_Entry | E_Procedure 1241 and then Is_Overloaded (Selector_Name (N))))) 1242 1243 -- If one of the above three conditions is met, rewrite as call. Apply 1244 -- the rewriting only once. 1245 1246 then 1247 if Nkind (Parent (N)) /= N_Function_Call 1248 or else N /= Name (Parent (N)) 1249 then 1250 1251 -- This may be a prefixed call that was not fully analyzed, e.g. 1252 -- an actual in an instance. 1253 1254 if Ada_Version >= Ada_2005 1255 and then Nkind (N) = N_Selected_Component 1256 and then Is_Dispatching_Operation (Entity (Selector_Name (N))) 1257 then 1258 Analyze_Selected_Component (N); 1259 1260 if Nkind (N) /= N_Selected_Component then 1261 return; 1262 end if; 1263 end if; 1264 1265 -- The node is the name of the parameterless call. Preserve its 1266 -- descendants, which may be complex expressions. 1267 1268 Nam := Relocate_Node (N); 1269 1270 -- If overloaded, overload set belongs to new copy 1271 1272 Save_Interps (N, Nam); 1273 1274 -- Change node to parameterless function call (note that the 1275 -- Parameter_Associations associations field is left set to Empty, 1276 -- its normal default value since there are no parameters) 1277 1278 Change_Node (N, N_Function_Call); 1279 Set_Name (N, Nam); 1280 Set_Sloc (N, Sloc (Nam)); 1281 Analyze_Call (N); 1282 end if; 1283 1284 elsif Nkind (N) = N_Parameter_Association then 1285 Check_Parameterless_Call (Explicit_Actual_Parameter (N)); 1286 1287 elsif Nkind (N) = N_Operator_Symbol then 1288 Change_Operator_Symbol_To_String_Literal (N); 1289 Set_Is_Overloaded (N, False); 1290 Set_Etype (N, Any_String); 1291 end if; 1292 end Check_Parameterless_Call; 1293 1294 -------------------------------- 1295 -- Is_Atomic_Ref_With_Address -- 1296 -------------------------------- 1297 1298 function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean is 1299 Pref : constant Node_Id := Prefix (N); 1300 1301 begin 1302 if not Is_Entity_Name (Pref) then 1303 return False; 1304 1305 else 1306 declare 1307 Pent : constant Entity_Id := Entity (Pref); 1308 Ptyp : constant Entity_Id := Etype (Pent); 1309 begin 1310 return not Is_Access_Type (Ptyp) 1311 and then (Is_Atomic (Ptyp) or else Is_Atomic (Pent)) 1312 and then Present (Address_Clause (Pent)); 1313 end; 1314 end if; 1315 end Is_Atomic_Ref_With_Address; 1316 1317 ----------------------------- 1318 -- Is_Definite_Access_Type -- 1319 ----------------------------- 1320 1321 function Is_Definite_Access_Type (E : Entity_Id) return Boolean is 1322 Btyp : constant Entity_Id := Base_Type (E); 1323 begin 1324 return Ekind (Btyp) = E_Access_Type 1325 or else (Ekind (Btyp) = E_Access_Subprogram_Type 1326 and then Comes_From_Source (Btyp)); 1327 end Is_Definite_Access_Type; 1328 1329 ---------------------- 1330 -- Is_Predefined_Op -- 1331 ---------------------- 1332 1333 function Is_Predefined_Op (Nam : Entity_Id) return Boolean is 1334 begin 1335 -- Predefined operators are intrinsic subprograms 1336 1337 if not Is_Intrinsic_Subprogram (Nam) then 1338 return False; 1339 end if; 1340 1341 -- A call to a back-end builtin is never a predefined operator 1342 1343 if Is_Imported (Nam) and then Present (Interface_Name (Nam)) then 1344 return False; 1345 end if; 1346 1347 return not Is_Generic_Instance (Nam) 1348 and then Chars (Nam) in Any_Operator_Name 1349 and then (No (Alias (Nam)) or else Is_Predefined_Op (Alias (Nam))); 1350 end Is_Predefined_Op; 1351 1352 ----------------------------- 1353 -- Make_Call_Into_Operator -- 1354 ----------------------------- 1355 1356 procedure Make_Call_Into_Operator 1357 (N : Node_Id; 1358 Typ : Entity_Id; 1359 Op_Id : Entity_Id) 1360 is 1361 Op_Name : constant Name_Id := Chars (Op_Id); 1362 Act1 : Node_Id := First_Actual (N); 1363 Act2 : Node_Id := Next_Actual (Act1); 1364 Error : Boolean := False; 1365 Func : constant Entity_Id := Entity (Name (N)); 1366 Is_Binary : constant Boolean := Present (Act2); 1367 Op_Node : Node_Id; 1368 Opnd_Type : Entity_Id := Empty; 1369 Orig_Type : Entity_Id := Empty; 1370 Pack : Entity_Id; 1371 1372 type Kind_Test is access function (E : Entity_Id) return Boolean; 1373 1374 function Operand_Type_In_Scope (S : Entity_Id) return Boolean; 1375 -- If the operand is not universal, and the operator is given by an 1376 -- expanded name, verify that the operand has an interpretation with a 1377 -- type defined in the given scope of the operator. 1378 1379 function Type_In_P (Test : Kind_Test) return Entity_Id; 1380 -- Find a type of the given class in package Pack that contains the 1381 -- operator. 1382 1383 --------------------------- 1384 -- Operand_Type_In_Scope -- 1385 --------------------------- 1386 1387 function Operand_Type_In_Scope (S : Entity_Id) return Boolean is 1388 Nod : constant Node_Id := Right_Opnd (Op_Node); 1389 I : Interp_Index; 1390 It : Interp; 1391 1392 begin 1393 if not Is_Overloaded (Nod) then 1394 return Scope (Base_Type (Etype (Nod))) = S; 1395 1396 else 1397 Get_First_Interp (Nod, I, It); 1398 while Present (It.Typ) loop 1399 if Scope (Base_Type (It.Typ)) = S then 1400 return True; 1401 end if; 1402 1403 Get_Next_Interp (I, It); 1404 end loop; 1405 1406 return False; 1407 end if; 1408 end Operand_Type_In_Scope; 1409 1410 --------------- 1411 -- Type_In_P -- 1412 --------------- 1413 1414 function Type_In_P (Test : Kind_Test) return Entity_Id is 1415 E : Entity_Id; 1416 1417 function In_Decl return Boolean; 1418 -- Verify that node is not part of the type declaration for the 1419 -- candidate type, which would otherwise be invisible. 1420 1421 ------------- 1422 -- In_Decl -- 1423 ------------- 1424 1425 function In_Decl return Boolean is 1426 Decl_Node : constant Node_Id := Parent (E); 1427 N2 : Node_Id; 1428 1429 begin 1430 N2 := N; 1431 1432 if Etype (E) = Any_Type then 1433 return True; 1434 1435 elsif No (Decl_Node) then 1436 return False; 1437 1438 else 1439 while Present (N2) 1440 and then Nkind (N2) /= N_Compilation_Unit 1441 loop 1442 if N2 = Decl_Node then 1443 return True; 1444 else 1445 N2 := Parent (N2); 1446 end if; 1447 end loop; 1448 1449 return False; 1450 end if; 1451 end In_Decl; 1452 1453 -- Start of processing for Type_In_P 1454 1455 begin 1456 -- If the context type is declared in the prefix package, this is the 1457 -- desired base type. 1458 1459 if Scope (Base_Type (Typ)) = Pack and then Test (Typ) then 1460 return Base_Type (Typ); 1461 1462 else 1463 E := First_Entity (Pack); 1464 while Present (E) loop 1465 if Test (E) and then not In_Decl then 1466 return E; 1467 end if; 1468 1469 Next_Entity (E); 1470 end loop; 1471 1472 return Empty; 1473 end if; 1474 end Type_In_P; 1475 1476 -- Start of processing for Make_Call_Into_Operator 1477 1478 begin 1479 Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N)); 1480 1481 -- Ensure that the corresponding operator has the same parent as the 1482 -- original call. This guarantees that parent traversals performed by 1483 -- the ABE mechanism succeed. 1484 1485 Set_Parent (Op_Node, Parent (N)); 1486 1487 -- Binary operator 1488 1489 if Is_Binary then 1490 Set_Left_Opnd (Op_Node, Relocate_Node (Act1)); 1491 Set_Right_Opnd (Op_Node, Relocate_Node (Act2)); 1492 Save_Interps (Act1, Left_Opnd (Op_Node)); 1493 Save_Interps (Act2, Right_Opnd (Op_Node)); 1494 Act1 := Left_Opnd (Op_Node); 1495 Act2 := Right_Opnd (Op_Node); 1496 1497 -- Unary operator 1498 1499 else 1500 Set_Right_Opnd (Op_Node, Relocate_Node (Act1)); 1501 Save_Interps (Act1, Right_Opnd (Op_Node)); 1502 Act1 := Right_Opnd (Op_Node); 1503 end if; 1504 1505 -- If the operator is denoted by an expanded name, and the prefix is 1506 -- not Standard, but the operator is a predefined one whose scope is 1507 -- Standard, then this is an implicit_operator, inserted as an 1508 -- interpretation by the procedure of the same name. This procedure 1509 -- overestimates the presence of implicit operators, because it does 1510 -- not examine the type of the operands. Verify now that the operand 1511 -- type appears in the given scope. If right operand is universal, 1512 -- check the other operand. In the case of concatenation, either 1513 -- argument can be the component type, so check the type of the result. 1514 -- If both arguments are literals, look for a type of the right kind 1515 -- defined in the given scope. This elaborate nonsense is brought to 1516 -- you courtesy of b33302a. The type itself must be frozen, so we must 1517 -- find the type of the proper class in the given scope. 1518 1519 -- A final wrinkle is the multiplication operator for fixed point types, 1520 -- which is defined in Standard only, and not in the scope of the 1521 -- fixed point type itself. 1522 1523 if Nkind (Name (N)) = N_Expanded_Name then 1524 Pack := Entity (Prefix (Name (N))); 1525 1526 -- If this is a package renaming, get renamed entity, which will be 1527 -- the scope of the operands if operaton is type-correct. 1528 1529 if Present (Renamed_Entity (Pack)) then 1530 Pack := Renamed_Entity (Pack); 1531 end if; 1532 1533 -- If the entity being called is defined in the given package, it is 1534 -- a renaming of a predefined operator, and known to be legal. 1535 1536 if Scope (Entity (Name (N))) = Pack 1537 and then Pack /= Standard_Standard 1538 then 1539 null; 1540 1541 -- Visibility does not need to be checked in an instance: if the 1542 -- operator was not visible in the generic it has been diagnosed 1543 -- already, else there is an implicit copy of it in the instance. 1544 1545 elsif In_Instance then 1546 null; 1547 1548 elsif Op_Name in Name_Op_Multiply | Name_Op_Divide 1549 and then Is_Fixed_Point_Type (Etype (Act1)) 1550 and then Is_Fixed_Point_Type (Etype (Act2)) 1551 then 1552 if Pack /= Standard_Standard then 1553 Error := True; 1554 end if; 1555 1556 -- Ada 2005 AI-420: Predefined equality on Universal_Access is 1557 -- available. 1558 1559 elsif Ada_Version >= Ada_2005 1560 and then Op_Name in Name_Op_Eq | Name_Op_Ne 1561 and then (Is_Anonymous_Access_Type (Etype (Act1)) 1562 or else Is_Anonymous_Access_Type (Etype (Act2))) 1563 then 1564 null; 1565 1566 else 1567 Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node))); 1568 1569 if Op_Name = Name_Op_Concat then 1570 Opnd_Type := Base_Type (Typ); 1571 1572 elsif (Scope (Opnd_Type) = Standard_Standard 1573 and then Is_Binary) 1574 or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference 1575 and then Is_Binary 1576 and then not Comes_From_Source (Opnd_Type)) 1577 then 1578 Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node))); 1579 end if; 1580 1581 if Scope (Opnd_Type) = Standard_Standard then 1582 1583 -- Verify that the scope contains a type that corresponds to 1584 -- the given literal. Optimize the case where Pack is Standard. 1585 1586 if Pack /= Standard_Standard then 1587 if Opnd_Type = Universal_Integer then 1588 Orig_Type := Type_In_P (Is_Integer_Type'Access); 1589 1590 elsif Opnd_Type = Universal_Real then 1591 Orig_Type := Type_In_P (Is_Real_Type'Access); 1592 1593 elsif Opnd_Type = Any_String then 1594 Orig_Type := Type_In_P (Is_String_Type'Access); 1595 1596 elsif Opnd_Type = Any_Access then 1597 Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); 1598 1599 elsif Opnd_Type = Any_Composite then 1600 Orig_Type := Type_In_P (Is_Composite_Type'Access); 1601 1602 if Present (Orig_Type) then 1603 if Has_Private_Component (Orig_Type) then 1604 Orig_Type := Empty; 1605 else 1606 Set_Etype (Act1, Orig_Type); 1607 1608 if Is_Binary then 1609 Set_Etype (Act2, Orig_Type); 1610 end if; 1611 end if; 1612 end if; 1613 1614 else 1615 Orig_Type := Empty; 1616 end if; 1617 1618 Error := No (Orig_Type); 1619 end if; 1620 1621 elsif Ekind (Opnd_Type) = E_Allocator_Type 1622 and then No (Type_In_P (Is_Definite_Access_Type'Access)) 1623 then 1624 Error := True; 1625 1626 -- If the type is defined elsewhere, and the operator is not 1627 -- defined in the given scope (by a renaming declaration, e.g.) 1628 -- then this is an error as well. If an extension of System is 1629 -- present, and the type may be defined there, Pack must be 1630 -- System itself. 1631 1632 elsif Scope (Opnd_Type) /= Pack 1633 and then Scope (Op_Id) /= Pack 1634 and then (No (System_Aux_Id) 1635 or else Scope (Opnd_Type) /= System_Aux_Id 1636 or else Pack /= Scope (System_Aux_Id)) 1637 then 1638 if not Is_Overloaded (Right_Opnd (Op_Node)) then 1639 Error := True; 1640 else 1641 Error := not Operand_Type_In_Scope (Pack); 1642 end if; 1643 1644 elsif Pack = Standard_Standard 1645 and then not Operand_Type_In_Scope (Standard_Standard) 1646 then 1647 Error := True; 1648 end if; 1649 end if; 1650 1651 if Error then 1652 Error_Msg_Node_2 := Pack; 1653 Error_Msg_NE 1654 ("& not declared in&", N, Selector_Name (Name (N))); 1655 Set_Etype (N, Any_Type); 1656 return; 1657 1658 -- Detect a mismatch between the context type and the result type 1659 -- in the named package, which is otherwise not detected if the 1660 -- operands are universal. Check is only needed if source entity is 1661 -- an operator, not a function that renames an operator. 1662 1663 elsif Nkind (Parent (N)) /= N_Type_Conversion 1664 and then Ekind (Entity (Name (N))) = E_Operator 1665 and then Is_Numeric_Type (Typ) 1666 and then not Is_Universal_Numeric_Type (Typ) 1667 and then Scope (Base_Type (Typ)) /= Pack 1668 and then not In_Instance 1669 then 1670 if Is_Fixed_Point_Type (Typ) 1671 and then Op_Name in Name_Op_Multiply | Name_Op_Divide 1672 then 1673 -- Already checked above 1674 1675 null; 1676 1677 -- Operator may be defined in an extension of System 1678 1679 elsif Present (System_Aux_Id) 1680 and then Present (Opnd_Type) 1681 and then Scope (Opnd_Type) = System_Aux_Id 1682 then 1683 null; 1684 1685 else 1686 -- Could we use Wrong_Type here??? (this would require setting 1687 -- Etype (N) to the actual type found where Typ was expected). 1688 1689 Error_Msg_NE ("expect }", N, Typ); 1690 end if; 1691 end if; 1692 end if; 1693 1694 Set_Chars (Op_Node, Op_Name); 1695 1696 if not Is_Private_Type (Etype (N)) then 1697 Set_Etype (Op_Node, Base_Type (Etype (N))); 1698 else 1699 Set_Etype (Op_Node, Etype (N)); 1700 end if; 1701 1702 -- If this is a call to a function that renames a predefined equality, 1703 -- the renaming declaration provides a type that must be used to 1704 -- resolve the operands. This must be done now because resolution of 1705 -- the equality node will not resolve any remaining ambiguity, and it 1706 -- assumes that the first operand is not overloaded. 1707 1708 if Op_Name in Name_Op_Eq | Name_Op_Ne 1709 and then Ekind (Func) = E_Function 1710 and then Is_Overloaded (Act1) 1711 then 1712 Resolve (Act1, Base_Type (Etype (First_Formal (Func)))); 1713 Resolve (Act2, Base_Type (Etype (First_Formal (Func)))); 1714 end if; 1715 1716 Set_Entity (Op_Node, Op_Id); 1717 Generate_Reference (Op_Id, N, ' '); 1718 1719 -- Do rewrite setting Comes_From_Source on the result if the original 1720 -- call came from source. Although it is not strictly the case that the 1721 -- operator as such comes from the source, logically it corresponds 1722 -- exactly to the function call in the source, so it should be marked 1723 -- this way (e.g. to make sure that validity checks work fine). 1724 1725 declare 1726 CS : constant Boolean := Comes_From_Source (N); 1727 begin 1728 Rewrite (N, Op_Node); 1729 Set_Comes_From_Source (N, CS); 1730 end; 1731 1732 -- If this is an arithmetic operator and the result type is private, 1733 -- the operands and the result must be wrapped in conversion to 1734 -- expose the underlying numeric type and expand the proper checks, 1735 -- e.g. on division. 1736 1737 if Is_Private_Type (Typ) then 1738 case Nkind (N) is 1739 when N_Op_Add 1740 | N_Op_Divide 1741 | N_Op_Expon 1742 | N_Op_Mod 1743 | N_Op_Multiply 1744 | N_Op_Rem 1745 | N_Op_Subtract 1746 => 1747 Resolve_Intrinsic_Operator (N, Typ); 1748 1749 when N_Op_Abs 1750 | N_Op_Minus 1751 | N_Op_Plus 1752 => 1753 Resolve_Intrinsic_Unary_Operator (N, Typ); 1754 1755 when others => 1756 Resolve (N, Typ); 1757 end case; 1758 else 1759 Resolve (N, Typ); 1760 end if; 1761 end Make_Call_Into_Operator; 1762 1763 ------------------- 1764 -- Operator_Kind -- 1765 ------------------- 1766 1767 function Operator_Kind 1768 (Op_Name : Name_Id; 1769 Is_Binary : Boolean) return Node_Kind 1770 is 1771 Kind : Node_Kind; 1772 1773 begin 1774 -- Use CASE statement or array??? 1775 1776 if Is_Binary then 1777 if Op_Name = Name_Op_And then 1778 Kind := N_Op_And; 1779 elsif Op_Name = Name_Op_Or then 1780 Kind := N_Op_Or; 1781 elsif Op_Name = Name_Op_Xor then 1782 Kind := N_Op_Xor; 1783 elsif Op_Name = Name_Op_Eq then 1784 Kind := N_Op_Eq; 1785 elsif Op_Name = Name_Op_Ne then 1786 Kind := N_Op_Ne; 1787 elsif Op_Name = Name_Op_Lt then 1788 Kind := N_Op_Lt; 1789 elsif Op_Name = Name_Op_Le then 1790 Kind := N_Op_Le; 1791 elsif Op_Name = Name_Op_Gt then 1792 Kind := N_Op_Gt; 1793 elsif Op_Name = Name_Op_Ge then 1794 Kind := N_Op_Ge; 1795 elsif Op_Name = Name_Op_Add then 1796 Kind := N_Op_Add; 1797 elsif Op_Name = Name_Op_Subtract then 1798 Kind := N_Op_Subtract; 1799 elsif Op_Name = Name_Op_Concat then 1800 Kind := N_Op_Concat; 1801 elsif Op_Name = Name_Op_Multiply then 1802 Kind := N_Op_Multiply; 1803 elsif Op_Name = Name_Op_Divide then 1804 Kind := N_Op_Divide; 1805 elsif Op_Name = Name_Op_Mod then 1806 Kind := N_Op_Mod; 1807 elsif Op_Name = Name_Op_Rem then 1808 Kind := N_Op_Rem; 1809 elsif Op_Name = Name_Op_Expon then 1810 Kind := N_Op_Expon; 1811 else 1812 raise Program_Error; 1813 end if; 1814 1815 -- Unary operators 1816 1817 else 1818 if Op_Name = Name_Op_Add then 1819 Kind := N_Op_Plus; 1820 elsif Op_Name = Name_Op_Subtract then 1821 Kind := N_Op_Minus; 1822 elsif Op_Name = Name_Op_Abs then 1823 Kind := N_Op_Abs; 1824 elsif Op_Name = Name_Op_Not then 1825 Kind := N_Op_Not; 1826 else 1827 raise Program_Error; 1828 end if; 1829 end if; 1830 1831 return Kind; 1832 end Operator_Kind; 1833 1834 ---------------------------- 1835 -- Preanalyze_And_Resolve -- 1836 ---------------------------- 1837 1838 procedure Preanalyze_And_Resolve 1839 (N : Node_Id; 1840 T : Entity_Id; 1841 With_Freezing : Boolean) 1842 is 1843 Save_Full_Analysis : constant Boolean := Full_Analysis; 1844 Save_Must_Not_Freeze : constant Boolean := Must_Not_Freeze (N); 1845 Save_Preanalysis_Count : constant Nat := 1846 Inside_Preanalysis_Without_Freezing; 1847 begin 1848 pragma Assert (Nkind (N) in N_Subexpr); 1849 1850 if not With_Freezing then 1851 Set_Must_Not_Freeze (N); 1852 Inside_Preanalysis_Without_Freezing := 1853 Inside_Preanalysis_Without_Freezing + 1; 1854 end if; 1855 1856 Full_Analysis := False; 1857 Expander_Mode_Save_And_Set (False); 1858 1859 -- Normally, we suppress all checks for this preanalysis. There is no 1860 -- point in processing them now, since they will be applied properly 1861 -- and in the proper location when the default expressions reanalyzed 1862 -- and reexpanded later on. We will also have more information at that 1863 -- point for possible suppression of individual checks. 1864 1865 -- However, in SPARK mode, most expansion is suppressed, and this 1866 -- later reanalysis and reexpansion may not occur. SPARK mode does 1867 -- require the setting of checking flags for proof purposes, so we 1868 -- do the SPARK preanalysis without suppressing checks. 1869 1870 -- This special handling for SPARK mode is required for example in the 1871 -- case of Ada 2012 constructs such as quantified expressions, which are 1872 -- expanded in two separate steps. 1873 1874 if GNATprove_Mode then 1875 Analyze_And_Resolve (N, T); 1876 else 1877 Analyze_And_Resolve (N, T, Suppress => All_Checks); 1878 end if; 1879 1880 Expander_Mode_Restore; 1881 Full_Analysis := Save_Full_Analysis; 1882 Set_Must_Not_Freeze (N, Save_Must_Not_Freeze); 1883 1884 if not With_Freezing then 1885 Inside_Preanalysis_Without_Freezing := 1886 Inside_Preanalysis_Without_Freezing - 1; 1887 end if; 1888 1889 pragma Assert 1890 (Inside_Preanalysis_Without_Freezing = Save_Preanalysis_Count); 1891 end Preanalyze_And_Resolve; 1892 1893 ---------------------------- 1894 -- Preanalyze_And_Resolve -- 1895 ---------------------------- 1896 1897 procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is 1898 begin 1899 Preanalyze_And_Resolve (N, T, With_Freezing => False); 1900 end Preanalyze_And_Resolve; 1901 1902 -- Version without context type 1903 1904 procedure Preanalyze_And_Resolve (N : Node_Id) is 1905 Save_Full_Analysis : constant Boolean := Full_Analysis; 1906 1907 begin 1908 Full_Analysis := False; 1909 Expander_Mode_Save_And_Set (False); 1910 1911 Analyze (N); 1912 Resolve (N, Etype (N), Suppress => All_Checks); 1913 1914 Expander_Mode_Restore; 1915 Full_Analysis := Save_Full_Analysis; 1916 end Preanalyze_And_Resolve; 1917 1918 ------------------------------------------ 1919 -- Preanalyze_With_Freezing_And_Resolve -- 1920 ------------------------------------------ 1921 1922 procedure Preanalyze_With_Freezing_And_Resolve 1923 (N : Node_Id; 1924 T : Entity_Id) 1925 is 1926 begin 1927 Preanalyze_And_Resolve (N, T, With_Freezing => True); 1928 end Preanalyze_With_Freezing_And_Resolve; 1929 1930 ---------------------------------- 1931 -- Replace_Actual_Discriminants -- 1932 ---------------------------------- 1933 1934 procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is 1935 Loc : constant Source_Ptr := Sloc (N); 1936 Tsk : Node_Id := Empty; 1937 1938 function Process_Discr (Nod : Node_Id) return Traverse_Result; 1939 -- Comment needed??? 1940 1941 ------------------- 1942 -- Process_Discr -- 1943 ------------------- 1944 1945 function Process_Discr (Nod : Node_Id) return Traverse_Result is 1946 Ent : Entity_Id; 1947 1948 begin 1949 if Nkind (Nod) = N_Identifier then 1950 Ent := Entity (Nod); 1951 1952 if Present (Ent) 1953 and then Ekind (Ent) = E_Discriminant 1954 then 1955 Rewrite (Nod, 1956 Make_Selected_Component (Loc, 1957 Prefix => New_Copy_Tree (Tsk, New_Sloc => Loc), 1958 Selector_Name => Make_Identifier (Loc, Chars (Ent)))); 1959 1960 Set_Etype (Nod, Etype (Ent)); 1961 end if; 1962 1963 end if; 1964 1965 return OK; 1966 end Process_Discr; 1967 1968 procedure Replace_Discrs is new Traverse_Proc (Process_Discr); 1969 1970 -- Start of processing for Replace_Actual_Discriminants 1971 1972 begin 1973 if Expander_Active then 1974 null; 1975 1976 -- Allow the replacement of concurrent discriminants in GNATprove even 1977 -- though this is a light expansion activity. Note that generic units 1978 -- are not modified. 1979 1980 elsif GNATprove_Mode and not Inside_A_Generic then 1981 null; 1982 1983 else 1984 return; 1985 end if; 1986 1987 if Nkind (Name (N)) = N_Selected_Component then 1988 Tsk := Prefix (Name (N)); 1989 1990 elsif Nkind (Name (N)) = N_Indexed_Component then 1991 Tsk := Prefix (Prefix (Name (N))); 1992 end if; 1993 1994 if Present (Tsk) then 1995 Replace_Discrs (Default); 1996 end if; 1997 end Replace_Actual_Discriminants; 1998 1999 ------------- 2000 -- Resolve -- 2001 ------------- 2002 2003 procedure Resolve (N : Node_Id; Typ : Entity_Id) is 2004 Ambiguous : Boolean := False; 2005 Ctx_Type : Entity_Id := Typ; 2006 Expr_Type : Entity_Id := Empty; -- prevent junk warning 2007 Err_Type : Entity_Id := Empty; 2008 Found : Boolean := False; 2009 From_Lib : Boolean; 2010 I : Interp_Index; 2011 I1 : Interp_Index := 0; -- prevent junk warning 2012 It : Interp; 2013 It1 : Interp; 2014 Seen : Entity_Id := Empty; -- prevent junk warning 2015 2016 function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean; 2017 -- Determine whether a node comes from a predefined library unit or 2018 -- Standard. 2019 2020 procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); 2021 -- Try and fix up a literal so that it matches its expected type. New 2022 -- literals are manufactured if necessary to avoid cascaded errors. 2023 2024 procedure Report_Ambiguous_Argument; 2025 -- Additional diagnostics when an ambiguous call has an ambiguous 2026 -- argument (typically a controlling actual). 2027 2028 procedure Resolution_Failed; 2029 -- Called when attempt at resolving current expression fails 2030 2031 ------------------------------------ 2032 -- Comes_From_Predefined_Lib_Unit -- 2033 ------------------------------------- 2034 2035 function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is 2036 begin 2037 return 2038 Sloc (Nod) = Standard_Location or else In_Predefined_Unit (Nod); 2039 end Comes_From_Predefined_Lib_Unit; 2040 2041 -------------------- 2042 -- Patch_Up_Value -- 2043 -------------------- 2044 2045 procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is 2046 begin 2047 if Nkind (N) = N_Integer_Literal and then Is_Real_Type (Typ) then 2048 Rewrite (N, 2049 Make_Real_Literal (Sloc (N), 2050 Realval => UR_From_Uint (Intval (N)))); 2051 Set_Etype (N, Universal_Real); 2052 Set_Is_Static_Expression (N); 2053 2054 elsif Nkind (N) = N_Real_Literal and then Is_Integer_Type (Typ) then 2055 Rewrite (N, 2056 Make_Integer_Literal (Sloc (N), 2057 Intval => UR_To_Uint (Realval (N)))); 2058 Set_Etype (N, Universal_Integer); 2059 Set_Is_Static_Expression (N); 2060 2061 elsif Nkind (N) = N_String_Literal 2062 and then Is_Character_Type (Typ) 2063 then 2064 Set_Character_Literal_Name (Char_Code (Character'Pos ('A'))); 2065 Rewrite (N, 2066 Make_Character_Literal (Sloc (N), 2067 Chars => Name_Find, 2068 Char_Literal_Value => 2069 UI_From_Int (Character'Pos ('A')))); 2070 Set_Etype (N, Any_Character); 2071 Set_Is_Static_Expression (N); 2072 2073 elsif Nkind (N) /= N_String_Literal and then Is_String_Type (Typ) then 2074 Rewrite (N, 2075 Make_String_Literal (Sloc (N), 2076 Strval => End_String)); 2077 2078 elsif Nkind (N) = N_Range then 2079 Patch_Up_Value (Low_Bound (N), Typ); 2080 Patch_Up_Value (High_Bound (N), Typ); 2081 end if; 2082 end Patch_Up_Value; 2083 2084 ------------------------------- 2085 -- Report_Ambiguous_Argument -- 2086 ------------------------------- 2087 2088 procedure Report_Ambiguous_Argument is 2089 Arg : constant Node_Id := First (Parameter_Associations (N)); 2090 I : Interp_Index; 2091 It : Interp; 2092 2093 begin 2094 if Nkind (Arg) = N_Function_Call 2095 and then Is_Entity_Name (Name (Arg)) 2096 and then Is_Overloaded (Name (Arg)) 2097 then 2098 Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg)); 2099 2100 -- Examine possible interpretations, and adapt the message 2101 -- for inherited subprograms declared by a type derivation. 2102 2103 Get_First_Interp (Name (Arg), I, It); 2104 while Present (It.Nam) loop 2105 Error_Msg_Sloc := Sloc (It.Nam); 2106 2107 if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then 2108 Error_Msg_N ("interpretation (inherited) #!", Arg); 2109 else 2110 Error_Msg_N ("interpretation #!", Arg); 2111 end if; 2112 2113 Get_Next_Interp (I, It); 2114 end loop; 2115 end if; 2116 2117 -- Additional message and hint if the ambiguity involves an Ada2020 2118 -- container aggregate. 2119 2120 Check_Ambiguous_Aggregate (N); 2121 end Report_Ambiguous_Argument; 2122 2123 ----------------------- 2124 -- Resolution_Failed -- 2125 ----------------------- 2126 2127 procedure Resolution_Failed is 2128 begin 2129 Patch_Up_Value (N, Typ); 2130 2131 -- Set the type to the desired one to minimize cascaded errors. Note 2132 -- that this is an approximation and does not work in all cases. 2133 2134 Set_Etype (N, Typ); 2135 2136 Debug_A_Exit ("resolving ", N, " (done, resolution failed)"); 2137 Set_Is_Overloaded (N, False); 2138 2139 -- The caller will return without calling the expander, so we need 2140 -- to set the analyzed flag. Note that it is fine to set Analyzed 2141 -- to True even if we are in the middle of a shallow analysis, 2142 -- (see the spec of sem for more details) since this is an error 2143 -- situation anyway, and there is no point in repeating the 2144 -- analysis later (indeed it won't work to repeat it later, since 2145 -- we haven't got a clear resolution of which entity is being 2146 -- referenced.) 2147 2148 Set_Analyzed (N, True); 2149 return; 2150 end Resolution_Failed; 2151 2152 Literal_Aspect_Map : 2153 constant array (N_Numeric_Or_String_Literal) of Aspect_Id := 2154 (N_Integer_Literal => Aspect_Integer_Literal, 2155 N_Real_Literal => Aspect_Real_Literal, 2156 N_String_Literal => Aspect_String_Literal); 2157 2158 Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id := 2159 (E_Named_Integer => Aspect_Integer_Literal, 2160 E_Named_Real => Aspect_Real_Literal); 2161 2162 -- Start of processing for Resolve 2163 2164 begin 2165 if N = Error then 2166 return; 2167 end if; 2168 2169 -- Access attribute on remote subprogram cannot be used for a non-remote 2170 -- access-to-subprogram type. 2171 2172 if Nkind (N) = N_Attribute_Reference 2173 and then Attribute_Name (N) in Name_Access 2174 | Name_Unrestricted_Access 2175 | Name_Unchecked_Access 2176 and then Comes_From_Source (N) 2177 and then Is_Entity_Name (Prefix (N)) 2178 and then Is_Subprogram (Entity (Prefix (N))) 2179 and then Is_Remote_Call_Interface (Entity (Prefix (N))) 2180 and then not Is_Remote_Access_To_Subprogram_Type (Typ) 2181 then 2182 Error_Msg_N 2183 ("prefix must statically denote a non-remote subprogram", N); 2184 end if; 2185 2186 From_Lib := Comes_From_Predefined_Lib_Unit (N); 2187 2188 -- If the context is a Remote_Access_To_Subprogram, access attributes 2189 -- must be resolved with the corresponding fat pointer. There is no need 2190 -- to check for the attribute name since the return type of an 2191 -- attribute is never a remote type. 2192 2193 if Nkind (N) = N_Attribute_Reference 2194 and then Comes_From_Source (N) 2195 and then (Is_Remote_Call_Interface (Typ) or else Is_Remote_Types (Typ)) 2196 then 2197 declare 2198 Attr : constant Attribute_Id := 2199 Get_Attribute_Id (Attribute_Name (N)); 2200 Pref : constant Node_Id := Prefix (N); 2201 Decl : Node_Id; 2202 Spec : Node_Id; 2203 Is_Remote : Boolean := True; 2204 2205 begin 2206 -- Check that Typ is a remote access-to-subprogram type 2207 2208 if Is_Remote_Access_To_Subprogram_Type (Typ) then 2209 2210 -- Prefix (N) must statically denote a remote subprogram 2211 -- declared in a package specification. 2212 2213 if Attr = Attribute_Access or else 2214 Attr = Attribute_Unchecked_Access or else 2215 Attr = Attribute_Unrestricted_Access 2216 then 2217 Decl := Unit_Declaration_Node (Entity (Pref)); 2218 2219 if Nkind (Decl) = N_Subprogram_Body then 2220 Spec := Corresponding_Spec (Decl); 2221 2222 if Present (Spec) then 2223 Decl := Unit_Declaration_Node (Spec); 2224 end if; 2225 end if; 2226 2227 Spec := Parent (Decl); 2228 2229 if not Is_Entity_Name (Prefix (N)) 2230 or else Nkind (Spec) /= N_Package_Specification 2231 or else 2232 not Is_Remote_Call_Interface (Defining_Entity (Spec)) 2233 then 2234 Is_Remote := False; 2235 Error_Msg_N 2236 ("prefix must statically denote a remote subprogram ", 2237 N); 2238 end if; 2239 2240 -- If we are generating code in distributed mode, perform 2241 -- semantic checks against corresponding remote entities. 2242 2243 if Expander_Active 2244 and then Get_PCS_Name /= Name_No_DSA 2245 then 2246 Check_Subtype_Conformant 2247 (New_Id => Entity (Prefix (N)), 2248 Old_Id => Designated_Type 2249 (Corresponding_Remote_Type (Typ)), 2250 Err_Loc => N); 2251 2252 if Is_Remote then 2253 Process_Remote_AST_Attribute (N, Typ); 2254 end if; 2255 end if; 2256 end if; 2257 end if; 2258 end; 2259 end if; 2260 2261 Debug_A_Entry ("resolving ", N); 2262 2263 if Debug_Flag_V then 2264 Write_Overloads (N); 2265 end if; 2266 2267 if Comes_From_Source (N) then 2268 if Is_Fixed_Point_Type (Typ) then 2269 Check_Restriction (No_Fixed_Point, N); 2270 2271 elsif Is_Floating_Point_Type (Typ) 2272 and then Typ /= Universal_Real 2273 and then Typ /= Any_Real 2274 then 2275 Check_Restriction (No_Floating_Point, N); 2276 end if; 2277 end if; 2278 2279 -- Return if already analyzed 2280 2281 if Analyzed (N) then 2282 Debug_A_Exit ("resolving ", N, " (done, already analyzed)"); 2283 Analyze_Dimension (N); 2284 return; 2285 2286 -- Any case of Any_Type as the Etype value means that we had a 2287 -- previous error. 2288 2289 elsif Etype (N) = Any_Type then 2290 Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)"); 2291 return; 2292 end if; 2293 2294 Check_Parameterless_Call (N); 2295 2296 -- The resolution of an Expression_With_Actions is determined by 2297 -- its Expression, but if the node comes from source it is a 2298 -- Declare_Expression and requires scope management. 2299 2300 if Nkind (N) = N_Expression_With_Actions then 2301 if Comes_From_Source (N) and then N = Original_Node (N) then 2302 Resolve_Declare_Expression (N, Typ); 2303 else 2304 Resolve (Expression (N), Typ); 2305 end if; 2306 2307 Found := True; 2308 Expr_Type := Etype (Expression (N)); 2309 2310 -- If not overloaded, then we know the type, and all that needs doing 2311 -- is to check that this type is compatible with the context. 2312 2313 elsif not Is_Overloaded (N) then 2314 Found := Covers (Typ, Etype (N)); 2315 Expr_Type := Etype (N); 2316 2317 -- In the overloaded case, we must select the interpretation that 2318 -- is compatible with the context (i.e. the type passed to Resolve) 2319 2320 else 2321 -- Loop through possible interpretations 2322 2323 Get_First_Interp (N, I, It); 2324 Interp_Loop : while Present (It.Typ) loop 2325 if Debug_Flag_V then 2326 Write_Str ("Interp: "); 2327 Write_Interp (It); 2328 end if; 2329 2330 -- We are only interested in interpretations that are compatible 2331 -- with the expected type, any other interpretations are ignored. 2332 2333 if not Covers (Typ, It.Typ) then 2334 if Debug_Flag_V then 2335 Write_Str (" interpretation incompatible with context"); 2336 Write_Eol; 2337 end if; 2338 2339 else 2340 -- Skip the current interpretation if it is disabled by an 2341 -- abstract operator. This action is performed only when the 2342 -- type against which we are resolving is the same as the 2343 -- type of the interpretation. 2344 2345 if Ada_Version >= Ada_2005 2346 and then It.Typ = Typ 2347 and then Typ /= Universal_Integer 2348 and then Typ /= Universal_Real 2349 and then Present (It.Abstract_Op) 2350 then 2351 if Debug_Flag_V then 2352 Write_Line ("Skip."); 2353 end if; 2354 2355 goto Continue; 2356 end if; 2357 2358 -- First matching interpretation 2359 2360 if not Found then 2361 Found := True; 2362 I1 := I; 2363 Seen := It.Nam; 2364 Expr_Type := It.Typ; 2365 2366 -- Matching interpretation that is not the first, maybe an 2367 -- error, but there are some cases where preference rules are 2368 -- used to choose between the two possibilities. These and 2369 -- some more obscure cases are handled in Disambiguate. 2370 2371 else 2372 -- If the current statement is part of a predefined library 2373 -- unit, then all interpretations which come from user level 2374 -- packages should not be considered. Check previous and 2375 -- current one. 2376 2377 if From_Lib then 2378 if not Comes_From_Predefined_Lib_Unit (It.Nam) then 2379 goto Continue; 2380 2381 elsif not Comes_From_Predefined_Lib_Unit (Seen) then 2382 2383 -- Previous interpretation must be discarded 2384 2385 I1 := I; 2386 Seen := It.Nam; 2387 Expr_Type := It.Typ; 2388 Set_Entity (N, Seen); 2389 goto Continue; 2390 end if; 2391 end if; 2392 2393 -- Otherwise apply further disambiguation steps 2394 2395 Error_Msg_Sloc := Sloc (Seen); 2396 It1 := Disambiguate (N, I1, I, Typ); 2397 2398 -- Disambiguation has succeeded. Skip the remaining 2399 -- interpretations. 2400 2401 if It1 /= No_Interp then 2402 Seen := It1.Nam; 2403 Expr_Type := It1.Typ; 2404 2405 while Present (It.Typ) loop 2406 Get_Next_Interp (I, It); 2407 end loop; 2408 2409 else 2410 -- Before we issue an ambiguity complaint, check for the 2411 -- case of a subprogram call where at least one of the 2412 -- arguments is Any_Type, and if so suppress the message, 2413 -- since it is a cascaded error. This can also happen for 2414 -- a generalized indexing operation. 2415 2416 if Nkind (N) in N_Subprogram_Call 2417 or else (Nkind (N) = N_Indexed_Component 2418 and then Present (Generalized_Indexing (N))) 2419 then 2420 declare 2421 A : Node_Id; 2422 E : Node_Id; 2423 2424 begin 2425 if Nkind (N) = N_Indexed_Component then 2426 Rewrite (N, Generalized_Indexing (N)); 2427 end if; 2428 2429 A := First_Actual (N); 2430 while Present (A) loop 2431 E := A; 2432 2433 if Nkind (E) = N_Parameter_Association then 2434 E := Explicit_Actual_Parameter (E); 2435 end if; 2436 2437 if Etype (E) = Any_Type then 2438 if Debug_Flag_V then 2439 Write_Str ("Any_Type in call"); 2440 Write_Eol; 2441 end if; 2442 2443 exit Interp_Loop; 2444 end if; 2445 2446 Next_Actual (A); 2447 end loop; 2448 end; 2449 2450 elsif Nkind (N) in N_Binary_Op 2451 and then (Etype (Left_Opnd (N)) = Any_Type 2452 or else Etype (Right_Opnd (N)) = Any_Type) 2453 then 2454 exit Interp_Loop; 2455 2456 elsif Nkind (N) in N_Unary_Op 2457 and then Etype (Right_Opnd (N)) = Any_Type 2458 then 2459 exit Interp_Loop; 2460 end if; 2461 2462 -- Not that special case, so issue message using the flag 2463 -- Ambiguous to control printing of the header message 2464 -- only at the start of an ambiguous set. 2465 2466 if not Ambiguous then 2467 if Nkind (N) = N_Function_Call 2468 and then Nkind (Name (N)) = N_Explicit_Dereference 2469 then 2470 Error_Msg_N 2471 ("ambiguous expression (cannot resolve indirect " 2472 & "call)!", N); 2473 else 2474 Error_Msg_NE -- CODEFIX 2475 ("ambiguous expression (cannot resolve&)!", 2476 N, It.Nam); 2477 end if; 2478 2479 Ambiguous := True; 2480 2481 if Nkind (Parent (Seen)) = N_Full_Type_Declaration then 2482 Error_Msg_N 2483 ("\\possible interpretation (inherited)#!", N); 2484 else 2485 Error_Msg_N -- CODEFIX 2486 ("\\possible interpretation#!", N); 2487 end if; 2488 2489 if Nkind (N) in N_Subprogram_Call 2490 and then Present (Parameter_Associations (N)) 2491 then 2492 Report_Ambiguous_Argument; 2493 end if; 2494 end if; 2495 2496 Error_Msg_Sloc := Sloc (It.Nam); 2497 2498 -- By default, the error message refers to the candidate 2499 -- interpretation. But if it is a predefined operator, it 2500 -- is implicitly declared at the declaration of the type 2501 -- of the operand. Recover the sloc of that declaration 2502 -- for the error message. 2503 2504 if Nkind (N) in N_Op 2505 and then Scope (It.Nam) = Standard_Standard 2506 and then not Is_Overloaded (Right_Opnd (N)) 2507 and then Scope (Base_Type (Etype (Right_Opnd (N)))) /= 2508 Standard_Standard 2509 then 2510 Err_Type := First_Subtype (Etype (Right_Opnd (N))); 2511 2512 if Comes_From_Source (Err_Type) 2513 and then Present (Parent (Err_Type)) 2514 then 2515 Error_Msg_Sloc := Sloc (Parent (Err_Type)); 2516 end if; 2517 2518 elsif Nkind (N) in N_Binary_Op 2519 and then Scope (It.Nam) = Standard_Standard 2520 and then not Is_Overloaded (Left_Opnd (N)) 2521 and then Scope (Base_Type (Etype (Left_Opnd (N)))) /= 2522 Standard_Standard 2523 then 2524 Err_Type := First_Subtype (Etype (Left_Opnd (N))); 2525 2526 if Comes_From_Source (Err_Type) 2527 and then Present (Parent (Err_Type)) 2528 then 2529 Error_Msg_Sloc := Sloc (Parent (Err_Type)); 2530 end if; 2531 2532 -- If this is an indirect call, use the subprogram_type 2533 -- in the message, to have a meaningful location. Also 2534 -- indicate if this is an inherited operation, created 2535 -- by a type declaration. 2536 2537 elsif Nkind (N) = N_Function_Call 2538 and then Nkind (Name (N)) = N_Explicit_Dereference 2539 and then Is_Type (It.Nam) 2540 then 2541 Err_Type := It.Nam; 2542 Error_Msg_Sloc := 2543 Sloc (Associated_Node_For_Itype (Err_Type)); 2544 else 2545 Err_Type := Empty; 2546 end if; 2547 2548 if Nkind (N) in N_Op 2549 and then Scope (It.Nam) = Standard_Standard 2550 and then Present (Err_Type) 2551 then 2552 -- Special-case the message for universal_fixed 2553 -- operators, which are not declared with the type 2554 -- of the operand, but appear forever in Standard. 2555 2556 if It.Typ = Universal_Fixed 2557 and then Scope (It.Nam) = Standard_Standard 2558 then 2559 Error_Msg_N 2560 ("\\possible interpretation as universal_fixed " 2561 & "operation (RM 4.5.5 (19))", N); 2562 else 2563 Error_Msg_N 2564 ("\\possible interpretation (predefined)#!", N); 2565 end if; 2566 2567 elsif 2568 Nkind (Parent (It.Nam)) = N_Full_Type_Declaration 2569 then 2570 Error_Msg_N 2571 ("\\possible interpretation (inherited)#!", N); 2572 else 2573 Error_Msg_N -- CODEFIX 2574 ("\\possible interpretation#!", N); 2575 end if; 2576 2577 end if; 2578 end if; 2579 2580 -- We have a matching interpretation, Expr_Type is the type 2581 -- from this interpretation, and Seen is the entity. 2582 2583 -- For an operator, just set the entity name. The type will be 2584 -- set by the specific operator resolution routine. 2585 2586 if Nkind (N) in N_Op then 2587 Set_Entity (N, Seen); 2588 Generate_Reference (Seen, N); 2589 2590 elsif Nkind (N) in N_Case_Expression 2591 | N_Character_Literal 2592 | N_Delta_Aggregate 2593 | N_If_Expression 2594 then 2595 Set_Etype (N, Expr_Type); 2596 2597 -- AI05-0139-2: Expression is overloaded because type has 2598 -- implicit dereference. The context may be the one that 2599 -- requires implicit dereferemce. 2600 2601 elsif Has_Implicit_Dereference (Expr_Type) then 2602 Set_Etype (N, Expr_Type); 2603 Set_Is_Overloaded (N, False); 2604 2605 -- If the expression is an entity, generate a reference 2606 -- to it, as this is not done for an overloaded construct 2607 -- during analysis. 2608 2609 if Is_Entity_Name (N) 2610 and then Comes_From_Source (N) 2611 then 2612 Generate_Reference (Entity (N), N); 2613 2614 -- Examine access discriminants of entity type, 2615 -- to check whether one of them yields the 2616 -- expected type. 2617 2618 declare 2619 Disc : Entity_Id := 2620 First_Discriminant (Etype (Entity (N))); 2621 2622 begin 2623 while Present (Disc) loop 2624 exit when Is_Access_Type (Etype (Disc)) 2625 and then Has_Implicit_Dereference (Disc) 2626 and then Designated_Type (Etype (Disc)) = Typ; 2627 2628 Next_Discriminant (Disc); 2629 end loop; 2630 2631 if Present (Disc) then 2632 Build_Explicit_Dereference (N, Disc); 2633 end if; 2634 end; 2635 end if; 2636 2637 exit Interp_Loop; 2638 2639 elsif Is_Overloaded (N) 2640 and then Present (It.Nam) 2641 and then Ekind (It.Nam) = E_Discriminant 2642 and then Has_Implicit_Dereference (It.Nam) 2643 then 2644 -- If the node is a general indexing, the dereference is 2645 -- is inserted when resolving the rewritten form, else 2646 -- insert it now. 2647 2648 if Nkind (N) /= N_Indexed_Component 2649 or else No (Generalized_Indexing (N)) 2650 then 2651 Build_Explicit_Dereference (N, It.Nam); 2652 end if; 2653 2654 -- For an explicit dereference, attribute reference, range, 2655 -- short-circuit form (which is not an operator node), or call 2656 -- with a name that is an explicit dereference, there is 2657 -- nothing to be done at this point. 2658 2659 elsif Nkind (N) in N_Attribute_Reference 2660 | N_And_Then 2661 | N_Explicit_Dereference 2662 | N_Identifier 2663 | N_Indexed_Component 2664 | N_Or_Else 2665 | N_Range 2666 | N_Selected_Component 2667 | N_Slice 2668 or else Nkind (Name (N)) = N_Explicit_Dereference 2669 then 2670 null; 2671 2672 -- For procedure or function calls, set the type of the name, 2673 -- and also the entity pointer for the prefix. 2674 2675 elsif Nkind (N) in N_Subprogram_Call 2676 and then Is_Entity_Name (Name (N)) 2677 then 2678 Set_Etype (Name (N), Expr_Type); 2679 Set_Entity (Name (N), Seen); 2680 Generate_Reference (Seen, Name (N)); 2681 2682 elsif Nkind (N) = N_Function_Call 2683 and then Nkind (Name (N)) = N_Selected_Component 2684 then 2685 Set_Etype (Name (N), Expr_Type); 2686 Set_Entity (Selector_Name (Name (N)), Seen); 2687 Generate_Reference (Seen, Selector_Name (Name (N))); 2688 2689 -- For all other cases, just set the type of the Name 2690 2691 else 2692 Set_Etype (Name (N), Expr_Type); 2693 end if; 2694 2695 end if; 2696 2697 <<Continue>> 2698 2699 -- Move to next interpretation 2700 2701 exit Interp_Loop when No (It.Typ); 2702 2703 Get_Next_Interp (I, It); 2704 end loop Interp_Loop; 2705 end if; 2706 2707 -- At this stage Found indicates whether or not an acceptable 2708 -- interpretation exists. If not, then we have an error, except that if 2709 -- the context is Any_Type as a result of some other error, then we 2710 -- suppress the error report. 2711 2712 if not Found then 2713 if Typ /= Any_Type then 2714 2715 -- If type we are looking for is Void, then this is the procedure 2716 -- call case, and the error is simply that what we gave is not a 2717 -- procedure name (we think of procedure calls as expressions with 2718 -- types internally, but the user doesn't think of them this way). 2719 2720 if Typ = Standard_Void_Type then 2721 2722 -- Special case message if function used as a procedure 2723 2724 if Nkind (N) = N_Procedure_Call_Statement 2725 and then Is_Entity_Name (Name (N)) 2726 and then Ekind (Entity (Name (N))) = E_Function 2727 then 2728 Error_Msg_NE 2729 ("cannot use call to function & as a statement", 2730 Name (N), Entity (Name (N))); 2731 Error_Msg_N 2732 ("\return value of a function call cannot be ignored", 2733 Name (N)); 2734 2735 -- Otherwise give general message (not clear what cases this 2736 -- covers, but no harm in providing for them). 2737 2738 else 2739 Error_Msg_N ("expect procedure name in procedure call", N); 2740 end if; 2741 2742 Found := True; 2743 2744 -- Otherwise we do have a subexpression with the wrong type 2745 2746 -- Check for the case of an allocator which uses an access type 2747 -- instead of the designated type. This is a common error and we 2748 -- specialize the message, posting an error on the operand of the 2749 -- allocator, complaining that we expected the designated type of 2750 -- the allocator. 2751 2752 elsif Nkind (N) = N_Allocator 2753 and then Is_Access_Type (Typ) 2754 and then Is_Access_Type (Etype (N)) 2755 and then Designated_Type (Etype (N)) = Typ 2756 then 2757 Wrong_Type (Expression (N), Designated_Type (Typ)); 2758 Found := True; 2759 2760 -- Check for view mismatch on Null in instances, for which the 2761 -- view-swapping mechanism has no identifier. 2762 2763 elsif (In_Instance or else In_Inlined_Body) 2764 and then (Nkind (N) = N_Null) 2765 and then Is_Private_Type (Typ) 2766 and then Is_Access_Type (Full_View (Typ)) 2767 then 2768 Resolve (N, Full_View (Typ)); 2769 Set_Etype (N, Typ); 2770 return; 2771 2772 -- Check for an aggregate. Sometimes we can get bogus aggregates 2773 -- from misuse of parentheses, and we are about to complain about 2774 -- the aggregate without even looking inside it. 2775 2776 -- Instead, if we have an aggregate of type Any_Composite, then 2777 -- analyze and resolve the component fields, and then only issue 2778 -- another message if we get no errors doing this (otherwise 2779 -- assume that the errors in the aggregate caused the problem). 2780 2781 elsif Nkind (N) = N_Aggregate 2782 and then Etype (N) = Any_Composite 2783 then 2784 if Ada_Version >= Ada_2020 2785 and then Has_Aspect (Typ, Aspect_Aggregate) 2786 then 2787 Resolve_Container_Aggregate (N, Typ); 2788 2789 if Expander_Active then 2790 Expand (N); 2791 end if; 2792 return; 2793 end if; 2794 2795 -- Disable expansion in any case. If there is a type mismatch 2796 -- it may be fatal to try to expand the aggregate. The flag 2797 -- would otherwise be set to false when the error is posted. 2798 2799 Expander_Active := False; 2800 2801 declare 2802 procedure Check_Aggr (Aggr : Node_Id); 2803 -- Check one aggregate, and set Found to True if we have a 2804 -- definite error in any of its elements 2805 2806 procedure Check_Elmt (Aelmt : Node_Id); 2807 -- Check one element of aggregate and set Found to True if 2808 -- we definitely have an error in the element. 2809 2810 ---------------- 2811 -- Check_Aggr -- 2812 ---------------- 2813 2814 procedure Check_Aggr (Aggr : Node_Id) is 2815 Elmt : Node_Id; 2816 2817 begin 2818 if Present (Expressions (Aggr)) then 2819 Elmt := First (Expressions (Aggr)); 2820 while Present (Elmt) loop 2821 Check_Elmt (Elmt); 2822 Next (Elmt); 2823 end loop; 2824 end if; 2825 2826 if Present (Component_Associations (Aggr)) then 2827 Elmt := First (Component_Associations (Aggr)); 2828 while Present (Elmt) loop 2829 2830 -- If this is a default-initialized component, then 2831 -- there is nothing to check. The box will be 2832 -- replaced by the appropriate call during late 2833 -- expansion. 2834 2835 if Nkind (Elmt) /= N_Iterated_Component_Association 2836 and then not Box_Present (Elmt) 2837 then 2838 Check_Elmt (Expression (Elmt)); 2839 end if; 2840 2841 Next (Elmt); 2842 end loop; 2843 end if; 2844 end Check_Aggr; 2845 2846 ---------------- 2847 -- Check_Elmt -- 2848 ---------------- 2849 2850 procedure Check_Elmt (Aelmt : Node_Id) is 2851 begin 2852 -- If we have a nested aggregate, go inside it (to 2853 -- attempt a naked analyze-resolve of the aggregate can 2854 -- cause undesirable cascaded errors). Do not resolve 2855 -- expression if it needs a type from context, as for 2856 -- integer * fixed expression. 2857 2858 if Nkind (Aelmt) = N_Aggregate then 2859 Check_Aggr (Aelmt); 2860 2861 else 2862 Analyze (Aelmt); 2863 2864 if not Is_Overloaded (Aelmt) 2865 and then Etype (Aelmt) /= Any_Fixed 2866 then 2867 Resolve (Aelmt); 2868 end if; 2869 2870 if Etype (Aelmt) = Any_Type then 2871 Found := True; 2872 end if; 2873 end if; 2874 end Check_Elmt; 2875 2876 begin 2877 Check_Aggr (N); 2878 end; 2879 end if; 2880 2881 -- Rewrite Literal as a call if the corresponding literal aspect 2882 -- is set. 2883 2884 if (Nkind (N) in N_Numeric_Or_String_Literal 2885 and then 2886 Present 2887 (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))))) 2888 or else 2889 (Nkind (N) = N_Identifier 2890 and then Is_Named_Number (Entity (N)) 2891 and then 2892 Present 2893 (Find_Aspect 2894 (Typ, Named_Number_Aspect_Map (Ekind (Entity (N)))))) 2895 then 2896 declare 2897 Lit_Aspect : constant Aspect_Id := 2898 (if Nkind (N) = N_Identifier 2899 then Named_Number_Aspect_Map (Ekind (Entity (N))) 2900 else Literal_Aspect_Map (Nkind (N))); 2901 2902 Loc : constant Source_Ptr := Sloc (N); 2903 2904 Callee : Entity_Id := 2905 Entity (Expression (Find_Aspect (Typ, Lit_Aspect))); 2906 2907 Name : constant Node_Id := 2908 Make_Identifier (Loc, Chars (Callee)); 2909 2910 Param1 : Node_Id; 2911 Param2 : Node_Id; 2912 Params : List_Id; 2913 Call : Node_Id; 2914 Expr : Node_Id; 2915 2916 begin 2917 if Nkind (N) = N_Identifier then 2918 Expr := Expression (Declaration_Node (Entity (N))); 2919 2920 if Ekind (Entity (N)) = E_Named_Integer then 2921 UI_Image (Expr_Value (Expr), Decimal); 2922 Start_String; 2923 Store_String_Chars 2924 (UI_Image_Buffer (1 .. UI_Image_Length)); 2925 Param1 := Make_String_Literal (Loc, End_String); 2926 Params := New_List (Param1); 2927 2928 else 2929 UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal); 2930 Start_String; 2931 Store_String_Chars 2932 (UI_Image_Buffer (1 .. UI_Image_Length)); 2933 Param1 := Make_String_Literal (Loc, End_String); 2934 2935 -- Note: Set_Etype is called below on Param1 2936 2937 UI_Image (Norm_Den (Expr_Value_R (Expr)), Decimal); 2938 Start_String; 2939 Store_String_Chars 2940 (UI_Image_Buffer (1 .. UI_Image_Length)); 2941 Param2 := Make_String_Literal (Loc, End_String); 2942 Set_Etype (Param2, Standard_String); 2943 2944 Params := New_List (Param1, Param2); 2945 2946 if Present (Related_Expression (Callee)) then 2947 Callee := Related_Expression (Callee); 2948 else 2949 Error_Msg_NE 2950 ("cannot resolve & for a named real", N, Callee); 2951 return; 2952 end if; 2953 end if; 2954 2955 elsif Nkind (N) = N_String_Literal then 2956 Param1 := Make_String_Literal (Loc, Strval (N)); 2957 Params := New_List (Param1); 2958 else 2959 Param1 := 2960 Make_String_Literal 2961 (Loc, String_From_Numeric_Literal (N)); 2962 Params := New_List (Param1); 2963 end if; 2964 2965 Call := 2966 Make_Function_Call 2967 (Sloc => Loc, 2968 Name => Name, 2969 Parameter_Associations => Params); 2970 2971 Set_Entity (Name, Callee); 2972 Set_Is_Overloaded (Name, False); 2973 2974 if Lit_Aspect = Aspect_String_Literal then 2975 Set_Etype (Param1, Standard_Wide_Wide_String); 2976 else 2977 Set_Etype (Param1, Standard_String); 2978 end if; 2979 2980 Set_Etype (Call, Etype (Callee)); 2981 2982 -- Conversion needed in case of an inherited aspect 2983 -- of a derived type. 2984 -- 2985 -- ??? Need to do something different here for downward 2986 -- tagged conversion case (which is only possible in the 2987 -- case of a null extension); the current call to 2988 -- Convert_To results in an error message about an illegal 2989 -- downward conversion. 2990 2991 Call := Convert_To (Typ, Call); 2992 2993 Rewrite (N, Call); 2994 end; 2995 2996 Analyze_And_Resolve (N, Typ); 2997 return; 2998 end if; 2999 3000 -- Looks like we have a type error, but check for special case 3001 -- of Address wanted, integer found, with the configuration pragma 3002 -- Allow_Integer_Address active. If we have this case, introduce 3003 -- an unchecked conversion to allow the integer expression to be 3004 -- treated as an Address. The reverse case of integer wanted, 3005 -- Address found, is treated in an analogous manner. 3006 3007 if Address_Integer_Convert_OK (Typ, Etype (N)) then 3008 Rewrite (N, Unchecked_Convert_To (Typ, Relocate_Node (N))); 3009 Analyze_And_Resolve (N, Typ); 3010 return; 3011 3012 -- Under relaxed RM semantics silently replace occurrences of null 3013 -- by System.Null_Address. 3014 3015 elsif Null_To_Null_Address_Convert_OK (N, Typ) then 3016 Replace_Null_By_Null_Address (N); 3017 Analyze_And_Resolve (N, Typ); 3018 return; 3019 end if; 3020 3021 -- That special Allow_Integer_Address check did not apply, so we 3022 -- have a real type error. If an error message was issued already, 3023 -- Found got reset to True, so if it's still False, issue standard 3024 -- Wrong_Type message. 3025 3026 if not Found then 3027 if Is_Overloaded (N) and then Nkind (N) = N_Function_Call then 3028 declare 3029 Subp_Name : Node_Id; 3030 3031 begin 3032 if Is_Entity_Name (Name (N)) then 3033 Subp_Name := Name (N); 3034 3035 elsif Nkind (Name (N)) = N_Selected_Component then 3036 3037 -- Protected operation: retrieve operation name 3038 3039 Subp_Name := Selector_Name (Name (N)); 3040 3041 else 3042 raise Program_Error; 3043 end if; 3044 3045 Error_Msg_Node_2 := Typ; 3046 Error_Msg_NE 3047 ("no visible interpretation of& matches expected type&", 3048 N, Subp_Name); 3049 end; 3050 3051 if All_Errors_Mode then 3052 declare 3053 Index : Interp_Index; 3054 It : Interp; 3055 3056 begin 3057 Error_Msg_N ("\\possible interpretations:", N); 3058 3059 Get_First_Interp (Name (N), Index, It); 3060 while Present (It.Nam) loop 3061 Error_Msg_Sloc := Sloc (It.Nam); 3062 Error_Msg_Node_2 := It.Nam; 3063 Error_Msg_NE 3064 ("\\ type& for & declared#", N, It.Typ); 3065 Get_Next_Interp (Index, It); 3066 end loop; 3067 end; 3068 3069 else 3070 Error_Msg_N ("\use -gnatf for details", N); 3071 end if; 3072 3073 else 3074 Wrong_Type (N, Typ); 3075 end if; 3076 end if; 3077 end if; 3078 3079 Resolution_Failed; 3080 return; 3081 3082 -- Test if we have more than one interpretation for the context 3083 3084 elsif Ambiguous then 3085 Resolution_Failed; 3086 return; 3087 3088 -- Only one interpretation 3089 3090 else 3091 -- In Ada 2005, if we have something like "X : T := 2 + 2;", where 3092 -- the "+" on T is abstract, and the operands are of universal type, 3093 -- the above code will have (incorrectly) resolved the "+" to the 3094 -- universal one in Standard. Therefore check for this case and give 3095 -- an error. We can't do this earlier, because it would cause legal 3096 -- cases to get errors (when some other type has an abstract "+"). 3097 3098 if Ada_Version >= Ada_2005 3099 and then Nkind (N) in N_Op 3100 and then Is_Overloaded (N) 3101 and then Is_Universal_Numeric_Type (Etype (Entity (N))) 3102 then 3103 Get_First_Interp (N, I, It); 3104 while Present (It.Typ) loop 3105 if Present (It.Abstract_Op) and then 3106 Etype (It.Abstract_Op) = Typ 3107 then 3108 Error_Msg_NE 3109 ("cannot call abstract subprogram &!", N, It.Abstract_Op); 3110 return; 3111 end if; 3112 3113 Get_Next_Interp (I, It); 3114 end loop; 3115 end if; 3116 3117 -- Here we have an acceptable interpretation for the context 3118 3119 -- Propagate type information and normalize tree for various 3120 -- predefined operations. If the context only imposes a class of 3121 -- types, rather than a specific type, propagate the actual type 3122 -- downward. 3123 3124 if Typ = Any_Integer or else 3125 Typ = Any_Boolean or else 3126 Typ = Any_Modular or else 3127 Typ = Any_Real or else 3128 Typ = Any_Discrete 3129 then 3130 Ctx_Type := Expr_Type; 3131 3132 -- Any_Fixed is legal in a real context only if a specific fixed- 3133 -- point type is imposed. If Norman Cohen can be confused by this, 3134 -- it deserves a separate message. 3135 3136 if Typ = Any_Real 3137 and then Expr_Type = Any_Fixed 3138 then 3139 Error_Msg_N ("illegal context for mixed mode operation", N); 3140 Set_Etype (N, Universal_Real); 3141 Ctx_Type := Universal_Real; 3142 end if; 3143 end if; 3144 3145 -- A user-defined operator is transformed into a function call at 3146 -- this point, so that further processing knows that operators are 3147 -- really operators (i.e. are predefined operators). User-defined 3148 -- operators that are intrinsic are just renamings of the predefined 3149 -- ones, and need not be turned into calls either, but if they rename 3150 -- a different operator, we must transform the node accordingly. 3151 -- Instantiations of Unchecked_Conversion are intrinsic but are 3152 -- treated as functions, even if given an operator designator. 3153 3154 if Nkind (N) in N_Op 3155 and then Present (Entity (N)) 3156 and then Ekind (Entity (N)) /= E_Operator 3157 then 3158 if not Is_Predefined_Op (Entity (N)) then 3159 Rewrite_Operator_As_Call (N, Entity (N)); 3160 3161 elsif Present (Alias (Entity (N))) 3162 and then 3163 Nkind (Parent (Parent (Entity (N)))) = 3164 N_Subprogram_Renaming_Declaration 3165 then 3166 Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); 3167 3168 -- If the node is rewritten, it will be fully resolved in 3169 -- Rewrite_Renamed_Operator. 3170 3171 if Analyzed (N) then 3172 return; 3173 end if; 3174 end if; 3175 end if; 3176 3177 case N_Subexpr'(Nkind (N)) is 3178 when N_Aggregate => 3179 Resolve_Aggregate (N, Ctx_Type); 3180 3181 when N_Allocator => 3182 Resolve_Allocator (N, Ctx_Type); 3183 3184 when N_Short_Circuit => 3185 Resolve_Short_Circuit (N, Ctx_Type); 3186 3187 when N_Attribute_Reference => 3188 Resolve_Attribute (N, Ctx_Type); 3189 3190 when N_Case_Expression => 3191 Resolve_Case_Expression (N, Ctx_Type); 3192 3193 when N_Character_Literal => 3194 Resolve_Character_Literal (N, Ctx_Type); 3195 3196 when N_Delta_Aggregate => 3197 Resolve_Delta_Aggregate (N, Ctx_Type); 3198 3199 when N_Expanded_Name => 3200 Resolve_Entity_Name (N, Ctx_Type); 3201 3202 when N_Explicit_Dereference => 3203 Resolve_Explicit_Dereference (N, Ctx_Type); 3204 3205 when N_Expression_With_Actions => 3206 Resolve_Expression_With_Actions (N, Ctx_Type); 3207 3208 when N_Extension_Aggregate => 3209 Resolve_Extension_Aggregate (N, Ctx_Type); 3210 3211 when N_Function_Call => 3212 Resolve_Call (N, Ctx_Type); 3213 3214 when N_Identifier => 3215 Resolve_Entity_Name (N, Ctx_Type); 3216 3217 when N_If_Expression => 3218 Resolve_If_Expression (N, Ctx_Type); 3219 3220 when N_Indexed_Component => 3221 Resolve_Indexed_Component (N, Ctx_Type); 3222 3223 when N_Integer_Literal => 3224 Resolve_Integer_Literal (N, Ctx_Type); 3225 3226 when N_Membership_Test => 3227 Resolve_Membership_Op (N, Ctx_Type); 3228 3229 when N_Null => 3230 Resolve_Null (N, Ctx_Type); 3231 3232 when N_Op_And 3233 | N_Op_Or 3234 | N_Op_Xor 3235 => 3236 Resolve_Logical_Op (N, Ctx_Type); 3237 3238 when N_Op_Eq 3239 | N_Op_Ne 3240 => 3241 Resolve_Equality_Op (N, Ctx_Type); 3242 3243 when N_Op_Ge 3244 | N_Op_Gt 3245 | N_Op_Le 3246 | N_Op_Lt 3247 => 3248 Resolve_Comparison_Op (N, Ctx_Type); 3249 3250 when N_Op_Not => 3251 Resolve_Op_Not (N, Ctx_Type); 3252 3253 when N_Op_Add 3254 | N_Op_Divide 3255 | N_Op_Mod 3256 | N_Op_Multiply 3257 | N_Op_Rem 3258 | N_Op_Subtract 3259 => 3260 Resolve_Arithmetic_Op (N, Ctx_Type); 3261 3262 when N_Op_Concat => 3263 Resolve_Op_Concat (N, Ctx_Type); 3264 3265 when N_Op_Expon => 3266 Resolve_Op_Expon (N, Ctx_Type); 3267 3268 when N_Op_Abs 3269 | N_Op_Minus 3270 | N_Op_Plus 3271 => 3272 Resolve_Unary_Op (N, Ctx_Type); 3273 3274 when N_Op_Shift => 3275 Resolve_Shift (N, Ctx_Type); 3276 3277 when N_Procedure_Call_Statement => 3278 Resolve_Call (N, Ctx_Type); 3279 3280 when N_Operator_Symbol => 3281 Resolve_Operator_Symbol (N, Ctx_Type); 3282 3283 when N_Qualified_Expression => 3284 Resolve_Qualified_Expression (N, Ctx_Type); 3285 3286 -- Why is the following null, needs a comment ??? 3287 3288 when N_Quantified_Expression => 3289 null; 3290 3291 when N_Raise_Expression => 3292 Resolve_Raise_Expression (N, Ctx_Type); 3293 3294 when N_Raise_xxx_Error => 3295 Set_Etype (N, Ctx_Type); 3296 3297 when N_Range => 3298 Resolve_Range (N, Ctx_Type); 3299 3300 when N_Real_Literal => 3301 Resolve_Real_Literal (N, Ctx_Type); 3302 3303 when N_Reference => 3304 Resolve_Reference (N, Ctx_Type); 3305 3306 when N_Selected_Component => 3307 Resolve_Selected_Component (N, Ctx_Type); 3308 3309 when N_Slice => 3310 Resolve_Slice (N, Ctx_Type); 3311 3312 when N_String_Literal => 3313 Resolve_String_Literal (N, Ctx_Type); 3314 3315 when N_Target_Name => 3316 Resolve_Target_Name (N, Ctx_Type); 3317 3318 when N_Type_Conversion => 3319 Resolve_Type_Conversion (N, Ctx_Type); 3320 3321 when N_Unchecked_Expression => 3322 Resolve_Unchecked_Expression (N, Ctx_Type); 3323 3324 when N_Unchecked_Type_Conversion => 3325 Resolve_Unchecked_Type_Conversion (N, Ctx_Type); 3326 end case; 3327 3328 -- Mark relevant use-type and use-package clauses as effective using 3329 -- the original node because constant folding may have occured and 3330 -- removed references that need to be examined. 3331 3332 if Nkind (Original_Node (N)) in N_Op then 3333 Mark_Use_Clauses (Original_Node (N)); 3334 end if; 3335 3336 -- Ada 2012 (AI05-0149): Apply an (implicit) conversion to an 3337 -- expression of an anonymous access type that occurs in the context 3338 -- of a named general access type, except when the expression is that 3339 -- of a membership test. This ensures proper legality checking in 3340 -- terms of allowed conversions (expressions that would be illegal to 3341 -- convert implicitly are allowed in membership tests). 3342 3343 if Ada_Version >= Ada_2012 3344 and then Ekind (Base_Type (Ctx_Type)) = E_General_Access_Type 3345 and then Ekind (Etype (N)) = E_Anonymous_Access_Type 3346 and then Nkind (Parent (N)) not in N_Membership_Test 3347 then 3348 Rewrite (N, Convert_To (Ctx_Type, Relocate_Node (N))); 3349 Analyze_And_Resolve (N, Ctx_Type); 3350 end if; 3351 3352 -- If the subexpression was replaced by a non-subexpression, then 3353 -- all we do is to expand it. The only legitimate case we know of 3354 -- is converting procedure call statement to entry call statements, 3355 -- but there may be others, so we are making this test general. 3356 3357 if Nkind (N) not in N_Subexpr then 3358 Debug_A_Exit ("resolving ", N, " (done)"); 3359 Expand (N); 3360 return; 3361 end if; 3362 3363 -- The expression is definitely NOT overloaded at this point, so 3364 -- we reset the Is_Overloaded flag to avoid any confusion when 3365 -- reanalyzing the node. 3366 3367 Set_Is_Overloaded (N, False); 3368 3369 -- Freeze expression type, entity if it is a name, and designated 3370 -- type if it is an allocator (RM 13.14(10,11,13)). 3371 3372 -- Now that the resolution of the type of the node is complete, and 3373 -- we did not detect an error, we can expand this node. We skip the 3374 -- expand call if we are in a default expression, see section 3375 -- "Handling of Default Expressions" in Sem spec. 3376 3377 Debug_A_Exit ("resolving ", N, " (done)"); 3378 3379 -- We unconditionally freeze the expression, even if we are in 3380 -- default expression mode (the Freeze_Expression routine tests this 3381 -- flag and only freezes static types if it is set). 3382 3383 -- Ada 2012 (AI05-177): The declaration of an expression function 3384 -- does not cause freezing, but we never reach here in that case. 3385 -- Here we are resolving the corresponding expanded body, so we do 3386 -- need to perform normal freezing. 3387 3388 -- As elsewhere we do not emit freeze node within a generic. We make 3389 -- an exception for entities that are expressions, only to detect 3390 -- misuses of deferred constants and preserve the output of various 3391 -- tests. 3392 3393 if not Inside_A_Generic or else Is_Entity_Name (N) then 3394 Freeze_Expression (N); 3395 end if; 3396 3397 -- Now we can do the expansion 3398 3399 Expand (N); 3400 end if; 3401 end Resolve; 3402 3403 ------------- 3404 -- Resolve -- 3405 ------------- 3406 3407 -- Version with check(s) suppressed 3408 3409 procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is 3410 begin 3411 if Suppress = All_Checks then 3412 declare 3413 Sva : constant Suppress_Array := Scope_Suppress.Suppress; 3414 begin 3415 Scope_Suppress.Suppress := (others => True); 3416 Resolve (N, Typ); 3417 Scope_Suppress.Suppress := Sva; 3418 end; 3419 3420 else 3421 declare 3422 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 3423 begin 3424 Scope_Suppress.Suppress (Suppress) := True; 3425 Resolve (N, Typ); 3426 Scope_Suppress.Suppress (Suppress) := Svg; 3427 end; 3428 end if; 3429 end Resolve; 3430 3431 ------------- 3432 -- Resolve -- 3433 ------------- 3434 3435 -- Version with implicit type 3436 3437 procedure Resolve (N : Node_Id) is 3438 begin 3439 Resolve (N, Etype (N)); 3440 end Resolve; 3441 3442 --------------------- 3443 -- Resolve_Actuals -- 3444 --------------------- 3445 3446 procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is 3447 Loc : constant Source_Ptr := Sloc (N); 3448 A : Node_Id; 3449 A_Id : Entity_Id; 3450 A_Typ : Entity_Id := Empty; -- init to avoid warning 3451 F : Entity_Id; 3452 F_Typ : Entity_Id; 3453 Prev : Node_Id := Empty; 3454 Orig_A : Node_Id; 3455 Real_F : Entity_Id := Empty; -- init to avoid warning 3456 3457 Real_Subp : Entity_Id; 3458 -- If the subprogram being called is an inherited operation for 3459 -- a formal derived type in an instance, Real_Subp is the subprogram 3460 -- that will be called. It may have different formal names than the 3461 -- operation of the formal in the generic, so after actual is resolved 3462 -- the name of the actual in a named association must carry the name 3463 -- of the actual of the subprogram being called. 3464 3465 procedure Check_Aliased_Parameter; 3466 -- Check rules on aliased parameters and related accessibility rules 3467 -- in (RM 3.10.2 (10.2-10.4)). 3468 3469 procedure Check_Argument_Order; 3470 -- Performs a check for the case where the actuals are all simple 3471 -- identifiers that correspond to the formal names, but in the wrong 3472 -- order, which is considered suspicious and cause for a warning. 3473 3474 procedure Check_Prefixed_Call; 3475 -- If the original node is an overloaded call in prefix notation, 3476 -- insert an 'Access or a dereference as needed over the first actual. 3477 -- Try_Object_Operation has already verified that there is a valid 3478 -- interpretation, but the form of the actual can only be determined 3479 -- once the primitive operation is identified. 3480 3481 procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id); 3482 -- Emit an error concerning the illegal usage of an effectively volatile 3483 -- object for reading in interfering context (SPARK RM 7.1.3(10)). 3484 3485 procedure Insert_Default; 3486 -- If the actual is missing in a call, insert in the actuals list 3487 -- an instance of the default expression. The insertion is always 3488 -- a named association. 3489 3490 function Same_Ancestor (T1, T2 : Entity_Id) return Boolean; 3491 -- Check whether T1 and T2, or their full views, are derived from a 3492 -- common type. Used to enforce the restrictions on array conversions 3493 -- of AI95-00246. 3494 3495 function Static_Concatenation (N : Node_Id) return Boolean; 3496 -- Predicate to determine whether an actual that is a concatenation 3497 -- will be evaluated statically and does not need a transient scope. 3498 -- This must be determined before the actual is resolved and expanded 3499 -- because if needed the transient scope must be introduced earlier. 3500 3501 ----------------------------- 3502 -- Check_Aliased_Parameter -- 3503 ----------------------------- 3504 3505 procedure Check_Aliased_Parameter is 3506 Nominal_Subt : Entity_Id; 3507 3508 begin 3509 if Is_Aliased (F) then 3510 if Is_Tagged_Type (A_Typ) then 3511 null; 3512 3513 elsif Is_Aliased_View (A) then 3514 if Is_Constr_Subt_For_U_Nominal (A_Typ) then 3515 Nominal_Subt := Base_Type (A_Typ); 3516 else 3517 Nominal_Subt := A_Typ; 3518 end if; 3519 3520 if Subtypes_Statically_Match (F_Typ, Nominal_Subt) then 3521 null; 3522 3523 -- In a generic body assume the worst for generic formals: 3524 -- they can have a constrained partial view (AI05-041). 3525 3526 elsif Has_Discriminants (F_Typ) 3527 and then not Is_Constrained (F_Typ) 3528 and then not Object_Type_Has_Constrained_Partial_View 3529 (Typ => F_Typ, Scop => Current_Scope) 3530 then 3531 null; 3532 3533 else 3534 Error_Msg_NE ("untagged actual does not statically match " 3535 & "aliased formal&", A, F); 3536 end if; 3537 3538 else 3539 Error_Msg_NE ("actual for aliased formal& must be " 3540 & "aliased object", A, F); 3541 end if; 3542 3543 if Ekind (Nam) = E_Procedure then 3544 null; 3545 3546 elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then 3547 if Nkind (Parent (N)) = N_Type_Conversion 3548 and then Type_Access_Level (Etype (Parent (N))) 3549 < Static_Accessibility_Level (A, Object_Decl_Level) 3550 then 3551 Error_Msg_N ("aliased actual has wrong accessibility", A); 3552 end if; 3553 3554 elsif Nkind (Parent (N)) = N_Qualified_Expression 3555 and then Nkind (Parent (Parent (N))) = N_Allocator 3556 and then Type_Access_Level (Etype (Parent (Parent (N)))) 3557 < Static_Accessibility_Level (A, Object_Decl_Level) 3558 then 3559 Error_Msg_N 3560 ("aliased actual in allocator has wrong accessibility", A); 3561 end if; 3562 end if; 3563 end Check_Aliased_Parameter; 3564 3565 -------------------------- 3566 -- Check_Argument_Order -- 3567 -------------------------- 3568 3569 procedure Check_Argument_Order is 3570 begin 3571 -- Nothing to do if no parameters, or original node is neither a 3572 -- function call nor a procedure call statement (happens in the 3573 -- operator-transformed-to-function call case), or the call is to an 3574 -- operator symbol (which is usually in infix form), or the call does 3575 -- not come from source, or this warning is off. 3576 3577 if not Warn_On_Parameter_Order 3578 or else No (Parameter_Associations (N)) 3579 or else Nkind (Original_Node (N)) not in N_Subprogram_Call 3580 or else (Nkind (Name (N)) = N_Identifier 3581 and then Present (Entity (Name (N))) 3582 and then Nkind (Entity (Name (N))) = 3583 N_Defining_Operator_Symbol) 3584 or else not Comes_From_Source (N) 3585 then 3586 return; 3587 end if; 3588 3589 declare 3590 Nargs : constant Nat := List_Length (Parameter_Associations (N)); 3591 3592 begin 3593 -- Nothing to do if only one parameter 3594 3595 if Nargs < 2 then 3596 return; 3597 end if; 3598 3599 -- Here if at least two arguments 3600 3601 declare 3602 Actuals : array (1 .. Nargs) of Node_Id; 3603 Actual : Node_Id; 3604 Formal : Node_Id; 3605 3606 Wrong_Order : Boolean := False; 3607 -- Set True if an out of order case is found 3608 3609 begin 3610 -- Collect identifier names of actuals, fail if any actual is 3611 -- not a simple identifier, and record max length of name. 3612 3613 Actual := First (Parameter_Associations (N)); 3614 for J in Actuals'Range loop 3615 if Nkind (Actual) /= N_Identifier then 3616 return; 3617 else 3618 Actuals (J) := Actual; 3619 Next (Actual); 3620 end if; 3621 end loop; 3622 3623 -- If we got this far, all actuals are identifiers and the list 3624 -- of their names is stored in the Actuals array. 3625 3626 Formal := First_Formal (Nam); 3627 for J in Actuals'Range loop 3628 3629 -- If we ran out of formals, that's odd, probably an error 3630 -- which will be detected elsewhere, but abandon the search. 3631 3632 if No (Formal) then 3633 return; 3634 end if; 3635 3636 -- If name matches and is in order OK 3637 3638 if Chars (Formal) = Chars (Actuals (J)) then 3639 null; 3640 3641 else 3642 -- If no match, see if it is elsewhere in list and if so 3643 -- flag potential wrong order if type is compatible. 3644 3645 for K in Actuals'Range loop 3646 if Chars (Formal) = Chars (Actuals (K)) 3647 and then 3648 Has_Compatible_Type (Actuals (K), Etype (Formal)) 3649 then 3650 Wrong_Order := True; 3651 goto Continue; 3652 end if; 3653 end loop; 3654 3655 -- No match 3656 3657 return; 3658 end if; 3659 3660 <<Continue>> Next_Formal (Formal); 3661 end loop; 3662 3663 -- If Formals left over, also probably an error, skip warning 3664 3665 if Present (Formal) then 3666 return; 3667 end if; 3668 3669 -- Here we give the warning if something was out of order 3670 3671 if Wrong_Order then 3672 Error_Msg_N 3673 ("?P?actuals for this call may be in wrong order", N); 3674 end if; 3675 end; 3676 end; 3677 end Check_Argument_Order; 3678 3679 ------------------------- 3680 -- Check_Prefixed_Call -- 3681 ------------------------- 3682 3683 procedure Check_Prefixed_Call is 3684 Act : constant Node_Id := First_Actual (N); 3685 A_Type : constant Entity_Id := Etype (Act); 3686 F_Type : constant Entity_Id := Etype (First_Formal (Nam)); 3687 Orig : constant Node_Id := Original_Node (N); 3688 New_A : Node_Id; 3689 3690 begin 3691 -- Check whether the call is a prefixed call, with or without 3692 -- additional actuals. 3693 3694 if Nkind (Orig) = N_Selected_Component 3695 or else 3696 (Nkind (Orig) = N_Indexed_Component 3697 and then Nkind (Prefix (Orig)) = N_Selected_Component 3698 and then Is_Entity_Name (Prefix (Prefix (Orig))) 3699 and then Is_Entity_Name (Act) 3700 and then Chars (Act) = Chars (Prefix (Prefix (Orig)))) 3701 then 3702 if Is_Access_Type (A_Type) 3703 and then not Is_Access_Type (F_Type) 3704 then 3705 -- Introduce dereference on object in prefix 3706 3707 New_A := 3708 Make_Explicit_Dereference (Sloc (Act), 3709 Prefix => Relocate_Node (Act)); 3710 Rewrite (Act, New_A); 3711 Analyze (Act); 3712 3713 elsif Is_Access_Type (F_Type) 3714 and then not Is_Access_Type (A_Type) 3715 then 3716 -- Introduce an implicit 'Access in prefix 3717 3718 if not Is_Aliased_View (Act) then 3719 Error_Msg_NE 3720 ("object in prefixed call to& must be aliased " 3721 & "(RM 4.1.3 (13 1/2))", 3722 Prefix (Act), Nam); 3723 end if; 3724 3725 Rewrite (Act, 3726 Make_Attribute_Reference (Loc, 3727 Attribute_Name => Name_Access, 3728 Prefix => Relocate_Node (Act))); 3729 end if; 3730 3731 Analyze (Act); 3732 end if; 3733 end Check_Prefixed_Call; 3734 3735 --------------------------------------- 3736 -- Flag_Effectively_Volatile_Objects -- 3737 --------------------------------------- 3738 3739 procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id) is 3740 function Flag_Object (N : Node_Id) return Traverse_Result; 3741 -- Determine whether arbitrary node N denotes an effectively volatile 3742 -- object for reading and if it does, emit an error. 3743 3744 ----------------- 3745 -- Flag_Object -- 3746 ----------------- 3747 3748 function Flag_Object (N : Node_Id) return Traverse_Result is 3749 Id : Entity_Id; 3750 3751 begin 3752 -- Do not consider nested function calls because they have already 3753 -- been processed during their own resolution. 3754 3755 if Nkind (N) = N_Function_Call then 3756 return Skip; 3757 3758 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 3759 Id := Entity (N); 3760 3761 if Is_Object (Id) 3762 and then Is_Effectively_Volatile_For_Reading (Id) 3763 then 3764 Error_Msg_N 3765 ("volatile object cannot appear in this context (SPARK " 3766 & "RM 7.1.3(10))", N); 3767 return Skip; 3768 end if; 3769 end if; 3770 3771 return OK; 3772 end Flag_Object; 3773 3774 procedure Flag_Objects is new Traverse_Proc (Flag_Object); 3775 3776 -- Start of processing for Flag_Effectively_Volatile_Objects 3777 3778 begin 3779 Flag_Objects (Expr); 3780 end Flag_Effectively_Volatile_Objects; 3781 3782 -------------------- 3783 -- Insert_Default -- 3784 -------------------- 3785 3786 procedure Insert_Default is 3787 Actval : Node_Id; 3788 Assoc : Node_Id; 3789 3790 begin 3791 -- Missing argument in call, nothing to insert 3792 3793 if No (Default_Value (F)) then 3794 return; 3795 3796 else 3797 -- Note that we do a full New_Copy_Tree, so that any associated 3798 -- Itypes are properly copied. This may not be needed any more, 3799 -- but it does no harm as a safety measure. Defaults of a generic 3800 -- formal may be out of bounds of the corresponding actual (see 3801 -- cc1311b) and an additional check may be required. 3802 3803 Actval := 3804 New_Copy_Tree 3805 (Default_Value (F), 3806 New_Scope => Current_Scope, 3807 New_Sloc => Loc); 3808 3809 -- Propagate dimension information, if any. 3810 3811 Copy_Dimensions (Default_Value (F), Actval); 3812 3813 if Is_Concurrent_Type (Scope (Nam)) 3814 and then Has_Discriminants (Scope (Nam)) 3815 then 3816 Replace_Actual_Discriminants (N, Actval); 3817 end if; 3818 3819 if Is_Overloadable (Nam) 3820 and then Present (Alias (Nam)) 3821 then 3822 if Base_Type (Etype (F)) /= Base_Type (Etype (Actval)) 3823 and then not Is_Tagged_Type (Etype (F)) 3824 then 3825 -- If default is a real literal, do not introduce a 3826 -- conversion whose effect may depend on the run-time 3827 -- size of universal real. 3828 3829 if Nkind (Actval) = N_Real_Literal then 3830 Set_Etype (Actval, Base_Type (Etype (F))); 3831 else 3832 Actval := Unchecked_Convert_To (Etype (F), Actval); 3833 end if; 3834 end if; 3835 3836 if Is_Scalar_Type (Etype (F)) then 3837 Enable_Range_Check (Actval); 3838 end if; 3839 3840 Set_Parent (Actval, N); 3841 3842 -- Resolve aggregates with their base type, to avoid scope 3843 -- anomalies: the subtype was first built in the subprogram 3844 -- declaration, and the current call may be nested. 3845 3846 if Nkind (Actval) = N_Aggregate then 3847 Analyze_And_Resolve (Actval, Etype (F)); 3848 else 3849 Analyze_And_Resolve (Actval, Etype (Actval)); 3850 end if; 3851 3852 else 3853 Set_Parent (Actval, N); 3854 3855 -- See note above concerning aggregates 3856 3857 if Nkind (Actval) = N_Aggregate 3858 and then Has_Discriminants (Etype (Actval)) 3859 then 3860 Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); 3861 3862 -- Resolve entities with their own type, which may differ from 3863 -- the type of a reference in a generic context (the view 3864 -- swapping mechanism did not anticipate the re-analysis of 3865 -- default values in calls). 3866 3867 elsif Is_Entity_Name (Actval) then 3868 Analyze_And_Resolve (Actval, Etype (Entity (Actval))); 3869 3870 else 3871 Analyze_And_Resolve (Actval, Etype (Actval)); 3872 end if; 3873 end if; 3874 3875 -- If default is a tag indeterminate function call, propagate tag 3876 -- to obtain proper dispatching. 3877 3878 if Is_Controlling_Formal (F) 3879 and then Nkind (Default_Value (F)) = N_Function_Call 3880 then 3881 Set_Is_Controlling_Actual (Actval); 3882 end if; 3883 end if; 3884 3885 -- If the default expression raises constraint error, then just 3886 -- silently replace it with an N_Raise_Constraint_Error node, since 3887 -- we already gave the warning on the subprogram spec. If node is 3888 -- already a Raise_Constraint_Error leave as is, to prevent loops in 3889 -- the warnings removal machinery. 3890 3891 if Raises_Constraint_Error (Actval) 3892 and then Nkind (Actval) /= N_Raise_Constraint_Error 3893 then 3894 Rewrite (Actval, 3895 Make_Raise_Constraint_Error (Loc, 3896 Reason => CE_Range_Check_Failed)); 3897 3898 Set_Raises_Constraint_Error (Actval); 3899 Set_Etype (Actval, Etype (F)); 3900 end if; 3901 3902 Assoc := 3903 Make_Parameter_Association (Loc, 3904 Explicit_Actual_Parameter => Actval, 3905 Selector_Name => Make_Identifier (Loc, Chars (F))); 3906 3907 -- Case of insertion is first named actual 3908 3909 if No (Prev) 3910 or else Nkind (Parent (Prev)) /= N_Parameter_Association 3911 then 3912 Set_Next_Named_Actual (Assoc, First_Named_Actual (N)); 3913 Set_First_Named_Actual (N, Actval); 3914 3915 if No (Prev) then 3916 if No (Parameter_Associations (N)) then 3917 Set_Parameter_Associations (N, New_List (Assoc)); 3918 else 3919 Append (Assoc, Parameter_Associations (N)); 3920 end if; 3921 3922 else 3923 Insert_After (Prev, Assoc); 3924 end if; 3925 3926 -- Case of insertion is not first named actual 3927 3928 else 3929 Set_Next_Named_Actual 3930 (Assoc, Next_Named_Actual (Parent (Prev))); 3931 Set_Next_Named_Actual (Parent (Prev), Actval); 3932 Append (Assoc, Parameter_Associations (N)); 3933 end if; 3934 3935 Mark_Rewrite_Insertion (Assoc); 3936 Mark_Rewrite_Insertion (Actval); 3937 3938 Prev := Actval; 3939 end Insert_Default; 3940 3941 ------------------- 3942 -- Same_Ancestor -- 3943 ------------------- 3944 3945 function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is 3946 FT1 : Entity_Id := T1; 3947 FT2 : Entity_Id := T2; 3948 3949 begin 3950 if Is_Private_Type (T1) 3951 and then Present (Full_View (T1)) 3952 then 3953 FT1 := Full_View (T1); 3954 end if; 3955 3956 if Is_Private_Type (T2) 3957 and then Present (Full_View (T2)) 3958 then 3959 FT2 := Full_View (T2); 3960 end if; 3961 3962 return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2)); 3963 end Same_Ancestor; 3964 3965 -------------------------- 3966 -- Static_Concatenation -- 3967 -------------------------- 3968 3969 function Static_Concatenation (N : Node_Id) return Boolean is 3970 begin 3971 case Nkind (N) is 3972 when N_String_Literal => 3973 return True; 3974 3975 when N_Op_Concat => 3976 3977 -- Concatenation is static when both operands are static and 3978 -- the concatenation operator is a predefined one. 3979 3980 return Scope (Entity (N)) = Standard_Standard 3981 and then 3982 Static_Concatenation (Left_Opnd (N)) 3983 and then 3984 Static_Concatenation (Right_Opnd (N)); 3985 3986 when others => 3987 if Is_Entity_Name (N) then 3988 declare 3989 Ent : constant Entity_Id := Entity (N); 3990 begin 3991 return Ekind (Ent) = E_Constant 3992 and then Present (Constant_Value (Ent)) 3993 and then 3994 Is_OK_Static_Expression (Constant_Value (Ent)); 3995 end; 3996 3997 else 3998 return False; 3999 end if; 4000 end case; 4001 end Static_Concatenation; 4002 4003 -- Start of processing for Resolve_Actuals 4004 4005 begin 4006 Check_Argument_Order; 4007 4008 if Is_Overloadable (Nam) 4009 and then Is_Inherited_Operation (Nam) 4010 and then In_Instance 4011 and then Present (Alias (Nam)) 4012 and then Present (Overridden_Operation (Alias (Nam))) 4013 then 4014 Real_Subp := Alias (Nam); 4015 else 4016 Real_Subp := Empty; 4017 end if; 4018 4019 if Present (First_Actual (N)) then 4020 Check_Prefixed_Call; 4021 end if; 4022 4023 A := First_Actual (N); 4024 F := First_Formal (Nam); 4025 4026 if Present (Real_Subp) then 4027 Real_F := First_Formal (Real_Subp); 4028 end if; 4029 4030 while Present (F) loop 4031 if No (A) and then Needs_No_Actuals (Nam) then 4032 null; 4033 4034 -- If we have an error in any actual or formal, indicated by a type 4035 -- of Any_Type, then abandon resolution attempt, and set result type 4036 -- to Any_Type. Skip this if the actual is a Raise_Expression, whose 4037 -- type is imposed from context. 4038 4039 elsif (Present (A) and then Etype (A) = Any_Type) 4040 or else Etype (F) = Any_Type 4041 then 4042 if Nkind (A) /= N_Raise_Expression then 4043 Set_Etype (N, Any_Type); 4044 return; 4045 end if; 4046 end if; 4047 4048 -- Case where actual is present 4049 4050 -- If the actual is an entity, generate a reference to it now. We 4051 -- do this before the actual is resolved, because a formal of some 4052 -- protected subprogram, or a task discriminant, will be rewritten 4053 -- during expansion, and the source entity reference may be lost. 4054 4055 if Present (A) 4056 and then Is_Entity_Name (A) 4057 and then Comes_From_Source (A) 4058 then 4059 -- Annotate the tree by creating a variable reference marker when 4060 -- the actual denotes a variable reference, in case the reference 4061 -- is folded or optimized away. The variable reference marker is 4062 -- automatically saved for later examination by the ABE Processing 4063 -- phase. The status of the reference is set as follows: 4064 4065 -- status mode 4066 -- read IN, IN OUT 4067 -- write IN OUT, OUT 4068 4069 if Needs_Variable_Reference_Marker 4070 (N => A, 4071 Calls_OK => True) 4072 then 4073 Build_Variable_Reference_Marker 4074 (N => A, 4075 Read => Ekind (F) /= E_Out_Parameter, 4076 Write => Ekind (F) /= E_In_Parameter); 4077 end if; 4078 4079 Orig_A := Entity (A); 4080 4081 if Present (Orig_A) then 4082 if Is_Formal (Orig_A) 4083 and then Ekind (F) /= E_In_Parameter 4084 then 4085 Generate_Reference (Orig_A, A, 'm'); 4086 4087 elsif not Is_Overloaded (A) then 4088 if Ekind (F) /= E_Out_Parameter then 4089 Generate_Reference (Orig_A, A); 4090 4091 -- RM 6.4.1(12): For an out parameter that is passed by 4092 -- copy, the formal parameter object is created, and: 4093 4094 -- * For an access type, the formal parameter is initialized 4095 -- from the value of the actual, without checking that the 4096 -- value satisfies any constraint, any predicate, or any 4097 -- exclusion of the null value. 4098 4099 -- * For a scalar type that has the Default_Value aspect 4100 -- specified, the formal parameter is initialized from the 4101 -- value of the actual, without checking that the value 4102 -- satisfies any constraint or any predicate. 4103 -- I do not understand why this case is included??? this is 4104 -- not a case where an OUT parameter is treated as IN OUT. 4105 4106 -- * For a composite type with discriminants or that has 4107 -- implicit initial values for any subcomponents, the 4108 -- behavior is as for an in out parameter passed by copy. 4109 4110 -- Hence for these cases we generate the read reference now 4111 -- (the write reference will be generated later by 4112 -- Note_Possible_Modification). 4113 4114 elsif Is_By_Copy_Type (Etype (F)) 4115 and then 4116 (Is_Access_Type (Etype (F)) 4117 or else 4118 (Is_Scalar_Type (Etype (F)) 4119 and then 4120 Present (Default_Aspect_Value (Etype (F)))) 4121 or else 4122 (Is_Composite_Type (Etype (F)) 4123 and then (Has_Discriminants (Etype (F)) 4124 or else Is_Partially_Initialized_Type 4125 (Etype (F))))) 4126 then 4127 Generate_Reference (Orig_A, A); 4128 end if; 4129 end if; 4130 end if; 4131 end if; 4132 4133 if Present (A) 4134 and then (Nkind (Parent (A)) /= N_Parameter_Association 4135 or else Chars (Selector_Name (Parent (A))) = Chars (F)) 4136 then 4137 -- If style checking mode on, check match of formal name 4138 4139 if Style_Check then 4140 if Nkind (Parent (A)) = N_Parameter_Association then 4141 Check_Identifier (Selector_Name (Parent (A)), F); 4142 end if; 4143 end if; 4144 4145 -- If the formal is Out or In_Out, do not resolve and expand the 4146 -- conversion, because it is subsequently expanded into explicit 4147 -- temporaries and assignments. However, the object of the 4148 -- conversion can be resolved. An exception is the case of tagged 4149 -- type conversion with a class-wide actual. In that case we want 4150 -- the tag check to occur and no temporary will be needed (no 4151 -- representation change can occur) and the parameter is passed by 4152 -- reference, so we go ahead and resolve the type conversion. 4153 -- Another exception is the case of reference to component or 4154 -- subcomponent of a bit-packed array, in which case we want to 4155 -- defer expansion to the point the in and out assignments are 4156 -- performed. 4157 4158 if Ekind (F) /= E_In_Parameter 4159 and then Nkind (A) = N_Type_Conversion 4160 and then not Is_Class_Wide_Type (Etype (Expression (A))) 4161 and then not Is_Interface (Etype (A)) 4162 then 4163 declare 4164 Expr_Typ : constant Entity_Id := Etype (Expression (A)); 4165 4166 begin 4167 -- Check RM 4.6 (24.2/2) 4168 4169 if Is_Array_Type (Etype (F)) 4170 and then Is_View_Conversion (A) 4171 then 4172 -- In a view conversion, the conversion must be legal in 4173 -- both directions, and thus both component types must be 4174 -- aliased, or neither (4.6 (8)). 4175 4176 -- Check RM 4.6 (24.8/2) 4177 4178 if Has_Aliased_Components (Expr_Typ) /= 4179 Has_Aliased_Components (Etype (F)) 4180 then 4181 -- This normally illegal conversion is legal in an 4182 -- expanded instance body because of RM 12.3(11). 4183 -- At runtime, conversion must create a new object. 4184 4185 if not In_Instance then 4186 Error_Msg_N 4187 ("both component types in a view conversion must" 4188 & " be aliased, or neither", A); 4189 end if; 4190 4191 -- Check RM 4.6 (24/3) 4192 4193 elsif not Same_Ancestor (Etype (F), Expr_Typ) then 4194 -- Check view conv between unrelated by ref array 4195 -- types. 4196 4197 if Is_By_Reference_Type (Etype (F)) 4198 or else Is_By_Reference_Type (Expr_Typ) 4199 then 4200 Error_Msg_N 4201 ("view conversion between unrelated by reference " 4202 & "array types not allowed ('A'I-00246)", A); 4203 4204 -- In Ada 2005 mode, check view conversion component 4205 -- type cannot be private, tagged, or volatile. Note 4206 -- that we only apply this to source conversions. The 4207 -- generated code can contain conversions which are 4208 -- not subject to this test, and we cannot extract the 4209 -- component type in such cases since it is not 4210 -- present. 4211 4212 elsif Comes_From_Source (A) 4213 and then Ada_Version >= Ada_2005 4214 then 4215 declare 4216 Comp_Type : constant Entity_Id := 4217 Component_Type (Expr_Typ); 4218 begin 4219 if (Is_Private_Type (Comp_Type) 4220 and then not Is_Generic_Type (Comp_Type)) 4221 or else Is_Tagged_Type (Comp_Type) 4222 or else Is_Volatile (Comp_Type) 4223 then 4224 Error_Msg_N 4225 ("component type of a view conversion " & 4226 "cannot be private, tagged, or volatile" & 4227 " (RM 4.6 (24))", 4228 Expression (A)); 4229 end if; 4230 end; 4231 end if; 4232 end if; 4233 4234 -- AI12-0074 & AI12-0377 4235 -- Check 6.4.1: If the mode is out, the actual parameter is 4236 -- a view conversion, and the type of the formal parameter 4237 -- is a scalar type, then either: 4238 -- - the target and operand type both do not have the 4239 -- Default_Value aspect specified; or 4240 -- - the target and operand type both have the 4241 -- Default_Value aspect specified, and there shall exist 4242 -- a type (other than a root numeric type) that is an 4243 -- ancestor of both the target type and the operand 4244 -- type. 4245 4246 elsif Ekind (F) = E_Out_Parameter 4247 and then Is_Scalar_Type (Etype (F)) 4248 then 4249 if Has_Default_Aspect (Etype (F)) /= 4250 Has_Default_Aspect (Expr_Typ) 4251 then 4252 Error_Msg_N 4253 ("view conversion requires Default_Value on both " & 4254 "types (RM 6.4.1)", A); 4255 elsif Has_Default_Aspect (Expr_Typ) 4256 and then not Same_Ancestor (Etype (F), Expr_Typ) 4257 then 4258 Error_Msg_N 4259 ("view conversion between unrelated types with " 4260 & "Default_Value not allowed (RM 6.4.1)", A); 4261 end if; 4262 end if; 4263 end; 4264 4265 -- Resolve expression if conversion is all OK 4266 4267 if (Conversion_OK (A) 4268 or else Valid_Conversion (A, Etype (A), Expression (A))) 4269 and then not Is_Ref_To_Bit_Packed_Array (Expression (A)) 4270 then 4271 Resolve (Expression (A)); 4272 end if; 4273 4274 -- If the actual is a function call that returns a limited 4275 -- unconstrained object that needs finalization, create a 4276 -- transient scope for it, so that it can receive the proper 4277 -- finalization list. 4278 4279 elsif Expander_Active 4280 and then Nkind (A) = N_Function_Call 4281 and then Is_Limited_Record (Etype (F)) 4282 and then not Is_Constrained (Etype (F)) 4283 and then (Needs_Finalization (Etype (F)) 4284 or else Has_Task (Etype (F))) 4285 then 4286 Establish_Transient_Scope (A, Manage_Sec_Stack => False); 4287 Resolve (A, Etype (F)); 4288 4289 -- A small optimization: if one of the actuals is a concatenation 4290 -- create a block around a procedure call to recover stack space. 4291 -- This alleviates stack usage when several procedure calls in 4292 -- the same statement list use concatenation. We do not perform 4293 -- this wrapping for code statements, where the argument is a 4294 -- static string, and we want to preserve warnings involving 4295 -- sequences of such statements. 4296 4297 elsif Expander_Active 4298 and then Nkind (A) = N_Op_Concat 4299 and then Nkind (N) = N_Procedure_Call_Statement 4300 and then not (Is_Intrinsic_Subprogram (Nam) 4301 and then Chars (Nam) = Name_Asm) 4302 and then not Static_Concatenation (A) 4303 then 4304 Establish_Transient_Scope (A, Manage_Sec_Stack => False); 4305 Resolve (A, Etype (F)); 4306 4307 else 4308 if Nkind (A) = N_Type_Conversion 4309 and then Is_Array_Type (Etype (F)) 4310 and then not Same_Ancestor (Etype (F), Etype (Expression (A))) 4311 and then 4312 (Is_Limited_Type (Etype (F)) 4313 or else Is_Limited_Type (Etype (Expression (A)))) 4314 then 4315 Error_Msg_N 4316 ("conversion between unrelated limited array types not " 4317 & "allowed ('A'I-00246)", A); 4318 4319 if Is_Limited_Type (Etype (F)) then 4320 Explain_Limited_Type (Etype (F), A); 4321 end if; 4322 4323 if Is_Limited_Type (Etype (Expression (A))) then 4324 Explain_Limited_Type (Etype (Expression (A)), A); 4325 end if; 4326 end if; 4327 4328 -- (Ada 2005: AI-251): If the actual is an allocator whose 4329 -- directly designated type is a class-wide interface, we build 4330 -- an anonymous access type to use it as the type of the 4331 -- allocator. Later, when the subprogram call is expanded, if 4332 -- the interface has a secondary dispatch table the expander 4333 -- will add a type conversion to force the correct displacement 4334 -- of the pointer. 4335 4336 if Nkind (A) = N_Allocator then 4337 declare 4338 DDT : constant Entity_Id := 4339 Directly_Designated_Type (Base_Type (Etype (F))); 4340 4341 begin 4342 -- Displace the pointer to the object to reference its 4343 -- secondary dispatch table. 4344 4345 if Is_Class_Wide_Type (DDT) 4346 and then Is_Interface (DDT) 4347 then 4348 Rewrite (A, Convert_To (Etype (F), Relocate_Node (A))); 4349 Analyze_And_Resolve (A, Etype (F), 4350 Suppress => Access_Check); 4351 end if; 4352 4353 -- Ada 2005, AI-162:If the actual is an allocator, the 4354 -- innermost enclosing statement is the master of the 4355 -- created object. This needs to be done with expansion 4356 -- enabled only, otherwise the transient scope will not 4357 -- be removed in the expansion of the wrapped construct. 4358 4359 if Expander_Active 4360 and then (Needs_Finalization (DDT) 4361 or else Has_Task (DDT)) 4362 then 4363 Establish_Transient_Scope 4364 (A, Manage_Sec_Stack => False); 4365 end if; 4366 end; 4367 4368 if Ekind (Etype (F)) = E_Anonymous_Access_Type then 4369 Check_Restriction (No_Access_Parameter_Allocators, A); 4370 end if; 4371 end if; 4372 4373 -- (Ada 2005): The call may be to a primitive operation of a 4374 -- tagged synchronized type, declared outside of the type. In 4375 -- this case the controlling actual must be converted to its 4376 -- corresponding record type, which is the formal type. The 4377 -- actual may be a subtype, either because of a constraint or 4378 -- because it is a generic actual, so use base type to locate 4379 -- concurrent type. 4380 4381 F_Typ := Base_Type (Etype (F)); 4382 4383 if Is_Tagged_Type (F_Typ) 4384 and then (Is_Concurrent_Type (F_Typ) 4385 or else Is_Concurrent_Record_Type (F_Typ)) 4386 then 4387 -- If the actual is overloaded, look for an interpretation 4388 -- that has a synchronized type. 4389 4390 if not Is_Overloaded (A) then 4391 A_Typ := Base_Type (Etype (A)); 4392 4393 else 4394 declare 4395 Index : Interp_Index; 4396 It : Interp; 4397 4398 begin 4399 Get_First_Interp (A, Index, It); 4400 while Present (It.Typ) loop 4401 if Is_Concurrent_Type (It.Typ) 4402 or else Is_Concurrent_Record_Type (It.Typ) 4403 then 4404 A_Typ := Base_Type (It.Typ); 4405 exit; 4406 end if; 4407 4408 Get_Next_Interp (Index, It); 4409 end loop; 4410 end; 4411 end if; 4412 4413 declare 4414 Full_A_Typ : Entity_Id; 4415 4416 begin 4417 if Present (Full_View (A_Typ)) then 4418 Full_A_Typ := Base_Type (Full_View (A_Typ)); 4419 else 4420 Full_A_Typ := A_Typ; 4421 end if; 4422 4423 -- Tagged synchronized type (case 1): the actual is a 4424 -- concurrent type. 4425 4426 if Is_Concurrent_Type (A_Typ) 4427 and then Corresponding_Record_Type (A_Typ) = F_Typ 4428 then 4429 Rewrite (A, 4430 Unchecked_Convert_To 4431 (Corresponding_Record_Type (A_Typ), A)); 4432 Resolve (A, Etype (F)); 4433 4434 -- Tagged synchronized type (case 2): the formal is a 4435 -- concurrent type. 4436 4437 elsif Ekind (Full_A_Typ) = E_Record_Type 4438 and then Present 4439 (Corresponding_Concurrent_Type (Full_A_Typ)) 4440 and then Is_Concurrent_Type (F_Typ) 4441 and then Present (Corresponding_Record_Type (F_Typ)) 4442 and then Full_A_Typ = Corresponding_Record_Type (F_Typ) 4443 then 4444 Resolve (A, Corresponding_Record_Type (F_Typ)); 4445 4446 -- Common case 4447 4448 else 4449 Resolve (A, Etype (F)); 4450 end if; 4451 end; 4452 4453 -- Not a synchronized operation 4454 4455 else 4456 Resolve (A, Etype (F)); 4457 end if; 4458 end if; 4459 4460 A_Typ := Etype (A); 4461 F_Typ := Etype (F); 4462 4463 -- An actual cannot be an untagged formal incomplete type 4464 4465 if Ekind (A_Typ) = E_Incomplete_Type 4466 and then not Is_Tagged_Type (A_Typ) 4467 and then Is_Generic_Type (A_Typ) 4468 then 4469 Error_Msg_N 4470 ("invalid use of untagged formal incomplete type", A); 4471 end if; 4472 4473 -- has warnings suppressed, then we reset Never_Set_In_Source for 4474 -- the calling entity. The reason for this is to catch cases like 4475 -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram 4476 -- uses trickery to modify an IN parameter. 4477 4478 if Ekind (F) = E_In_Parameter 4479 and then Is_Entity_Name (A) 4480 and then Present (Entity (A)) 4481 and then Ekind (Entity (A)) = E_Variable 4482 and then Has_Warnings_Off (F_Typ) 4483 then 4484 Set_Never_Set_In_Source (Entity (A), False); 4485 end if; 4486 4487 -- Perform error checks for IN and IN OUT parameters 4488 4489 if Ekind (F) /= E_Out_Parameter then 4490 4491 -- Check unset reference. For scalar parameters, it is clearly 4492 -- wrong to pass an uninitialized value as either an IN or 4493 -- IN-OUT parameter. For composites, it is also clearly an 4494 -- error to pass a completely uninitialized value as an IN 4495 -- parameter, but the case of IN OUT is trickier. We prefer 4496 -- not to give a warning here. For example, suppose there is 4497 -- a routine that sets some component of a record to False. 4498 -- It is perfectly reasonable to make this IN-OUT and allow 4499 -- either initialized or uninitialized records to be passed 4500 -- in this case. 4501 4502 -- For partially initialized composite values, we also avoid 4503 -- warnings, since it is quite likely that we are passing a 4504 -- partially initialized value and only the initialized fields 4505 -- will in fact be read in the subprogram. 4506 4507 if Is_Scalar_Type (A_Typ) 4508 or else (Ekind (F) = E_In_Parameter 4509 and then not Is_Partially_Initialized_Type (A_Typ)) 4510 then 4511 Check_Unset_Reference (A); 4512 end if; 4513 4514 -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT 4515 -- actual to a nested call, since this constitutes a reading of 4516 -- the parameter, which is not allowed. 4517 4518 if Ada_Version = Ada_83 4519 and then Is_Entity_Name (A) 4520 and then Ekind (Entity (A)) = E_Out_Parameter 4521 then 4522 Error_Msg_N ("(Ada 83) illegal reading of out parameter", A); 4523 end if; 4524 end if; 4525 4526 -- In -gnatd.q mode, forget that a given array is constant when 4527 -- it is passed as an IN parameter to a foreign-convention 4528 -- subprogram. This is in case the subprogram evilly modifies the 4529 -- object. Of course, correct code would use IN OUT. 4530 4531 if Debug_Flag_Dot_Q 4532 and then Ekind (F) = E_In_Parameter 4533 and then Has_Foreign_Convention (Nam) 4534 and then Is_Array_Type (F_Typ) 4535 and then Nkind (A) in N_Has_Entity 4536 and then Present (Entity (A)) 4537 then 4538 Set_Is_True_Constant (Entity (A), False); 4539 end if; 4540 4541 -- Case of OUT or IN OUT parameter 4542 4543 if Ekind (F) /= E_In_Parameter then 4544 4545 -- For an Out parameter, check for useless assignment. Note 4546 -- that we can't set Last_Assignment this early, because we may 4547 -- kill current values in Resolve_Call, and that call would 4548 -- clobber the Last_Assignment field. 4549 4550 -- Note: call Warn_On_Useless_Assignment before doing the check 4551 -- below for Is_OK_Variable_For_Out_Formal so that the setting 4552 -- of Referenced_As_LHS/Referenced_As_Out_Formal properly 4553 -- reflects the last assignment, not this one. 4554 4555 if Ekind (F) = E_Out_Parameter then 4556 if Warn_On_Modified_As_Out_Parameter (F) 4557 and then Is_Entity_Name (A) 4558 and then Present (Entity (A)) 4559 and then Comes_From_Source (N) 4560 then 4561 Warn_On_Useless_Assignment (Entity (A), A); 4562 end if; 4563 end if; 4564 4565 -- Validate the form of the actual. Note that the call to 4566 -- Is_OK_Variable_For_Out_Formal generates the required 4567 -- reference in this case. 4568 4569 -- A call to an initialization procedure for an aggregate 4570 -- component may initialize a nested component of a constant 4571 -- designated object. In this context the object is variable. 4572 4573 if not Is_OK_Variable_For_Out_Formal (A) 4574 and then not Is_Init_Proc (Nam) 4575 then 4576 Error_Msg_NE ("actual for& must be a variable", A, F); 4577 4578 if Is_Subprogram (Current_Scope) then 4579 if Is_Invariant_Procedure (Current_Scope) 4580 or else Is_Partial_Invariant_Procedure (Current_Scope) 4581 then 4582 Error_Msg_N 4583 ("function used in invariant cannot modify its " 4584 & "argument", F); 4585 4586 elsif Is_Predicate_Function (Current_Scope) then 4587 Error_Msg_N 4588 ("function used in predicate cannot modify its " 4589 & "argument", F); 4590 end if; 4591 end if; 4592 end if; 4593 4594 -- What's the following about??? 4595 4596 if Is_Entity_Name (A) then 4597 Kill_Checks (Entity (A)); 4598 else 4599 Kill_All_Checks; 4600 end if; 4601 end if; 4602 4603 if A_Typ = Any_Type then 4604 Set_Etype (N, Any_Type); 4605 return; 4606 end if; 4607 4608 -- Apply appropriate constraint/predicate checks for IN [OUT] case 4609 4610 if Ekind (F) in E_In_Parameter | E_In_Out_Parameter then 4611 4612 -- Apply predicate tests except in certain special cases. Note 4613 -- that it might be more consistent to apply these only when 4614 -- expansion is active (in Exp_Ch6.Expand_Actuals), as we do 4615 -- for the outbound predicate tests ??? In any case indicate 4616 -- the function being called, for better warnings if the call 4617 -- leads to an infinite recursion. 4618 4619 if Predicate_Tests_On_Arguments (Nam) then 4620 Apply_Predicate_Check (A, F_Typ, Nam); 4621 end if; 4622 4623 -- Apply required constraint checks 4624 4625 if Is_Scalar_Type (A_Typ) then 4626 Apply_Scalar_Range_Check (A, F_Typ); 4627 4628 elsif Is_Array_Type (A_Typ) then 4629 Apply_Length_Check (A, F_Typ); 4630 4631 elsif Is_Record_Type (F_Typ) 4632 and then Has_Discriminants (F_Typ) 4633 and then Is_Constrained (F_Typ) 4634 and then (not Is_Derived_Type (F_Typ) 4635 or else Comes_From_Source (Nam)) 4636 then 4637 Apply_Discriminant_Check (A, F_Typ); 4638 4639 -- For view conversions of a discriminated object, apply 4640 -- check to object itself, the conversion alreay has the 4641 -- proper type. 4642 4643 if Nkind (A) = N_Type_Conversion 4644 and then Is_Constrained (Etype (Expression (A))) 4645 then 4646 Apply_Discriminant_Check (Expression (A), F_Typ); 4647 end if; 4648 4649 elsif Is_Access_Type (F_Typ) 4650 and then Is_Array_Type (Designated_Type (F_Typ)) 4651 and then Is_Constrained (Designated_Type (F_Typ)) 4652 then 4653 Apply_Length_Check (A, F_Typ); 4654 4655 elsif Is_Access_Type (F_Typ) 4656 and then Has_Discriminants (Designated_Type (F_Typ)) 4657 and then Is_Constrained (Designated_Type (F_Typ)) 4658 then 4659 Apply_Discriminant_Check (A, F_Typ); 4660 4661 else 4662 Apply_Range_Check (A, F_Typ); 4663 end if; 4664 4665 -- Ada 2005 (AI-231): Note that the controlling parameter case 4666 -- already existed in Ada 95, which is partially checked 4667 -- elsewhere (see Checks), and we don't want the warning 4668 -- message to differ. 4669 4670 if Is_Access_Type (F_Typ) 4671 and then Can_Never_Be_Null (F_Typ) 4672 and then Known_Null (A) 4673 then 4674 if Is_Controlling_Formal (F) then 4675 Apply_Compile_Time_Constraint_Error 4676 (N => A, 4677 Msg => "null value not allowed here??", 4678 Reason => CE_Access_Check_Failed); 4679 4680 elsif Ada_Version >= Ada_2005 then 4681 Apply_Compile_Time_Constraint_Error 4682 (N => A, 4683 Msg => "(Ada 2005) NULL not allowed in " 4684 & "null-excluding formal??", 4685 Reason => CE_Null_Not_Allowed); 4686 end if; 4687 end if; 4688 end if; 4689 4690 -- Checks for OUT parameters and IN OUT parameters 4691 4692 if Ekind (F) in E_Out_Parameter | E_In_Out_Parameter then 4693 4694 -- If there is a type conversion, make sure the return value 4695 -- meets the constraints of the variable before the conversion. 4696 4697 if Nkind (A) = N_Type_Conversion then 4698 if Is_Scalar_Type (A_Typ) then 4699 4700 -- Special case here tailored to Exp_Ch6.Is_Legal_Copy, 4701 -- which would prevent the check from being generated. 4702 -- This is for Starlet only though, so long obsolete. 4703 4704 if Mechanism (F) = By_Reference 4705 and then Ekind (Nam) = E_Procedure 4706 and then Is_Valued_Procedure (Nam) 4707 then 4708 null; 4709 else 4710 Apply_Scalar_Range_Check 4711 (Expression (A), Etype (Expression (A)), A_Typ); 4712 end if; 4713 4714 -- In addition the return value must meet the constraints 4715 -- of the object type (see the comment below). 4716 4717 Apply_Scalar_Range_Check (A, A_Typ, F_Typ); 4718 4719 else 4720 Apply_Range_Check 4721 (Expression (A), Etype (Expression (A)), A_Typ); 4722 end if; 4723 4724 -- If no conversion, apply scalar range checks and length check 4725 -- based on the subtype of the actual (NOT that of the formal). 4726 -- This indicates that the check takes place on return from the 4727 -- call. During expansion the required constraint checks are 4728 -- inserted. In GNATprove mode, in the absence of expansion, 4729 -- the flag indicates that the returned value is valid. 4730 4731 else 4732 if Is_Scalar_Type (F_Typ) then 4733 Apply_Scalar_Range_Check (A, A_Typ, F_Typ); 4734 4735 elsif Is_Array_Type (F_Typ) 4736 and then Ekind (F) = E_Out_Parameter 4737 then 4738 Apply_Length_Check (A, F_Typ); 4739 4740 else 4741 Apply_Range_Check (A, A_Typ, F_Typ); 4742 end if; 4743 end if; 4744 4745 -- Note: we do not apply the predicate checks for the case of 4746 -- OUT and IN OUT parameters. They are instead applied in the 4747 -- Expand_Actuals routine in Exp_Ch6. 4748 end if; 4749 4750 -- An actual associated with an access parameter is implicitly 4751 -- converted to the anonymous access type of the formal and must 4752 -- satisfy the legality checks for access conversions. 4753 4754 if Ekind (F_Typ) = E_Anonymous_Access_Type then 4755 if not Valid_Conversion (A, F_Typ, A) then 4756 Error_Msg_N 4757 ("invalid implicit conversion for access parameter", A); 4758 end if; 4759 4760 -- If the actual is an access selected component of a variable, 4761 -- the call may modify its designated object. It is reasonable 4762 -- to treat this as a potential modification of the enclosing 4763 -- record, to prevent spurious warnings that it should be 4764 -- declared as a constant, because intuitively programmers 4765 -- regard the designated subcomponent as part of the record. 4766 4767 if Nkind (A) = N_Selected_Component 4768 and then Is_Entity_Name (Prefix (A)) 4769 and then not Is_Constant_Object (Entity (Prefix (A))) 4770 then 4771 Note_Possible_Modification (A, Sure => False); 4772 end if; 4773 end if; 4774 4775 -- Check illegal cases of atomic/volatile/VFA actual (RM C.6(12)) 4776 4777 if (Is_By_Reference_Type (Etype (F)) or else Is_Aliased (F)) 4778 and then Comes_From_Source (N) 4779 then 4780 if Is_Atomic_Object (A) 4781 and then not Is_Atomic (Etype (F)) 4782 then 4783 Error_Msg_NE 4784 ("cannot pass atomic object to nonatomic formal&", 4785 A, F); 4786 Error_Msg_N 4787 ("\which is passed by reference (RM C.6(12))", A); 4788 4789 elsif Is_Volatile_Object (A) 4790 and then not Is_Volatile (Etype (F)) 4791 then 4792 Error_Msg_NE 4793 ("cannot pass volatile object to nonvolatile formal&", 4794 A, F); 4795 Error_Msg_N 4796 ("\which is passed by reference (RM C.6(12))", A); 4797 4798 elsif Is_Volatile_Full_Access_Object (A) 4799 and then not Is_Volatile_Full_Access (Etype (F)) 4800 then 4801 Error_Msg_NE 4802 ("cannot pass full access object to nonfull access " 4803 & "formal&", A, F); 4804 Error_Msg_N 4805 ("\which is passed by reference (RM C.6(12))", A); 4806 end if; 4807 4808 -- Check for nonatomic subcomponent of a full access object 4809 -- in Ada 2020 (RM C.6 (12)). 4810 4811 if Ada_Version >= Ada_2020 4812 and then Is_Subcomponent_Of_Full_Access_Object (A) 4813 and then not Is_Atomic_Object (A) 4814 then 4815 Error_Msg_N 4816 ("cannot pass nonatomic subcomponent of full access " 4817 & "object", A); 4818 Error_Msg_NE 4819 ("\to formal & which is passed by reference (RM C.6(12))", 4820 A, F); 4821 end if; 4822 end if; 4823 4824 -- Check that subprograms don't have improper controlling 4825 -- arguments (RM 3.9.2 (9)). 4826 4827 -- A primitive operation may have an access parameter of an 4828 -- incomplete tagged type, but a dispatching call is illegal 4829 -- if the type is still incomplete. 4830 4831 if Is_Controlling_Formal (F) then 4832 Set_Is_Controlling_Actual (A); 4833 4834 if Ekind (Etype (F)) = E_Anonymous_Access_Type then 4835 declare 4836 Desig : constant Entity_Id := Designated_Type (Etype (F)); 4837 begin 4838 if Ekind (Desig) = E_Incomplete_Type 4839 and then No (Full_View (Desig)) 4840 and then No (Non_Limited_View (Desig)) 4841 then 4842 Error_Msg_NE 4843 ("premature use of incomplete type& " 4844 & "in dispatching call", A, Desig); 4845 end if; 4846 end; 4847 end if; 4848 4849 elsif Nkind (A) = N_Explicit_Dereference then 4850 Validate_Remote_Access_To_Class_Wide_Type (A); 4851 end if; 4852 4853 -- Apply legality rule 3.9.2 (9/1) 4854 4855 if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A)) 4856 and then not Is_Class_Wide_Type (F_Typ) 4857 and then not Is_Controlling_Formal (F) 4858 and then not In_Instance 4859 then 4860 Error_Msg_N ("class-wide argument not allowed here!", A); 4861 4862 if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then 4863 Error_Msg_Node_2 := F_Typ; 4864 Error_Msg_NE 4865 ("& is not a dispatching operation of &!", A, Nam); 4866 end if; 4867 4868 -- Apply the checks described in 3.10.2(27): if the context is a 4869 -- specific access-to-object, the actual cannot be class-wide. 4870 -- Use base type to exclude access_to_subprogram cases. 4871 4872 elsif Is_Access_Type (A_Typ) 4873 and then Is_Access_Type (F_Typ) 4874 and then not Is_Access_Subprogram_Type (Base_Type (F_Typ)) 4875 and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) 4876 or else (Nkind (A) = N_Attribute_Reference 4877 and then 4878 Is_Class_Wide_Type (Etype (Prefix (A))))) 4879 and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) 4880 and then not Is_Controlling_Formal (F) 4881 4882 -- Disable these checks for call to imported C++ subprograms 4883 4884 and then not 4885 (Is_Entity_Name (Name (N)) 4886 and then Is_Imported (Entity (Name (N))) 4887 and then Convention (Entity (Name (N))) = Convention_CPP) 4888 then 4889 Error_Msg_N 4890 ("access to class-wide argument not allowed here!", A); 4891 4892 if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then 4893 Error_Msg_Node_2 := Designated_Type (F_Typ); 4894 Error_Msg_NE 4895 ("& is not a dispatching operation of &!", A, Nam); 4896 end if; 4897 end if; 4898 4899 Check_Aliased_Parameter; 4900 4901 Eval_Actual (A); 4902 4903 -- If it is a named association, treat the selector_name as a 4904 -- proper identifier, and mark the corresponding entity. 4905 4906 if Nkind (Parent (A)) = N_Parameter_Association 4907 4908 -- Ignore reference in SPARK mode, as it refers to an entity not 4909 -- in scope at the point of reference, so the reference should 4910 -- be ignored for computing effects of subprograms. 4911 4912 and then not GNATprove_Mode 4913 then 4914 -- If subprogram is overridden, use name of formal that 4915 -- is being called. 4916 4917 if Present (Real_Subp) then 4918 Set_Entity (Selector_Name (Parent (A)), Real_F); 4919 Set_Etype (Selector_Name (Parent (A)), Etype (Real_F)); 4920 4921 else 4922 Set_Entity (Selector_Name (Parent (A)), F); 4923 Generate_Reference (F, Selector_Name (Parent (A))); 4924 Set_Etype (Selector_Name (Parent (A)), F_Typ); 4925 Generate_Reference (F_Typ, N, ' '); 4926 end if; 4927 end if; 4928 4929 Prev := A; 4930 4931 if Ekind (F) /= E_Out_Parameter then 4932 Check_Unset_Reference (A); 4933 end if; 4934 4935 -- The following checks are only relevant when SPARK_Mode is on as 4936 -- they are not standard Ada legality rule. Internally generated 4937 -- temporaries are ignored. 4938 4939 if SPARK_Mode = On and then Comes_From_Source (A) then 4940 4941 -- An effectively volatile object for reading may act as an 4942 -- actual when the corresponding formal is of a non-scalar 4943 -- effectively volatile type for reading (SPARK RM 7.1.3(10)). 4944 4945 if not Is_Scalar_Type (Etype (F)) 4946 and then Is_Effectively_Volatile_For_Reading (Etype (F)) 4947 then 4948 null; 4949 4950 -- An effectively volatile object for reading may act as an 4951 -- actual in a call to an instance of Unchecked_Conversion. 4952 -- (SPARK RM 7.1.3(10)). 4953 4954 elsif Is_Unchecked_Conversion_Instance (Nam) then 4955 null; 4956 4957 -- The actual denotes an object 4958 4959 elsif Is_Effectively_Volatile_Object_For_Reading (A) then 4960 Error_Msg_N 4961 ("volatile object cannot act as actual in a call (SPARK " 4962 & "RM 7.1.3(10))", A); 4963 4964 -- Otherwise the actual denotes an expression. Inspect the 4965 -- expression and flag each effectively volatile object 4966 -- for reading as illegal because it apprears within an 4967 -- interfering context. Note that this is usually done in 4968 -- Resolve_Entity_Name, but when the effectively volatile 4969 -- object for reading appears as an actual in a call, the 4970 -- call must be resolved first. 4971 4972 else 4973 Flag_Effectively_Volatile_Objects (A); 4974 end if; 4975 4976 -- An effectively volatile variable cannot act as an actual 4977 -- parameter in a procedure call when the variable has enabled 4978 -- property Effective_Reads and the corresponding formal is of 4979 -- mode IN (SPARK RM 7.1.3(10)). 4980 4981 if Ekind (Nam) = E_Procedure 4982 and then Ekind (F) = E_In_Parameter 4983 and then Is_Entity_Name (A) 4984 then 4985 A_Id := Entity (A); 4986 4987 if Ekind (A_Id) = E_Variable 4988 and then Is_Effectively_Volatile_For_Reading (Etype (A_Id)) 4989 and then Effective_Reads_Enabled (A_Id) 4990 then 4991 Error_Msg_NE 4992 ("effectively volatile variable & cannot appear as " 4993 & "actual in procedure call", A, A_Id); 4994 4995 Error_Msg_Name_1 := Name_Effective_Reads; 4996 Error_Msg_N ("\\variable has enabled property %", A); 4997 Error_Msg_N ("\\corresponding formal has mode IN", A); 4998 end if; 4999 end if; 5000 end if; 5001 5002 -- A formal parameter of a specific tagged type whose related 5003 -- subprogram is subject to pragma Extensions_Visible with value 5004 -- "False" cannot act as an actual in a subprogram with value 5005 -- "True" (SPARK RM 6.1.7(3)). 5006 5007 if Is_EVF_Expression (A) 5008 and then Extensions_Visible_Status (Nam) = 5009 Extensions_Visible_True 5010 then 5011 Error_Msg_N 5012 ("formal parameter cannot act as actual parameter when " 5013 & "Extensions_Visible is False", A); 5014 Error_Msg_NE 5015 ("\subprogram & has Extensions_Visible True", A, Nam); 5016 end if; 5017 5018 -- The actual parameter of a Ghost subprogram whose formal is of 5019 -- mode IN OUT or OUT must be a Ghost variable (SPARK RM 6.9(12)). 5020 5021 if Comes_From_Source (Nam) 5022 and then Is_Ghost_Entity (Nam) 5023 and then Ekind (F) in E_In_Out_Parameter | E_Out_Parameter 5024 and then Is_Entity_Name (A) 5025 and then Present (Entity (A)) 5026 and then not Is_Ghost_Entity (Entity (A)) 5027 then 5028 Error_Msg_NE 5029 ("non-ghost variable & cannot appear as actual in call to " 5030 & "ghost procedure", A, Entity (A)); 5031 5032 if Ekind (F) = E_In_Out_Parameter then 5033 Error_Msg_N ("\corresponding formal has mode `IN OUT`", A); 5034 else 5035 Error_Msg_N ("\corresponding formal has mode OUT", A); 5036 end if; 5037 end if; 5038 5039 Next_Actual (A); 5040 5041 -- Case where actual is not present 5042 5043 else 5044 Insert_Default; 5045 end if; 5046 5047 Next_Formal (F); 5048 5049 if Present (Real_Subp) then 5050 Next_Formal (Real_F); 5051 end if; 5052 end loop; 5053 end Resolve_Actuals; 5054 5055 ----------------------- 5056 -- Resolve_Allocator -- 5057 ----------------------- 5058 5059 procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is 5060 Desig_T : constant Entity_Id := Designated_Type (Typ); 5061 E : constant Node_Id := Expression (N); 5062 Subtyp : Entity_Id; 5063 Discrim : Entity_Id; 5064 Constr : Node_Id; 5065 Aggr : Node_Id; 5066 Assoc : Node_Id := Empty; 5067 Disc_Exp : Node_Id; 5068 5069 procedure Check_Allocator_Discrim_Accessibility 5070 (Disc_Exp : Node_Id; 5071 Alloc_Typ : Entity_Id); 5072 -- Check that accessibility level associated with an access discriminant 5073 -- initialized in an allocator by the expression Disc_Exp is not deeper 5074 -- than the level of the allocator type Alloc_Typ. An error message is 5075 -- issued if this condition is violated. Specialized checks are done for 5076 -- the cases of a constraint expression which is an access attribute or 5077 -- an access discriminant. 5078 5079 procedure Check_Allocator_Discrim_Accessibility_Exprs 5080 (Curr_Exp : Node_Id; 5081 Alloc_Typ : Entity_Id); 5082 -- Dispatch checks performed by Check_Allocator_Discrim_Accessibility 5083 -- across all expressions within a given conditional expression. 5084 5085 function In_Dispatching_Context return Boolean; 5086 -- If the allocator is an actual in a call, it is allowed to be class- 5087 -- wide when the context is not because it is a controlling actual. 5088 5089 ------------------------------------------- 5090 -- Check_Allocator_Discrim_Accessibility -- 5091 ------------------------------------------- 5092 5093 procedure Check_Allocator_Discrim_Accessibility 5094 (Disc_Exp : Node_Id; 5095 Alloc_Typ : Entity_Id) 5096 is 5097 begin 5098 if Type_Access_Level (Etype (Disc_Exp)) > 5099 Deepest_Type_Access_Level (Alloc_Typ) 5100 then 5101 Error_Msg_N 5102 ("operand type has deeper level than allocator type", Disc_Exp); 5103 5104 -- When the expression is an Access attribute the level of the prefix 5105 -- object must not be deeper than that of the allocator's type. 5106 5107 elsif Nkind (Disc_Exp) = N_Attribute_Reference 5108 and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) = 5109 Attribute_Access 5110 and then Static_Accessibility_Level 5111 (Disc_Exp, Zero_On_Dynamic_Level) 5112 > Deepest_Type_Access_Level (Alloc_Typ) 5113 then 5114 Error_Msg_N 5115 ("prefix of attribute has deeper level than allocator type", 5116 Disc_Exp); 5117 5118 -- When the expression is an access discriminant the check is against 5119 -- the level of the prefix object. 5120 5121 elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type 5122 and then Nkind (Disc_Exp) = N_Selected_Component 5123 and then Static_Accessibility_Level 5124 (Disc_Exp, Zero_On_Dynamic_Level) 5125 > Deepest_Type_Access_Level (Alloc_Typ) 5126 then 5127 Error_Msg_N 5128 ("access discriminant has deeper level than allocator type", 5129 Disc_Exp); 5130 5131 -- All other cases are legal 5132 5133 else 5134 null; 5135 end if; 5136 end Check_Allocator_Discrim_Accessibility; 5137 5138 ------------------------------------------------- 5139 -- Check_Allocator_Discrim_Accessibility_Exprs -- 5140 ------------------------------------------------- 5141 5142 procedure Check_Allocator_Discrim_Accessibility_Exprs 5143 (Curr_Exp : Node_Id; 5144 Alloc_Typ : Entity_Id) 5145 is 5146 Alt : Node_Id; 5147 Expr : Node_Id; 5148 Disc_Exp : constant Node_Id := Original_Node (Curr_Exp); 5149 begin 5150 -- When conditional expressions are constant folded we know at 5151 -- compile time which expression to check - so don't bother with 5152 -- the rest of the cases. 5153 5154 if Nkind (Curr_Exp) = N_Attribute_Reference then 5155 Check_Allocator_Discrim_Accessibility (Curr_Exp, Alloc_Typ); 5156 5157 -- Non-constant-folded if expressions 5158 5159 elsif Nkind (Disc_Exp) = N_If_Expression then 5160 -- Check both expressions if they are still present in the face 5161 -- of expansion. 5162 5163 Expr := Next (First (Expressions (Disc_Exp))); 5164 if Present (Expr) then 5165 Check_Allocator_Discrim_Accessibility_Exprs (Expr, Alloc_Typ); 5166 Next (Expr); 5167 if Present (Expr) then 5168 Check_Allocator_Discrim_Accessibility_Exprs 5169 (Expr, Alloc_Typ); 5170 end if; 5171 end if; 5172 5173 -- Non-constant-folded case expressions 5174 5175 elsif Nkind (Disc_Exp) = N_Case_Expression then 5176 -- Check all alternatives 5177 5178 Alt := First (Alternatives (Disc_Exp)); 5179 while Present (Alt) loop 5180 Check_Allocator_Discrim_Accessibility_Exprs 5181 (Expression (Alt), Alloc_Typ); 5182 5183 Next (Alt); 5184 end loop; 5185 5186 -- Base case, check the accessibility of the original node of the 5187 -- expression. 5188 5189 else 5190 Check_Allocator_Discrim_Accessibility (Disc_Exp, Alloc_Typ); 5191 end if; 5192 end Check_Allocator_Discrim_Accessibility_Exprs; 5193 5194 ---------------------------- 5195 -- In_Dispatching_Context -- 5196 ---------------------------- 5197 5198 function In_Dispatching_Context return Boolean is 5199 Par : constant Node_Id := Parent (N); 5200 5201 begin 5202 return Nkind (Par) in N_Subprogram_Call 5203 and then Is_Entity_Name (Name (Par)) 5204 and then Is_Dispatching_Operation (Entity (Name (Par))); 5205 end In_Dispatching_Context; 5206 5207 -- Start of processing for Resolve_Allocator 5208 5209 begin 5210 -- Replace general access with specific type 5211 5212 if Ekind (Etype (N)) = E_Allocator_Type then 5213 Set_Etype (N, Base_Type (Typ)); 5214 end if; 5215 5216 if Is_Abstract_Type (Typ) then 5217 Error_Msg_N ("type of allocator cannot be abstract", N); 5218 end if; 5219 5220 -- For qualified expression, resolve the expression using the given 5221 -- subtype (nothing to do for type mark, subtype indication) 5222 5223 if Nkind (E) = N_Qualified_Expression then 5224 if Is_Class_Wide_Type (Etype (E)) 5225 and then not Is_Class_Wide_Type (Desig_T) 5226 and then not In_Dispatching_Context 5227 then 5228 Error_Msg_N 5229 ("class-wide allocator not allowed for this access type", N); 5230 end if; 5231 5232 -- Do a full resolution to apply constraint and predicate checks 5233 5234 Resolve_Qualified_Expression (E, Etype (E)); 5235 Check_Unset_Reference (Expression (E)); 5236 5237 -- Allocators generated by the build-in-place expansion mechanism 5238 -- are explicitly marked as coming from source but do not need to be 5239 -- checked for limited initialization. To exclude this case, ensure 5240 -- that the parent of the allocator is a source node. 5241 -- The return statement constructed for an Expression_Function does 5242 -- not come from source but requires a limited check. 5243 5244 if Is_Limited_Type (Etype (E)) 5245 and then Comes_From_Source (N) 5246 and then 5247 (Comes_From_Source (Parent (N)) 5248 or else 5249 (Ekind (Current_Scope) = E_Function 5250 and then Nkind (Original_Node (Unit_Declaration_Node 5251 (Current_Scope))) = N_Expression_Function)) 5252 and then not In_Instance_Body 5253 then 5254 if not OK_For_Limited_Init (Etype (E), Expression (E)) then 5255 if Nkind (Parent (N)) = N_Assignment_Statement then 5256 Error_Msg_N 5257 ("illegal expression for initialized allocator of a " 5258 & "limited type (RM 7.5 (2.7/2))", N); 5259 else 5260 Error_Msg_N 5261 ("initialization not allowed for limited types", N); 5262 end if; 5263 5264 Explain_Limited_Type (Etype (E), N); 5265 end if; 5266 end if; 5267 5268 -- Calls to build-in-place functions are not currently supported in 5269 -- allocators for access types associated with a simple storage pool. 5270 -- Supporting such allocators may require passing additional implicit 5271 -- parameters to build-in-place functions (or a significant revision 5272 -- of the current b-i-p implementation to unify the handling for 5273 -- multiple kinds of storage pools). ??? 5274 5275 if Is_Limited_View (Desig_T) 5276 and then Nkind (Expression (E)) = N_Function_Call 5277 then 5278 declare 5279 Pool : constant Entity_Id := 5280 Associated_Storage_Pool (Root_Type (Typ)); 5281 begin 5282 if Present (Pool) 5283 and then 5284 Present (Get_Rep_Pragma 5285 (Etype (Pool), Name_Simple_Storage_Pool_Type)) 5286 then 5287 Error_Msg_N 5288 ("limited function calls not yet supported in simple " 5289 & "storage pool allocators", Expression (E)); 5290 end if; 5291 end; 5292 end if; 5293 5294 -- A special accessibility check is needed for allocators that 5295 -- constrain access discriminants. The level of the type of the 5296 -- expression used to constrain an access discriminant cannot be 5297 -- deeper than the type of the allocator (in contrast to access 5298 -- parameters, where the level of the actual can be arbitrary). 5299 5300 -- We can't use Valid_Conversion to perform this check because in 5301 -- general the type of the allocator is unrelated to the type of 5302 -- the access discriminant. 5303 5304 if Ekind (Typ) /= E_Anonymous_Access_Type 5305 or else Is_Local_Anonymous_Access (Typ) 5306 then 5307 Subtyp := Entity (Subtype_Mark (E)); 5308 5309 Aggr := Original_Node (Expression (E)); 5310 5311 if Has_Discriminants (Subtyp) 5312 and then Nkind (Aggr) in N_Aggregate | N_Extension_Aggregate 5313 then 5314 Discrim := First_Discriminant (Base_Type (Subtyp)); 5315 5316 -- Get the first component expression of the aggregate 5317 5318 if Present (Expressions (Aggr)) then 5319 Disc_Exp := First (Expressions (Aggr)); 5320 5321 elsif Present (Component_Associations (Aggr)) then 5322 Assoc := First (Component_Associations (Aggr)); 5323 5324 if Present (Assoc) then 5325 Disc_Exp := Expression (Assoc); 5326 else 5327 Disc_Exp := Empty; 5328 end if; 5329 5330 else 5331 Disc_Exp := Empty; 5332 end if; 5333 5334 while Present (Discrim) and then Present (Disc_Exp) loop 5335 if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then 5336 Check_Allocator_Discrim_Accessibility_Exprs 5337 (Disc_Exp, Typ); 5338 end if; 5339 5340 Next_Discriminant (Discrim); 5341 5342 if Present (Discrim) then 5343 if Present (Assoc) then 5344 Next (Assoc); 5345 Disc_Exp := Expression (Assoc); 5346 5347 elsif Present (Next (Disc_Exp)) then 5348 Next (Disc_Exp); 5349 5350 else 5351 Assoc := First (Component_Associations (Aggr)); 5352 5353 if Present (Assoc) then 5354 Disc_Exp := Expression (Assoc); 5355 else 5356 Disc_Exp := Empty; 5357 end if; 5358 end if; 5359 end if; 5360 end loop; 5361 end if; 5362 end if; 5363 5364 -- For a subtype mark or subtype indication, freeze the subtype 5365 5366 else 5367 Freeze_Expression (E); 5368 5369 if Is_Access_Constant (Typ) and then not No_Initialization (N) then 5370 Error_Msg_N 5371 ("initialization required for access-to-constant allocator", N); 5372 end if; 5373 5374 -- A special accessibility check is needed for allocators that 5375 -- constrain access discriminants. The level of the type of the 5376 -- expression used to constrain an access discriminant cannot be 5377 -- deeper than the type of the allocator (in contrast to access 5378 -- parameters, where the level of the actual can be arbitrary). 5379 -- We can't use Valid_Conversion to perform this check because 5380 -- in general the type of the allocator is unrelated to the type 5381 -- of the access discriminant. 5382 5383 if Nkind (Original_Node (E)) = N_Subtype_Indication 5384 and then (Ekind (Typ) /= E_Anonymous_Access_Type 5385 or else Is_Local_Anonymous_Access (Typ)) 5386 then 5387 Subtyp := Entity (Subtype_Mark (Original_Node (E))); 5388 5389 if Has_Discriminants (Subtyp) then 5390 Discrim := First_Discriminant (Base_Type (Subtyp)); 5391 Constr := First (Constraints (Constraint (Original_Node (E)))); 5392 while Present (Discrim) and then Present (Constr) loop 5393 if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then 5394 if Nkind (Constr) = N_Discriminant_Association then 5395 Disc_Exp := Expression (Constr); 5396 else 5397 Disc_Exp := Constr; 5398 end if; 5399 5400 Check_Allocator_Discrim_Accessibility_Exprs 5401 (Disc_Exp, Typ); 5402 end if; 5403 5404 Next_Discriminant (Discrim); 5405 Next (Constr); 5406 end loop; 5407 end if; 5408 end if; 5409 end if; 5410 5411 -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility 5412 -- check that the level of the type of the created object is not deeper 5413 -- than the level of the allocator's access type, since extensions can 5414 -- now occur at deeper levels than their ancestor types. This is a 5415 -- static accessibility level check; a run-time check is also needed in 5416 -- the case of an initialized allocator with a class-wide argument (see 5417 -- Expand_Allocator_Expression). 5418 5419 if Ada_Version >= Ada_2005 5420 and then Is_Class_Wide_Type (Desig_T) 5421 then 5422 declare 5423 Exp_Typ : Entity_Id; 5424 5425 begin 5426 if Nkind (E) = N_Qualified_Expression then 5427 Exp_Typ := Etype (E); 5428 elsif Nkind (E) = N_Subtype_Indication then 5429 Exp_Typ := Entity (Subtype_Mark (Original_Node (E))); 5430 else 5431 Exp_Typ := Entity (E); 5432 end if; 5433 5434 if Type_Access_Level (Exp_Typ) > 5435 Deepest_Type_Access_Level (Typ) 5436 then 5437 if In_Instance_Body then 5438 Error_Msg_Warn := SPARK_Mode /= On; 5439 Error_Msg_N 5440 ("type in allocator has deeper level than designated " 5441 & "class-wide type<<", E); 5442 Error_Msg_N ("\Program_Error [<<", E); 5443 5444 Rewrite (N, 5445 Make_Raise_Program_Error (Sloc (N), 5446 Reason => PE_Accessibility_Check_Failed)); 5447 Set_Etype (N, Typ); 5448 5449 -- Do not apply Ada 2005 accessibility checks on a class-wide 5450 -- allocator if the type given in the allocator is a formal 5451 -- type or within a formal package. A run-time check will be 5452 -- performed in the instance. 5453 5454 elsif not Is_Generic_Type (Exp_Typ) 5455 and then not In_Generic_Formal_Package (Exp_Typ) 5456 then 5457 Error_Msg_N 5458 ("type in allocator has deeper level than designated " 5459 & "class-wide type", E); 5460 end if; 5461 end if; 5462 end; 5463 end if; 5464 5465 -- Check for allocation from an empty storage pool. But do not complain 5466 -- if it's a return statement for a build-in-place function, because the 5467 -- allocator is there just in case the caller uses an allocator. If the 5468 -- caller does use an allocator, it will be caught at the call site. 5469 5470 if No_Pool_Assigned (Typ) 5471 and then not Alloc_For_BIP_Return (N) 5472 then 5473 Error_Msg_N ("allocation from empty storage pool!", N); 5474 5475 -- If the context is an unchecked conversion, as may happen within an 5476 -- inlined subprogram, the allocator is being resolved with its own 5477 -- anonymous type. In that case, if the target type has a specific 5478 -- storage pool, it must be inherited explicitly by the allocator type. 5479 5480 elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion 5481 and then No (Associated_Storage_Pool (Typ)) 5482 then 5483 Set_Associated_Storage_Pool 5484 (Typ, Associated_Storage_Pool (Etype (Parent (N)))); 5485 end if; 5486 5487 if Ekind (Etype (N)) = E_Anonymous_Access_Type then 5488 Check_Restriction (No_Anonymous_Allocators, N); 5489 end if; 5490 5491 -- Check that an allocator with task parts isn't for a nested access 5492 -- type when restriction No_Task_Hierarchy applies. 5493 5494 if not Is_Library_Level_Entity (Base_Type (Typ)) 5495 and then Has_Task (Base_Type (Desig_T)) 5496 then 5497 Check_Restriction (No_Task_Hierarchy, N); 5498 end if; 5499 5500 -- An illegal allocator may be rewritten as a raise Program_Error 5501 -- statement. 5502 5503 if Nkind (N) = N_Allocator then 5504 5505 -- Avoid coextension processing for an allocator that is the 5506 -- expansion of a build-in-place function call. 5507 5508 if Nkind (Original_Node (N)) = N_Allocator 5509 and then Nkind (Expression (Original_Node (N))) = 5510 N_Qualified_Expression 5511 and then Nkind (Expression (Expression (Original_Node (N)))) = 5512 N_Function_Call 5513 and then Is_Expanded_Build_In_Place_Call 5514 (Expression (Expression (Original_Node (N)))) 5515 then 5516 null; -- b-i-p function call case 5517 5518 else 5519 -- An anonymous access discriminant is the definition of a 5520 -- coextension. 5521 5522 if Ekind (Typ) = E_Anonymous_Access_Type 5523 and then Nkind (Associated_Node_For_Itype (Typ)) = 5524 N_Discriminant_Specification 5525 then 5526 declare 5527 Discr : constant Entity_Id := 5528 Defining_Identifier (Associated_Node_For_Itype (Typ)); 5529 5530 begin 5531 Check_Restriction (No_Coextensions, N); 5532 5533 -- Ada 2012 AI05-0052: If the designated type of the 5534 -- allocator is limited, then the allocator shall not 5535 -- be used to define the value of an access discriminant 5536 -- unless the discriminated type is immutably limited. 5537 5538 if Ada_Version >= Ada_2012 5539 and then Is_Limited_Type (Desig_T) 5540 and then not Is_Limited_View (Scope (Discr)) 5541 then 5542 Error_Msg_N 5543 ("only immutably limited types can have anonymous " 5544 & "access discriminants designating a limited type", 5545 N); 5546 end if; 5547 end; 5548 5549 -- Avoid marking an allocator as a dynamic coextension if it is 5550 -- within a static construct. 5551 5552 if not Is_Static_Coextension (N) then 5553 Set_Is_Dynamic_Coextension (N); 5554 5555 -- Finalization and deallocation of coextensions utilizes an 5556 -- approximate implementation which does not directly adhere 5557 -- to the semantic rules. Warn on potential issues involving 5558 -- coextensions. 5559 5560 if Is_Controlled (Desig_T) then 5561 Error_Msg_N 5562 ("??coextension will not be finalized when its " 5563 & "associated owner is deallocated or finalized", N); 5564 else 5565 Error_Msg_N 5566 ("??coextension will not be deallocated when its " 5567 & "associated owner is deallocated", N); 5568 end if; 5569 end if; 5570 5571 -- Cleanup for potential static coextensions 5572 5573 else 5574 Set_Is_Dynamic_Coextension (N, False); 5575 Set_Is_Static_Coextension (N, False); 5576 5577 -- Anonymous access-to-controlled objects are not finalized on 5578 -- time because this involves run-time ownership and currently 5579 -- this property is not available. In rare cases the object may 5580 -- not be finalized at all. Warn on potential issues involving 5581 -- anonymous access-to-controlled objects. 5582 5583 if Ekind (Typ) = E_Anonymous_Access_Type 5584 and then Is_Controlled_Active (Desig_T) 5585 then 5586 Error_Msg_N 5587 ("??object designated by anonymous access object might " 5588 & "not be finalized until its enclosing library unit " 5589 & "goes out of scope", N); 5590 Error_Msg_N ("\use named access type instead", N); 5591 end if; 5592 end if; 5593 end if; 5594 end if; 5595 5596 -- Report a simple error: if the designated object is a local task, 5597 -- its body has not been seen yet, and its activation will fail an 5598 -- elaboration check. 5599 5600 if Is_Task_Type (Desig_T) 5601 and then Scope (Base_Type (Desig_T)) = Current_Scope 5602 and then Is_Compilation_Unit (Current_Scope) 5603 and then Ekind (Current_Scope) = E_Package 5604 and then not In_Package_Body (Current_Scope) 5605 then 5606 Error_Msg_Warn := SPARK_Mode /= On; 5607 Error_Msg_N ("cannot activate task before body seen<<", N); 5608 Error_Msg_N ("\Program_Error [<<", N); 5609 end if; 5610 5611 -- Ada 2012 (AI05-0111-3): Detect an attempt to allocate a task or a 5612 -- type with a task component on a subpool. This action must raise 5613 -- Program_Error at runtime. 5614 5615 if Ada_Version >= Ada_2012 5616 and then Nkind (N) = N_Allocator 5617 and then Present (Subpool_Handle_Name (N)) 5618 and then Has_Task (Desig_T) 5619 then 5620 Error_Msg_Warn := SPARK_Mode /= On; 5621 Error_Msg_N ("cannot allocate task on subpool<<", N); 5622 Error_Msg_N ("\Program_Error [<<", N); 5623 5624 Rewrite (N, 5625 Make_Raise_Program_Error (Sloc (N), 5626 Reason => PE_Explicit_Raise)); 5627 Set_Etype (N, Typ); 5628 end if; 5629 end Resolve_Allocator; 5630 5631 --------------------------- 5632 -- Resolve_Arithmetic_Op -- 5633 --------------------------- 5634 5635 -- Used for resolving all arithmetic operators except exponentiation 5636 5637 procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is 5638 L : constant Node_Id := Left_Opnd (N); 5639 R : constant Node_Id := Right_Opnd (N); 5640 TL : constant Entity_Id := Base_Type (Etype (L)); 5641 TR : constant Entity_Id := Base_Type (Etype (R)); 5642 T : Entity_Id; 5643 Rop : Node_Id; 5644 5645 B_Typ : constant Entity_Id := Base_Type (Typ); 5646 -- We do the resolution using the base type, because intermediate values 5647 -- in expressions always are of the base type, not a subtype of it. 5648 5649 function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean; 5650 -- Returns True if N is in a context that expects "any real type" 5651 5652 function Is_Integer_Or_Universal (N : Node_Id) return Boolean; 5653 -- Return True iff given type is Integer or universal real/integer 5654 5655 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id); 5656 -- Choose type of integer literal in fixed-point operation to conform 5657 -- to available fixed-point type. T is the type of the other operand, 5658 -- which is needed to determine the expected type of N. 5659 5660 procedure Set_Operand_Type (N : Node_Id); 5661 -- Set operand type to T if universal 5662 5663 ------------------------------- 5664 -- Expected_Type_Is_Any_Real -- 5665 ------------------------------- 5666 5667 function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is 5668 begin 5669 -- N is the expression after "delta" in a fixed_point_definition; 5670 -- see RM-3.5.9(6): 5671 5672 return Nkind (Parent (N)) in N_Ordinary_Fixed_Point_Definition 5673 | N_Decimal_Fixed_Point_Definition 5674 5675 -- N is one of the bounds in a real_range_specification; 5676 -- see RM-3.5.7(5): 5677 5678 | N_Real_Range_Specification 5679 5680 -- N is the expression of a delta_constraint; 5681 -- see RM-J.3(3): 5682 5683 | N_Delta_Constraint; 5684 end Expected_Type_Is_Any_Real; 5685 5686 ----------------------------- 5687 -- Is_Integer_Or_Universal -- 5688 ----------------------------- 5689 5690 function Is_Integer_Or_Universal (N : Node_Id) return Boolean is 5691 T : Entity_Id; 5692 Index : Interp_Index; 5693 It : Interp; 5694 5695 begin 5696 if not Is_Overloaded (N) then 5697 T := Etype (N); 5698 return Base_Type (T) = Base_Type (Standard_Integer) 5699 or else T = Universal_Integer 5700 or else T = Universal_Real; 5701 else 5702 Get_First_Interp (N, Index, It); 5703 while Present (It.Typ) loop 5704 if Base_Type (It.Typ) = Base_Type (Standard_Integer) 5705 or else It.Typ = Universal_Integer 5706 or else It.Typ = Universal_Real 5707 then 5708 return True; 5709 end if; 5710 5711 Get_Next_Interp (Index, It); 5712 end loop; 5713 end if; 5714 5715 return False; 5716 end Is_Integer_Or_Universal; 5717 5718 ---------------------------- 5719 -- Set_Mixed_Mode_Operand -- 5720 ---------------------------- 5721 5722 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is 5723 Index : Interp_Index; 5724 It : Interp; 5725 5726 begin 5727 if Universal_Interpretation (N) = Universal_Integer then 5728 5729 -- A universal integer literal is resolved as standard integer 5730 -- except in the case of a fixed-point result, where we leave it 5731 -- as universal (to be handled by Exp_Fixd later on) 5732 5733 if Is_Fixed_Point_Type (T) then 5734 Resolve (N, Universal_Integer); 5735 else 5736 Resolve (N, Standard_Integer); 5737 end if; 5738 5739 elsif Universal_Interpretation (N) = Universal_Real 5740 and then (T = Base_Type (Standard_Integer) 5741 or else T = Universal_Integer 5742 or else T = Universal_Real) 5743 then 5744 -- A universal real can appear in a fixed-type context. We resolve 5745 -- the literal with that context, even though this might raise an 5746 -- exception prematurely (the other operand may be zero). 5747 5748 Resolve (N, B_Typ); 5749 5750 elsif Etype (N) = Base_Type (Standard_Integer) 5751 and then T = Universal_Real 5752 and then Is_Overloaded (N) 5753 then 5754 -- Integer arg in mixed-mode operation. Resolve with universal 5755 -- type, in case preference rule must be applied. 5756 5757 Resolve (N, Universal_Integer); 5758 5759 elsif Etype (N) = T and then B_Typ /= Universal_Fixed then 5760 5761 -- If the operand is part of a fixed multiplication operation, 5762 -- a conversion will be applied to each operand, so resolve it 5763 -- with its own type. 5764 5765 if Nkind (Parent (N)) in N_Op_Divide | N_Op_Multiply then 5766 Resolve (N); 5767 5768 else 5769 -- Not a mixed-mode operation, resolve with context 5770 5771 Resolve (N, B_Typ); 5772 end if; 5773 5774 elsif Etype (N) = Any_Fixed then 5775 5776 -- N may itself be a mixed-mode operation, so use context type 5777 5778 Resolve (N, B_Typ); 5779 5780 elsif Is_Fixed_Point_Type (T) 5781 and then B_Typ = Universal_Fixed 5782 and then Is_Overloaded (N) 5783 then 5784 -- Must be (fixed * fixed) operation, operand must have one 5785 -- compatible interpretation. 5786 5787 Resolve (N, Any_Fixed); 5788 5789 elsif Is_Fixed_Point_Type (B_Typ) 5790 and then (T = Universal_Real or else Is_Fixed_Point_Type (T)) 5791 and then Is_Overloaded (N) 5792 then 5793 -- C * F(X) in a fixed context, where C is a real literal or a 5794 -- fixed-point expression. F must have either a fixed type 5795 -- interpretation or an integer interpretation, but not both. 5796 5797 Get_First_Interp (N, Index, It); 5798 while Present (It.Typ) loop 5799 if Base_Type (It.Typ) = Base_Type (Standard_Integer) then 5800 if Analyzed (N) then 5801 Error_Msg_N ("ambiguous operand in fixed operation", N); 5802 else 5803 Resolve (N, Standard_Integer); 5804 end if; 5805 5806 elsif Is_Fixed_Point_Type (It.Typ) then 5807 if Analyzed (N) then 5808 Error_Msg_N ("ambiguous operand in fixed operation", N); 5809 else 5810 Resolve (N, It.Typ); 5811 end if; 5812 end if; 5813 5814 Get_Next_Interp (Index, It); 5815 end loop; 5816 5817 -- Reanalyze the literal with the fixed type of the context. If 5818 -- context is Universal_Fixed, we are within a conversion, leave 5819 -- the literal as a universal real because there is no usable 5820 -- fixed type, and the target of the conversion plays no role in 5821 -- the resolution. 5822 5823 declare 5824 Op2 : Node_Id; 5825 T2 : Entity_Id; 5826 5827 begin 5828 if N = L then 5829 Op2 := R; 5830 else 5831 Op2 := L; 5832 end if; 5833 5834 if B_Typ = Universal_Fixed 5835 and then Nkind (Op2) = N_Real_Literal 5836 then 5837 T2 := Universal_Real; 5838 else 5839 T2 := B_Typ; 5840 end if; 5841 5842 Set_Analyzed (Op2, False); 5843 Resolve (Op2, T2); 5844 end; 5845 5846 -- A universal real conditional expression can appear in a fixed-type 5847 -- context and must be resolved with that context to facilitate the 5848 -- code generation in the back end. However, If the context is 5849 -- Universal_fixed (i.e. as an operand of a multiplication/division 5850 -- involving a fixed-point operand) the conditional expression must 5851 -- resolve to a unique visible fixed_point type, normally Duration. 5852 5853 elsif Nkind (N) in N_Case_Expression | N_If_Expression 5854 and then Etype (N) = Universal_Real 5855 and then Is_Fixed_Point_Type (B_Typ) 5856 then 5857 if B_Typ = Universal_Fixed then 5858 Resolve (N, Unique_Fixed_Point_Type (N)); 5859 5860 else 5861 Resolve (N, B_Typ); 5862 end if; 5863 5864 else 5865 Resolve (N); 5866 end if; 5867 end Set_Mixed_Mode_Operand; 5868 5869 ---------------------- 5870 -- Set_Operand_Type -- 5871 ---------------------- 5872 5873 procedure Set_Operand_Type (N : Node_Id) is 5874 begin 5875 if Etype (N) = Universal_Integer 5876 or else Etype (N) = Universal_Real 5877 then 5878 Set_Etype (N, T); 5879 end if; 5880 end Set_Operand_Type; 5881 5882 -- Start of processing for Resolve_Arithmetic_Op 5883 5884 begin 5885 if Comes_From_Source (N) 5886 and then Ekind (Entity (N)) = E_Function 5887 and then Is_Imported (Entity (N)) 5888 and then Is_Intrinsic_Subprogram (Entity (N)) 5889 then 5890 Resolve_Intrinsic_Operator (N, Typ); 5891 return; 5892 5893 -- Special-case for mixed-mode universal expressions or fixed point type 5894 -- operation: each argument is resolved separately. The same treatment 5895 -- is required if one of the operands of a fixed point operation is 5896 -- universal real, since in this case we don't do a conversion to a 5897 -- specific fixed-point type (instead the expander handles the case). 5898 5899 -- Set the type of the node to its universal interpretation because 5900 -- legality checks on an exponentiation operand need the context. 5901 5902 elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real) 5903 and then Present (Universal_Interpretation (L)) 5904 and then Present (Universal_Interpretation (R)) 5905 then 5906 Set_Etype (N, B_Typ); 5907 Resolve (L, Universal_Interpretation (L)); 5908 Resolve (R, Universal_Interpretation (R)); 5909 5910 elsif (B_Typ = Universal_Real 5911 or else Etype (N) = Universal_Fixed 5912 or else (Etype (N) = Any_Fixed 5913 and then Is_Fixed_Point_Type (B_Typ)) 5914 or else (Is_Fixed_Point_Type (B_Typ) 5915 and then (Is_Integer_Or_Universal (L) 5916 or else 5917 Is_Integer_Or_Universal (R)))) 5918 and then Nkind (N) in N_Op_Multiply | N_Op_Divide 5919 then 5920 if TL = Universal_Integer or else TR = Universal_Integer then 5921 Check_For_Visible_Operator (N, B_Typ); 5922 end if; 5923 5924 -- If context is a fixed type and one operand is integer, the other 5925 -- is resolved with the type of the context. 5926 5927 if Is_Fixed_Point_Type (B_Typ) 5928 and then (Base_Type (TL) = Base_Type (Standard_Integer) 5929 or else TL = Universal_Integer) 5930 then 5931 Resolve (R, B_Typ); 5932 Resolve (L, TL); 5933 5934 elsif Is_Fixed_Point_Type (B_Typ) 5935 and then (Base_Type (TR) = Base_Type (Standard_Integer) 5936 or else TR = Universal_Integer) 5937 then 5938 Resolve (L, B_Typ); 5939 Resolve (R, TR); 5940 5941 -- If both operands are universal and the context is a floating 5942 -- point type, the operands are resolved to the type of the context. 5943 5944 elsif Is_Floating_Point_Type (B_Typ) then 5945 Resolve (L, B_Typ); 5946 Resolve (R, B_Typ); 5947 5948 else 5949 Set_Mixed_Mode_Operand (L, TR); 5950 Set_Mixed_Mode_Operand (R, TL); 5951 end if; 5952 5953 -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed 5954 -- multiplying operators from being used when the expected type is 5955 -- also universal_fixed. Note that B_Typ will be Universal_Fixed in 5956 -- some cases where the expected type is actually Any_Real; 5957 -- Expected_Type_Is_Any_Real takes care of that case. 5958 5959 if Etype (N) = Universal_Fixed 5960 or else Etype (N) = Any_Fixed 5961 then 5962 if B_Typ = Universal_Fixed 5963 and then not Expected_Type_Is_Any_Real (N) 5964 and then Nkind (Parent (N)) not in 5965 N_Type_Conversion | N_Unchecked_Type_Conversion 5966 then 5967 Error_Msg_N ("type cannot be determined from context!", N); 5968 Error_Msg_N ("\explicit conversion to result type required", N); 5969 5970 Set_Etype (L, Any_Type); 5971 Set_Etype (R, Any_Type); 5972 5973 else 5974 if Ada_Version = Ada_83 5975 and then Etype (N) = Universal_Fixed 5976 and then Nkind (Parent (N)) not in 5977 N_Type_Conversion | N_Unchecked_Type_Conversion 5978 then 5979 Error_Msg_N 5980 ("(Ada 83) fixed-point operation needs explicit " 5981 & "conversion", N); 5982 end if; 5983 5984 -- The expected type is "any real type" in contexts like 5985 5986 -- type T is delta <universal_fixed-expression> ... 5987 5988 -- in which case we need to set the type to Universal_Real 5989 -- so that static expression evaluation will work properly. 5990 5991 if Expected_Type_Is_Any_Real (N) then 5992 Set_Etype (N, Universal_Real); 5993 else 5994 Set_Etype (N, B_Typ); 5995 end if; 5996 end if; 5997 5998 elsif Is_Fixed_Point_Type (B_Typ) 5999 and then (Is_Integer_Or_Universal (L) 6000 or else Nkind (L) = N_Real_Literal 6001 or else Nkind (R) = N_Real_Literal 6002 or else Is_Integer_Or_Universal (R)) 6003 then 6004 Set_Etype (N, B_Typ); 6005 6006 elsif Etype (N) = Any_Fixed then 6007 6008 -- If no previous errors, this is only possible if one operand is 6009 -- overloaded and the context is universal. Resolve as such. 6010 6011 Set_Etype (N, B_Typ); 6012 end if; 6013 6014 else 6015 if (TL = Universal_Integer or else TL = Universal_Real) 6016 and then 6017 (TR = Universal_Integer or else TR = Universal_Real) 6018 then 6019 Check_For_Visible_Operator (N, B_Typ); 6020 end if; 6021 6022 -- If the context is Universal_Fixed and the operands are also 6023 -- universal fixed, this is an error, unless there is only one 6024 -- applicable fixed_point type (usually Duration). 6025 6026 if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then 6027 T := Unique_Fixed_Point_Type (N); 6028 6029 if T = Any_Type then 6030 Set_Etype (N, T); 6031 return; 6032 else 6033 Resolve (L, T); 6034 Resolve (R, T); 6035 end if; 6036 6037 else 6038 Resolve (L, B_Typ); 6039 Resolve (R, B_Typ); 6040 end if; 6041 6042 -- If one of the arguments was resolved to a non-universal type. 6043 -- label the result of the operation itself with the same type. 6044 -- Do the same for the universal argument, if any. 6045 6046 T := Intersect_Types (L, R); 6047 Set_Etype (N, Base_Type (T)); 6048 Set_Operand_Type (L); 6049 Set_Operand_Type (R); 6050 end if; 6051 6052 Generate_Operator_Reference (N, Typ); 6053 Analyze_Dimension (N); 6054 Eval_Arithmetic_Op (N); 6055 6056 -- Set overflow and division checking bit 6057 6058 if Nkind (N) in N_Op then 6059 if not Overflow_Checks_Suppressed (Etype (N)) then 6060 Enable_Overflow_Check (N); 6061 end if; 6062 6063 -- Give warning if explicit division by zero 6064 6065 if Nkind (N) in N_Op_Divide | N_Op_Rem | N_Op_Mod 6066 and then not Division_Checks_Suppressed (Etype (N)) 6067 then 6068 Rop := Right_Opnd (N); 6069 6070 if Compile_Time_Known_Value (Rop) 6071 and then ((Is_Integer_Type (Etype (Rop)) 6072 and then Expr_Value (Rop) = Uint_0) 6073 or else 6074 (Is_Real_Type (Etype (Rop)) 6075 and then Expr_Value_R (Rop) = Ureal_0)) 6076 then 6077 -- Specialize the warning message according to the operation. 6078 -- When SPARK_Mode is On, force a warning instead of an error 6079 -- in that case, as this likely corresponds to deactivated 6080 -- code. The following warnings are for the case 6081 6082 case Nkind (N) is 6083 when N_Op_Divide => 6084 6085 -- For division, we have two cases, for float division 6086 -- of an unconstrained float type, on a machine where 6087 -- Machine_Overflows is false, we don't get an exception 6088 -- at run-time, but rather an infinity or Nan. The Nan 6089 -- case is pretty obscure, so just warn about infinities. 6090 6091 if Is_Floating_Point_Type (Typ) 6092 and then not Is_Constrained (Typ) 6093 and then not Machine_Overflows_On_Target 6094 then 6095 Error_Msg_N 6096 ("float division by zero, may generate " 6097 & "'+'/'- infinity??", Right_Opnd (N)); 6098 6099 -- For all other cases, we get a Constraint_Error 6100 6101 else 6102 Apply_Compile_Time_Constraint_Error 6103 (N, "division by zero??", CE_Divide_By_Zero, 6104 Loc => Sloc (Right_Opnd (N)), 6105 Warn => SPARK_Mode = On); 6106 end if; 6107 6108 when N_Op_Rem => 6109 Apply_Compile_Time_Constraint_Error 6110 (N, "rem with zero divisor??", CE_Divide_By_Zero, 6111 Loc => Sloc (Right_Opnd (N)), 6112 Warn => SPARK_Mode = On); 6113 6114 when N_Op_Mod => 6115 Apply_Compile_Time_Constraint_Error 6116 (N, "mod with zero divisor??", CE_Divide_By_Zero, 6117 Loc => Sloc (Right_Opnd (N)), 6118 Warn => SPARK_Mode = On); 6119 6120 -- Division by zero can only happen with division, rem, 6121 -- and mod operations. 6122 6123 when others => 6124 raise Program_Error; 6125 end case; 6126 6127 -- In GNATprove mode, we enable the division check so that 6128 -- GNATprove will issue a message if it cannot be proved. 6129 6130 if GNATprove_Mode then 6131 Activate_Division_Check (N); 6132 end if; 6133 6134 -- Otherwise just set the flag to check at run time 6135 6136 else 6137 Activate_Division_Check (N); 6138 end if; 6139 end if; 6140 6141 -- If Restriction No_Implicit_Conditionals is active, then it is 6142 -- violated if either operand can be negative for mod, or for rem 6143 -- if both operands can be negative. 6144 6145 if Restriction_Check_Required (No_Implicit_Conditionals) 6146 and then Nkind (N) in N_Op_Rem | N_Op_Mod 6147 then 6148 declare 6149 Lo : Uint; 6150 Hi : Uint; 6151 OK : Boolean; 6152 6153 LNeg : Boolean; 6154 RNeg : Boolean; 6155 -- Set if corresponding operand might be negative 6156 6157 begin 6158 Determine_Range 6159 (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True); 6160 LNeg := (not OK) or else Lo < 0; 6161 6162 Determine_Range 6163 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); 6164 RNeg := (not OK) or else Lo < 0; 6165 6166 -- Check if we will be generating conditionals. There are two 6167 -- cases where that can happen, first for REM, the only case 6168 -- is largest negative integer mod -1, where the division can 6169 -- overflow, but we still have to give the right result. The 6170 -- front end generates a test for this annoying case. Here we 6171 -- just test if both operands can be negative (that's what the 6172 -- expander does, so we match its logic here). 6173 6174 -- The second case is mod where either operand can be negative. 6175 -- In this case, the back end has to generate additional tests. 6176 6177 if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) 6178 or else 6179 (Nkind (N) = N_Op_Mod and then (LNeg or RNeg)) 6180 then 6181 Check_Restriction (No_Implicit_Conditionals, N); 6182 end if; 6183 end; 6184 end if; 6185 end if; 6186 6187 Check_Unset_Reference (L); 6188 Check_Unset_Reference (R); 6189 end Resolve_Arithmetic_Op; 6190 6191 ------------------ 6192 -- Resolve_Call -- 6193 ------------------ 6194 6195 procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is 6196 Loc : constant Source_Ptr := Sloc (N); 6197 Subp : constant Node_Id := Name (N); 6198 Body_Id : Entity_Id; 6199 I : Interp_Index; 6200 It : Interp; 6201 Nam : Entity_Id; 6202 Nam_Decl : Node_Id; 6203 Nam_UA : Entity_Id; 6204 Norm_OK : Boolean; 6205 Rtype : Entity_Id; 6206 Scop : Entity_Id; 6207 6208 begin 6209 -- Preserve relevant elaboration-related attributes of the context which 6210 -- are no longer available or very expensive to recompute once analysis, 6211 -- resolution, and expansion are over. 6212 6213 Mark_Elaboration_Attributes 6214 (N_Id => N, 6215 Checks => True, 6216 Modes => True, 6217 Warnings => True); 6218 6219 -- The context imposes a unique interpretation with type Typ on a 6220 -- procedure or function call. Find the entity of the subprogram that 6221 -- yields the expected type, and propagate the corresponding formal 6222 -- constraints on the actuals. The caller has established that an 6223 -- interpretation exists, and emitted an error if not unique. 6224 6225 -- First deal with the case of a call to an access-to-subprogram, 6226 -- dereference made explicit in Analyze_Call. 6227 6228 if Ekind (Etype (Subp)) = E_Subprogram_Type then 6229 if not Is_Overloaded (Subp) then 6230 Nam := Etype (Subp); 6231 6232 else 6233 -- Find the interpretation whose type (a subprogram type) has a 6234 -- return type that is compatible with the context. Analysis of 6235 -- the node has established that one exists. 6236 6237 Nam := Empty; 6238 6239 Get_First_Interp (Subp, I, It); 6240 while Present (It.Typ) loop 6241 if Covers (Typ, Etype (It.Typ)) then 6242 Nam := It.Typ; 6243 exit; 6244 end if; 6245 6246 Get_Next_Interp (I, It); 6247 end loop; 6248 6249 if No (Nam) then 6250 raise Program_Error; 6251 end if; 6252 end if; 6253 6254 -- If the prefix is not an entity, then resolve it 6255 6256 if not Is_Entity_Name (Subp) then 6257 Resolve (Subp, Nam); 6258 end if; 6259 6260 -- For an indirect call, we always invalidate checks, since we do not 6261 -- know whether the subprogram is local or global. Yes we could do 6262 -- better here, e.g. by knowing that there are no local subprograms, 6263 -- but it does not seem worth the effort. Similarly, we kill all 6264 -- knowledge of current constant values. 6265 6266 Kill_Current_Values; 6267 6268 -- If this is a procedure call which is really an entry call, do 6269 -- the conversion of the procedure call to an entry call. Protected 6270 -- operations use the same circuitry because the name in the call 6271 -- can be an arbitrary expression with special resolution rules. 6272 6273 elsif Nkind (Subp) in N_Selected_Component | N_Indexed_Component 6274 or else (Is_Entity_Name (Subp) and then Is_Entry (Entity (Subp))) 6275 then 6276 Resolve_Entry_Call (N, Typ); 6277 6278 if Legacy_Elaboration_Checks then 6279 Check_Elab_Call (N); 6280 end if; 6281 6282 -- Annotate the tree by creating a call marker in case the original 6283 -- call is transformed by expansion. The call marker is automatically 6284 -- saved for later examination by the ABE Processing phase. 6285 6286 Build_Call_Marker (N); 6287 6288 -- Kill checks and constant values, as above for indirect case 6289 -- Who knows what happens when another task is activated? 6290 6291 Kill_Current_Values; 6292 return; 6293 6294 -- Normal subprogram call with name established in Resolve 6295 6296 elsif not Is_Type (Entity (Subp)) then 6297 Nam := Entity (Subp); 6298 Set_Entity_With_Checks (Subp, Nam); 6299 6300 -- Otherwise we must have the case of an overloaded call 6301 6302 else 6303 pragma Assert (Is_Overloaded (Subp)); 6304 6305 -- Initialize Nam to prevent warning (we know it will be assigned 6306 -- in the loop below, but the compiler does not know that). 6307 6308 Nam := Empty; 6309 6310 Get_First_Interp (Subp, I, It); 6311 while Present (It.Typ) loop 6312 if Covers (Typ, It.Typ) then 6313 Nam := It.Nam; 6314 Set_Entity_With_Checks (Subp, Nam); 6315 exit; 6316 end if; 6317 6318 Get_Next_Interp (I, It); 6319 end loop; 6320 end if; 6321 6322 -- Check that a call to Current_Task does not occur in an entry body 6323 6324 if Is_RTE (Nam, RE_Current_Task) then 6325 declare 6326 P : Node_Id; 6327 6328 begin 6329 P := N; 6330 loop 6331 P := Parent (P); 6332 6333 -- Exclude calls that occur within the default of a formal 6334 -- parameter of the entry, since those are evaluated outside 6335 -- of the body. 6336 6337 exit when No (P) or else Nkind (P) = N_Parameter_Specification; 6338 6339 if Nkind (P) = N_Entry_Body 6340 or else (Nkind (P) = N_Subprogram_Body 6341 and then Is_Entry_Barrier_Function (P)) 6342 then 6343 Rtype := Etype (N); 6344 Error_Msg_Warn := SPARK_Mode /= On; 6345 Error_Msg_NE 6346 ("& should not be used in entry body (RM C.7(17))<<", 6347 N, Nam); 6348 Error_Msg_NE ("\Program_Error [<<", N, Nam); 6349 Rewrite (N, 6350 Make_Raise_Program_Error (Loc, 6351 Reason => PE_Current_Task_In_Entry_Body)); 6352 Set_Etype (N, Rtype); 6353 return; 6354 end if; 6355 end loop; 6356 end; 6357 end if; 6358 6359 -- Check that a procedure call does not occur in the context of the 6360 -- entry call statement of a conditional or timed entry call. Note that 6361 -- the case of a call to a subprogram renaming of an entry will also be 6362 -- rejected. The test for N not being an N_Entry_Call_Statement is 6363 -- defensive, covering the possibility that the processing of entry 6364 -- calls might reach this point due to later modifications of the code 6365 -- above. 6366 6367 if Nkind (Parent (N)) = N_Entry_Call_Alternative 6368 and then Nkind (N) /= N_Entry_Call_Statement 6369 and then Entry_Call_Statement (Parent (N)) = N 6370 then 6371 if Ada_Version < Ada_2005 then 6372 Error_Msg_N ("entry call required in select statement", N); 6373 6374 -- Ada 2005 (AI-345): If a procedure_call_statement is used 6375 -- for a procedure_or_entry_call, the procedure_name or 6376 -- procedure_prefix of the procedure_call_statement shall denote 6377 -- an entry renamed by a procedure, or (a view of) a primitive 6378 -- subprogram of a limited interface whose first parameter is 6379 -- a controlling parameter. 6380 6381 elsif Nkind (N) = N_Procedure_Call_Statement 6382 and then not Is_Renamed_Entry (Nam) 6383 and then not Is_Controlling_Limited_Procedure (Nam) 6384 then 6385 Error_Msg_N 6386 ("entry call or dispatching primitive of interface required", N); 6387 end if; 6388 end if; 6389 6390 -- Check that this is not a call to a protected procedure or entry from 6391 -- within a protected function. 6392 6393 Check_Internal_Protected_Use (N, Nam); 6394 6395 -- Freeze the subprogram name if not in a spec-expression. Note that 6396 -- we freeze procedure calls as well as function calls. Procedure calls 6397 -- are not frozen according to the rules (RM 13.14(14)) because it is 6398 -- impossible to have a procedure call to a non-frozen procedure in 6399 -- pure Ada, but in the code that we generate in the expander, this 6400 -- rule needs extending because we can generate procedure calls that 6401 -- need freezing. 6402 6403 -- In Ada 2012, expression functions may be called within pre/post 6404 -- conditions of subsequent functions or expression functions. Such 6405 -- calls do not freeze when they appear within generated bodies, 6406 -- (including the body of another expression function) which would 6407 -- place the freeze node in the wrong scope. An expression function 6408 -- is frozen in the usual fashion, by the appearance of a real body, 6409 -- or at the end of a declarative part. However an implicit call to 6410 -- an expression function may appear when it is part of a default 6411 -- expression in a call to an initialization procedure, and must be 6412 -- frozen now, even if the body is inserted at a later point. 6413 -- Otherwise, the call freezes the expression if expander is active, 6414 -- for example as part of an object declaration. 6415 6416 if Is_Entity_Name (Subp) 6417 and then not In_Spec_Expression 6418 and then not Is_Expression_Function_Or_Completion (Current_Scope) 6419 and then 6420 (not Is_Expression_Function_Or_Completion (Entity (Subp)) 6421 or else Expander_Active) 6422 then 6423 if Is_Expression_Function (Entity (Subp)) then 6424 6425 -- Force freeze of expression function in call 6426 6427 Set_Comes_From_Source (Subp, True); 6428 Set_Must_Not_Freeze (Subp, False); 6429 end if; 6430 6431 Freeze_Expression (Subp); 6432 end if; 6433 6434 -- For a predefined operator, the type of the result is the type imposed 6435 -- by context, except for a predefined operation on universal fixed. 6436 -- Otherwise the type of the call is the type returned by the subprogram 6437 -- being called. 6438 6439 if Is_Predefined_Op (Nam) then 6440 if Etype (N) /= Universal_Fixed then 6441 Set_Etype (N, Typ); 6442 end if; 6443 6444 -- If the subprogram returns an array type, and the context requires the 6445 -- component type of that array type, the node is really an indexing of 6446 -- the parameterless call. Resolve as such. A pathological case occurs 6447 -- when the type of the component is an access to the array type. In 6448 -- this case the call is truly ambiguous. If the call is to an intrinsic 6449 -- subprogram, it can't be an indexed component. This check is necessary 6450 -- because if it's Unchecked_Conversion, and we have "type T_Ptr is 6451 -- access T;" and "type T is array (...) of T_Ptr;" (i.e. an array of 6452 -- pointers to the same array), the compiler gets confused and does an 6453 -- infinite recursion. 6454 6455 elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam)) 6456 and then 6457 ((Is_Array_Type (Etype (Nam)) 6458 and then Covers (Typ, Component_Type (Etype (Nam)))) 6459 or else 6460 (Is_Access_Type (Etype (Nam)) 6461 and then Is_Array_Type (Designated_Type (Etype (Nam))) 6462 and then 6463 Covers (Typ, Component_Type (Designated_Type (Etype (Nam)))) 6464 and then not Is_Intrinsic_Subprogram (Entity (Subp)))) 6465 then 6466 declare 6467 Index_Node : Node_Id; 6468 New_Subp : Node_Id; 6469 Ret_Type : constant Entity_Id := Etype (Nam); 6470 6471 begin 6472 -- If this is a parameterless call there is no ambiguity and the 6473 -- call has the type of the function. 6474 6475 if No (First_Actual (N)) then 6476 Set_Etype (N, Etype (Nam)); 6477 6478 if Present (First_Formal (Nam)) then 6479 Resolve_Actuals (N, Nam); 6480 end if; 6481 6482 -- Annotate the tree by creating a call marker in case the 6483 -- original call is transformed by expansion. The call marker 6484 -- is automatically saved for later examination by the ABE 6485 -- Processing phase. 6486 6487 Build_Call_Marker (N); 6488 6489 elsif Is_Access_Type (Ret_Type) 6490 6491 and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) 6492 then 6493 Error_Msg_N 6494 ("cannot disambiguate function call and indexing", N); 6495 else 6496 New_Subp := Relocate_Node (Subp); 6497 6498 -- The called entity may be an explicit dereference, in which 6499 -- case there is no entity to set. 6500 6501 if Nkind (New_Subp) /= N_Explicit_Dereference then 6502 Set_Entity (Subp, Nam); 6503 end if; 6504 6505 if (Is_Array_Type (Ret_Type) 6506 and then Component_Type (Ret_Type) /= Any_Type) 6507 or else 6508 (Is_Access_Type (Ret_Type) 6509 and then 6510 Component_Type (Designated_Type (Ret_Type)) /= Any_Type) 6511 then 6512 if Needs_No_Actuals (Nam) then 6513 6514 -- Indexed call to a parameterless function 6515 6516 Index_Node := 6517 Make_Indexed_Component (Loc, 6518 Prefix => 6519 Make_Function_Call (Loc, Name => New_Subp), 6520 Expressions => Parameter_Associations (N)); 6521 else 6522 -- An Ada 2005 prefixed call to a primitive operation 6523 -- whose first parameter is the prefix. This prefix was 6524 -- prepended to the parameter list, which is actually a 6525 -- list of indexes. Remove the prefix in order to build 6526 -- the proper indexed component. 6527 6528 Index_Node := 6529 Make_Indexed_Component (Loc, 6530 Prefix => 6531 Make_Function_Call (Loc, 6532 Name => New_Subp, 6533 Parameter_Associations => 6534 New_List 6535 (Remove_Head (Parameter_Associations (N)))), 6536 Expressions => Parameter_Associations (N)); 6537 end if; 6538 6539 -- Preserve the parenthesis count of the node 6540 6541 Set_Paren_Count (Index_Node, Paren_Count (N)); 6542 6543 -- Since we are correcting a node classification error made 6544 -- by the parser, we call Replace rather than Rewrite. 6545 6546 Replace (N, Index_Node); 6547 6548 Set_Etype (Prefix (N), Ret_Type); 6549 Set_Etype (N, Typ); 6550 6551 if Legacy_Elaboration_Checks then 6552 Check_Elab_Call (Prefix (N)); 6553 end if; 6554 6555 -- Annotate the tree by creating a call marker in case 6556 -- the original call is transformed by expansion. The call 6557 -- marker is automatically saved for later examination by 6558 -- the ABE Processing phase. 6559 6560 Build_Call_Marker (Prefix (N)); 6561 6562 Resolve_Indexed_Component (N, Typ); 6563 end if; 6564 end if; 6565 6566 return; 6567 end; 6568 6569 else 6570 -- If the called function is not declared in the main unit and it 6571 -- returns the limited view of type then use the available view (as 6572 -- is done in Try_Object_Operation) to prevent back-end confusion; 6573 -- for the function entity itself. The call must appear in a context 6574 -- where the nonlimited view is available. If the function entity is 6575 -- in the extended main unit then no action is needed, because the 6576 -- back end handles this case. In either case the type of the call 6577 -- is the nonlimited view. 6578 6579 if From_Limited_With (Etype (Nam)) 6580 and then Present (Available_View (Etype (Nam))) 6581 then 6582 Set_Etype (N, Available_View (Etype (Nam))); 6583 6584 if not In_Extended_Main_Code_Unit (Nam) then 6585 Set_Etype (Nam, Available_View (Etype (Nam))); 6586 end if; 6587 6588 else 6589 Set_Etype (N, Etype (Nam)); 6590 end if; 6591 end if; 6592 6593 -- In the case where the call is to an overloaded subprogram, Analyze 6594 -- calls Normalize_Actuals once per overloaded subprogram. Therefore in 6595 -- such a case Normalize_Actuals needs to be called once more to order 6596 -- the actuals correctly. Otherwise the call will have the ordering 6597 -- given by the last overloaded subprogram whether this is the correct 6598 -- one being called or not. 6599 6600 if Is_Overloaded (Subp) then 6601 Normalize_Actuals (N, Nam, False, Norm_OK); 6602 pragma Assert (Norm_OK); 6603 end if; 6604 6605 -- In any case, call is fully resolved now. Reset Overload flag, to 6606 -- prevent subsequent overload resolution if node is analyzed again 6607 6608 Set_Is_Overloaded (Subp, False); 6609 Set_Is_Overloaded (N, False); 6610 6611 -- A Ghost entity must appear in a specific context 6612 6613 if Is_Ghost_Entity (Nam) and then Comes_From_Source (N) then 6614 Check_Ghost_Context (Nam, N); 6615 end if; 6616 6617 -- If we are calling the current subprogram from immediately within its 6618 -- body, then that is the case where we can sometimes detect cases of 6619 -- infinite recursion statically. Do not try this in case restriction 6620 -- No_Recursion is in effect anyway, and do it only for source calls. 6621 6622 if Comes_From_Source (N) then 6623 Scop := Current_Scope; 6624 6625 -- Issue warning for possible infinite recursion in the absence 6626 -- of the No_Recursion restriction. 6627 6628 if Same_Or_Aliased_Subprograms (Nam, Scop) 6629 and then not Restriction_Active (No_Recursion) 6630 and then not Is_Static_Function (Scop) 6631 and then Check_Infinite_Recursion (N) 6632 then 6633 -- Here we detected and flagged an infinite recursion, so we do 6634 -- not need to test the case below for further warnings. Also we 6635 -- are all done if we now have a raise SE node. 6636 6637 if Nkind (N) = N_Raise_Storage_Error then 6638 return; 6639 end if; 6640 6641 -- If call is to immediately containing subprogram, then check for 6642 -- the case of a possible run-time detectable infinite recursion. 6643 6644 else 6645 Scope_Loop : while Scop /= Standard_Standard loop 6646 if Same_Or_Aliased_Subprograms (Nam, Scop) then 6647 6648 -- Ada 202x (AI12-0075): Static functions are never allowed 6649 -- to make a recursive call, as specified by 6.8(5.4/5). 6650 6651 if Is_Static_Function (Scop) then 6652 Error_Msg_N 6653 ("recursive call not allowed in static expression " 6654 & "function", N); 6655 6656 Set_Error_Posted (Scop); 6657 6658 exit Scope_Loop; 6659 end if; 6660 6661 -- Although in general case, recursion is not statically 6662 -- checkable, the case of calling an immediately containing 6663 -- subprogram is easy to catch. 6664 6665 if not Is_Ignored_Ghost_Entity (Nam) then 6666 Check_Restriction (No_Recursion, N); 6667 end if; 6668 6669 -- If the recursive call is to a parameterless subprogram, 6670 -- then even if we can't statically detect infinite 6671 -- recursion, this is pretty suspicious, and we output a 6672 -- warning. Furthermore, we will try later to detect some 6673 -- cases here at run time by expanding checking code (see 6674 -- Detect_Infinite_Recursion in package Exp_Ch6). 6675 6676 -- If the recursive call is within a handler, do not emit a 6677 -- warning, because this is a common idiom: loop until input 6678 -- is correct, catch illegal input in handler and restart. 6679 6680 if No (First_Formal (Nam)) 6681 and then Etype (Nam) = Standard_Void_Type 6682 and then not Error_Posted (N) 6683 and then Nkind (Parent (N)) /= N_Exception_Handler 6684 then 6685 -- For the case of a procedure call. We give the message 6686 -- only if the call is the first statement in a sequence 6687 -- of statements, or if all previous statements are 6688 -- simple assignments. This is simply a heuristic to 6689 -- decrease false positives, without losing too many good 6690 -- warnings. The idea is that these previous statements 6691 -- may affect global variables the procedure depends on. 6692 -- We also exclude raise statements, that may arise from 6693 -- constraint checks and are probably unrelated to the 6694 -- intended control flow. 6695 6696 if Nkind (N) = N_Procedure_Call_Statement 6697 and then Is_List_Member (N) 6698 then 6699 declare 6700 P : Node_Id; 6701 begin 6702 P := Prev (N); 6703 while Present (P) loop 6704 if Nkind (P) not in N_Assignment_Statement 6705 | N_Raise_Constraint_Error 6706 then 6707 exit Scope_Loop; 6708 end if; 6709 6710 Prev (P); 6711 end loop; 6712 end; 6713 end if; 6714 6715 -- Do not give warning if we are in a conditional context 6716 6717 declare 6718 K : constant Node_Kind := Nkind (Parent (N)); 6719 begin 6720 if (K = N_Loop_Statement 6721 and then Present (Iteration_Scheme (Parent (N)))) 6722 or else K = N_If_Statement 6723 or else K = N_Elsif_Part 6724 or else K = N_Case_Statement_Alternative 6725 then 6726 exit Scope_Loop; 6727 end if; 6728 end; 6729 6730 -- Here warning is to be issued 6731 6732 Set_Has_Recursive_Call (Nam); 6733 Error_Msg_Warn := SPARK_Mode /= On; 6734 Error_Msg_N ("possible infinite recursion<<!", N); 6735 Error_Msg_N ("\Storage_Error ]<<!", N); 6736 end if; 6737 6738 exit Scope_Loop; 6739 end if; 6740 6741 Scop := Scope (Scop); 6742 end loop Scope_Loop; 6743 end if; 6744 end if; 6745 6746 -- Check obsolescent reference to Ada.Characters.Handling subprogram 6747 6748 Check_Obsolescent_2005_Entity (Nam, Subp); 6749 6750 -- If subprogram name is a predefined operator, it was given in 6751 -- functional notation. Replace call node with operator node, so 6752 -- that actuals can be resolved appropriately. 6753 6754 if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then 6755 Make_Call_Into_Operator (N, Typ, Entity (Name (N))); 6756 return; 6757 6758 elsif Present (Alias (Nam)) 6759 and then Is_Predefined_Op (Alias (Nam)) 6760 then 6761 Resolve_Actuals (N, Nam); 6762 Make_Call_Into_Operator (N, Typ, Alias (Nam)); 6763 return; 6764 end if; 6765 6766 -- Create a transient scope if the resulting type requires it 6767 6768 -- There are several notable exceptions: 6769 6770 -- a) In init procs, the transient scope overhead is not needed, and is 6771 -- even incorrect when the call is a nested initialization call for a 6772 -- component whose expansion may generate adjust calls. However, if the 6773 -- call is some other procedure call within an initialization procedure 6774 -- (for example a call to Create_Task in the init_proc of the task 6775 -- run-time record) a transient scope must be created around this call. 6776 6777 -- b) Enumeration literal pseudo-calls need no transient scope 6778 6779 -- c) Intrinsic subprograms (Unchecked_Conversion and source info 6780 -- functions) do not use the secondary stack even though the return 6781 -- type may be unconstrained. 6782 6783 -- d) Calls to a build-in-place function, since such functions may 6784 -- allocate their result directly in a target object, and cases where 6785 -- the result does get allocated in the secondary stack are checked for 6786 -- within the specialized Exp_Ch6 procedures for expanding those 6787 -- build-in-place calls. 6788 6789 -- e) Calls to inlinable expression functions do not use the secondary 6790 -- stack (since the call will be replaced by its returned object). 6791 6792 -- f) If the subprogram is marked Inline_Always, then even if it returns 6793 -- an unconstrained type the call does not require use of the secondary 6794 -- stack. However, inlining will only take place if the body to inline 6795 -- is already present. It may not be available if e.g. the subprogram is 6796 -- declared in a child instance. 6797 6798 -- g) If the subprogram is a static expression function and the call is 6799 -- a static call (the actuals are all static expressions), then we never 6800 -- want to create a transient scope (this could occur in the case of a 6801 -- static string-returning call). 6802 6803 if Is_Inlined (Nam) 6804 and then Has_Pragma_Inline (Nam) 6805 and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration 6806 and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) 6807 then 6808 null; 6809 6810 elsif Ekind (Nam) = E_Enumeration_Literal 6811 or else Is_Build_In_Place_Function (Nam) 6812 or else Is_Intrinsic_Subprogram (Nam) 6813 or else Is_Inlinable_Expression_Function (Nam) 6814 or else Is_Static_Function_Call (N) 6815 then 6816 null; 6817 6818 -- A return statement from an ignored Ghost function does not use the 6819 -- secondary stack (or any other one). 6820 6821 elsif Expander_Active 6822 and then Ekind (Nam) in E_Function | E_Subprogram_Type 6823 and then Requires_Transient_Scope (Etype (Nam)) 6824 and then not Is_Ignored_Ghost_Entity (Nam) 6825 then 6826 Establish_Transient_Scope (N, Manage_Sec_Stack => True); 6827 6828 -- If the call appears within the bounds of a loop, it will be 6829 -- rewritten and reanalyzed, nothing left to do here. 6830 6831 if Nkind (N) /= N_Function_Call then 6832 return; 6833 end if; 6834 end if; 6835 6836 -- A protected function cannot be called within the definition of the 6837 -- enclosing protected type, unless it is part of a pre/postcondition 6838 -- on another protected operation. This may appear in the entry wrapper 6839 -- created for an entry with preconditions. 6840 6841 if Is_Protected_Type (Scope (Nam)) 6842 and then In_Open_Scopes (Scope (Nam)) 6843 and then not Has_Completion (Scope (Nam)) 6844 and then not In_Spec_Expression 6845 and then not Is_Entry_Wrapper (Current_Scope) 6846 then 6847 Error_Msg_NE 6848 ("& cannot be called before end of protected definition", N, Nam); 6849 end if; 6850 6851 -- Propagate interpretation to actuals, and add default expressions 6852 -- where needed. 6853 6854 if Present (First_Formal (Nam)) then 6855 Resolve_Actuals (N, Nam); 6856 6857 -- Overloaded literals are rewritten as function calls, for purpose of 6858 -- resolution. After resolution, we can replace the call with the 6859 -- literal itself. 6860 6861 elsif Ekind (Nam) = E_Enumeration_Literal then 6862 Copy_Node (Subp, N); 6863 Resolve_Entity_Name (N, Typ); 6864 6865 -- Avoid validation, since it is a static function call 6866 6867 Generate_Reference (Nam, Subp); 6868 return; 6869 end if; 6870 6871 -- If the subprogram is not global, then kill all saved values and 6872 -- checks. This is a bit conservative, since in many cases we could do 6873 -- better, but it is not worth the effort. Similarly, we kill constant 6874 -- values. However we do not need to do this for internal entities 6875 -- (unless they are inherited user-defined subprograms), since they 6876 -- are not in the business of molesting local values. 6877 6878 -- If the flag Suppress_Value_Tracking_On_Calls is set, then we also 6879 -- kill all checks and values for calls to global subprograms. This 6880 -- takes care of the case where an access to a local subprogram is 6881 -- taken, and could be passed directly or indirectly and then called 6882 -- from almost any context. 6883 6884 -- Note: we do not do this step till after resolving the actuals. That 6885 -- way we still take advantage of the current value information while 6886 -- scanning the actuals. 6887 6888 -- We suppress killing values if we are processing the nodes associated 6889 -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged 6890 -- type kills all the values as part of analyzing the code that 6891 -- initializes the dispatch tables. 6892 6893 if Inside_Freezing_Actions = 0 6894 and then (not Is_Library_Level_Entity (Nam) 6895 or else Suppress_Value_Tracking_On_Call 6896 (Nearest_Dynamic_Scope (Current_Scope))) 6897 and then (Comes_From_Source (Nam) 6898 or else (Present (Alias (Nam)) 6899 and then Comes_From_Source (Alias (Nam)))) 6900 then 6901 Kill_Current_Values; 6902 end if; 6903 6904 -- If we are warning about unread OUT parameters, this is the place to 6905 -- set Last_Assignment for OUT and IN OUT parameters. We have to do this 6906 -- after the above call to Kill_Current_Values (since that call clears 6907 -- the Last_Assignment field of all local variables). 6908 6909 if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters) 6910 and then Comes_From_Source (N) 6911 and then In_Extended_Main_Source_Unit (N) 6912 then 6913 declare 6914 F : Entity_Id; 6915 A : Node_Id; 6916 6917 begin 6918 F := First_Formal (Nam); 6919 A := First_Actual (N); 6920 while Present (F) and then Present (A) loop 6921 if Ekind (F) in E_Out_Parameter | E_In_Out_Parameter 6922 and then Warn_On_Modified_As_Out_Parameter (F) 6923 and then Is_Entity_Name (A) 6924 and then Present (Entity (A)) 6925 and then Comes_From_Source (N) 6926 and then Safe_To_Capture_Value (N, Entity (A)) 6927 then 6928 Set_Last_Assignment (Entity (A), A); 6929 end if; 6930 6931 Next_Formal (F); 6932 Next_Actual (A); 6933 end loop; 6934 end; 6935 end if; 6936 6937 -- If the subprogram is a primitive operation, check whether or not 6938 -- it is a correct dispatching call. 6939 6940 if Is_Overloadable (Nam) 6941 and then Is_Dispatching_Operation (Nam) 6942 then 6943 Check_Dispatching_Call (N); 6944 6945 elsif Ekind (Nam) /= E_Subprogram_Type 6946 and then Is_Abstract_Subprogram (Nam) 6947 and then not In_Instance 6948 then 6949 Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam); 6950 end if; 6951 6952 -- If this is a dispatching call, generate the appropriate reference, 6953 -- for better source navigation in GNAT Studio. 6954 6955 if Is_Overloadable (Nam) 6956 and then Present (Controlling_Argument (N)) 6957 then 6958 Generate_Reference (Nam, Subp, 'R'); 6959 6960 -- Normal case, not a dispatching call: generate a call reference 6961 6962 else 6963 Generate_Reference (Nam, Subp, 's'); 6964 end if; 6965 6966 if Is_Intrinsic_Subprogram (Nam) then 6967 Check_Intrinsic_Call (N); 6968 end if; 6969 6970 -- Check for violation of restriction No_Specific_Termination_Handlers 6971 -- and warn on a potentially blocking call to Abort_Task. 6972 6973 if Restriction_Check_Required (No_Specific_Termination_Handlers) 6974 and then (Is_RTE (Nam, RE_Set_Specific_Handler) 6975 or else 6976 Is_RTE (Nam, RE_Specific_Handler)) 6977 then 6978 Check_Restriction (No_Specific_Termination_Handlers, N); 6979 6980 elsif Is_RTE (Nam, RE_Abort_Task) then 6981 Check_Potentially_Blocking_Operation (N); 6982 end if; 6983 6984 -- A call to Ada.Real_Time.Timing_Events.Set_Handler to set a relative 6985 -- timing event violates restriction No_Relative_Delay (AI-0211). We 6986 -- need to check the second argument to determine whether it is an 6987 -- absolute or relative timing event. 6988 6989 if Restriction_Check_Required (No_Relative_Delay) 6990 and then Is_RTE (Nam, RE_Set_Handler) 6991 and then Is_RTE (Etype (Next_Actual (First_Actual (N))), RE_Time_Span) 6992 then 6993 Check_Restriction (No_Relative_Delay, N); 6994 end if; 6995 6996 -- Issue an error for a call to an eliminated subprogram. This routine 6997 -- will not perform the check if the call appears within a default 6998 -- expression. 6999 7000 Check_For_Eliminated_Subprogram (Subp, Nam); 7001 7002 -- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is 7003 -- class-wide and the call dispatches on result in a context that does 7004 -- not provide a tag, the call raises Program_Error. 7005 7006 if Nkind (N) = N_Function_Call 7007 and then In_Instance 7008 and then Is_Generic_Actual_Type (Typ) 7009 and then Is_Class_Wide_Type (Typ) 7010 and then Has_Controlling_Result (Nam) 7011 and then Nkind (Parent (N)) = N_Object_Declaration 7012 then 7013 -- Verify that none of the formals are controlling 7014 7015 declare 7016 Call_OK : Boolean := False; 7017 F : Entity_Id; 7018 7019 begin 7020 F := First_Formal (Nam); 7021 while Present (F) loop 7022 if Is_Controlling_Formal (F) then 7023 Call_OK := True; 7024 exit; 7025 end if; 7026 7027 Next_Formal (F); 7028 end loop; 7029 7030 if not Call_OK then 7031 Error_Msg_Warn := SPARK_Mode /= On; 7032 Error_Msg_N ("!cannot determine tag of result<<", N); 7033 Error_Msg_N ("\Program_Error [<<!", N); 7034 Insert_Action (N, 7035 Make_Raise_Program_Error (Sloc (N), 7036 Reason => PE_Explicit_Raise)); 7037 end if; 7038 end; 7039 end if; 7040 7041 -- Check for calling a function with OUT or IN OUT parameter when the 7042 -- calling context (us right now) is not Ada 2012, so does not allow 7043 -- OUT or IN OUT parameters in function calls. Functions declared in 7044 -- a predefined unit are OK, as they may be called indirectly from a 7045 -- user-declared instantiation. 7046 7047 if Ada_Version < Ada_2012 7048 and then Ekind (Nam) = E_Function 7049 and then Has_Out_Or_In_Out_Parameter (Nam) 7050 and then not In_Predefined_Unit (Nam) 7051 then 7052 Error_Msg_NE ("& has at least one OUT or `IN OUT` parameter", N, Nam); 7053 Error_Msg_N ("\call to this function only allowed in Ada 2012", N); 7054 end if; 7055 7056 -- Check the dimensions of the actuals in the call. For function calls, 7057 -- propagate the dimensions from the returned type to N. 7058 7059 Analyze_Dimension_Call (N, Nam); 7060 7061 -- All done, evaluate call and deal with elaboration issues 7062 7063 Eval_Call (N); 7064 7065 if Legacy_Elaboration_Checks then 7066 Check_Elab_Call (N); 7067 end if; 7068 7069 -- Annotate the tree by creating a call marker in case the original call 7070 -- is transformed by expansion. The call marker is automatically saved 7071 -- for later examination by the ABE Processing phase. 7072 7073 Build_Call_Marker (N); 7074 7075 Mark_Use_Clauses (Subp); 7076 7077 Warn_On_Overlapping_Actuals (Nam, N); 7078 7079 -- Ada 202x (AI12-0075): If the call is a static call to a static 7080 -- expression function, then we want to "inline" the call, replacing 7081 -- it with the folded static result. This is not done if the checking 7082 -- for a potentially static expression is enabled or if an error has 7083 -- been posted on the call (which may be due to the check for recursive 7084 -- calls, in which case we don't want to fall into infinite recursion 7085 -- when doing the inlining). 7086 7087 if not Checking_Potentially_Static_Expression 7088 and then Is_Static_Function_Call (N) 7089 and then not Is_Intrinsic_Subprogram (Ultimate_Alias (Nam)) 7090 and then not Error_Posted (Ultimate_Alias (Nam)) 7091 then 7092 Inline_Static_Function_Call (N, Ultimate_Alias (Nam)); 7093 7094 -- In GNATprove mode, expansion is disabled, but we want to inline some 7095 -- subprograms to facilitate formal verification. Indirect calls through 7096 -- a subprogram type or within a generic cannot be inlined. Inlining is 7097 -- performed only for calls subject to SPARK_Mode on. 7098 7099 elsif GNATprove_Mode 7100 and then SPARK_Mode = On 7101 and then Is_Overloadable (Nam) 7102 and then not Inside_A_Generic 7103 then 7104 Nam_UA := Ultimate_Alias (Nam); 7105 Nam_Decl := Unit_Declaration_Node (Nam_UA); 7106 7107 if Nkind (Nam_Decl) = N_Subprogram_Declaration then 7108 Body_Id := Corresponding_Body (Nam_Decl); 7109 7110 -- Nothing to do if the subprogram is not eligible for inlining in 7111 -- GNATprove mode, or inlining is disabled with switch -gnatdm 7112 7113 if not Is_Inlined_Always (Nam_UA) 7114 or else not Can_Be_Inlined_In_GNATprove_Mode (Nam_UA, Body_Id) 7115 or else Debug_Flag_M 7116 then 7117 null; 7118 7119 -- Calls cannot be inlined inside assertions, as GNATprove treats 7120 -- assertions as logic expressions. Only issue a message when the 7121 -- body has been seen, otherwise this leads to spurious messages 7122 -- on expression functions. 7123 7124 elsif In_Assertion_Expr /= 0 then 7125 Cannot_Inline 7126 ("cannot inline & (in assertion expression)?", N, Nam_UA, 7127 Suppress_Info => No (Body_Id)); 7128 7129 -- Calls cannot be inlined inside default expressions 7130 7131 elsif In_Default_Expr then 7132 Cannot_Inline 7133 ("cannot inline & (in default expression)?", N, Nam_UA); 7134 7135 -- Calls cannot be inlined inside quantified expressions, which 7136 -- are left in expression form for GNATprove. Since these 7137 -- expressions are only preanalyzed, we need to detect the failure 7138 -- to inline outside of the case for Full_Analysis below. 7139 7140 elsif In_Quantified_Expression (N) then 7141 Cannot_Inline 7142 ("cannot inline & (in quantified expression)?", N, Nam_UA); 7143 7144 -- Inlining should not be performed during preanalysis 7145 7146 elsif Full_Analysis then 7147 7148 -- Do not inline calls inside expression functions or functions 7149 -- generated by the front end for subtype predicates, as this 7150 -- would prevent interpreting them as logical formulas in 7151 -- GNATprove. Only issue a message when the body has been seen, 7152 -- otherwise this leads to spurious messages on callees that 7153 -- are themselves expression functions. 7154 7155 if Present (Current_Subprogram) 7156 and then 7157 (Is_Expression_Function_Or_Completion (Current_Subprogram) 7158 or else Is_Predicate_Function (Current_Subprogram) 7159 or else Is_Invariant_Procedure (Current_Subprogram) 7160 or else Is_DIC_Procedure (Current_Subprogram)) 7161 then 7162 if Present (Body_Id) 7163 and then Present (Body_To_Inline (Nam_Decl)) 7164 then 7165 if Is_Predicate_Function (Current_Subprogram) then 7166 Cannot_Inline 7167 ("cannot inline & (inside predicate)?", 7168 N, Nam_UA); 7169 7170 elsif Is_Invariant_Procedure (Current_Subprogram) then 7171 Cannot_Inline 7172 ("cannot inline & (inside invariant)?", 7173 N, Nam_UA); 7174 7175 elsif Is_DIC_Procedure (Current_Subprogram) then 7176 Cannot_Inline 7177 ("cannot inline & (inside Default_Initial_Condition)?", 7178 N, Nam_UA); 7179 7180 else 7181 Cannot_Inline 7182 ("cannot inline & (inside expression function)?", 7183 N, Nam_UA); 7184 end if; 7185 end if; 7186 7187 -- Cannot inline a call inside the definition of a record type, 7188 -- typically inside the constraints of the type. Calls in 7189 -- default expressions are also not inlined, but this is 7190 -- filtered out above when testing In_Default_Expr. 7191 7192 elsif Is_Record_Type (Current_Scope) then 7193 Cannot_Inline 7194 ("cannot inline & (inside record type)?", N, Nam_UA); 7195 7196 -- With the one-pass inlining technique, a call cannot be 7197 -- inlined if the corresponding body has not been seen yet. 7198 7199 elsif No (Body_Id) then 7200 Cannot_Inline 7201 ("cannot inline & (body not seen yet)?", N, Nam_UA); 7202 7203 -- Nothing to do if there is no body to inline, indicating that 7204 -- the subprogram is not suitable for inlining in GNATprove 7205 -- mode. 7206 7207 elsif No (Body_To_Inline (Nam_Decl)) then 7208 null; 7209 7210 -- Calls cannot be inlined inside potentially unevaluated 7211 -- expressions, as this would create complex actions inside 7212 -- expressions, that are not handled by GNATprove. 7213 7214 elsif Is_Potentially_Unevaluated (N) then 7215 Cannot_Inline 7216 ("cannot inline & (in potentially unevaluated context)?", 7217 N, Nam_UA); 7218 7219 -- Calls cannot be inlined inside the conditions of while 7220 -- loops, as this would create complex actions inside 7221 -- the condition, that are not handled by GNATprove. 7222 7223 elsif In_While_Loop_Condition (N) then 7224 Cannot_Inline 7225 ("cannot inline & (in while loop condition)?", N, Nam_UA); 7226 7227 -- Do not inline calls which would possibly lead to missing a 7228 -- type conversion check on an input parameter. 7229 7230 elsif not Call_Can_Be_Inlined_In_GNATprove_Mode (N, Nam) then 7231 Cannot_Inline 7232 ("cannot inline & (possible check on input parameters)?", 7233 N, Nam_UA); 7234 7235 -- Otherwise, inline the call, issuing an info message when 7236 -- -gnatd_f is set. 7237 7238 else 7239 if Debug_Flag_Underscore_F then 7240 Error_Msg_NE 7241 ("info: analyzing call to & in context?", N, Nam_UA); 7242 end if; 7243 7244 Expand_Inlined_Call (N, Nam_UA, Nam); 7245 end if; 7246 end if; 7247 end if; 7248 end if; 7249 end Resolve_Call; 7250 7251 ----------------------------- 7252 -- Resolve_Case_Expression -- 7253 ----------------------------- 7254 7255 procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is 7256 Alt : Node_Id; 7257 Alt_Expr : Node_Id; 7258 Alt_Typ : Entity_Id; 7259 Is_Dyn : Boolean; 7260 7261 begin 7262 Alt := First (Alternatives (N)); 7263 while Present (Alt) loop 7264 Alt_Expr := Expression (Alt); 7265 7266 if Error_Posted (Alt_Expr) then 7267 return; 7268 end if; 7269 7270 Resolve (Alt_Expr, Typ); 7271 Alt_Typ := Etype (Alt_Expr); 7272 7273 -- When the expression is of a scalar subtype different from the 7274 -- result subtype, then insert a conversion to ensure the generation 7275 -- of a constraint check. 7276 7277 if Is_Scalar_Type (Alt_Typ) and then Alt_Typ /= Typ then 7278 Rewrite (Alt_Expr, Convert_To (Typ, Alt_Expr)); 7279 Analyze_And_Resolve (Alt_Expr, Typ); 7280 end if; 7281 7282 Next (Alt); 7283 end loop; 7284 7285 -- Apply RM 4.5.7 (17/3): whether the expression is statically or 7286 -- dynamically tagged must be known statically. 7287 7288 if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then 7289 Alt := First (Alternatives (N)); 7290 Is_Dyn := Is_Dynamically_Tagged (Expression (Alt)); 7291 7292 while Present (Alt) loop 7293 if Is_Dynamically_Tagged (Expression (Alt)) /= Is_Dyn then 7294 Error_Msg_N 7295 ("all or none of the dependent expressions can be " 7296 & "dynamically tagged", N); 7297 end if; 7298 7299 Next (Alt); 7300 end loop; 7301 end if; 7302 7303 Set_Etype (N, Typ); 7304 Eval_Case_Expression (N); 7305 Analyze_Dimension (N); 7306 end Resolve_Case_Expression; 7307 7308 ------------------------------- 7309 -- Resolve_Character_Literal -- 7310 ------------------------------- 7311 7312 procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is 7313 B_Typ : constant Entity_Id := Base_Type (Typ); 7314 C : Entity_Id; 7315 7316 begin 7317 -- Verify that the character does belong to the type of the context 7318 7319 Set_Etype (N, B_Typ); 7320 Eval_Character_Literal (N); 7321 7322 -- Wide_Wide_Character literals must always be defined, since the set 7323 -- of wide wide character literals is complete, i.e. if a character 7324 -- literal is accepted by the parser, then it is OK for wide wide 7325 -- character (out of range character literals are rejected). 7326 7327 if Root_Type (B_Typ) = Standard_Wide_Wide_Character then 7328 return; 7329 7330 -- Always accept character literal for type Any_Character, which 7331 -- occurs in error situations and in comparisons of literals, both 7332 -- of which should accept all literals. 7333 7334 elsif B_Typ = Any_Character then 7335 return; 7336 7337 -- For Standard.Character or a type derived from it, check that the 7338 -- literal is in range. 7339 7340 elsif Root_Type (B_Typ) = Standard_Character then 7341 if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then 7342 return; 7343 end if; 7344 7345 -- For Standard.Wide_Character or a type derived from it, check that the 7346 -- literal is in range. 7347 7348 elsif Root_Type (B_Typ) = Standard_Wide_Character then 7349 if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then 7350 return; 7351 end if; 7352 7353 -- If the entity is already set, this has already been resolved in a 7354 -- generic context, or comes from expansion. Nothing else to do. 7355 7356 elsif Present (Entity (N)) then 7357 return; 7358 7359 -- Otherwise we have a user defined character type, and we can use the 7360 -- standard visibility mechanisms to locate the referenced entity. 7361 7362 else 7363 C := Current_Entity (N); 7364 while Present (C) loop 7365 if Etype (C) = B_Typ then 7366 Set_Entity_With_Checks (N, C); 7367 Generate_Reference (C, N); 7368 return; 7369 end if; 7370 7371 C := Homonym (C); 7372 end loop; 7373 end if; 7374 7375 -- If we fall through, then the literal does not match any of the 7376 -- entries of the enumeration type. This isn't just a constraint error 7377 -- situation, it is an illegality (see RM 4.2). 7378 7379 Error_Msg_NE 7380 ("character not defined for }", N, First_Subtype (B_Typ)); 7381 end Resolve_Character_Literal; 7382 7383 --------------------------- 7384 -- Resolve_Comparison_Op -- 7385 --------------------------- 7386 7387 -- Context requires a boolean type, and plays no role in resolution. 7388 -- Processing identical to that for equality operators. The result type is 7389 -- the base type, which matters when pathological subtypes of booleans with 7390 -- limited ranges are used. 7391 7392 procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is 7393 L : constant Node_Id := Left_Opnd (N); 7394 R : constant Node_Id := Right_Opnd (N); 7395 T : Entity_Id; 7396 7397 begin 7398 -- If this is an intrinsic operation which is not predefined, use the 7399 -- types of its declared arguments to resolve the possibly overloaded 7400 -- operands. Otherwise the operands are unambiguous and specify the 7401 -- expected type. 7402 7403 if Scope (Entity (N)) /= Standard_Standard then 7404 T := Etype (First_Entity (Entity (N))); 7405 7406 else 7407 T := Find_Unique_Type (L, R); 7408 7409 if T = Any_Fixed then 7410 T := Unique_Fixed_Point_Type (L); 7411 end if; 7412 end if; 7413 7414 Set_Etype (N, Base_Type (Typ)); 7415 Generate_Reference (T, N, ' '); 7416 7417 -- Skip remaining processing if already set to Any_Type 7418 7419 if T = Any_Type then 7420 return; 7421 end if; 7422 7423 -- Deal with other error cases 7424 7425 if T = Any_String or else 7426 T = Any_Composite or else 7427 T = Any_Character 7428 then 7429 if T = Any_Character then 7430 Ambiguous_Character (L); 7431 else 7432 Error_Msg_N ("ambiguous operands for comparison", N); 7433 end if; 7434 7435 Set_Etype (N, Any_Type); 7436 return; 7437 end if; 7438 7439 -- Resolve the operands if types OK 7440 7441 Resolve (L, T); 7442 Resolve (R, T); 7443 Check_Unset_Reference (L); 7444 Check_Unset_Reference (R); 7445 Generate_Operator_Reference (N, T); 7446 Check_Low_Bound_Tested (N); 7447 7448 -- Check comparison on unordered enumeration 7449 7450 if Bad_Unordered_Enumeration_Reference (N, Etype (L)) then 7451 Error_Msg_Sloc := Sloc (Etype (L)); 7452 Error_Msg_NE 7453 ("comparison on unordered enumeration type& declared#?U?", 7454 N, Etype (L)); 7455 end if; 7456 7457 Analyze_Dimension (N); 7458 7459 Eval_Relational_Op (N); 7460 end Resolve_Comparison_Op; 7461 7462 -------------------------------- 7463 -- Resolve_Declare_Expression -- 7464 -------------------------------- 7465 7466 procedure Resolve_Declare_Expression 7467 (N : Node_Id; 7468 Typ : Entity_Id) 7469 is 7470 Decl : Node_Id; 7471 Need_Transient_Scope : Boolean := False; 7472 begin 7473 -- Install the scope created for local declarations, if 7474 -- any. The syntax allows a Declare_Expression with no 7475 -- declarations, in analogy with block statements. 7476 -- Note that that scope has no explicit declaration, but 7477 -- appears as the scope of all entities declared therein. 7478 7479 Decl := First (Actions (N)); 7480 while Present (Decl) loop 7481 exit when Nkind (Decl) 7482 in N_Object_Declaration | N_Object_Renaming_Declaration; 7483 Next (Decl); 7484 end loop; 7485 7486 if Present (Decl) then 7487 7488 -- Need to establish a transient scope in case Expression (N) 7489 -- requires actions to be wrapped. 7490 7491 declare 7492 Node : Node_Id; 7493 begin 7494 Node := First (Actions (N)); 7495 while Present (Node) loop 7496 if Nkind (Node) = N_Object_Declaration 7497 and then Requires_Transient_Scope 7498 (Etype (Defining_Identifier (Node))) 7499 then 7500 Need_Transient_Scope := True; 7501 exit; 7502 end if; 7503 7504 Next (Node); 7505 end loop; 7506 end; 7507 7508 if Need_Transient_Scope then 7509 Establish_Transient_Scope (Decl, True); 7510 else 7511 Push_Scope (Scope (Defining_Identifier (Decl))); 7512 end if; 7513 7514 declare 7515 E : Entity_Id := First_Entity (Current_Scope); 7516 begin 7517 while Present (E) loop 7518 Set_Current_Entity (E); 7519 Set_Is_Immediately_Visible (E); 7520 Next_Entity (E); 7521 end loop; 7522 end; 7523 7524 Resolve (Expression (N), Typ); 7525 End_Scope; 7526 7527 else 7528 Resolve (Expression (N), Typ); 7529 end if; 7530 end Resolve_Declare_Expression; 7531 7532 ----------------------------------------- 7533 -- Resolve_Discrete_Subtype_Indication -- 7534 ----------------------------------------- 7535 7536 procedure Resolve_Discrete_Subtype_Indication 7537 (N : Node_Id; 7538 Typ : Entity_Id) 7539 is 7540 R : Node_Id; 7541 S : Entity_Id; 7542 7543 begin 7544 Analyze (Subtype_Mark (N)); 7545 S := Entity (Subtype_Mark (N)); 7546 7547 if Nkind (Constraint (N)) /= N_Range_Constraint then 7548 Error_Msg_N ("expect range constraint for discrete type", N); 7549 Set_Etype (N, Any_Type); 7550 7551 else 7552 R := Range_Expression (Constraint (N)); 7553 7554 if R = Error then 7555 return; 7556 end if; 7557 7558 Analyze (R); 7559 7560 if Base_Type (S) /= Base_Type (Typ) then 7561 Error_Msg_NE 7562 ("expect subtype of }", N, First_Subtype (Typ)); 7563 7564 -- Rewrite the constraint as a range of Typ 7565 -- to allow compilation to proceed further. 7566 7567 Set_Etype (N, Typ); 7568 Rewrite (Low_Bound (R), 7569 Make_Attribute_Reference (Sloc (Low_Bound (R)), 7570 Prefix => New_Occurrence_Of (Typ, Sloc (R)), 7571 Attribute_Name => Name_First)); 7572 Rewrite (High_Bound (R), 7573 Make_Attribute_Reference (Sloc (High_Bound (R)), 7574 Prefix => New_Occurrence_Of (Typ, Sloc (R)), 7575 Attribute_Name => Name_First)); 7576 7577 else 7578 Resolve (R, Typ); 7579 Set_Etype (N, Etype (R)); 7580 7581 -- Additionally, we must check that the bounds are compatible 7582 -- with the given subtype, which might be different from the 7583 -- type of the context. 7584 7585 Apply_Range_Check (R, S); 7586 7587 -- ??? If the above check statically detects a Constraint_Error 7588 -- it replaces the offending bound(s) of the range R with a 7589 -- Constraint_Error node. When the itype which uses these bounds 7590 -- is frozen the resulting call to Duplicate_Subexpr generates 7591 -- a new temporary for the bounds. 7592 7593 -- Unfortunately there are other itypes that are also made depend 7594 -- on these bounds, so when Duplicate_Subexpr is called they get 7595 -- a forward reference to the newly created temporaries and Gigi 7596 -- aborts on such forward references. This is probably sign of a 7597 -- more fundamental problem somewhere else in either the order of 7598 -- itype freezing or the way certain itypes are constructed. 7599 7600 -- To get around this problem we call Remove_Side_Effects right 7601 -- away if either bounds of R are a Constraint_Error. 7602 7603 declare 7604 L : constant Node_Id := Low_Bound (R); 7605 H : constant Node_Id := High_Bound (R); 7606 7607 begin 7608 if Nkind (L) = N_Raise_Constraint_Error then 7609 Remove_Side_Effects (L); 7610 end if; 7611 7612 if Nkind (H) = N_Raise_Constraint_Error then 7613 Remove_Side_Effects (H); 7614 end if; 7615 end; 7616 7617 Check_Unset_Reference (Low_Bound (R)); 7618 Check_Unset_Reference (High_Bound (R)); 7619 end if; 7620 end if; 7621 end Resolve_Discrete_Subtype_Indication; 7622 7623 ------------------------- 7624 -- Resolve_Entity_Name -- 7625 ------------------------- 7626 7627 -- Used to resolve identifiers and expanded names 7628 7629 procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is 7630 function Is_Assignment_Or_Object_Expression 7631 (Context : Node_Id; 7632 Expr : Node_Id) return Boolean; 7633 -- Determine whether node Context denotes an assignment statement or an 7634 -- object declaration whose expression is node Expr. 7635 7636 function Is_Attribute_Expression (Expr : Node_Id) return Boolean; 7637 -- Determine whether Expr is part of an N_Attribute_Reference 7638 -- expression. 7639 7640 ---------------------------------------- 7641 -- Is_Assignment_Or_Object_Expression -- 7642 ---------------------------------------- 7643 7644 function Is_Assignment_Or_Object_Expression 7645 (Context : Node_Id; 7646 Expr : Node_Id) return Boolean 7647 is 7648 begin 7649 if Nkind (Context) in 7650 N_Assignment_Statement | N_Object_Declaration 7651 and then Expression (Context) = Expr 7652 then 7653 return True; 7654 7655 -- Check whether a construct that yields a name is the expression of 7656 -- an assignment statement or an object declaration. 7657 7658 elsif (Nkind (Context) in N_Attribute_Reference 7659 | N_Explicit_Dereference 7660 | N_Indexed_Component 7661 | N_Selected_Component 7662 | N_Slice 7663 and then Prefix (Context) = Expr) 7664 or else 7665 (Nkind (Context) in N_Type_Conversion 7666 | N_Unchecked_Type_Conversion 7667 and then Expression (Context) = Expr) 7668 then 7669 return 7670 Is_Assignment_Or_Object_Expression 7671 (Context => Parent (Context), 7672 Expr => Context); 7673 7674 -- Otherwise the context is not an assignment statement or an object 7675 -- declaration. 7676 7677 else 7678 return False; 7679 end if; 7680 end Is_Assignment_Or_Object_Expression; 7681 7682 ----------------------------- 7683 -- Is_Attribute_Expression -- 7684 ----------------------------- 7685 7686 function Is_Attribute_Expression (Expr : Node_Id) return Boolean is 7687 N : Node_Id := Expr; 7688 begin 7689 while Present (N) loop 7690 if Nkind (N) = N_Attribute_Reference then 7691 return True; 7692 end if; 7693 7694 N := Parent (N); 7695 end loop; 7696 7697 return False; 7698 end Is_Attribute_Expression; 7699 7700 -- Local variables 7701 7702 E : constant Entity_Id := Entity (N); 7703 Par : Node_Id; 7704 7705 -- Start of processing for Resolve_Entity_Name 7706 7707 begin 7708 -- If garbage from errors, set to Any_Type and return 7709 7710 if No (E) and then Total_Errors_Detected /= 0 then 7711 Set_Etype (N, Any_Type); 7712 return; 7713 end if; 7714 7715 -- Replace named numbers by corresponding literals. Note that this is 7716 -- the one case where Resolve_Entity_Name must reset the Etype, since 7717 -- it is currently marked as universal. 7718 7719 if Ekind (E) = E_Named_Integer then 7720 Set_Etype (N, Typ); 7721 Eval_Named_Integer (N); 7722 7723 elsif Ekind (E) = E_Named_Real then 7724 Set_Etype (N, Typ); 7725 Eval_Named_Real (N); 7726 7727 -- For enumeration literals, we need to make sure that a proper style 7728 -- check is done, since such literals are overloaded, and thus we did 7729 -- not do a style check during the first phase of analysis. 7730 7731 elsif Ekind (E) = E_Enumeration_Literal then 7732 Set_Entity_With_Checks (N, E); 7733 Eval_Entity_Name (N); 7734 7735 -- Case of (sub)type name appearing in a context where an expression 7736 -- is expected. This is legal if occurrence is a current instance. 7737 -- See RM 8.6 (17/3). 7738 7739 elsif Is_Type (E) then 7740 if Is_Current_Instance (N) then 7741 null; 7742 7743 -- Any other use is an error 7744 7745 else 7746 Error_Msg_N 7747 ("invalid use of subtype mark in expression or call", N); 7748 end if; 7749 7750 -- Check discriminant use if entity is discriminant in current scope, 7751 -- i.e. discriminant of record or concurrent type currently being 7752 -- analyzed. Uses in corresponding body are unrestricted. 7753 7754 elsif Ekind (E) = E_Discriminant 7755 and then Scope (E) = Current_Scope 7756 and then not Has_Completion (Current_Scope) 7757 then 7758 Check_Discriminant_Use (N); 7759 7760 -- A parameterless generic function cannot appear in a context that 7761 -- requires resolution. 7762 7763 elsif Ekind (E) = E_Generic_Function then 7764 Error_Msg_N ("illegal use of generic function", N); 7765 7766 -- In Ada 83 an OUT parameter cannot be read, but attributes of 7767 -- array types (i.e. bounds and length) are legal. 7768 7769 elsif Ekind (E) = E_Out_Parameter 7770 and then (Is_Scalar_Type (Etype (E)) 7771 or else not Is_Attribute_Expression (Parent (N))) 7772 7773 and then (Nkind (Parent (N)) in N_Op 7774 or else Nkind (Parent (N)) = N_Explicit_Dereference 7775 or else Is_Assignment_Or_Object_Expression 7776 (Context => Parent (N), 7777 Expr => N)) 7778 then 7779 if Ada_Version = Ada_83 then 7780 Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); 7781 end if; 7782 7783 -- In all other cases, just do the possible static evaluation 7784 7785 else 7786 -- A deferred constant that appears in an expression must have a 7787 -- completion, unless it has been removed by in-place expansion of 7788 -- an aggregate. A constant that is a renaming does not need 7789 -- initialization. 7790 7791 if Ekind (E) = E_Constant 7792 and then Comes_From_Source (E) 7793 and then No (Constant_Value (E)) 7794 and then Is_Frozen (Etype (E)) 7795 and then not In_Spec_Expression 7796 and then not Is_Imported (E) 7797 and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration 7798 then 7799 if No_Initialization (Parent (E)) 7800 or else (Present (Full_View (E)) 7801 and then No_Initialization (Parent (Full_View (E)))) 7802 then 7803 null; 7804 else 7805 Error_Msg_N 7806 ("deferred constant is frozen before completion", N); 7807 end if; 7808 end if; 7809 7810 Eval_Entity_Name (N); 7811 end if; 7812 7813 Par := Parent (N); 7814 7815 -- When the entity appears in a parameter association, retrieve the 7816 -- related subprogram call. 7817 7818 if Nkind (Par) = N_Parameter_Association then 7819 Par := Parent (Par); 7820 end if; 7821 7822 if Comes_From_Source (N) then 7823 7824 -- The following checks are only relevant when SPARK_Mode is on as 7825 -- they are not standard Ada legality rules. 7826 7827 if SPARK_Mode = On then 7828 7829 -- An effectively volatile object for reading must appear in 7830 -- non-interfering context (SPARK RM 7.1.3(10)). 7831 7832 if Is_Object (E) 7833 and then Is_Effectively_Volatile_For_Reading (E) 7834 and then not Is_OK_Volatile_Context (Par, N) 7835 then 7836 SPARK_Msg_N 7837 ("volatile object cannot appear in this context " 7838 & "(SPARK RM 7.1.3(10))", N); 7839 end if; 7840 7841 -- Check for possible elaboration issues with respect to reads of 7842 -- variables. The act of renaming the variable is not considered a 7843 -- read as it simply establishes an alias. 7844 7845 if Legacy_Elaboration_Checks 7846 and then Ekind (E) = E_Variable 7847 and then Dynamic_Elaboration_Checks 7848 and then Nkind (Par) /= N_Object_Renaming_Declaration 7849 then 7850 Check_Elab_Call (N); 7851 end if; 7852 end if; 7853 7854 -- The variable may eventually become a constituent of a single 7855 -- protected/task type. Record the reference now and verify its 7856 -- legality when analyzing the contract of the variable 7857 -- (SPARK RM 9.3). 7858 7859 if Ekind (E) = E_Variable then 7860 Record_Possible_Part_Of_Reference (E, N); 7861 end if; 7862 7863 -- A Ghost entity must appear in a specific context 7864 7865 if Is_Ghost_Entity (E) then 7866 Check_Ghost_Context (E, N); 7867 end if; 7868 end if; 7869 7870 -- We may be resolving an entity within expanded code, so a reference to 7871 -- an entity should be ignored when calculating effective use clauses to 7872 -- avoid inappropriate marking. 7873 7874 if Comes_From_Source (N) then 7875 Mark_Use_Clauses (E); 7876 end if; 7877 end Resolve_Entity_Name; 7878 7879 ------------------- 7880 -- Resolve_Entry -- 7881 ------------------- 7882 7883 procedure Resolve_Entry (Entry_Name : Node_Id) is 7884 Loc : constant Source_Ptr := Sloc (Entry_Name); 7885 Nam : Entity_Id; 7886 New_N : Node_Id; 7887 S : Entity_Id; 7888 Tsk : Entity_Id; 7889 E_Name : Node_Id; 7890 Index : Node_Id; 7891 7892 function Actual_Index_Type (E : Entity_Id) return Entity_Id; 7893 -- If the bounds of the entry family being called depend on task 7894 -- discriminants, build a new index subtype where a discriminant is 7895 -- replaced with the value of the discriminant of the target task. 7896 -- The target task is the prefix of the entry name in the call. 7897 7898 ----------------------- 7899 -- Actual_Index_Type -- 7900 ----------------------- 7901 7902 function Actual_Index_Type (E : Entity_Id) return Entity_Id is 7903 Typ : constant Entity_Id := Entry_Index_Type (E); 7904 Tsk : constant Entity_Id := Scope (E); 7905 Lo : constant Node_Id := Type_Low_Bound (Typ); 7906 Hi : constant Node_Id := Type_High_Bound (Typ); 7907 New_T : Entity_Id; 7908 7909 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; 7910 -- If the bound is given by a discriminant, replace with a reference 7911 -- to the discriminant of the same name in the target task. If the 7912 -- entry name is the target of a requeue statement and the entry is 7913 -- in the current protected object, the bound to be used is the 7914 -- discriminal of the object (see Apply_Range_Check for details of 7915 -- the transformation). 7916 7917 ----------------------------- 7918 -- Actual_Discriminant_Ref -- 7919 ----------------------------- 7920 7921 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is 7922 Typ : constant Entity_Id := Etype (Bound); 7923 Ref : Node_Id; 7924 7925 begin 7926 Remove_Side_Effects (Bound); 7927 7928 if not Is_Entity_Name (Bound) 7929 or else Ekind (Entity (Bound)) /= E_Discriminant 7930 then 7931 return Bound; 7932 7933 elsif Is_Protected_Type (Tsk) 7934 and then In_Open_Scopes (Tsk) 7935 and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement 7936 then 7937 -- Note: here Bound denotes a discriminant of the corresponding 7938 -- record type tskV, whose discriminal is a formal of the 7939 -- init-proc tskVIP. What we want is the body discriminal, 7940 -- which is associated to the discriminant of the original 7941 -- concurrent type tsk. 7942 7943 return New_Occurrence_Of 7944 (Find_Body_Discriminal (Entity (Bound)), Loc); 7945 7946 else 7947 Ref := 7948 Make_Selected_Component (Loc, 7949 Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))), 7950 Selector_Name => New_Occurrence_Of (Entity (Bound), Loc)); 7951 Analyze (Ref); 7952 Resolve (Ref, Typ); 7953 return Ref; 7954 end if; 7955 end Actual_Discriminant_Ref; 7956 7957 -- Start of processing for Actual_Index_Type 7958 7959 begin 7960 if not Has_Discriminants (Tsk) 7961 or else (not Is_Entity_Name (Lo) and then not Is_Entity_Name (Hi)) 7962 then 7963 return Entry_Index_Type (E); 7964 7965 else 7966 New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name)); 7967 Set_Etype (New_T, Base_Type (Typ)); 7968 Set_Size_Info (New_T, Typ); 7969 Set_RM_Size (New_T, RM_Size (Typ)); 7970 Set_Scalar_Range (New_T, 7971 Make_Range (Sloc (Entry_Name), 7972 Low_Bound => Actual_Discriminant_Ref (Lo), 7973 High_Bound => Actual_Discriminant_Ref (Hi))); 7974 7975 return New_T; 7976 end if; 7977 end Actual_Index_Type; 7978 7979 -- Start of processing for Resolve_Entry 7980 7981 begin 7982 -- Find name of entry being called, and resolve prefix of name with its 7983 -- own type. The prefix can be overloaded, and the name and signature of 7984 -- the entry must be taken into account. 7985 7986 if Nkind (Entry_Name) = N_Indexed_Component then 7987 7988 -- Case of dealing with entry family within the current tasks 7989 7990 E_Name := Prefix (Entry_Name); 7991 7992 else 7993 E_Name := Entry_Name; 7994 end if; 7995 7996 if Is_Entity_Name (E_Name) then 7997 7998 -- Entry call to an entry (or entry family) in the current task. This 7999 -- is legal even though the task will deadlock. Rewrite as call to 8000 -- current task. 8001 8002 -- This can also be a call to an entry in an enclosing task. If this 8003 -- is a single task, we have to retrieve its name, because the scope 8004 -- of the entry is the task type, not the object. If the enclosing 8005 -- task is a task type, the identity of the task is given by its own 8006 -- self variable. 8007 8008 -- Finally this can be a requeue on an entry of the same task or 8009 -- protected object. 8010 8011 S := Scope (Entity (E_Name)); 8012 8013 for J in reverse 0 .. Scope_Stack.Last loop 8014 if Is_Task_Type (Scope_Stack.Table (J).Entity) 8015 and then not Comes_From_Source (S) 8016 then 8017 -- S is an enclosing task or protected object. The concurrent 8018 -- declaration has been converted into a type declaration, and 8019 -- the object itself has an object declaration that follows 8020 -- the type in the same declarative part. 8021 8022 Tsk := Next_Entity (S); 8023 while Etype (Tsk) /= S loop 8024 Next_Entity (Tsk); 8025 end loop; 8026 8027 S := Tsk; 8028 exit; 8029 8030 elsif S = Scope_Stack.Table (J).Entity then 8031 8032 -- Call to current task. Will be transformed into call to Self 8033 8034 exit; 8035 8036 end if; 8037 end loop; 8038 8039 New_N := 8040 Make_Selected_Component (Loc, 8041 Prefix => New_Occurrence_Of (S, Loc), 8042 Selector_Name => 8043 New_Occurrence_Of (Entity (E_Name), Loc)); 8044 Rewrite (E_Name, New_N); 8045 Analyze (E_Name); 8046 8047 elsif Nkind (Entry_Name) = N_Selected_Component 8048 and then Is_Overloaded (Prefix (Entry_Name)) 8049 then 8050 -- Use the entry name (which must be unique at this point) to find 8051 -- the prefix that returns the corresponding task/protected type. 8052 8053 declare 8054 Pref : constant Node_Id := Prefix (Entry_Name); 8055 Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); 8056 I : Interp_Index; 8057 It : Interp; 8058 8059 begin 8060 Get_First_Interp (Pref, I, It); 8061 while Present (It.Typ) loop 8062 if Scope (Ent) = It.Typ then 8063 Set_Etype (Pref, It.Typ); 8064 exit; 8065 end if; 8066 8067 Get_Next_Interp (I, It); 8068 end loop; 8069 end; 8070 end if; 8071 8072 if Nkind (Entry_Name) = N_Selected_Component then 8073 Resolve (Prefix (Entry_Name)); 8074 Resolve_Implicit_Dereference (Prefix (Entry_Name)); 8075 8076 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); 8077 Nam := Entity (Selector_Name (Prefix (Entry_Name))); 8078 Resolve (Prefix (Prefix (Entry_Name))); 8079 Resolve_Implicit_Dereference (Prefix (Prefix (Entry_Name))); 8080 8081 -- We do not resolve the prefix because an Entry_Family has no type, 8082 -- although it has the semantics of an array since it can be indexed. 8083 -- In order to perform the associated range check, we would need to 8084 -- build an array type on the fly and set it on the prefix, but this 8085 -- would be wasteful since only the index type matters. Therefore we 8086 -- attach this index type directly, so that Actual_Index_Expression 8087 -- can pick it up later in order to generate the range check. 8088 8089 Set_Etype (Prefix (Entry_Name), Actual_Index_Type (Nam)); 8090 8091 Index := First (Expressions (Entry_Name)); 8092 Resolve (Index, Entry_Index_Type (Nam)); 8093 8094 -- Generate a reference for the index when it denotes an entity 8095 8096 if Is_Entity_Name (Index) then 8097 Generate_Reference (Entity (Index), Nam); 8098 end if; 8099 8100 -- Up to this point the expression could have been the actual in a 8101 -- simple entry call, and be given by a named association. 8102 8103 if Nkind (Index) = N_Parameter_Association then 8104 Error_Msg_N ("expect expression for entry index", Index); 8105 else 8106 Apply_Scalar_Range_Check (Index, Etype (Prefix (Entry_Name))); 8107 end if; 8108 end if; 8109 end Resolve_Entry; 8110 8111 ------------------------ 8112 -- Resolve_Entry_Call -- 8113 ------------------------ 8114 8115 procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is 8116 Entry_Name : constant Node_Id := Name (N); 8117 Loc : constant Source_Ptr := Sloc (Entry_Name); 8118 8119 Nam : Entity_Id; 8120 Norm_OK : Boolean; 8121 Obj : Node_Id; 8122 Was_Over : Boolean; 8123 8124 begin 8125 -- We kill all checks here, because it does not seem worth the effort to 8126 -- do anything better, an entry call is a big operation. 8127 8128 Kill_All_Checks; 8129 8130 -- Processing of the name is similar for entry calls and protected 8131 -- operation calls. Once the entity is determined, we can complete 8132 -- the resolution of the actuals. 8133 8134 -- The selector may be overloaded, in the case of a protected object 8135 -- with overloaded functions. The type of the context is used for 8136 -- resolution. 8137 8138 if Nkind (Entry_Name) = N_Selected_Component 8139 and then Is_Overloaded (Selector_Name (Entry_Name)) 8140 and then Typ /= Standard_Void_Type 8141 then 8142 declare 8143 I : Interp_Index; 8144 It : Interp; 8145 8146 begin 8147 Get_First_Interp (Selector_Name (Entry_Name), I, It); 8148 while Present (It.Typ) loop 8149 if Covers (Typ, It.Typ) then 8150 Set_Entity (Selector_Name (Entry_Name), It.Nam); 8151 Set_Etype (Entry_Name, It.Typ); 8152 8153 Generate_Reference (It.Typ, N, ' '); 8154 end if; 8155 8156 Get_Next_Interp (I, It); 8157 end loop; 8158 end; 8159 end if; 8160 8161 Resolve_Entry (Entry_Name); 8162 8163 if Nkind (Entry_Name) = N_Selected_Component then 8164 8165 -- Simple entry or protected operation call 8166 8167 Nam := Entity (Selector_Name (Entry_Name)); 8168 Obj := Prefix (Entry_Name); 8169 8170 if Is_Subprogram (Nam) then 8171 Check_For_Eliminated_Subprogram (Entry_Name, Nam); 8172 end if; 8173 8174 Was_Over := Is_Overloaded (Selector_Name (Entry_Name)); 8175 8176 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); 8177 8178 -- Call to member of entry family 8179 8180 Nam := Entity (Selector_Name (Prefix (Entry_Name))); 8181 Obj := Prefix (Prefix (Entry_Name)); 8182 Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name))); 8183 end if; 8184 8185 -- We cannot in general check the maximum depth of protected entry calls 8186 -- at compile time. But we can tell that any protected entry call at all 8187 -- violates a specified nesting depth of zero. 8188 8189 if Is_Protected_Type (Scope (Nam)) then 8190 Check_Restriction (Max_Entry_Queue_Length, N); 8191 end if; 8192 8193 -- Use context type to disambiguate a protected function that can be 8194 -- called without actuals and that returns an array type, and where the 8195 -- argument list may be an indexing of the returned value. 8196 8197 if Ekind (Nam) = E_Function 8198 and then Needs_No_Actuals (Nam) 8199 and then Present (Parameter_Associations (N)) 8200 and then 8201 ((Is_Array_Type (Etype (Nam)) 8202 and then Covers (Typ, Component_Type (Etype (Nam)))) 8203 8204 or else (Is_Access_Type (Etype (Nam)) 8205 and then Is_Array_Type (Designated_Type (Etype (Nam))) 8206 and then 8207 Covers 8208 (Typ, 8209 Component_Type (Designated_Type (Etype (Nam)))))) 8210 then 8211 declare 8212 Index_Node : Node_Id; 8213 8214 begin 8215 Index_Node := 8216 Make_Indexed_Component (Loc, 8217 Prefix => 8218 Make_Function_Call (Loc, Name => Relocate_Node (Entry_Name)), 8219 Expressions => Parameter_Associations (N)); 8220 8221 -- Since we are correcting a node classification error made by the 8222 -- parser, we call Replace rather than Rewrite. 8223 8224 Replace (N, Index_Node); 8225 Set_Etype (Prefix (N), Etype (Nam)); 8226 Set_Etype (N, Typ); 8227 Resolve_Indexed_Component (N, Typ); 8228 return; 8229 end; 8230 end if; 8231 8232 if Is_Entry (Nam) 8233 and then Present (Contract_Wrapper (Nam)) 8234 and then Current_Scope /= Contract_Wrapper (Nam) 8235 then 8236 -- Note the entity being called before rewriting the call, so that 8237 -- it appears used at this point. 8238 8239 Generate_Reference (Nam, Entry_Name, 'r'); 8240 8241 -- Rewrite as call to the precondition wrapper, adding the task 8242 -- object to the list of actuals. If the call is to a member of an 8243 -- entry family, include the index as well. 8244 8245 declare 8246 New_Call : Node_Id; 8247 New_Actuals : List_Id; 8248 8249 begin 8250 New_Actuals := New_List (Obj); 8251 8252 if Nkind (Entry_Name) = N_Indexed_Component then 8253 Append_To (New_Actuals, 8254 New_Copy_Tree (First (Expressions (Entry_Name)))); 8255 end if; 8256 8257 Append_List (Parameter_Associations (N), New_Actuals); 8258 New_Call := 8259 Make_Procedure_Call_Statement (Loc, 8260 Name => 8261 New_Occurrence_Of (Contract_Wrapper (Nam), Loc), 8262 Parameter_Associations => New_Actuals); 8263 Rewrite (N, New_Call); 8264 8265 -- Preanalyze and resolve new call. Current procedure is called 8266 -- from Resolve_Call, after which expansion will take place. 8267 8268 Preanalyze_And_Resolve (N); 8269 return; 8270 end; 8271 end if; 8272 8273 -- The operation name may have been overloaded. Order the actuals 8274 -- according to the formals of the resolved entity, and set the return 8275 -- type to that of the operation. 8276 8277 if Was_Over then 8278 Normalize_Actuals (N, Nam, False, Norm_OK); 8279 pragma Assert (Norm_OK); 8280 Set_Etype (N, Etype (Nam)); 8281 8282 -- Reset the Is_Overloaded flag, since resolution is now completed 8283 8284 -- Simple entry call 8285 8286 if Nkind (Entry_Name) = N_Selected_Component then 8287 Set_Is_Overloaded (Selector_Name (Entry_Name), False); 8288 8289 -- Call to a member of an entry family 8290 8291 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); 8292 Set_Is_Overloaded (Selector_Name (Prefix (Entry_Name)), False); 8293 end if; 8294 end if; 8295 8296 Resolve_Actuals (N, Nam); 8297 Check_Internal_Protected_Use (N, Nam); 8298 8299 -- Create a call reference to the entry 8300 8301 Generate_Reference (Nam, Entry_Name, 's'); 8302 8303 if Is_Entry (Nam) then 8304 Check_Potentially_Blocking_Operation (N); 8305 end if; 8306 8307 -- Verify that a procedure call cannot masquerade as an entry 8308 -- call where an entry call is expected. 8309 8310 if Ekind (Nam) = E_Procedure then 8311 if Nkind (Parent (N)) = N_Entry_Call_Alternative 8312 and then N = Entry_Call_Statement (Parent (N)) 8313 then 8314 Error_Msg_N ("entry call required in select statement", N); 8315 8316 elsif Nkind (Parent (N)) = N_Triggering_Alternative 8317 and then N = Triggering_Statement (Parent (N)) 8318 then 8319 Error_Msg_N ("triggering statement cannot be procedure call", N); 8320 8321 elsif Ekind (Scope (Nam)) = E_Task_Type 8322 and then not In_Open_Scopes (Scope (Nam)) 8323 then 8324 Error_Msg_N ("task has no entry with this name", Entry_Name); 8325 end if; 8326 end if; 8327 8328 -- After resolution, entry calls and protected procedure calls are 8329 -- changed into entry calls, for expansion. The structure of the node 8330 -- does not change, so it can safely be done in place. Protected 8331 -- function calls must keep their structure because they are 8332 -- subexpressions. 8333 8334 if Ekind (Nam) /= E_Function then 8335 8336 -- A protected operation that is not a function may modify the 8337 -- corresponding object, and cannot apply to a constant. If this 8338 -- is an internal call, the prefix is the type itself. 8339 8340 if Is_Protected_Type (Scope (Nam)) 8341 and then not Is_Variable (Obj) 8342 and then (not Is_Entity_Name (Obj) 8343 or else not Is_Type (Entity (Obj))) 8344 then 8345 Error_Msg_N 8346 ("prefix of protected procedure or entry call must be variable", 8347 Entry_Name); 8348 end if; 8349 8350 declare 8351 Entry_Call : Node_Id; 8352 8353 begin 8354 Entry_Call := 8355 Make_Entry_Call_Statement (Loc, 8356 Name => Entry_Name, 8357 Parameter_Associations => Parameter_Associations (N)); 8358 8359 -- Inherit relevant attributes from the original call 8360 8361 Set_First_Named_Actual 8362 (Entry_Call, First_Named_Actual (N)); 8363 8364 Set_Is_Elaboration_Checks_OK_Node 8365 (Entry_Call, Is_Elaboration_Checks_OK_Node (N)); 8366 8367 Set_Is_Elaboration_Warnings_OK_Node 8368 (Entry_Call, Is_Elaboration_Warnings_OK_Node (N)); 8369 8370 Set_Is_SPARK_Mode_On_Node 8371 (Entry_Call, Is_SPARK_Mode_On_Node (N)); 8372 8373 Rewrite (N, Entry_Call); 8374 Set_Analyzed (N, True); 8375 end; 8376 8377 -- Protected functions can return on the secondary stack, in which case 8378 -- we must trigger the transient scope mechanism. 8379 8380 elsif Expander_Active 8381 and then Requires_Transient_Scope (Etype (Nam)) 8382 then 8383 Establish_Transient_Scope (N, Manage_Sec_Stack => True); 8384 end if; 8385 8386 -- Now we know that this is not a call to a function that returns an 8387 -- array type; moreover, we know the name of the called entry. Detect 8388 -- overlapping actuals, just like for a subprogram call. 8389 8390 Warn_On_Overlapping_Actuals (Nam, N); 8391 8392 end Resolve_Entry_Call; 8393 8394 ------------------------- 8395 -- Resolve_Equality_Op -- 8396 ------------------------- 8397 8398 -- Both arguments must have the same type, and the boolean context does 8399 -- not participate in the resolution. The first pass verifies that the 8400 -- interpretation is not ambiguous, and the type of the left argument is 8401 -- correctly set, or is Any_Type in case of ambiguity. If both arguments 8402 -- are strings or aggregates, allocators, or Null, they are ambiguous even 8403 -- though they carry a single (universal) type. Diagnose this case here. 8404 8405 procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is 8406 L : constant Node_Id := Left_Opnd (N); 8407 R : constant Node_Id := Right_Opnd (N); 8408 T : Entity_Id := Find_Unique_Type (L, R); 8409 8410 procedure Check_If_Expression (Cond : Node_Id); 8411 -- The resolution rule for if expressions requires that each such must 8412 -- have a unique type. This means that if several dependent expressions 8413 -- are of a non-null anonymous access type, and the context does not 8414 -- impose an expected type (as can be the case in an equality operation) 8415 -- the expression must be rejected. 8416 8417 procedure Explain_Redundancy (N : Node_Id); 8418 -- Attempt to explain the nature of a redundant comparison with True. If 8419 -- the expression N is too complex, this routine issues a general error 8420 -- message. 8421 8422 function Find_Unique_Access_Type return Entity_Id; 8423 -- In the case of allocators and access attributes, the context must 8424 -- provide an indication of the specific access type to be used. If 8425 -- one operand is of such a "generic" access type, check whether there 8426 -- is a specific visible access type that has the same designated type. 8427 -- This is semantically dubious, and of no interest to any real code, 8428 -- but c48008a makes it all worthwhile. 8429 8430 function Suspicious_Prio_For_Equality return Boolean; 8431 -- Returns True iff the parent node is a and/or/xor operation that 8432 -- could be the cause of confused priorities. Note that if the not is 8433 -- in parens, then False is returned. 8434 8435 ------------------------- 8436 -- Check_If_Expression -- 8437 ------------------------- 8438 8439 procedure Check_If_Expression (Cond : Node_Id) is 8440 Then_Expr : Node_Id; 8441 Else_Expr : Node_Id; 8442 8443 begin 8444 if Nkind (Cond) = N_If_Expression then 8445 Then_Expr := Next (First (Expressions (Cond))); 8446 Else_Expr := Next (Then_Expr); 8447 8448 if Nkind (Then_Expr) /= N_Null 8449 and then Nkind (Else_Expr) /= N_Null 8450 then 8451 Error_Msg_N ("cannot determine type of if expression", Cond); 8452 end if; 8453 end if; 8454 end Check_If_Expression; 8455 8456 ------------------------ 8457 -- Explain_Redundancy -- 8458 ------------------------ 8459 8460 procedure Explain_Redundancy (N : Node_Id) is 8461 Error : Name_Id; 8462 Val : Node_Id; 8463 Val_Id : Entity_Id; 8464 8465 begin 8466 Val := N; 8467 8468 -- Strip the operand down to an entity 8469 8470 loop 8471 if Nkind (Val) = N_Selected_Component then 8472 Val := Selector_Name (Val); 8473 else 8474 exit; 8475 end if; 8476 end loop; 8477 8478 -- The construct denotes an entity 8479 8480 if Is_Entity_Name (Val) and then Present (Entity (Val)) then 8481 Val_Id := Entity (Val); 8482 8483 -- Do not generate an error message when the comparison is done 8484 -- against the enumeration literal Standard.True. 8485 8486 if Ekind (Val_Id) /= E_Enumeration_Literal then 8487 8488 -- Build a customized error message 8489 8490 Name_Len := 0; 8491 Add_Str_To_Name_Buffer ("?r?"); 8492 8493 if Ekind (Val_Id) = E_Component then 8494 Add_Str_To_Name_Buffer ("component "); 8495 8496 elsif Ekind (Val_Id) = E_Constant then 8497 Add_Str_To_Name_Buffer ("constant "); 8498 8499 elsif Ekind (Val_Id) = E_Discriminant then 8500 Add_Str_To_Name_Buffer ("discriminant "); 8501 8502 elsif Is_Formal (Val_Id) then 8503 Add_Str_To_Name_Buffer ("parameter "); 8504 8505 elsif Ekind (Val_Id) = E_Variable then 8506 Add_Str_To_Name_Buffer ("variable "); 8507 end if; 8508 8509 Add_Str_To_Name_Buffer ("& is always True!"); 8510 Error := Name_Find; 8511 8512 Error_Msg_NE (Get_Name_String (Error), Val, Val_Id); 8513 end if; 8514 8515 -- The construct is too complex to disect, issue a general message 8516 8517 else 8518 Error_Msg_N ("?r?expression is always True!", Val); 8519 end if; 8520 end Explain_Redundancy; 8521 8522 ----------------------------- 8523 -- Find_Unique_Access_Type -- 8524 ----------------------------- 8525 8526 function Find_Unique_Access_Type return Entity_Id is 8527 Acc : Entity_Id; 8528 E : Entity_Id; 8529 S : Entity_Id; 8530 8531 begin 8532 if Ekind (Etype (R)) in E_Allocator_Type | E_Access_Attribute_Type 8533 then 8534 Acc := Designated_Type (Etype (R)); 8535 8536 elsif Ekind (Etype (L)) in E_Allocator_Type | E_Access_Attribute_Type 8537 then 8538 Acc := Designated_Type (Etype (L)); 8539 else 8540 return Empty; 8541 end if; 8542 8543 S := Current_Scope; 8544 while S /= Standard_Standard loop 8545 E := First_Entity (S); 8546 while Present (E) loop 8547 if Is_Type (E) 8548 and then Is_Access_Type (E) 8549 and then Ekind (E) /= E_Allocator_Type 8550 and then Designated_Type (E) = Base_Type (Acc) 8551 then 8552 return E; 8553 end if; 8554 8555 Next_Entity (E); 8556 end loop; 8557 8558 S := Scope (S); 8559 end loop; 8560 8561 return Empty; 8562 end Find_Unique_Access_Type; 8563 8564 ---------------------------------- 8565 -- Suspicious_Prio_For_Equality -- 8566 ---------------------------------- 8567 8568 function Suspicious_Prio_For_Equality return Boolean is 8569 Par : constant Node_Id := Parent (N); 8570 8571 begin 8572 -- Check if parent node is one of and/or/xor, not parenthesized 8573 -- explicitly, and its own parent is not of this kind. Otherwise, 8574 -- it's a case of chained Boolean conditions which is likely well 8575 -- parenthesized. 8576 8577 if Nkind (Par) in N_Op_And | N_Op_Or | N_Op_Xor 8578 and then Paren_Count (N) = 0 8579 and then Nkind (Parent (Par)) not in N_Op_And | N_Op_Or | N_Op_Xor 8580 then 8581 declare 8582 Compar : Node_Id := 8583 (if Left_Opnd (Par) = N then 8584 Right_Opnd (Par) 8585 else 8586 Left_Opnd (Par)); 8587 begin 8588 -- Compar may have been rewritten, for example from (a /= b) 8589 -- into not (a = b). Use the Original_Node instead. 8590 8591 Compar := Original_Node (Compar); 8592 8593 -- If the other argument of the and/or/xor is also a 8594 -- comparison, or another and/or/xor then most likely 8595 -- the priorities are correctly set. 8596 8597 return Nkind (Compar) not in N_Op_Boolean; 8598 end; 8599 8600 else 8601 return False; 8602 end if; 8603 end Suspicious_Prio_For_Equality; 8604 8605 -- Start of processing for Resolve_Equality_Op 8606 8607 begin 8608 Set_Etype (N, Base_Type (Typ)); 8609 Generate_Reference (T, N, ' '); 8610 8611 if T = Any_Fixed then 8612 T := Unique_Fixed_Point_Type (L); 8613 end if; 8614 8615 if T /= Any_Type then 8616 if T = Any_String or else 8617 T = Any_Composite or else 8618 T = Any_Character 8619 then 8620 if T = Any_Character then 8621 Ambiguous_Character (L); 8622 else 8623 Error_Msg_N ("ambiguous operands for equality", N); 8624 end if; 8625 8626 Set_Etype (N, Any_Type); 8627 return; 8628 8629 elsif T = Any_Access 8630 or else Ekind (T) in E_Allocator_Type | E_Access_Attribute_Type 8631 then 8632 T := Find_Unique_Access_Type; 8633 8634 if No (T) then 8635 Error_Msg_N ("ambiguous operands for equality", N); 8636 Set_Etype (N, Any_Type); 8637 return; 8638 end if; 8639 8640 -- If expressions must have a single type, and if the context does 8641 -- not impose one the dependent expressions cannot be anonymous 8642 -- access types. 8643 8644 -- Why no similar processing for case expressions??? 8645 8646 elsif Ada_Version >= Ada_2012 8647 and then Is_Anonymous_Access_Type (Etype (L)) 8648 and then Is_Anonymous_Access_Type (Etype (R)) 8649 then 8650 Check_If_Expression (L); 8651 Check_If_Expression (R); 8652 end if; 8653 8654 Resolve (L, T); 8655 Resolve (R, T); 8656 8657 -- If the unique type is a class-wide type then it will be expanded 8658 -- into a dispatching call to the predefined primitive. Therefore we 8659 -- check here for potential violation of such restriction. 8660 8661 if Is_Class_Wide_Type (T) then 8662 Check_Restriction (No_Dispatching_Calls, N); 8663 end if; 8664 8665 -- Only warn for redundant equality comparison to True for objects 8666 -- (e.g. "X = True") and operations (e.g. "(X < Y) = True"). For 8667 -- other expressions, it may be a matter of preference to write 8668 -- "Expr = True" or "Expr". 8669 8670 if Warn_On_Redundant_Constructs 8671 and then Comes_From_Source (N) 8672 and then Comes_From_Source (R) 8673 and then Is_Entity_Name (R) 8674 and then Entity (R) = Standard_True 8675 and then 8676 ((Is_Entity_Name (L) and then Is_Object (Entity (L))) 8677 or else 8678 Nkind (L) in N_Op) 8679 then 8680 Error_Msg_N -- CODEFIX 8681 ("?r?comparison with True is redundant!", N); 8682 Explain_Redundancy (Original_Node (R)); 8683 end if; 8684 8685 -- Warn on a (in)equality between boolean values which is not 8686 -- parenthesized when the parent expression is one of and/or/xor, as 8687 -- this is interpreted as (a = b) op c where most likely a = (b op c) 8688 -- was intended. Do not generate a warning in generic instances, as 8689 -- the problematic expression may be implicitly parenthesized in 8690 -- the generic itself if one of the operators is a generic formal. 8691 -- Also do not generate a warning for generated equality, for 8692 -- example from rewritting a membership test. 8693 8694 if Warn_On_Questionable_Missing_Parens 8695 and then not In_Instance 8696 and then Comes_From_Source (N) 8697 and then Is_Boolean_Type (T) 8698 and then Suspicious_Prio_For_Equality 8699 then 8700 Error_Msg_N ("?q?equality should be parenthesized here!", N); 8701 end if; 8702 8703 -- If the equality is overloaded and the operands have resolved 8704 -- properly, set the proper equality operator on the node. The 8705 -- current setting is the first one found during analysis, which 8706 -- is not necessarily the one to which the node has resolved. 8707 8708 if Is_Overloaded (N) then 8709 declare 8710 I : Interp_Index; 8711 It : Interp; 8712 8713 begin 8714 Get_First_Interp (N, I, It); 8715 8716 -- If the equality is user-defined, the type of the operands 8717 -- matches that of the formals. For a predefined operator, 8718 -- it is the scope that matters, given that the predefined 8719 -- equality has Any_Type formals. In either case the result 8720 -- type (most often Boolean) must match the context. The scope 8721 -- is either that of the type, if there is a generated equality 8722 -- (when there is an equality for the component type), or else 8723 -- Standard otherwise. 8724 8725 while Present (It.Typ) loop 8726 if Etype (It.Nam) = Typ 8727 and then 8728 (Etype (First_Entity (It.Nam)) = Etype (L) 8729 or else Scope (It.Nam) = Standard_Standard 8730 or else Scope (It.Nam) = Scope (T)) 8731 then 8732 Set_Entity (N, It.Nam); 8733 8734 Set_Is_Overloaded (N, False); 8735 exit; 8736 end if; 8737 8738 Get_Next_Interp (I, It); 8739 end loop; 8740 8741 -- If expansion is active and this is an inherited operation, 8742 -- replace it with its ancestor. This must not be done during 8743 -- preanalysis because the type may not be frozen yet, as when 8744 -- the context is a precondition or postcondition. 8745 8746 if Present (Alias (Entity (N))) and then Expander_Active then 8747 Set_Entity (N, Alias (Entity (N))); 8748 end if; 8749 end; 8750 end if; 8751 8752 Check_Unset_Reference (L); 8753 Check_Unset_Reference (R); 8754 Generate_Operator_Reference (N, T); 8755 Check_Low_Bound_Tested (N); 8756 8757 -- If this is an inequality, it may be the implicit inequality 8758 -- created for a user-defined operation, in which case the corres- 8759 -- ponding equality operation is not intrinsic, and the operation 8760 -- cannot be constant-folded. Else fold. 8761 8762 if Nkind (N) = N_Op_Eq 8763 or else Comes_From_Source (Entity (N)) 8764 or else Ekind (Entity (N)) = E_Operator 8765 or else Is_Intrinsic_Subprogram 8766 (Corresponding_Equality (Entity (N))) 8767 then 8768 Analyze_Dimension (N); 8769 Eval_Relational_Op (N); 8770 8771 elsif Nkind (N) = N_Op_Ne 8772 and then Is_Abstract_Subprogram (Entity (N)) 8773 then 8774 Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); 8775 end if; 8776 8777 -- Ada 2005: If one operand is an anonymous access type, convert the 8778 -- other operand to it, to ensure that the underlying types match in 8779 -- the back-end. Same for access_to_subprogram, and the conversion 8780 -- verifies that the types are subtype conformant. 8781 8782 -- We apply the same conversion in the case one of the operands is a 8783 -- private subtype of the type of the other. 8784 8785 -- Why the Expander_Active test here ??? 8786 8787 if Expander_Active 8788 and then 8789 (Ekind (T) in E_Anonymous_Access_Type 8790 | E_Anonymous_Access_Subprogram_Type 8791 or else Is_Private_Type (T)) 8792 then 8793 if Etype (L) /= T then 8794 Rewrite (L, 8795 Make_Unchecked_Type_Conversion (Sloc (L), 8796 Subtype_Mark => New_Occurrence_Of (T, Sloc (L)), 8797 Expression => Relocate_Node (L))); 8798 Analyze_And_Resolve (L, T); 8799 end if; 8800 8801 if (Etype (R)) /= T then 8802 Rewrite (R, 8803 Make_Unchecked_Type_Conversion (Sloc (R), 8804 Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)), 8805 Expression => Relocate_Node (R))); 8806 Analyze_And_Resolve (R, T); 8807 end if; 8808 end if; 8809 end if; 8810 end Resolve_Equality_Op; 8811 8812 ---------------------------------- 8813 -- Resolve_Explicit_Dereference -- 8814 ---------------------------------- 8815 8816 procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is 8817 Loc : constant Source_Ptr := Sloc (N); 8818 New_N : Node_Id; 8819 P : constant Node_Id := Prefix (N); 8820 8821 P_Typ : Entity_Id; 8822 -- The candidate prefix type, if overloaded 8823 8824 I : Interp_Index; 8825 It : Interp; 8826 8827 begin 8828 Check_Fully_Declared_Prefix (Typ, P); 8829 P_Typ := Empty; 8830 8831 -- A useful optimization: check whether the dereference denotes an 8832 -- element of a container, and if so rewrite it as a call to the 8833 -- corresponding Element function. 8834 8835 -- Disabled for now, on advice of ARG. A more restricted form of the 8836 -- predicate might be acceptable ??? 8837 8838 -- if Is_Container_Element (N) then 8839 -- return; 8840 -- end if; 8841 8842 if Is_Overloaded (P) then 8843 8844 -- Use the context type to select the prefix that has the correct 8845 -- designated type. Keep the first match, which will be the inner- 8846 -- most. 8847 8848 Get_First_Interp (P, I, It); 8849 8850 while Present (It.Typ) loop 8851 if Is_Access_Type (It.Typ) 8852 and then Covers (Typ, Designated_Type (It.Typ)) 8853 then 8854 if No (P_Typ) then 8855 P_Typ := It.Typ; 8856 end if; 8857 8858 -- Remove access types that do not match, but preserve access 8859 -- to subprogram interpretations, in case a further dereference 8860 -- is needed (see below). 8861 8862 elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then 8863 Remove_Interp (I); 8864 end if; 8865 8866 Get_Next_Interp (I, It); 8867 end loop; 8868 8869 if Present (P_Typ) then 8870 Resolve (P, P_Typ); 8871 Set_Etype (N, Designated_Type (P_Typ)); 8872 8873 else 8874 -- If no interpretation covers the designated type of the prefix, 8875 -- this is the pathological case where not all implementations of 8876 -- the prefix allow the interpretation of the node as a call. Now 8877 -- that the expected type is known, Remove other interpretations 8878 -- from prefix, rewrite it as a call, and resolve again, so that 8879 -- the proper call node is generated. 8880 8881 Get_First_Interp (P, I, It); 8882 while Present (It.Typ) loop 8883 if Ekind (It.Typ) /= E_Access_Subprogram_Type then 8884 Remove_Interp (I); 8885 end if; 8886 8887 Get_Next_Interp (I, It); 8888 end loop; 8889 8890 New_N := 8891 Make_Function_Call (Loc, 8892 Name => 8893 Make_Explicit_Dereference (Loc, 8894 Prefix => P), 8895 Parameter_Associations => New_List); 8896 8897 Save_Interps (N, New_N); 8898 Rewrite (N, New_N); 8899 Analyze_And_Resolve (N, Typ); 8900 return; 8901 end if; 8902 8903 -- If not overloaded, resolve P with its own type 8904 8905 else 8906 Resolve (P); 8907 end if; 8908 8909 -- If the prefix might be null, add an access check 8910 8911 if Is_Access_Type (Etype (P)) 8912 and then not Can_Never_Be_Null (Etype (P)) 8913 then 8914 Apply_Access_Check (N); 8915 end if; 8916 8917 -- If the designated type is a packed unconstrained array type, and the 8918 -- explicit dereference is not in the context of an attribute reference, 8919 -- then we must compute and set the actual subtype, since it is needed 8920 -- by Gigi. The reason we exclude the attribute case is that this is 8921 -- handled fine by Gigi, and in fact we use such attributes to build the 8922 -- actual subtype. We also exclude generated code (which builds actual 8923 -- subtypes directly if they are needed). 8924 8925 if Is_Packed_Array (Etype (N)) 8926 and then not Is_Constrained (Etype (N)) 8927 and then Nkind (Parent (N)) /= N_Attribute_Reference 8928 and then Comes_From_Source (N) 8929 then 8930 Set_Etype (N, Get_Actual_Subtype (N)); 8931 end if; 8932 8933 Analyze_Dimension (N); 8934 8935 -- Note: No Eval processing is required for an explicit dereference, 8936 -- because such a name can never be static. 8937 8938 end Resolve_Explicit_Dereference; 8939 8940 ------------------------------------- 8941 -- Resolve_Expression_With_Actions -- 8942 ------------------------------------- 8943 8944 procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is 8945 8946 function OK_For_Static (Act : Node_Id) return Boolean; 8947 -- True if Act is an action of a declare_expression that is allowed in a 8948 -- static declare_expression. 8949 8950 function All_OK_For_Static return Boolean; 8951 -- True if all actions of N are allowed in a static declare_expression. 8952 8953 function Get_Literal (Expr : Node_Id) return Node_Id; 8954 -- Expr is an expression with compile-time-known value. This returns the 8955 -- literal node that reprsents that value. 8956 8957 function OK_For_Static (Act : Node_Id) return Boolean is 8958 begin 8959 case Nkind (Act) is 8960 when N_Object_Declaration => 8961 if Constant_Present (Act) 8962 and then Is_Static_Expression (Expression (Act)) 8963 then 8964 return True; 8965 end if; 8966 8967 when N_Object_Renaming_Declaration => 8968 if Statically_Names_Object (Name (Act)) then 8969 return True; 8970 end if; 8971 8972 when others => 8973 -- No other declarations, nor even pragmas, are allowed in a 8974 -- declare expression, so if we see something else, it must be 8975 -- an internally generated expression_with_actions. 8976 null; 8977 end case; 8978 8979 return False; 8980 end OK_For_Static; 8981 8982 function All_OK_For_Static return Boolean is 8983 Act : Node_Id := First (Actions (N)); 8984 begin 8985 while Present (Act) loop 8986 if not OK_For_Static (Act) then 8987 return False; 8988 end if; 8989 8990 Next (Act); 8991 end loop; 8992 8993 return True; 8994 end All_OK_For_Static; 8995 8996 function Get_Literal (Expr : Node_Id) return Node_Id is 8997 pragma Assert (Compile_Time_Known_Value (Expr)); 8998 Result : Node_Id; 8999 begin 9000 case Nkind (Expr) is 9001 when N_Has_Entity => 9002 if Ekind (Entity (Expr)) = E_Enumeration_Literal then 9003 Result := Expr; 9004 else 9005 Result := Constant_Value (Entity (Expr)); 9006 end if; 9007 when N_Numeric_Or_String_Literal => 9008 Result := Expr; 9009 when others => 9010 raise Program_Error; 9011 end case; 9012 9013 pragma Assert 9014 (Nkind (Result) in N_Numeric_Or_String_Literal 9015 or else Ekind (Entity (Result)) = E_Enumeration_Literal); 9016 return Result; 9017 end Get_Literal; 9018 9019 Loc : constant Source_Ptr := Sloc (N); 9020 9021 begin 9022 Set_Etype (N, Typ); 9023 9024 if Is_Empty_List (Actions (N)) then 9025 pragma Assert (All_OK_For_Static); null; 9026 end if; 9027 9028 -- If the value of the expression is known at compile time, and all 9029 -- of the actions (if any) are suitable, then replace the declare 9030 -- expression with its expression. This allows the declare expression 9031 -- as a whole to be static if appropriate. See AI12-0368. 9032 9033 if Compile_Time_Known_Value (Expression (N)) then 9034 if Is_Empty_List (Actions (N)) then 9035 Rewrite (N, Expression (N)); 9036 elsif All_OK_For_Static then 9037 Rewrite 9038 (N, New_Copy_Tree 9039 (Get_Literal (Expression (N)), New_Sloc => Loc)); 9040 end if; 9041 end if; 9042 end Resolve_Expression_With_Actions; 9043 9044 ---------------------------------- 9045 -- Resolve_Generalized_Indexing -- 9046 ---------------------------------- 9047 9048 procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id) is 9049 Indexing : constant Node_Id := Generalized_Indexing (N); 9050 begin 9051 Rewrite (N, Indexing); 9052 Resolve (N, Typ); 9053 end Resolve_Generalized_Indexing; 9054 9055 --------------------------- 9056 -- Resolve_If_Expression -- 9057 --------------------------- 9058 9059 procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id) is 9060 procedure Apply_Check (Expr : Node_Id); 9061 -- When a dependent expression is of a subtype different from 9062 -- the context subtype, then insert a qualification to ensure 9063 -- the generation of a constraint check. This was previously 9064 -- for scalar types. For array types apply a length check, given 9065 -- that the context in general allows sliding, while a qualified 9066 -- expression forces equality of bounds. 9067 9068 ----------------- 9069 -- Apply_Check -- 9070 ----------------- 9071 9072 procedure Apply_Check (Expr : Node_Id) is 9073 Expr_Typ : constant Entity_Id := Etype (Expr); 9074 Loc : constant Source_Ptr := Sloc (Expr); 9075 9076 begin 9077 if Expr_Typ = Typ 9078 or else Is_Tagged_Type (Typ) 9079 or else Is_Access_Type (Typ) 9080 or else not Is_Constrained (Typ) 9081 or else Inside_A_Generic 9082 then 9083 null; 9084 9085 elsif Is_Array_Type (Typ) then 9086 Apply_Length_Check (Expr, Typ); 9087 9088 else 9089 Rewrite (Expr, 9090 Make_Qualified_Expression (Loc, 9091 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 9092 Expression => Relocate_Node (Expr))); 9093 9094 Analyze_And_Resolve (Expr, Typ); 9095 end if; 9096 end Apply_Check; 9097 9098 -- Local variables 9099 9100 Condition : constant Node_Id := First (Expressions (N)); 9101 Else_Expr : Node_Id; 9102 Then_Expr : Node_Id; 9103 9104 -- Start of processing for Resolve_If_Expression 9105 9106 begin 9107 -- Defend against malformed expressions 9108 9109 if No (Condition) then 9110 return; 9111 end if; 9112 9113 Then_Expr := Next (Condition); 9114 9115 if No (Then_Expr) then 9116 return; 9117 end if; 9118 9119 Else_Expr := Next (Then_Expr); 9120 9121 Resolve (Condition, Any_Boolean); 9122 Resolve (Then_Expr, Typ); 9123 Apply_Check (Then_Expr); 9124 9125 -- If ELSE expression present, just resolve using the determined type 9126 -- If type is universal, resolve to any member of the class. 9127 9128 if Present (Else_Expr) then 9129 if Typ = Universal_Integer then 9130 Resolve (Else_Expr, Any_Integer); 9131 9132 elsif Typ = Universal_Real then 9133 Resolve (Else_Expr, Any_Real); 9134 9135 else 9136 Resolve (Else_Expr, Typ); 9137 end if; 9138 9139 Apply_Check (Else_Expr); 9140 9141 -- Apply RM 4.5.7 (17/3): whether the expression is statically or 9142 -- dynamically tagged must be known statically. 9143 9144 if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then 9145 if Is_Dynamically_Tagged (Then_Expr) /= 9146 Is_Dynamically_Tagged (Else_Expr) 9147 then 9148 Error_Msg_N ("all or none of the dependent expressions " 9149 & "can be dynamically tagged", N); 9150 end if; 9151 end if; 9152 9153 -- If no ELSE expression is present, root type must be Standard.Boolean 9154 -- and we provide a Standard.True result converted to the appropriate 9155 -- Boolean type (in case it is a derived boolean type). 9156 9157 elsif Root_Type (Typ) = Standard_Boolean then 9158 Else_Expr := 9159 Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))); 9160 Analyze_And_Resolve (Else_Expr, Typ); 9161 Append_To (Expressions (N), Else_Expr); 9162 9163 else 9164 Error_Msg_N ("can only omit ELSE expression in Boolean case", N); 9165 Append_To (Expressions (N), Error); 9166 end if; 9167 9168 Set_Etype (N, Typ); 9169 9170 if not Error_Posted (N) then 9171 Eval_If_Expression (N); 9172 end if; 9173 9174 Analyze_Dimension (N); 9175 end Resolve_If_Expression; 9176 9177 ---------------------------------- 9178 -- Resolve_Implicit_Dereference -- 9179 ---------------------------------- 9180 9181 procedure Resolve_Implicit_Dereference (P : Node_Id) is 9182 Desig_Typ : Entity_Id; 9183 9184 begin 9185 -- In an instance the proper view may not always be correct for 9186 -- private types, see e.g. Sem_Type.Covers for similar handling. 9187 9188 if Is_Private_Type (Etype (P)) 9189 and then Present (Full_View (Etype (P))) 9190 and then Is_Access_Type (Full_View (Etype (P))) 9191 and then In_Instance 9192 then 9193 Set_Etype (P, Full_View (Etype (P))); 9194 end if; 9195 9196 if Is_Access_Type (Etype (P)) then 9197 Desig_Typ := Implicitly_Designated_Type (Etype (P)); 9198 Insert_Explicit_Dereference (P); 9199 Analyze_And_Resolve (P, Desig_Typ); 9200 end if; 9201 end Resolve_Implicit_Dereference; 9202 9203 ------------------------------- 9204 -- Resolve_Indexed_Component -- 9205 ------------------------------- 9206 9207 procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is 9208 Name : constant Node_Id := Prefix (N); 9209 Expr : Node_Id; 9210 Array_Type : Entity_Id := Empty; -- to prevent junk warning 9211 Index : Node_Id; 9212 9213 begin 9214 if Present (Generalized_Indexing (N)) then 9215 Resolve_Generalized_Indexing (N, Typ); 9216 return; 9217 end if; 9218 9219 if Is_Overloaded (Name) then 9220 9221 -- Use the context type to select the prefix that yields the correct 9222 -- component type. 9223 9224 declare 9225 I : Interp_Index; 9226 It : Interp; 9227 I1 : Interp_Index := 0; 9228 P : constant Node_Id := Prefix (N); 9229 Found : Boolean := False; 9230 9231 begin 9232 Get_First_Interp (P, I, It); 9233 while Present (It.Typ) loop 9234 if (Is_Array_Type (It.Typ) 9235 and then Covers (Typ, Component_Type (It.Typ))) 9236 or else (Is_Access_Type (It.Typ) 9237 and then Is_Array_Type (Designated_Type (It.Typ)) 9238 and then 9239 Covers 9240 (Typ, 9241 Component_Type (Designated_Type (It.Typ)))) 9242 then 9243 if Found then 9244 It := Disambiguate (P, I1, I, Any_Type); 9245 9246 if It = No_Interp then 9247 Error_Msg_N ("ambiguous prefix for indexing", N); 9248 Set_Etype (N, Typ); 9249 return; 9250 9251 else 9252 Found := True; 9253 Array_Type := It.Typ; 9254 I1 := I; 9255 end if; 9256 9257 else 9258 Found := True; 9259 Array_Type := It.Typ; 9260 I1 := I; 9261 end if; 9262 end if; 9263 9264 Get_Next_Interp (I, It); 9265 end loop; 9266 end; 9267 9268 else 9269 Array_Type := Etype (Name); 9270 end if; 9271 9272 Resolve (Name, Array_Type); 9273 Array_Type := Get_Actual_Subtype_If_Available (Name); 9274 9275 -- If the prefix's type is an access type, get to the real array type. 9276 -- Note: we do not apply an access check because an explicit dereference 9277 -- will be introduced later, and the check will happen there. 9278 9279 if Is_Access_Type (Array_Type) then 9280 Array_Type := Implicitly_Designated_Type (Array_Type); 9281 end if; 9282 9283 -- If name was overloaded, set component type correctly now. 9284 -- If a misplaced call to an entry family (which has no index types) 9285 -- return. Error will be diagnosed from calling context. 9286 9287 if Is_Array_Type (Array_Type) then 9288 Set_Etype (N, Component_Type (Array_Type)); 9289 else 9290 return; 9291 end if; 9292 9293 Index := First_Index (Array_Type); 9294 Expr := First (Expressions (N)); 9295 9296 -- The prefix may have resolved to a string literal, in which case its 9297 -- etype has a special representation. This is only possible currently 9298 -- if the prefix is a static concatenation, written in functional 9299 -- notation. 9300 9301 if Ekind (Array_Type) = E_String_Literal_Subtype then 9302 Resolve (Expr, Standard_Positive); 9303 9304 else 9305 while Present (Index) and then Present (Expr) loop 9306 Resolve (Expr, Etype (Index)); 9307 Check_Unset_Reference (Expr); 9308 9309 Apply_Scalar_Range_Check (Expr, Etype (Index)); 9310 9311 Next_Index (Index); 9312 Next (Expr); 9313 end loop; 9314 end if; 9315 9316 Resolve_Implicit_Dereference (Prefix (N)); 9317 Analyze_Dimension (N); 9318 9319 -- Do not generate the warning on suspicious index if we are analyzing 9320 -- package Ada.Tags; otherwise we will report the warning with the 9321 -- Prims_Ptr field of the dispatch table. 9322 9323 if Scope (Etype (Prefix (N))) = Standard_Standard 9324 or else not 9325 Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))), 9326 Ada_Tags) 9327 then 9328 Warn_On_Suspicious_Index (Name, First (Expressions (N))); 9329 Eval_Indexed_Component (N); 9330 end if; 9331 9332 -- If the array type is atomic and the component is not, then this is 9333 -- worth a warning before Ada 2020, since we have a situation where the 9334 -- access to the component may cause extra read/writes of the atomic 9335 -- object, or partial word accesses, both of which may be unexpected. 9336 9337 if Nkind (N) = N_Indexed_Component 9338 and then Is_Atomic_Ref_With_Address (N) 9339 and then not (Has_Atomic_Components (Array_Type) 9340 or else (Is_Entity_Name (Prefix (N)) 9341 and then Has_Atomic_Components 9342 (Entity (Prefix (N))))) 9343 and then not Is_Atomic (Component_Type (Array_Type)) 9344 and then Ada_Version < Ada_2020 9345 then 9346 Error_Msg_N 9347 ("??access to non-atomic component of atomic array", Prefix (N)); 9348 Error_Msg_N 9349 ("??\may cause unexpected accesses to atomic object", Prefix (N)); 9350 end if; 9351 end Resolve_Indexed_Component; 9352 9353 ----------------------------- 9354 -- Resolve_Integer_Literal -- 9355 ----------------------------- 9356 9357 procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is 9358 begin 9359 Set_Etype (N, Typ); 9360 Eval_Integer_Literal (N); 9361 end Resolve_Integer_Literal; 9362 9363 -------------------------------- 9364 -- Resolve_Intrinsic_Operator -- 9365 -------------------------------- 9366 9367 procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is 9368 Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); 9369 Op : Entity_Id; 9370 Arg1 : Node_Id; 9371 Arg2 : Node_Id; 9372 9373 function Convert_Operand (Opnd : Node_Id) return Node_Id; 9374 -- If the operand is a literal, it cannot be the expression in a 9375 -- conversion. Use a qualified expression instead. 9376 9377 --------------------- 9378 -- Convert_Operand -- 9379 --------------------- 9380 9381 function Convert_Operand (Opnd : Node_Id) return Node_Id is 9382 Loc : constant Source_Ptr := Sloc (Opnd); 9383 Res : Node_Id; 9384 9385 begin 9386 if Nkind (Opnd) in N_Integer_Literal | N_Real_Literal then 9387 Res := 9388 Make_Qualified_Expression (Loc, 9389 Subtype_Mark => New_Occurrence_Of (Btyp, Loc), 9390 Expression => Relocate_Node (Opnd)); 9391 Analyze (Res); 9392 9393 else 9394 Res := Unchecked_Convert_To (Btyp, Opnd); 9395 end if; 9396 9397 return Res; 9398 end Convert_Operand; 9399 9400 -- Start of processing for Resolve_Intrinsic_Operator 9401 9402 begin 9403 -- We must preserve the original entity in a generic setting, so that 9404 -- the legality of the operation can be verified in an instance. 9405 9406 if not Expander_Active then 9407 return; 9408 end if; 9409 9410 Op := Entity (N); 9411 while Scope (Op) /= Standard_Standard loop 9412 Op := Homonym (Op); 9413 pragma Assert (Present (Op)); 9414 end loop; 9415 9416 Set_Entity (N, Op); 9417 Set_Is_Overloaded (N, False); 9418 9419 -- If the result or operand types are private, rewrite with unchecked 9420 -- conversions on the operands and the result, to expose the proper 9421 -- underlying numeric type. 9422 9423 if Is_Private_Type (Typ) 9424 or else Is_Private_Type (Etype (Left_Opnd (N))) 9425 or else Is_Private_Type (Etype (Right_Opnd (N))) 9426 then 9427 Arg1 := Convert_Operand (Left_Opnd (N)); 9428 9429 if Nkind (N) = N_Op_Expon then 9430 Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N)); 9431 else 9432 Arg2 := Convert_Operand (Right_Opnd (N)); 9433 end if; 9434 9435 if Nkind (Arg1) = N_Type_Conversion then 9436 Save_Interps (Left_Opnd (N), Expression (Arg1)); 9437 end if; 9438 9439 if Nkind (Arg2) = N_Type_Conversion then 9440 Save_Interps (Right_Opnd (N), Expression (Arg2)); 9441 end if; 9442 9443 Set_Left_Opnd (N, Arg1); 9444 Set_Right_Opnd (N, Arg2); 9445 9446 Set_Etype (N, Btyp); 9447 Rewrite (N, Unchecked_Convert_To (Typ, N)); 9448 Resolve (N, Typ); 9449 9450 elsif Typ /= Etype (Left_Opnd (N)) 9451 or else Typ /= Etype (Right_Opnd (N)) 9452 then 9453 -- Add explicit conversion where needed, and save interpretations in 9454 -- case operands are overloaded. 9455 9456 Arg1 := Convert_To (Typ, Left_Opnd (N)); 9457 Arg2 := Convert_To (Typ, Right_Opnd (N)); 9458 9459 if Nkind (Arg1) = N_Type_Conversion then 9460 Save_Interps (Left_Opnd (N), Expression (Arg1)); 9461 else 9462 Save_Interps (Left_Opnd (N), Arg1); 9463 end if; 9464 9465 if Nkind (Arg2) = N_Type_Conversion then 9466 Save_Interps (Right_Opnd (N), Expression (Arg2)); 9467 else 9468 Save_Interps (Right_Opnd (N), Arg2); 9469 end if; 9470 9471 Rewrite (Left_Opnd (N), Arg1); 9472 Rewrite (Right_Opnd (N), Arg2); 9473 Analyze (Arg1); 9474 Analyze (Arg2); 9475 Resolve_Arithmetic_Op (N, Typ); 9476 9477 else 9478 Resolve_Arithmetic_Op (N, Typ); 9479 end if; 9480 end Resolve_Intrinsic_Operator; 9481 9482 -------------------------------------- 9483 -- Resolve_Intrinsic_Unary_Operator -- 9484 -------------------------------------- 9485 9486 procedure Resolve_Intrinsic_Unary_Operator 9487 (N : Node_Id; 9488 Typ : Entity_Id) 9489 is 9490 Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); 9491 Op : Entity_Id; 9492 Arg2 : Node_Id; 9493 9494 begin 9495 Op := Entity (N); 9496 while Scope (Op) /= Standard_Standard loop 9497 Op := Homonym (Op); 9498 pragma Assert (Present (Op)); 9499 end loop; 9500 9501 Set_Entity (N, Op); 9502 9503 if Is_Private_Type (Typ) then 9504 Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); 9505 Save_Interps (Right_Opnd (N), Expression (Arg2)); 9506 9507 Set_Right_Opnd (N, Arg2); 9508 9509 Set_Etype (N, Btyp); 9510 Rewrite (N, Unchecked_Convert_To (Typ, N)); 9511 Resolve (N, Typ); 9512 9513 else 9514 Resolve_Unary_Op (N, Typ); 9515 end if; 9516 end Resolve_Intrinsic_Unary_Operator; 9517 9518 ------------------------ 9519 -- Resolve_Logical_Op -- 9520 ------------------------ 9521 9522 procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is 9523 B_Typ : Entity_Id; 9524 9525 begin 9526 Check_No_Direct_Boolean_Operators (N); 9527 9528 -- Predefined operations on scalar types yield the base type. On the 9529 -- other hand, logical operations on arrays yield the type of the 9530 -- arguments (and the context). 9531 9532 if Is_Array_Type (Typ) then 9533 B_Typ := Typ; 9534 else 9535 B_Typ := Base_Type (Typ); 9536 end if; 9537 9538 -- The following test is required because the operands of the operation 9539 -- may be literals, in which case the resulting type appears to be 9540 -- compatible with a signed integer type, when in fact it is compatible 9541 -- only with modular types. If the context itself is universal, the 9542 -- operation is illegal. 9543 9544 if not Valid_Boolean_Arg (Typ) then 9545 Error_Msg_N ("invalid context for logical operation", N); 9546 Set_Etype (N, Any_Type); 9547 return; 9548 9549 elsif Typ = Any_Modular then 9550 Error_Msg_N 9551 ("no modular type available in this context", N); 9552 Set_Etype (N, Any_Type); 9553 return; 9554 9555 elsif Is_Modular_Integer_Type (Typ) 9556 and then Etype (Left_Opnd (N)) = Universal_Integer 9557 and then Etype (Right_Opnd (N)) = Universal_Integer 9558 then 9559 Check_For_Visible_Operator (N, B_Typ); 9560 end if; 9561 9562 -- Replace AND by AND THEN, or OR by OR ELSE, if Short_Circuit_And_Or 9563 -- is active and the result type is standard Boolean (do not mess with 9564 -- ops that return a nonstandard Boolean type, because something strange 9565 -- is going on). 9566 9567 -- Note: you might expect this replacement to be done during expansion, 9568 -- but that doesn't work, because when the pragma Short_Circuit_And_Or 9569 -- is used, no part of the right operand of an "and" or "or" operator 9570 -- should be executed if the left operand would short-circuit the 9571 -- evaluation of the corresponding "and then" or "or else". If we left 9572 -- the replacement to expansion time, then run-time checks associated 9573 -- with such operands would be evaluated unconditionally, due to being 9574 -- before the condition prior to the rewriting as short-circuit forms 9575 -- during expansion. 9576 9577 if Short_Circuit_And_Or 9578 and then B_Typ = Standard_Boolean 9579 and then Nkind (N) in N_Op_And | N_Op_Or 9580 then 9581 -- Mark the corresponding putative SCO operator as truly a logical 9582 -- (and short-circuit) operator. 9583 9584 if Generate_SCO and then Comes_From_Source (N) then 9585 Set_SCO_Logical_Operator (N); 9586 end if; 9587 9588 if Nkind (N) = N_Op_And then 9589 Rewrite (N, 9590 Make_And_Then (Sloc (N), 9591 Left_Opnd => Relocate_Node (Left_Opnd (N)), 9592 Right_Opnd => Relocate_Node (Right_Opnd (N)))); 9593 Analyze_And_Resolve (N, B_Typ); 9594 9595 -- Case of OR changed to OR ELSE 9596 9597 else 9598 Rewrite (N, 9599 Make_Or_Else (Sloc (N), 9600 Left_Opnd => Relocate_Node (Left_Opnd (N)), 9601 Right_Opnd => Relocate_Node (Right_Opnd (N)))); 9602 Analyze_And_Resolve (N, B_Typ); 9603 end if; 9604 9605 -- Return now, since analysis of the rewritten ops will take care of 9606 -- other reference bookkeeping and expression folding. 9607 9608 return; 9609 end if; 9610 9611 Resolve (Left_Opnd (N), B_Typ); 9612 Resolve (Right_Opnd (N), B_Typ); 9613 9614 Check_Unset_Reference (Left_Opnd (N)); 9615 Check_Unset_Reference (Right_Opnd (N)); 9616 9617 Set_Etype (N, B_Typ); 9618 Generate_Operator_Reference (N, B_Typ); 9619 Eval_Logical_Op (N); 9620 end Resolve_Logical_Op; 9621 9622 --------------------------- 9623 -- Resolve_Membership_Op -- 9624 --------------------------- 9625 9626 -- The context can only be a boolean type, and does not determine the 9627 -- arguments. Arguments should be unambiguous, but the preference rule for 9628 -- universal types applies. 9629 9630 procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is 9631 pragma Assert (Is_Boolean_Type (Typ)); 9632 9633 L : constant Node_Id := Left_Opnd (N); 9634 R : constant Node_Id := Right_Opnd (N); 9635 T : Entity_Id; 9636 9637 procedure Resolve_Set_Membership; 9638 -- Analysis has determined a unique type for the left operand. Use it as 9639 -- the basis to resolve the disjuncts. 9640 9641 ---------------------------- 9642 -- Resolve_Set_Membership -- 9643 ---------------------------- 9644 9645 procedure Resolve_Set_Membership is 9646 Alt : Node_Id; 9647 9648 begin 9649 -- If the left operand is overloaded, find type compatible with not 9650 -- overloaded alternative of the right operand. 9651 9652 Alt := First (Alternatives (N)); 9653 if Is_Overloaded (L) then 9654 T := Empty; 9655 while Present (Alt) loop 9656 if not Is_Overloaded (Alt) then 9657 T := Intersect_Types (L, Alt); 9658 exit; 9659 else 9660 Next (Alt); 9661 end if; 9662 end loop; 9663 9664 -- Unclear how to resolve expression if all alternatives are also 9665 -- overloaded. 9666 9667 if No (T) then 9668 Error_Msg_N ("ambiguous expression", N); 9669 end if; 9670 9671 else 9672 T := Intersect_Types (L, Alt); 9673 end if; 9674 9675 Resolve (L, T); 9676 9677 Alt := First (Alternatives (N)); 9678 while Present (Alt) loop 9679 9680 -- Alternative is an expression, a range 9681 -- or a subtype mark. 9682 9683 if not Is_Entity_Name (Alt) 9684 or else not Is_Type (Entity (Alt)) 9685 then 9686 Resolve (Alt, T); 9687 end if; 9688 9689 Next (Alt); 9690 end loop; 9691 9692 -- Check for duplicates for discrete case 9693 9694 if Is_Discrete_Type (T) then 9695 declare 9696 type Ent is record 9697 Alt : Node_Id; 9698 Val : Uint; 9699 end record; 9700 9701 Alts : array (0 .. List_Length (Alternatives (N))) of Ent; 9702 Nalts : Nat; 9703 9704 begin 9705 -- Loop checking duplicates. This is quadratic, but giant sets 9706 -- are unlikely in this context so it's a reasonable choice. 9707 9708 Nalts := 0; 9709 Alt := First (Alternatives (N)); 9710 while Present (Alt) loop 9711 if Is_OK_Static_Expression (Alt) 9712 and then Nkind (Alt) in N_Integer_Literal 9713 | N_Character_Literal 9714 | N_Has_Entity 9715 then 9716 Nalts := Nalts + 1; 9717 Alts (Nalts) := (Alt, Expr_Value (Alt)); 9718 9719 for J in 1 .. Nalts - 1 loop 9720 if Alts (J).Val = Alts (Nalts).Val then 9721 Error_Msg_Sloc := Sloc (Alts (J).Alt); 9722 Error_Msg_N ("duplicate of value given#??", Alt); 9723 end if; 9724 end loop; 9725 end if; 9726 9727 Next (Alt); 9728 end loop; 9729 end; 9730 end if; 9731 9732 -- RM 4.5.2 (28.1/3) specifies that for types other than records or 9733 -- limited types, evaluation of a membership test uses the predefined 9734 -- equality for the type. This may be confusing to users, and the 9735 -- following warning appears useful for the most common case. 9736 9737 if Is_Scalar_Type (Etype (L)) 9738 and then Present (Get_User_Defined_Eq (Etype (L))) 9739 then 9740 Error_Msg_NE 9741 ("membership test on& uses predefined equality?", N, Etype (L)); 9742 Error_Msg_N 9743 ("\even if user-defined equality exists (RM 4.5.2 (28.1/3)?", N); 9744 end if; 9745 end Resolve_Set_Membership; 9746 9747 -- Start of processing for Resolve_Membership_Op 9748 9749 begin 9750 if L = Error or else R = Error then 9751 return; 9752 end if; 9753 9754 if Present (Alternatives (N)) then 9755 Resolve_Set_Membership; 9756 goto SM_Exit; 9757 9758 elsif not Is_Overloaded (R) 9759 and then 9760 (Etype (R) = Universal_Integer 9761 or else 9762 Etype (R) = Universal_Real) 9763 and then Is_Overloaded (L) 9764 then 9765 T := Etype (R); 9766 9767 -- Ada 2005 (AI-251): Support the following case: 9768 9769 -- type I is interface; 9770 -- type T is tagged ... 9771 9772 -- function Test (O : I'Class) is 9773 -- begin 9774 -- return O in T'Class. 9775 -- end Test; 9776 9777 -- In this case we have nothing else to do. The membership test will be 9778 -- done at run time. 9779 9780 elsif Ada_Version >= Ada_2005 9781 and then Is_Class_Wide_Type (Etype (L)) 9782 and then Is_Interface (Etype (L)) 9783 and then not Is_Interface (Etype (R)) 9784 then 9785 return; 9786 else 9787 T := Intersect_Types (L, R); 9788 end if; 9789 9790 -- If mixed-mode operations are present and operands are all literal, 9791 -- the only interpretation involves Duration, which is probably not 9792 -- the intention of the programmer. 9793 9794 if T = Any_Fixed then 9795 T := Unique_Fixed_Point_Type (N); 9796 9797 if T = Any_Type then 9798 return; 9799 end if; 9800 end if; 9801 9802 Resolve (L, T); 9803 Check_Unset_Reference (L); 9804 9805 if Nkind (R) = N_Range 9806 and then not Is_Scalar_Type (T) 9807 then 9808 Error_Msg_N ("scalar type required for range", R); 9809 end if; 9810 9811 if Is_Entity_Name (R) then 9812 Freeze_Expression (R); 9813 else 9814 Resolve (R, T); 9815 Check_Unset_Reference (R); 9816 end if; 9817 9818 -- Here after resolving membership operation 9819 9820 <<SM_Exit>> 9821 9822 Eval_Membership_Op (N); 9823 end Resolve_Membership_Op; 9824 9825 ------------------ 9826 -- Resolve_Null -- 9827 ------------------ 9828 9829 procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is 9830 Loc : constant Source_Ptr := Sloc (N); 9831 9832 begin 9833 -- Handle restriction against anonymous null access values This 9834 -- restriction can be turned off using -gnatdj. 9835 9836 -- Ada 2005 (AI-231): Remove restriction 9837 9838 if Ada_Version < Ada_2005 9839 and then not Debug_Flag_J 9840 and then Ekind (Typ) = E_Anonymous_Access_Type 9841 and then Comes_From_Source (N) 9842 then 9843 -- In the common case of a call which uses an explicitly null value 9844 -- for an access parameter, give specialized error message. 9845 9846 if Nkind (Parent (N)) in N_Subprogram_Call then 9847 Error_Msg_N 9848 ("NULL is not allowed as argument for an access parameter", N); 9849 9850 -- Standard message for all other cases (are there any?) 9851 9852 else 9853 Error_Msg_N 9854 ("NULL cannot be of an anonymous access type", N); 9855 end if; 9856 end if; 9857 9858 -- Ada 2005 (AI-231): Generate the null-excluding check in case of 9859 -- assignment to a null-excluding object. 9860 9861 if Ada_Version >= Ada_2005 9862 and then Can_Never_Be_Null (Typ) 9863 and then Nkind (Parent (N)) = N_Assignment_Statement 9864 then 9865 if Inside_Init_Proc then 9866 9867 -- Decide whether to generate an if_statement around our 9868 -- null-excluding check to avoid them on certain internal object 9869 -- declarations by looking at the type the current Init_Proc 9870 -- belongs to. 9871 9872 -- Generate: 9873 -- if T1b_skip_null_excluding_check then 9874 -- [constraint_error "access check failed"] 9875 -- end if; 9876 9877 if Needs_Conditional_Null_Excluding_Check 9878 (Etype (First_Formal (Enclosing_Init_Proc))) 9879 then 9880 Insert_Action (N, 9881 Make_If_Statement (Loc, 9882 Condition => 9883 Make_Identifier (Loc, 9884 New_External_Name 9885 (Chars (Typ), "_skip_null_excluding_check")), 9886 Then_Statements => 9887 New_List ( 9888 Make_Raise_Constraint_Error (Loc, 9889 Reason => CE_Access_Check_Failed)))); 9890 9891 -- Otherwise, simply create the check 9892 9893 else 9894 Insert_Action (N, 9895 Make_Raise_Constraint_Error (Loc, 9896 Reason => CE_Access_Check_Failed)); 9897 end if; 9898 else 9899 Insert_Action 9900 (Compile_Time_Constraint_Error (N, 9901 "(Ada 2005) NULL not allowed in null-excluding objects??"), 9902 Make_Raise_Constraint_Error (Loc, 9903 Reason => CE_Access_Check_Failed)); 9904 end if; 9905 end if; 9906 9907 -- In a distributed context, null for a remote access to subprogram may 9908 -- need to be replaced with a special record aggregate. In this case, 9909 -- return after having done the transformation. 9910 9911 if (Ekind (Typ) = E_Record_Type 9912 or else Is_Remote_Access_To_Subprogram_Type (Typ)) 9913 and then Remote_AST_Null_Value (N, Typ) 9914 then 9915 return; 9916 end if; 9917 9918 -- The null literal takes its type from the context 9919 9920 Set_Etype (N, Typ); 9921 end Resolve_Null; 9922 9923 ----------------------- 9924 -- Resolve_Op_Concat -- 9925 ----------------------- 9926 9927 procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is 9928 9929 -- We wish to avoid deep recursion, because concatenations are often 9930 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left 9931 -- operands nonrecursively until we find something that is not a simple 9932 -- concatenation (A in this case). We resolve that, and then walk back 9933 -- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest 9934 -- to do the rest of the work at each level. The Parent pointers allow 9935 -- us to avoid recursion, and thus avoid running out of memory. See also 9936 -- Sem_Ch4.Analyze_Concatenation, where a similar approach is used. 9937 9938 NN : Node_Id := N; 9939 Op1 : Node_Id; 9940 9941 begin 9942 -- The following code is equivalent to: 9943 9944 -- Resolve_Op_Concat_First (NN, Typ); 9945 -- Resolve_Op_Concat_Arg (N, ...); 9946 -- Resolve_Op_Concat_Rest (N, Typ); 9947 9948 -- where the Resolve_Op_Concat_Arg call recurses back here if the left 9949 -- operand is a concatenation. 9950 9951 -- Walk down left operands 9952 9953 loop 9954 Resolve_Op_Concat_First (NN, Typ); 9955 Op1 := Left_Opnd (NN); 9956 exit when not (Nkind (Op1) = N_Op_Concat 9957 and then not Is_Array_Type (Component_Type (Typ)) 9958 and then Entity (Op1) = Entity (NN)); 9959 NN := Op1; 9960 end loop; 9961 9962 -- Now (given the above example) NN is A&B and Op1 is A 9963 9964 -- First resolve Op1 ... 9965 9966 Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN)); 9967 9968 -- ... then walk NN back up until we reach N (where we started), calling 9969 -- Resolve_Op_Concat_Rest along the way. 9970 9971 loop 9972 Resolve_Op_Concat_Rest (NN, Typ); 9973 exit when NN = N; 9974 NN := Parent (NN); 9975 end loop; 9976 end Resolve_Op_Concat; 9977 9978 --------------------------- 9979 -- Resolve_Op_Concat_Arg -- 9980 --------------------------- 9981 9982 procedure Resolve_Op_Concat_Arg 9983 (N : Node_Id; 9984 Arg : Node_Id; 9985 Typ : Entity_Id; 9986 Is_Comp : Boolean) 9987 is 9988 Btyp : constant Entity_Id := Base_Type (Typ); 9989 Ctyp : constant Entity_Id := Component_Type (Typ); 9990 9991 begin 9992 if In_Instance then 9993 if Is_Comp 9994 or else (not Is_Overloaded (Arg) 9995 and then Etype (Arg) /= Any_Composite 9996 and then Covers (Ctyp, Etype (Arg))) 9997 then 9998 Resolve (Arg, Ctyp); 9999 else 10000 Resolve (Arg, Btyp); 10001 end if; 10002 10003 -- If both Array & Array and Array & Component are visible, there is a 10004 -- potential ambiguity that must be reported. 10005 10006 elsif Has_Compatible_Type (Arg, Ctyp) then 10007 if Nkind (Arg) = N_Aggregate 10008 and then Is_Composite_Type (Ctyp) 10009 then 10010 if Is_Private_Type (Ctyp) then 10011 Resolve (Arg, Btyp); 10012 10013 -- If the operation is user-defined and not overloaded use its 10014 -- profile. The operation may be a renaming, in which case it has 10015 -- been rewritten, and we want the original profile. 10016 10017 elsif not Is_Overloaded (N) 10018 and then Comes_From_Source (Entity (Original_Node (N))) 10019 and then Ekind (Entity (Original_Node (N))) = E_Function 10020 then 10021 Resolve (Arg, 10022 Etype 10023 (Next_Formal (First_Formal (Entity (Original_Node (N)))))); 10024 return; 10025 10026 -- Otherwise an aggregate may match both the array type and the 10027 -- component type. 10028 10029 else 10030 Error_Msg_N ("ambiguous aggregate must be qualified", Arg); 10031 Set_Etype (Arg, Any_Type); 10032 end if; 10033 10034 else 10035 if Is_Overloaded (Arg) 10036 and then Has_Compatible_Type (Arg, Typ) 10037 and then Etype (Arg) /= Any_Type 10038 then 10039 declare 10040 I : Interp_Index; 10041 It : Interp; 10042 Func : Entity_Id; 10043 10044 begin 10045 Get_First_Interp (Arg, I, It); 10046 Func := It.Nam; 10047 Get_Next_Interp (I, It); 10048 10049 -- Special-case the error message when the overloading is 10050 -- caused by a function that yields an array and can be 10051 -- called without parameters. 10052 10053 if It.Nam = Func then 10054 Error_Msg_Sloc := Sloc (Func); 10055 Error_Msg_N ("ambiguous call to function#", Arg); 10056 Error_Msg_NE 10057 ("\\interpretation as call yields&", Arg, Typ); 10058 Error_Msg_NE 10059 ("\\interpretation as indexing of call yields&", 10060 Arg, Component_Type (Typ)); 10061 10062 else 10063 Error_Msg_N ("ambiguous operand for concatenation!", Arg); 10064 10065 Get_First_Interp (Arg, I, It); 10066 while Present (It.Nam) loop 10067 Error_Msg_Sloc := Sloc (It.Nam); 10068 10069 if Base_Type (It.Typ) = Btyp 10070 or else 10071 Base_Type (It.Typ) = Base_Type (Ctyp) 10072 then 10073 Error_Msg_N -- CODEFIX 10074 ("\\possible interpretation#", Arg); 10075 end if; 10076 10077 Get_Next_Interp (I, It); 10078 end loop; 10079 end if; 10080 end; 10081 end if; 10082 10083 Resolve (Arg, Component_Type (Typ)); 10084 10085 if Nkind (Arg) = N_String_Literal then 10086 Set_Etype (Arg, Component_Type (Typ)); 10087 end if; 10088 10089 if Arg = Left_Opnd (N) then 10090 Set_Is_Component_Left_Opnd (N); 10091 else 10092 Set_Is_Component_Right_Opnd (N); 10093 end if; 10094 end if; 10095 10096 else 10097 Resolve (Arg, Btyp); 10098 end if; 10099 10100 Check_Unset_Reference (Arg); 10101 end Resolve_Op_Concat_Arg; 10102 10103 ----------------------------- 10104 -- Resolve_Op_Concat_First -- 10105 ----------------------------- 10106 10107 procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is 10108 Btyp : constant Entity_Id := Base_Type (Typ); 10109 Op1 : constant Node_Id := Left_Opnd (N); 10110 Op2 : constant Node_Id := Right_Opnd (N); 10111 10112 begin 10113 -- The parser folds an enormous sequence of concatenations of string 10114 -- literals into "" & "...", where the Is_Folded_In_Parser flag is set 10115 -- in the right operand. If the expression resolves to a predefined "&" 10116 -- operator, all is well. Otherwise, the parser's folding is wrong, so 10117 -- we give an error. See P_Simple_Expression in Par.Ch4. 10118 10119 if Nkind (Op2) = N_String_Literal 10120 and then Is_Folded_In_Parser (Op2) 10121 and then Ekind (Entity (N)) = E_Function 10122 then 10123 pragma Assert (Nkind (Op1) = N_String_Literal -- should be "" 10124 and then String_Length (Strval (Op1)) = 0); 10125 Error_Msg_N ("too many user-defined concatenations", N); 10126 return; 10127 end if; 10128 10129 Set_Etype (N, Btyp); 10130 10131 if Is_Limited_Composite (Btyp) then 10132 Error_Msg_N ("concatenation not available for limited array", N); 10133 Explain_Limited_Type (Btyp, N); 10134 end if; 10135 end Resolve_Op_Concat_First; 10136 10137 ---------------------------- 10138 -- Resolve_Op_Concat_Rest -- 10139 ---------------------------- 10140 10141 procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is 10142 Op1 : constant Node_Id := Left_Opnd (N); 10143 Op2 : constant Node_Id := Right_Opnd (N); 10144 10145 begin 10146 Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd (N)); 10147 10148 Generate_Operator_Reference (N, Typ); 10149 10150 if Is_String_Type (Typ) then 10151 Eval_Concatenation (N); 10152 end if; 10153 10154 -- If this is not a static concatenation, but the result is a string 10155 -- type (and not an array of strings) ensure that static string operands 10156 -- have their subtypes properly constructed. 10157 10158 if Nkind (N) /= N_String_Literal 10159 and then Is_Character_Type (Component_Type (Typ)) 10160 then 10161 Set_String_Literal_Subtype (Op1, Typ); 10162 Set_String_Literal_Subtype (Op2, Typ); 10163 end if; 10164 end Resolve_Op_Concat_Rest; 10165 10166 ---------------------- 10167 -- Resolve_Op_Expon -- 10168 ---------------------- 10169 10170 procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is 10171 B_Typ : constant Entity_Id := Base_Type (Typ); 10172 10173 begin 10174 -- Catch attempts to do fixed-point exponentiation with universal 10175 -- operands, which is a case where the illegality is not caught during 10176 -- normal operator analysis. This is not done in preanalysis mode 10177 -- since the tree is not fully decorated during preanalysis. 10178 10179 if Full_Analysis then 10180 if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then 10181 Error_Msg_N ("exponentiation not available for fixed point", N); 10182 return; 10183 10184 elsif Nkind (Parent (N)) in N_Op 10185 and then Present (Etype (Parent (N))) 10186 and then Is_Fixed_Point_Type (Etype (Parent (N))) 10187 and then Etype (N) = Universal_Real 10188 and then Comes_From_Source (N) 10189 then 10190 Error_Msg_N ("exponentiation not available for fixed point", N); 10191 return; 10192 end if; 10193 end if; 10194 10195 if Comes_From_Source (N) 10196 and then Ekind (Entity (N)) = E_Function 10197 and then Is_Imported (Entity (N)) 10198 and then Is_Intrinsic_Subprogram (Entity (N)) 10199 then 10200 Resolve_Intrinsic_Operator (N, Typ); 10201 return; 10202 end if; 10203 10204 if Etype (Left_Opnd (N)) = Universal_Integer 10205 or else Etype (Left_Opnd (N)) = Universal_Real 10206 then 10207 Check_For_Visible_Operator (N, B_Typ); 10208 end if; 10209 10210 -- We do the resolution using the base type, because intermediate values 10211 -- in expressions are always of the base type, not a subtype of it. 10212 10213 Resolve (Left_Opnd (N), B_Typ); 10214 Resolve (Right_Opnd (N), Standard_Integer); 10215 10216 -- For integer types, right argument must be in Natural range 10217 10218 if Is_Integer_Type (Typ) then 10219 Apply_Scalar_Range_Check (Right_Opnd (N), Standard_Natural); 10220 end if; 10221 10222 Check_Unset_Reference (Left_Opnd (N)); 10223 Check_Unset_Reference (Right_Opnd (N)); 10224 10225 Set_Etype (N, B_Typ); 10226 Generate_Operator_Reference (N, B_Typ); 10227 10228 Analyze_Dimension (N); 10229 10230 if Ada_Version >= Ada_2012 and then Has_Dimension_System (B_Typ) then 10231 -- Evaluate the exponentiation operator for dimensioned type 10232 10233 Eval_Op_Expon_For_Dimensioned_Type (N, B_Typ); 10234 else 10235 Eval_Op_Expon (N); 10236 end if; 10237 10238 -- Set overflow checking bit. Much cleverer code needed here eventually 10239 -- and perhaps the Resolve routines should be separated for the various 10240 -- arithmetic operations, since they will need different processing. ??? 10241 10242 if Nkind (N) in N_Op then 10243 if not Overflow_Checks_Suppressed (Etype (N)) then 10244 Enable_Overflow_Check (N); 10245 end if; 10246 end if; 10247 end Resolve_Op_Expon; 10248 10249 -------------------- 10250 -- Resolve_Op_Not -- 10251 -------------------- 10252 10253 procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is 10254 function Parent_Is_Boolean return Boolean; 10255 -- This function determines if the parent node is a boolean operator or 10256 -- operation (comparison op, membership test, or short circuit form) and 10257 -- the not in question is the left operand of this operation. Note that 10258 -- if the not is in parens, then false is returned. 10259 10260 ----------------------- 10261 -- Parent_Is_Boolean -- 10262 ----------------------- 10263 10264 function Parent_Is_Boolean return Boolean is 10265 begin 10266 return Paren_Count (N) = 0 10267 and then Nkind (Parent (N)) in N_Membership_Test 10268 | N_Op_Boolean 10269 | N_Short_Circuit 10270 and then Left_Opnd (Parent (N)) = N; 10271 end Parent_Is_Boolean; 10272 10273 -- Local variables 10274 10275 B_Typ : Entity_Id; 10276 10277 -- Start of processing for Resolve_Op_Not 10278 10279 begin 10280 -- Predefined operations on scalar types yield the base type. On the 10281 -- other hand, logical operations on arrays yield the type of the 10282 -- arguments (and the context). 10283 10284 if Is_Array_Type (Typ) then 10285 B_Typ := Typ; 10286 else 10287 B_Typ := Base_Type (Typ); 10288 end if; 10289 10290 -- Straightforward case of incorrect arguments 10291 10292 if not Valid_Boolean_Arg (Typ) then 10293 Error_Msg_N ("invalid operand type for operator&", N); 10294 Set_Etype (N, Any_Type); 10295 return; 10296 10297 -- Special case of probable missing parens 10298 10299 elsif Typ = Universal_Integer or else Typ = Any_Modular then 10300 if Parent_Is_Boolean then 10301 Error_Msg_N 10302 ("operand of NOT must be enclosed in parentheses", 10303 Right_Opnd (N)); 10304 else 10305 Error_Msg_N 10306 ("no modular type available in this context", N); 10307 end if; 10308 10309 Set_Etype (N, Any_Type); 10310 return; 10311 10312 -- OK resolution of NOT 10313 10314 else 10315 -- Warn if non-boolean types involved. This is a case like not a < b 10316 -- where a and b are modular, where we will get (not a) < b and most 10317 -- likely not (a < b) was intended. 10318 10319 if Warn_On_Questionable_Missing_Parens 10320 and then not Is_Boolean_Type (Typ) 10321 and then Parent_Is_Boolean 10322 then 10323 Error_Msg_N ("?q?not expression should be parenthesized here!", N); 10324 end if; 10325 10326 -- Warn on double negation if checking redundant constructs 10327 10328 if Warn_On_Redundant_Constructs 10329 and then Comes_From_Source (N) 10330 and then Comes_From_Source (Right_Opnd (N)) 10331 and then Root_Type (Typ) = Standard_Boolean 10332 and then Nkind (Right_Opnd (N)) = N_Op_Not 10333 then 10334 Error_Msg_N ("redundant double negation?r?", N); 10335 end if; 10336 10337 -- Complete resolution and evaluation of NOT 10338 -- If argument is an equality and expected type is boolean, that 10339 -- expected type has no effect on resolution, and there are 10340 -- special rules for resolution of Eq, Neq in the presence of 10341 -- overloaded operands, so we directly call its resolution routines. 10342 10343 declare 10344 Opnd : constant Node_Id := Right_Opnd (N); 10345 Op_Id : Entity_Id; 10346 10347 begin 10348 if B_Typ = Standard_Boolean 10349 and then Nkind (Opnd) in N_Op_Eq | N_Op_Ne 10350 and then Is_Overloaded (Opnd) 10351 then 10352 Resolve_Equality_Op (Opnd, B_Typ); 10353 Op_Id := Entity (Opnd); 10354 10355 if Ekind (Op_Id) = E_Function 10356 and then not Is_Intrinsic_Subprogram (Op_Id) 10357 then 10358 Rewrite_Operator_As_Call (Opnd, Op_Id); 10359 end if; 10360 10361 if not Inside_A_Generic or else Is_Entity_Name (Opnd) then 10362 Freeze_Expression (Opnd); 10363 end if; 10364 10365 Expand (Opnd); 10366 10367 else 10368 Resolve (Opnd, B_Typ); 10369 end if; 10370 10371 Check_Unset_Reference (Opnd); 10372 end; 10373 10374 Set_Etype (N, B_Typ); 10375 Generate_Operator_Reference (N, B_Typ); 10376 Eval_Op_Not (N); 10377 end if; 10378 end Resolve_Op_Not; 10379 10380 ----------------------------- 10381 -- Resolve_Operator_Symbol -- 10382 ----------------------------- 10383 10384 -- Nothing to be done, all resolved already 10385 10386 procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is 10387 pragma Warnings (Off, N); 10388 pragma Warnings (Off, Typ); 10389 10390 begin 10391 null; 10392 end Resolve_Operator_Symbol; 10393 10394 ---------------------------------- 10395 -- Resolve_Qualified_Expression -- 10396 ---------------------------------- 10397 10398 procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is 10399 pragma Warnings (Off, Typ); 10400 10401 Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N)); 10402 Expr : constant Node_Id := Expression (N); 10403 10404 begin 10405 Resolve (Expr, Target_Typ); 10406 10407 -- A qualified expression requires an exact match of the type, class- 10408 -- wide matching is not allowed. However, if the qualifying type is 10409 -- specific and the expression has a class-wide type, it may still be 10410 -- okay, since it can be the result of the expansion of a call to a 10411 -- dispatching function, so we also have to check class-wideness of the 10412 -- type of the expression's original node. 10413 10414 if (Is_Class_Wide_Type (Target_Typ) 10415 or else 10416 (Is_Class_Wide_Type (Etype (Expr)) 10417 and then Is_Class_Wide_Type (Etype (Original_Node (Expr))))) 10418 and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ) 10419 then 10420 Wrong_Type (Expr, Target_Typ); 10421 end if; 10422 10423 -- If the target type is unconstrained, then we reset the type of the 10424 -- result from the type of the expression. For other cases, the actual 10425 -- subtype of the expression is the target type. But we avoid doing it 10426 -- for an allocator since this is not needed and might be problematic. 10427 10428 if Is_Composite_Type (Target_Typ) 10429 and then not Is_Constrained (Target_Typ) 10430 and then Nkind (Parent (N)) /= N_Allocator 10431 then 10432 Set_Etype (N, Etype (Expr)); 10433 end if; 10434 10435 Analyze_Dimension (N); 10436 Eval_Qualified_Expression (N); 10437 10438 -- If we still have a qualified expression after the static evaluation, 10439 -- then apply a scalar range check if needed. The reason that we do this 10440 -- after the Eval call is that otherwise, the application of the range 10441 -- check may convert an illegal static expression and result in warning 10442 -- rather than giving an error (e.g Integer'(Integer'Last + 1)). 10443 10444 if Nkind (N) = N_Qualified_Expression 10445 and then Is_Scalar_Type (Target_Typ) 10446 then 10447 Apply_Scalar_Range_Check (Expr, Target_Typ); 10448 end if; 10449 10450 -- AI12-0100: Once the qualified expression is resolved, check whether 10451 -- operand statisfies a static predicate of the target subtype, if any. 10452 -- In the static expression case, a predicate check failure is an error. 10453 10454 if Has_Predicates (Target_Typ) then 10455 Check_Expression_Against_Static_Predicate 10456 (Expr, Target_Typ, Static_Failure_Is_Error => True); 10457 end if; 10458 end Resolve_Qualified_Expression; 10459 10460 ------------------------------ 10461 -- Resolve_Raise_Expression -- 10462 ------------------------------ 10463 10464 procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id) is 10465 begin 10466 if Typ = Raise_Type then 10467 Error_Msg_N ("cannot find unique type for raise expression", N); 10468 Set_Etype (N, Any_Type); 10469 else 10470 Set_Etype (N, Typ); 10471 end if; 10472 end Resolve_Raise_Expression; 10473 10474 ------------------- 10475 -- Resolve_Range -- 10476 ------------------- 10477 10478 procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is 10479 L : constant Node_Id := Low_Bound (N); 10480 H : constant Node_Id := High_Bound (N); 10481 10482 function First_Last_Ref return Boolean; 10483 -- Returns True if N is of the form X'First .. X'Last where X is the 10484 -- same entity for both attributes. 10485 10486 -------------------- 10487 -- First_Last_Ref -- 10488 -------------------- 10489 10490 function First_Last_Ref return Boolean is 10491 Lorig : constant Node_Id := Original_Node (L); 10492 Horig : constant Node_Id := Original_Node (H); 10493 10494 begin 10495 if Nkind (Lorig) = N_Attribute_Reference 10496 and then Nkind (Horig) = N_Attribute_Reference 10497 and then Attribute_Name (Lorig) = Name_First 10498 and then Attribute_Name (Horig) = Name_Last 10499 then 10500 declare 10501 PL : constant Node_Id := Prefix (Lorig); 10502 PH : constant Node_Id := Prefix (Horig); 10503 begin 10504 if Is_Entity_Name (PL) 10505 and then Is_Entity_Name (PH) 10506 and then Entity (PL) = Entity (PH) 10507 then 10508 return True; 10509 end if; 10510 end; 10511 end if; 10512 10513 return False; 10514 end First_Last_Ref; 10515 10516 -- Start of processing for Resolve_Range 10517 10518 begin 10519 Set_Etype (N, Typ); 10520 10521 Resolve (L, Typ); 10522 Resolve (H, Typ); 10523 10524 -- Reanalyze the lower bound after both bounds have been analyzed, so 10525 -- that the range is known to be static or not by now. This may trigger 10526 -- more compile-time evaluation, which is useful for static analysis 10527 -- with GNATprove. This is not needed for compilation or static analysis 10528 -- with CodePeer, as full expansion does that evaluation then. 10529 10530 if GNATprove_Mode then 10531 Set_Analyzed (L, False); 10532 Resolve (L, Typ); 10533 end if; 10534 10535 -- Check for inappropriate range on unordered enumeration type 10536 10537 if Bad_Unordered_Enumeration_Reference (N, Typ) 10538 10539 -- Exclude X'First .. X'Last if X is the same entity for both 10540 10541 and then not First_Last_Ref 10542 then 10543 Error_Msg_Sloc := Sloc (Typ); 10544 Error_Msg_NE 10545 ("subrange of unordered enumeration type& declared#?U?", N, Typ); 10546 end if; 10547 10548 Check_Unset_Reference (L); 10549 Check_Unset_Reference (H); 10550 10551 -- We have to check the bounds for being within the base range as 10552 -- required for a non-static context. Normally this is automatic and 10553 -- done as part of evaluating expressions, but the N_Range node is an 10554 -- exception, since in GNAT we consider this node to be a subexpression, 10555 -- even though in Ada it is not. The circuit in Sem_Eval could check for 10556 -- this, but that would put the test on the main evaluation path for 10557 -- expressions. 10558 10559 Check_Non_Static_Context (L); 10560 Check_Non_Static_Context (H); 10561 10562 -- Check for an ambiguous range over character literals. This will 10563 -- happen with a membership test involving only literals. 10564 10565 if Typ = Any_Character then 10566 Ambiguous_Character (L); 10567 Set_Etype (N, Any_Type); 10568 return; 10569 end if; 10570 10571 -- If bounds are static, constant-fold them, so size computations are 10572 -- identical between front-end and back-end. Do not perform this 10573 -- transformation while analyzing generic units, as type information 10574 -- would be lost when reanalyzing the constant node in the instance. 10575 10576 if Is_Discrete_Type (Typ) and then Expander_Active then 10577 if Is_OK_Static_Expression (L) then 10578 Fold_Uint (L, Expr_Value (L), Is_OK_Static_Expression (L)); 10579 end if; 10580 10581 if Is_OK_Static_Expression (H) then 10582 Fold_Uint (H, Expr_Value (H), Is_OK_Static_Expression (H)); 10583 end if; 10584 end if; 10585 end Resolve_Range; 10586 10587 -------------------------- 10588 -- Resolve_Real_Literal -- 10589 -------------------------- 10590 10591 procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is 10592 Actual_Typ : constant Entity_Id := Etype (N); 10593 10594 begin 10595 -- Special processing for fixed-point literals to make sure that the 10596 -- value is an exact multiple of small where this is required. We skip 10597 -- this for the universal real case, and also for generic types. 10598 10599 if Is_Fixed_Point_Type (Typ) 10600 and then Typ /= Universal_Fixed 10601 and then Typ /= Any_Fixed 10602 and then not Is_Generic_Type (Typ) 10603 then 10604 declare 10605 Val : constant Ureal := Realval (N); 10606 Cintr : constant Ureal := Val / Small_Value (Typ); 10607 Cint : constant Uint := UR_Trunc (Cintr); 10608 Den : constant Uint := Norm_Den (Cintr); 10609 Stat : Boolean; 10610 10611 begin 10612 -- Case of literal is not an exact multiple of the Small 10613 10614 if Den /= 1 then 10615 10616 -- For a source program literal for a decimal fixed-point type, 10617 -- this is statically illegal (RM 4.9(36)). 10618 10619 if Is_Decimal_Fixed_Point_Type (Typ) 10620 and then Actual_Typ = Universal_Real 10621 and then Comes_From_Source (N) 10622 then 10623 Error_Msg_N ("value has extraneous low order digits", N); 10624 end if; 10625 10626 -- Generate a warning if literal from source 10627 10628 if Is_OK_Static_Expression (N) 10629 and then Warn_On_Bad_Fixed_Value 10630 then 10631 Error_Msg_N 10632 ("?b?static fixed-point value is not a multiple of Small!", 10633 N); 10634 end if; 10635 10636 -- Replace literal by a value that is the exact representation 10637 -- of a value of the type, i.e. a multiple of the small value, 10638 -- by truncation, since Machine_Rounds is false for all GNAT 10639 -- fixed-point types (RM 4.9(38)). 10640 10641 Stat := Is_OK_Static_Expression (N); 10642 Rewrite (N, 10643 Make_Real_Literal (Sloc (N), 10644 Realval => Small_Value (Typ) * Cint)); 10645 10646 Set_Is_Static_Expression (N, Stat); 10647 end if; 10648 10649 -- In all cases, set the corresponding integer field 10650 10651 Set_Corresponding_Integer_Value (N, Cint); 10652 end; 10653 end if; 10654 10655 -- Now replace the actual type by the expected type as usual 10656 10657 Set_Etype (N, Typ); 10658 Eval_Real_Literal (N); 10659 end Resolve_Real_Literal; 10660 10661 ----------------------- 10662 -- Resolve_Reference -- 10663 ----------------------- 10664 10665 procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is 10666 P : constant Node_Id := Prefix (N); 10667 10668 begin 10669 -- Replace general access with specific type 10670 10671 if Ekind (Etype (N)) = E_Allocator_Type then 10672 Set_Etype (N, Base_Type (Typ)); 10673 end if; 10674 10675 Resolve (P, Designated_Type (Etype (N))); 10676 10677 -- If we are taking the reference of a volatile entity, then treat it as 10678 -- a potential modification of this entity. This is too conservative, 10679 -- but necessary because remove side effects can cause transformations 10680 -- of normal assignments into reference sequences that otherwise fail to 10681 -- notice the modification. 10682 10683 if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then 10684 Note_Possible_Modification (P, Sure => False); 10685 end if; 10686 end Resolve_Reference; 10687 10688 -------------------------------- 10689 -- Resolve_Selected_Component -- 10690 -------------------------------- 10691 10692 procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is 10693 Comp : Entity_Id; 10694 Comp1 : Entity_Id := Empty; -- prevent junk warning 10695 P : constant Node_Id := Prefix (N); 10696 S : constant Node_Id := Selector_Name (N); 10697 T : Entity_Id := Etype (P); 10698 I : Interp_Index; 10699 I1 : Interp_Index := 0; -- prevent junk warning 10700 It : Interp; 10701 It1 : Interp; 10702 Found : Boolean; 10703 10704 function Init_Component return Boolean; 10705 -- Check whether this is the initialization of a component within an 10706 -- init proc (by assignment or call to another init proc). If true, 10707 -- there is no need for a discriminant check. 10708 10709 -------------------- 10710 -- Init_Component -- 10711 -------------------- 10712 10713 function Init_Component return Boolean is 10714 begin 10715 return Inside_Init_Proc 10716 and then Nkind (Prefix (N)) = N_Identifier 10717 and then Chars (Prefix (N)) = Name_uInit 10718 and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative; 10719 end Init_Component; 10720 10721 -- Start of processing for Resolve_Selected_Component 10722 10723 begin 10724 if Is_Overloaded (P) then 10725 10726 -- Use the context type to select the prefix that has a selector 10727 -- of the correct name and type. 10728 10729 Found := False; 10730 Get_First_Interp (P, I, It); 10731 10732 Search : while Present (It.Typ) loop 10733 if Is_Access_Type (It.Typ) then 10734 T := Designated_Type (It.Typ); 10735 else 10736 T := It.Typ; 10737 end if; 10738 10739 -- Locate selected component. For a private prefix the selector 10740 -- can denote a discriminant. 10741 10742 if Is_Record_Type (T) or else Is_Private_Type (T) then 10743 10744 -- The visible components of a class-wide type are those of 10745 -- the root type. 10746 10747 if Is_Class_Wide_Type (T) then 10748 T := Etype (T); 10749 end if; 10750 10751 Comp := First_Entity (T); 10752 while Present (Comp) loop 10753 if Chars (Comp) = Chars (S) 10754 and then Covers (Typ, Etype (Comp)) 10755 then 10756 if not Found then 10757 Found := True; 10758 I1 := I; 10759 It1 := It; 10760 Comp1 := Comp; 10761 10762 else 10763 It := Disambiguate (P, I1, I, Any_Type); 10764 10765 if It = No_Interp then 10766 Error_Msg_N 10767 ("ambiguous prefix for selected component", N); 10768 Set_Etype (N, Typ); 10769 return; 10770 10771 else 10772 It1 := It; 10773 10774 -- There may be an implicit dereference. Retrieve 10775 -- designated record type. 10776 10777 if Is_Access_Type (It1.Typ) then 10778 T := Designated_Type (It1.Typ); 10779 else 10780 T := It1.Typ; 10781 end if; 10782 10783 if Scope (Comp1) /= T then 10784 10785 -- Resolution chooses the new interpretation. 10786 -- Find the component with the right name. 10787 10788 Comp1 := First_Entity (T); 10789 while Present (Comp1) 10790 and then Chars (Comp1) /= Chars (S) 10791 loop 10792 Next_Entity (Comp1); 10793 end loop; 10794 end if; 10795 10796 exit Search; 10797 end if; 10798 end if; 10799 end if; 10800 10801 Next_Entity (Comp); 10802 end loop; 10803 end if; 10804 10805 Get_Next_Interp (I, It); 10806 end loop Search; 10807 10808 -- There must be a legal interpretation at this point 10809 10810 pragma Assert (Found); 10811 Resolve (P, It1.Typ); 10812 10813 -- In general the expected type is the type of the context, not the 10814 -- type of the candidate selected component. 10815 10816 Set_Etype (N, Typ); 10817 Set_Entity_With_Checks (S, Comp1); 10818 10819 -- The type of the context and that of the component are 10820 -- compatible and in general identical, but if they are anonymous 10821 -- access-to-subprogram types, the relevant type is that of the 10822 -- component. This matters in Unnest_Subprograms mode, where the 10823 -- relevant context is the one in which the type is declared, not 10824 -- the point of use. This determines what activation record to use. 10825 10826 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then 10827 Set_Etype (N, Etype (Comp1)); 10828 10829 -- When the type of the component is an access to a class-wide type 10830 -- the relevant type is that of the component (since in such case we 10831 -- may need to generate implicit type conversions or dispatching 10832 -- calls). 10833 10834 elsif Is_Access_Type (Typ) 10835 and then not Is_Class_Wide_Type (Designated_Type (Typ)) 10836 and then Is_Class_Wide_Type (Designated_Type (Etype (Comp1))) 10837 then 10838 Set_Etype (N, Etype (Comp1)); 10839 end if; 10840 10841 else 10842 -- Resolve prefix with its type 10843 10844 Resolve (P, T); 10845 end if; 10846 10847 -- Generate cross-reference. We needed to wait until full overloading 10848 -- resolution was complete to do this, since otherwise we can't tell if 10849 -- we are an lvalue or not. 10850 10851 if May_Be_Lvalue (N) then 10852 Generate_Reference (Entity (S), S, 'm'); 10853 else 10854 Generate_Reference (Entity (S), S, 'r'); 10855 end if; 10856 10857 -- If the prefix's type is an access type, get to the real record type. 10858 -- Note: we do not apply an access check because an explicit dereference 10859 -- will be introduced later, and the check will happen there. 10860 10861 if Is_Access_Type (Etype (P)) then 10862 T := Implicitly_Designated_Type (Etype (P)); 10863 Check_Fully_Declared_Prefix (T, P); 10864 10865 else 10866 T := Etype (P); 10867 10868 -- If the prefix is an entity it may have a deferred reference set 10869 -- during analysis of the selected component. After resolution we 10870 -- can transform it into a proper reference. This prevents spurious 10871 -- warnings on useless assignments when the same selected component 10872 -- is the actual for an out parameter in a subsequent call. 10873 10874 if Is_Entity_Name (P) 10875 and then Has_Deferred_Reference (Entity (P)) 10876 then 10877 if May_Be_Lvalue (N) then 10878 Generate_Reference (Entity (P), P, 'm'); 10879 else 10880 Generate_Reference (Entity (P), P, 'r'); 10881 end if; 10882 end if; 10883 end if; 10884 10885 -- Set flag for expander if discriminant check required on a component 10886 -- appearing within a variant. 10887 10888 if Has_Discriminants (T) 10889 and then Ekind (Entity (S)) = E_Component 10890 and then Present (Original_Record_Component (Entity (S))) 10891 and then Ekind (Original_Record_Component (Entity (S))) = E_Component 10892 and then 10893 Is_Declared_Within_Variant (Original_Record_Component (Entity (S))) 10894 and then not Discriminant_Checks_Suppressed (T) 10895 and then not Init_Component 10896 then 10897 Set_Do_Discriminant_Check (N); 10898 end if; 10899 10900 if Ekind (Entity (S)) = E_Void then 10901 Error_Msg_N ("premature use of component", S); 10902 end if; 10903 10904 -- If the prefix is a record conversion, this may be a renamed 10905 -- discriminant whose bounds differ from those of the original 10906 -- one, so we must ensure that a range check is performed. 10907 10908 if Nkind (P) = N_Type_Conversion 10909 and then Ekind (Entity (S)) = E_Discriminant 10910 and then Is_Discrete_Type (Typ) 10911 then 10912 Set_Etype (N, Base_Type (Typ)); 10913 end if; 10914 10915 -- Eval_Selected_Component may e.g. fold statically known discriminants. 10916 10917 Eval_Selected_Component (N); 10918 10919 if Nkind (N) = N_Selected_Component then 10920 10921 -- If the record type is atomic and the component is not, then this 10922 -- is worth a warning before Ada 2020, since we have a situation 10923 -- where the access to the component may cause extra read/writes of 10924 -- the atomic object, or partial word accesses, both of which may be 10925 -- unexpected. 10926 10927 if Is_Atomic_Ref_With_Address (N) 10928 and then not Is_Atomic (Entity (S)) 10929 and then not Is_Atomic (Etype (Entity (S))) 10930 and then Ada_Version < Ada_2020 10931 then 10932 Error_Msg_N 10933 ("??access to non-atomic component of atomic record", 10934 Prefix (N)); 10935 Error_Msg_N 10936 ("\??may cause unexpected accesses to atomic object", 10937 Prefix (N)); 10938 end if; 10939 10940 Resolve_Implicit_Dereference (Prefix (N)); 10941 Analyze_Dimension (N); 10942 end if; 10943 end Resolve_Selected_Component; 10944 10945 ------------------- 10946 -- Resolve_Shift -- 10947 ------------------- 10948 10949 procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is 10950 B_Typ : constant Entity_Id := Base_Type (Typ); 10951 L : constant Node_Id := Left_Opnd (N); 10952 R : constant Node_Id := Right_Opnd (N); 10953 10954 begin 10955 -- We do the resolution using the base type, because intermediate values 10956 -- in expressions always are of the base type, not a subtype of it. 10957 10958 Resolve (L, B_Typ); 10959 Resolve (R, Standard_Natural); 10960 10961 Check_Unset_Reference (L); 10962 Check_Unset_Reference (R); 10963 10964 Set_Etype (N, B_Typ); 10965 Generate_Operator_Reference (N, B_Typ); 10966 Eval_Shift (N); 10967 end Resolve_Shift; 10968 10969 --------------------------- 10970 -- Resolve_Short_Circuit -- 10971 --------------------------- 10972 10973 procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is 10974 B_Typ : constant Entity_Id := Base_Type (Typ); 10975 L : constant Node_Id := Left_Opnd (N); 10976 R : constant Node_Id := Right_Opnd (N); 10977 10978 begin 10979 -- Ensure all actions associated with the left operand (e.g. 10980 -- finalization of transient objects) are fully evaluated locally within 10981 -- an expression with actions. This is particularly helpful for coverage 10982 -- analysis. However this should not happen in generics or if option 10983 -- Minimize_Expression_With_Actions is set. 10984 10985 if Expander_Active and not Minimize_Expression_With_Actions then 10986 declare 10987 Reloc_L : constant Node_Id := Relocate_Node (L); 10988 begin 10989 Save_Interps (Old_N => L, New_N => Reloc_L); 10990 10991 Rewrite (L, 10992 Make_Expression_With_Actions (Sloc (L), 10993 Actions => New_List, 10994 Expression => Reloc_L)); 10995 10996 -- Set Comes_From_Source on L to preserve warnings for unset 10997 -- reference. 10998 10999 Preserve_Comes_From_Source (L, Reloc_L); 11000 end; 11001 end if; 11002 11003 Resolve (L, B_Typ); 11004 Resolve (R, B_Typ); 11005 11006 -- Check for issuing warning for always False assert/check, this happens 11007 -- when assertions are turned off, in which case the pragma Assert/Check 11008 -- was transformed into: 11009 11010 -- if False and then <condition> then ... 11011 11012 -- and we detect this pattern 11013 11014 if Warn_On_Assertion_Failure 11015 and then Is_Entity_Name (R) 11016 and then Entity (R) = Standard_False 11017 and then Nkind (Parent (N)) = N_If_Statement 11018 and then Nkind (N) = N_And_Then 11019 and then Is_Entity_Name (L) 11020 and then Entity (L) = Standard_False 11021 then 11022 declare 11023 Orig : constant Node_Id := Original_Node (Parent (N)); 11024 11025 begin 11026 -- Special handling of Asssert pragma 11027 11028 if Nkind (Orig) = N_Pragma 11029 and then Pragma_Name (Orig) = Name_Assert 11030 then 11031 declare 11032 Expr : constant Node_Id := 11033 Original_Node 11034 (Expression 11035 (First (Pragma_Argument_Associations (Orig)))); 11036 11037 begin 11038 -- Don't warn if original condition is explicit False, 11039 -- since obviously the failure is expected in this case. 11040 11041 if Is_Entity_Name (Expr) 11042 and then Entity (Expr) = Standard_False 11043 then 11044 null; 11045 11046 -- Issue warning. We do not want the deletion of the 11047 -- IF/AND-THEN to take this message with it. We achieve this 11048 -- by making sure that the expanded code points to the Sloc 11049 -- of the expression, not the original pragma. 11050 11051 else 11052 -- Note: Use Error_Msg_F here rather than Error_Msg_N. 11053 -- The source location of the expression is not usually 11054 -- the best choice here. For example, it gets located on 11055 -- the last AND keyword in a chain of boolean expressiond 11056 -- AND'ed together. It is best to put the message on the 11057 -- first character of the assertion, which is the effect 11058 -- of the First_Node call here. 11059 11060 Error_Msg_F 11061 ("?A?assertion would fail at run time!", 11062 Expression 11063 (First (Pragma_Argument_Associations (Orig)))); 11064 end if; 11065 end; 11066 11067 -- Similar processing for Check pragma 11068 11069 elsif Nkind (Orig) = N_Pragma 11070 and then Pragma_Name (Orig) = Name_Check 11071 then 11072 -- Don't want to warn if original condition is explicit False 11073 11074 declare 11075 Expr : constant Node_Id := 11076 Original_Node 11077 (Expression 11078 (Next (First (Pragma_Argument_Associations (Orig))))); 11079 begin 11080 if Is_Entity_Name (Expr) 11081 and then Entity (Expr) = Standard_False 11082 then 11083 null; 11084 11085 -- Post warning 11086 11087 else 11088 -- Again use Error_Msg_F rather than Error_Msg_N, see 11089 -- comment above for an explanation of why we do this. 11090 11091 Error_Msg_F 11092 ("?A?check would fail at run time!", 11093 Expression 11094 (Last (Pragma_Argument_Associations (Orig)))); 11095 end if; 11096 end; 11097 end if; 11098 end; 11099 end if; 11100 11101 -- Continue with processing of short circuit 11102 11103 Check_Unset_Reference (L); 11104 Check_Unset_Reference (R); 11105 11106 Set_Etype (N, B_Typ); 11107 Eval_Short_Circuit (N); 11108 end Resolve_Short_Circuit; 11109 11110 ------------------- 11111 -- Resolve_Slice -- 11112 ------------------- 11113 11114 procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is 11115 Drange : constant Node_Id := Discrete_Range (N); 11116 Name : constant Node_Id := Prefix (N); 11117 Array_Type : Entity_Id := Empty; 11118 Dexpr : Node_Id := Empty; 11119 Index_Type : Entity_Id; 11120 11121 begin 11122 if Is_Overloaded (Name) then 11123 11124 -- Use the context type to select the prefix that yields the correct 11125 -- array type. 11126 11127 declare 11128 I : Interp_Index; 11129 I1 : Interp_Index := 0; 11130 It : Interp; 11131 P : constant Node_Id := Prefix (N); 11132 Found : Boolean := False; 11133 11134 begin 11135 Get_First_Interp (P, I, It); 11136 while Present (It.Typ) loop 11137 if (Is_Array_Type (It.Typ) 11138 and then Covers (Typ, It.Typ)) 11139 or else (Is_Access_Type (It.Typ) 11140 and then Is_Array_Type (Designated_Type (It.Typ)) 11141 and then Covers (Typ, Designated_Type (It.Typ))) 11142 then 11143 if Found then 11144 It := Disambiguate (P, I1, I, Any_Type); 11145 11146 if It = No_Interp then 11147 Error_Msg_N ("ambiguous prefix for slicing", N); 11148 Set_Etype (N, Typ); 11149 return; 11150 else 11151 Found := True; 11152 Array_Type := It.Typ; 11153 I1 := I; 11154 end if; 11155 else 11156 Found := True; 11157 Array_Type := It.Typ; 11158 I1 := I; 11159 end if; 11160 end if; 11161 11162 Get_Next_Interp (I, It); 11163 end loop; 11164 end; 11165 11166 else 11167 Array_Type := Etype (Name); 11168 end if; 11169 11170 Resolve (Name, Array_Type); 11171 11172 -- If the prefix's type is an access type, get to the real array type. 11173 -- Note: we do not apply an access check because an explicit dereference 11174 -- will be introduced later, and the check will happen there. 11175 11176 if Is_Access_Type (Array_Type) then 11177 Array_Type := Implicitly_Designated_Type (Array_Type); 11178 11179 -- If the prefix is an access to an unconstrained array, we must use 11180 -- the actual subtype of the object to perform the index checks. The 11181 -- object denoted by the prefix is implicit in the node, so we build 11182 -- an explicit representation for it in order to compute the actual 11183 -- subtype. 11184 11185 if not Is_Constrained (Array_Type) then 11186 Remove_Side_Effects (Prefix (N)); 11187 11188 declare 11189 Obj : constant Node_Id := 11190 Make_Explicit_Dereference (Sloc (N), 11191 Prefix => New_Copy_Tree (Prefix (N))); 11192 begin 11193 Set_Etype (Obj, Array_Type); 11194 Set_Parent (Obj, Parent (N)); 11195 Array_Type := Get_Actual_Subtype (Obj); 11196 end; 11197 end if; 11198 11199 elsif Is_Entity_Name (Name) 11200 or else Nkind (Name) = N_Explicit_Dereference 11201 or else (Nkind (Name) = N_Function_Call 11202 and then not Is_Constrained (Etype (Name))) 11203 then 11204 Array_Type := Get_Actual_Subtype (Name); 11205 11206 -- If the name is a selected component that depends on discriminants, 11207 -- build an actual subtype for it. This can happen only when the name 11208 -- itself is overloaded; otherwise the actual subtype is created when 11209 -- the selected component is analyzed. 11210 11211 elsif Nkind (Name) = N_Selected_Component 11212 and then Full_Analysis 11213 and then Depends_On_Discriminant (First_Index (Array_Type)) 11214 then 11215 declare 11216 Act_Decl : constant Node_Id := 11217 Build_Actual_Subtype_Of_Component (Array_Type, Name); 11218 begin 11219 Insert_Action (N, Act_Decl); 11220 Array_Type := Defining_Identifier (Act_Decl); 11221 end; 11222 11223 -- Maybe this should just be "else", instead of checking for the 11224 -- specific case of slice??? This is needed for the case where the 11225 -- prefix is an Image attribute, which gets expanded to a slice, and so 11226 -- has a constrained subtype which we want to use for the slice range 11227 -- check applied below (the range check won't get done if the 11228 -- unconstrained subtype of the 'Image is used). 11229 11230 elsif Nkind (Name) = N_Slice then 11231 Array_Type := Etype (Name); 11232 end if; 11233 11234 -- Obtain the type of the array index 11235 11236 if Ekind (Array_Type) = E_String_Literal_Subtype then 11237 Index_Type := Etype (String_Literal_Low_Bound (Array_Type)); 11238 else 11239 Index_Type := Etype (First_Index (Array_Type)); 11240 end if; 11241 11242 -- If name was overloaded, set slice type correctly now 11243 11244 Set_Etype (N, Array_Type); 11245 11246 -- Handle the generation of a range check that compares the array index 11247 -- against the discrete_range. The check is not applied to internally 11248 -- built nodes associated with the expansion of dispatch tables. Check 11249 -- that Ada.Tags has already been loaded to avoid extra dependencies on 11250 -- the unit. 11251 11252 if Tagged_Type_Expansion 11253 and then RTU_Loaded (Ada_Tags) 11254 and then Nkind (Prefix (N)) = N_Selected_Component 11255 and then Present (Entity (Selector_Name (Prefix (N)))) 11256 and then Entity (Selector_Name (Prefix (N))) = 11257 RTE_Record_Component (RE_Prims_Ptr) 11258 then 11259 null; 11260 11261 -- The discrete_range is specified by a subtype indication. Create a 11262 -- shallow copy and inherit the type, parent and source location from 11263 -- the discrete_range. This ensures that the range check is inserted 11264 -- relative to the slice and that the runtime exception points to the 11265 -- proper construct. 11266 11267 elsif Is_Entity_Name (Drange) then 11268 Dexpr := New_Copy (Scalar_Range (Entity (Drange))); 11269 11270 Set_Etype (Dexpr, Etype (Drange)); 11271 Set_Parent (Dexpr, Parent (Drange)); 11272 Set_Sloc (Dexpr, Sloc (Drange)); 11273 11274 -- The discrete_range is a regular range. Resolve the bounds and remove 11275 -- their side effects. 11276 11277 else 11278 Resolve (Drange, Base_Type (Index_Type)); 11279 11280 if Nkind (Drange) = N_Range then 11281 Force_Evaluation (Low_Bound (Drange)); 11282 Force_Evaluation (High_Bound (Drange)); 11283 11284 Dexpr := Drange; 11285 end if; 11286 end if; 11287 11288 if Present (Dexpr) then 11289 Apply_Range_Check (Dexpr, Index_Type); 11290 end if; 11291 11292 Set_Slice_Subtype (N); 11293 11294 -- Check bad use of type with predicates 11295 11296 declare 11297 Subt : Entity_Id; 11298 11299 begin 11300 if Nkind (Drange) = N_Subtype_Indication 11301 and then Has_Predicates (Entity (Subtype_Mark (Drange))) 11302 then 11303 Subt := Entity (Subtype_Mark (Drange)); 11304 else 11305 Subt := Etype (Drange); 11306 end if; 11307 11308 if Has_Predicates (Subt) then 11309 Bad_Predicated_Subtype_Use 11310 ("subtype& has predicate, not allowed in slice", Drange, Subt); 11311 end if; 11312 end; 11313 11314 -- Otherwise here is where we check suspicious indexes 11315 11316 if Nkind (Drange) = N_Range then 11317 Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); 11318 Warn_On_Suspicious_Index (Name, High_Bound (Drange)); 11319 end if; 11320 11321 Resolve_Implicit_Dereference (Prefix (N)); 11322 Analyze_Dimension (N); 11323 Eval_Slice (N); 11324 end Resolve_Slice; 11325 11326 ---------------------------- 11327 -- Resolve_String_Literal -- 11328 ---------------------------- 11329 11330 procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is 11331 C_Typ : constant Entity_Id := Component_Type (Typ); 11332 R_Typ : constant Entity_Id := Root_Type (C_Typ); 11333 Loc : constant Source_Ptr := Sloc (N); 11334 Str : constant String_Id := Strval (N); 11335 Strlen : constant Nat := String_Length (Str); 11336 Subtype_Id : Entity_Id; 11337 Need_Check : Boolean; 11338 11339 begin 11340 -- For a string appearing in a concatenation, defer creation of the 11341 -- string_literal_subtype until the end of the resolution of the 11342 -- concatenation, because the literal may be constant-folded away. This 11343 -- is a useful optimization for long concatenation expressions. 11344 11345 -- If the string is an aggregate built for a single character (which 11346 -- happens in a non-static context) or a is null string to which special 11347 -- checks may apply, we build the subtype. Wide strings must also get a 11348 -- string subtype if they come from a one character aggregate. Strings 11349 -- generated by attributes might be static, but it is often hard to 11350 -- determine whether the enclosing context is static, so we generate 11351 -- subtypes for them as well, thus losing some rarer optimizations ??? 11352 -- Same for strings that come from a static conversion. 11353 11354 Need_Check := 11355 (Strlen = 0 and then Typ /= Standard_String) 11356 or else Nkind (Parent (N)) /= N_Op_Concat 11357 or else (N /= Left_Opnd (Parent (N)) 11358 and then N /= Right_Opnd (Parent (N))) 11359 or else ((Typ = Standard_Wide_String 11360 or else Typ = Standard_Wide_Wide_String) 11361 and then Nkind (Original_Node (N)) /= N_String_Literal); 11362 11363 -- If the resolving type is itself a string literal subtype, we can just 11364 -- reuse it, since there is no point in creating another. 11365 11366 if Ekind (Typ) = E_String_Literal_Subtype then 11367 Subtype_Id := Typ; 11368 11369 elsif Nkind (Parent (N)) = N_Op_Concat 11370 and then not Need_Check 11371 and then Nkind (Original_Node (N)) not in N_Character_Literal 11372 | N_Attribute_Reference 11373 | N_Qualified_Expression 11374 | N_Type_Conversion 11375 then 11376 Subtype_Id := Typ; 11377 11378 -- Do not generate a string literal subtype for the default expression 11379 -- of a formal parameter in GNATprove mode. This is because the string 11380 -- subtype is associated with the freezing actions of the subprogram, 11381 -- however freezing is disabled in GNATprove mode and as a result the 11382 -- subtype is unavailable. 11383 11384 elsif GNATprove_Mode 11385 and then Nkind (Parent (N)) = N_Parameter_Specification 11386 then 11387 Subtype_Id := Typ; 11388 11389 -- Otherwise we must create a string literal subtype. Note that the 11390 -- whole idea of string literal subtypes is simply to avoid the need 11391 -- for building a full fledged array subtype for each literal. 11392 11393 else 11394 Set_String_Literal_Subtype (N, Typ); 11395 Subtype_Id := Etype (N); 11396 end if; 11397 11398 if Nkind (Parent (N)) /= N_Op_Concat 11399 or else Need_Check 11400 then 11401 Set_Etype (N, Subtype_Id); 11402 Eval_String_Literal (N); 11403 end if; 11404 11405 if Is_Limited_Composite (Typ) 11406 or else Is_Private_Composite (Typ) 11407 then 11408 Error_Msg_N ("string literal not available for private array", N); 11409 Set_Etype (N, Any_Type); 11410 return; 11411 end if; 11412 11413 -- The validity of a null string has been checked in the call to 11414 -- Eval_String_Literal. 11415 11416 if Strlen = 0 then 11417 return; 11418 11419 -- Always accept string literal with component type Any_Character, which 11420 -- occurs in error situations and in comparisons of literals, both of 11421 -- which should accept all literals. 11422 11423 elsif R_Typ = Any_Character then 11424 return; 11425 11426 -- If the type is bit-packed, then we always transform the string 11427 -- literal into a full fledged aggregate. 11428 11429 elsif Is_Bit_Packed_Array (Typ) then 11430 null; 11431 11432 -- Deal with cases of Wide_Wide_String, Wide_String, and String 11433 11434 else 11435 -- For Standard.Wide_Wide_String, or any other type whose component 11436 -- type is Standard.Wide_Wide_Character, we know that all the 11437 -- characters in the string must be acceptable, since the parser 11438 -- accepted the characters as valid character literals. 11439 11440 if R_Typ = Standard_Wide_Wide_Character then 11441 null; 11442 11443 -- For the case of Standard.String, or any other type whose component 11444 -- type is Standard.Character, we must make sure that there are no 11445 -- wide characters in the string, i.e. that it is entirely composed 11446 -- of characters in range of type Character. 11447 11448 -- If the string literal is the result of a static concatenation, the 11449 -- test has already been performed on the components, and need not be 11450 -- repeated. 11451 11452 elsif R_Typ = Standard_Character 11453 and then Nkind (Original_Node (N)) /= N_Op_Concat 11454 then 11455 for J in 1 .. Strlen loop 11456 if not In_Character_Range (Get_String_Char (Str, J)) then 11457 11458 -- If we are out of range, post error. This is one of the 11459 -- very few places that we place the flag in the middle of 11460 -- a token, right under the offending wide character. Not 11461 -- quite clear if this is right wrt wide character encoding 11462 -- sequences, but it's only an error message. 11463 11464 Error_Msg 11465 ("literal out of range of type Standard.Character", 11466 Source_Ptr (Int (Loc) + J)); 11467 return; 11468 end if; 11469 end loop; 11470 11471 -- For the case of Standard.Wide_String, or any other type whose 11472 -- component type is Standard.Wide_Character, we must make sure that 11473 -- there are no wide characters in the string, i.e. that it is 11474 -- entirely composed of characters in range of type Wide_Character. 11475 11476 -- If the string literal is the result of a static concatenation, 11477 -- the test has already been performed on the components, and need 11478 -- not be repeated. 11479 11480 elsif R_Typ = Standard_Wide_Character 11481 and then Nkind (Original_Node (N)) /= N_Op_Concat 11482 then 11483 for J in 1 .. Strlen loop 11484 if not In_Wide_Character_Range (Get_String_Char (Str, J)) then 11485 11486 -- If we are out of range, post error. This is one of the 11487 -- very few places that we place the flag in the middle of 11488 -- a token, right under the offending wide character. 11489 11490 -- This is not quite right, because characters in general 11491 -- will take more than one character position ??? 11492 11493 Error_Msg 11494 ("literal out of range of type Standard.Wide_Character", 11495 Source_Ptr (Int (Loc) + J)); 11496 return; 11497 end if; 11498 end loop; 11499 11500 -- If the root type is not a standard character, then we will convert 11501 -- the string into an aggregate and will let the aggregate code do 11502 -- the checking. Standard Wide_Wide_Character is also OK here. 11503 11504 else 11505 null; 11506 end if; 11507 11508 -- See if the component type of the array corresponding to the string 11509 -- has compile time known bounds. If yes we can directly check 11510 -- whether the evaluation of the string will raise constraint error. 11511 -- Otherwise we need to transform the string literal into the 11512 -- corresponding character aggregate and let the aggregate code do 11513 -- the checking. We use the same transformation if the component 11514 -- type has a static predicate, which will be applied to each 11515 -- character when the aggregate is resolved. 11516 11517 if Is_Standard_Character_Type (R_Typ) then 11518 11519 -- Check for the case of full range, where we are definitely OK 11520 11521 if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then 11522 return; 11523 end if; 11524 11525 -- Here the range is not the complete base type range, so check 11526 11527 declare 11528 Comp_Typ_Lo : constant Node_Id := 11529 Type_Low_Bound (Component_Type (Typ)); 11530 Comp_Typ_Hi : constant Node_Id := 11531 Type_High_Bound (Component_Type (Typ)); 11532 11533 Char_Val : Uint; 11534 11535 begin 11536 if Compile_Time_Known_Value (Comp_Typ_Lo) 11537 and then Compile_Time_Known_Value (Comp_Typ_Hi) 11538 then 11539 for J in 1 .. Strlen loop 11540 Char_Val := UI_From_Int (Int (Get_String_Char (Str, J))); 11541 11542 if Char_Val < Expr_Value (Comp_Typ_Lo) 11543 or else Char_Val > Expr_Value (Comp_Typ_Hi) 11544 then 11545 Apply_Compile_Time_Constraint_Error 11546 (N, "character out of range??", 11547 CE_Range_Check_Failed, 11548 Loc => Source_Ptr (Int (Loc) + J)); 11549 end if; 11550 end loop; 11551 11552 if not Has_Static_Predicate (C_Typ) then 11553 return; 11554 end if; 11555 end if; 11556 end; 11557 end if; 11558 end if; 11559 11560 -- If we got here we meed to transform the string literal into the 11561 -- equivalent qualified positional array aggregate. This is rather 11562 -- heavy artillery for this situation, but it is hard work to avoid. 11563 11564 declare 11565 Lits : constant List_Id := New_List; 11566 P : Source_Ptr := Loc + 1; 11567 C : Char_Code; 11568 11569 begin 11570 -- Build the character literals, we give them source locations that 11571 -- correspond to the string positions, which is a bit tricky given 11572 -- the possible presence of wide character escape sequences. 11573 11574 for J in 1 .. Strlen loop 11575 C := Get_String_Char (Str, J); 11576 Set_Character_Literal_Name (C); 11577 11578 Append_To (Lits, 11579 Make_Character_Literal (P, 11580 Chars => Name_Find, 11581 Char_Literal_Value => UI_From_CC (C))); 11582 11583 if In_Character_Range (C) then 11584 P := P + 1; 11585 11586 -- Should we have a call to Skip_Wide here ??? 11587 11588 -- ??? else 11589 -- Skip_Wide (P); 11590 11591 end if; 11592 end loop; 11593 11594 Rewrite (N, 11595 Make_Qualified_Expression (Loc, 11596 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 11597 Expression => 11598 Make_Aggregate (Loc, Expressions => Lits))); 11599 11600 Analyze_And_Resolve (N, Typ); 11601 end; 11602 end Resolve_String_Literal; 11603 11604 ------------------------- 11605 -- Resolve_Target_Name -- 11606 ------------------------- 11607 11608 procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id) is 11609 begin 11610 Set_Etype (N, Typ); 11611 end Resolve_Target_Name; 11612 11613 ----------------------------- 11614 -- Resolve_Type_Conversion -- 11615 ----------------------------- 11616 11617 procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is 11618 Conv_OK : constant Boolean := Conversion_OK (N); 11619 Operand : constant Node_Id := Expression (N); 11620 Operand_Typ : constant Entity_Id := Etype (Operand); 11621 Target_Typ : constant Entity_Id := Etype (N); 11622 Rop : Node_Id; 11623 Orig_N : Node_Id; 11624 Orig_T : Node_Id; 11625 11626 Test_Redundant : Boolean := Warn_On_Redundant_Constructs; 11627 -- Set to False to suppress cases where we want to suppress the test 11628 -- for redundancy to avoid possible false positives on this warning. 11629 11630 begin 11631 if not Conv_OK 11632 and then not Valid_Conversion (N, Target_Typ, Operand) 11633 then 11634 return; 11635 end if; 11636 11637 -- If the Operand Etype is Universal_Fixed, then the conversion is 11638 -- never redundant. We need this check because by the time we have 11639 -- finished the rather complex transformation, the conversion looks 11640 -- redundant when it is not. 11641 11642 if Operand_Typ = Universal_Fixed then 11643 Test_Redundant := False; 11644 11645 -- If the operand is marked as Any_Fixed, then special processing is 11646 -- required. This is also a case where we suppress the test for a 11647 -- redundant conversion, since most certainly it is not redundant. 11648 11649 elsif Operand_Typ = Any_Fixed then 11650 Test_Redundant := False; 11651 11652 -- Mixed-mode operation involving a literal. Context must be a fixed 11653 -- type which is applied to the literal subsequently. 11654 11655 -- Multiplication and division involving two fixed type operands must 11656 -- yield a universal real because the result is computed in arbitrary 11657 -- precision. 11658 11659 if Is_Fixed_Point_Type (Typ) 11660 and then Nkind (Operand) in N_Op_Divide | N_Op_Multiply 11661 and then Etype (Left_Opnd (Operand)) = Any_Fixed 11662 and then Etype (Right_Opnd (Operand)) = Any_Fixed 11663 then 11664 Set_Etype (Operand, Universal_Real); 11665 11666 elsif Is_Numeric_Type (Typ) 11667 and then Nkind (Operand) in N_Op_Multiply | N_Op_Divide 11668 and then (Etype (Right_Opnd (Operand)) = Universal_Real 11669 or else 11670 Etype (Left_Opnd (Operand)) = Universal_Real) 11671 then 11672 -- Return if expression is ambiguous 11673 11674 if Unique_Fixed_Point_Type (N) = Any_Type then 11675 return; 11676 11677 -- If nothing else, the available fixed type is Duration 11678 11679 else 11680 Set_Etype (Operand, Standard_Duration); 11681 end if; 11682 11683 -- Resolve the real operand with largest available precision 11684 11685 if Etype (Right_Opnd (Operand)) = Universal_Real then 11686 Rop := New_Copy_Tree (Right_Opnd (Operand)); 11687 else 11688 Rop := New_Copy_Tree (Left_Opnd (Operand)); 11689 end if; 11690 11691 Resolve (Rop, Universal_Real); 11692 11693 -- If the operand is a literal (it could be a non-static and 11694 -- illegal exponentiation) check whether the use of Duration 11695 -- is potentially inaccurate. 11696 11697 if Nkind (Rop) = N_Real_Literal 11698 and then Realval (Rop) /= Ureal_0 11699 and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) 11700 then 11701 Error_Msg_N 11702 ("??universal real operand can only " 11703 & "be interpreted as Duration!", Rop); 11704 Error_Msg_N 11705 ("\??precision will be lost in the conversion!", Rop); 11706 end if; 11707 11708 elsif Is_Numeric_Type (Typ) 11709 and then Nkind (Operand) in N_Op 11710 and then Unique_Fixed_Point_Type (N) /= Any_Type 11711 then 11712 Set_Etype (Operand, Standard_Duration); 11713 11714 else 11715 Error_Msg_N ("invalid context for mixed mode operation", N); 11716 Set_Etype (Operand, Any_Type); 11717 return; 11718 end if; 11719 end if; 11720 11721 Resolve (Operand); 11722 11723 Analyze_Dimension (N); 11724 11725 -- Note: we do the Eval_Type_Conversion call before applying the 11726 -- required checks for a subtype conversion. This is important, since 11727 -- both are prepared under certain circumstances to change the type 11728 -- conversion to a constraint error node, but in the case of 11729 -- Eval_Type_Conversion this may reflect an illegality in the static 11730 -- case, and we would miss the illegality (getting only a warning 11731 -- message), if we applied the type conversion checks first. 11732 11733 Eval_Type_Conversion (N); 11734 11735 -- Even when evaluation is not possible, we may be able to simplify the 11736 -- conversion or its expression. This needs to be done before applying 11737 -- checks, since otherwise the checks may use the original expression 11738 -- and defeat the simplifications. This is specifically the case for 11739 -- elimination of the floating-point Truncation attribute in 11740 -- float-to-int conversions. 11741 11742 Simplify_Type_Conversion (N); 11743 11744 -- If after evaluation we still have a type conversion, then we may need 11745 -- to apply checks required for a subtype conversion. But skip them if 11746 -- universal fixed operands are involved, since range checks are handled 11747 -- separately for these cases, after the expansion done by Exp_Fixd. 11748 11749 if Nkind (N) = N_Type_Conversion 11750 and then not Is_Generic_Type (Root_Type (Target_Typ)) 11751 and then Target_Typ /= Universal_Fixed 11752 and then Etype (Operand) /= Universal_Fixed 11753 then 11754 Apply_Type_Conversion_Checks (N); 11755 end if; 11756 11757 -- Issue warning for conversion of simple object to its own type. We 11758 -- have to test the original nodes, since they may have been rewritten 11759 -- by various optimizations. 11760 11761 Orig_N := Original_Node (N); 11762 11763 -- Here we test for a redundant conversion if the warning mode is 11764 -- active (and was not locally reset), and we have a type conversion 11765 -- from source not appearing in a generic instance. 11766 11767 if Test_Redundant 11768 and then Nkind (Orig_N) = N_Type_Conversion 11769 and then Comes_From_Source (Orig_N) 11770 and then not In_Instance 11771 then 11772 Orig_N := Original_Node (Expression (Orig_N)); 11773 Orig_T := Target_Typ; 11774 11775 -- If the node is part of a larger expression, the Target_Type 11776 -- may not be the original type of the node if the context is a 11777 -- condition. Recover original type to see if conversion is needed. 11778 11779 if Is_Boolean_Type (Orig_T) 11780 and then Nkind (Parent (N)) in N_Op 11781 then 11782 Orig_T := Etype (Parent (N)); 11783 end if; 11784 11785 -- If we have an entity name, then give the warning if the entity 11786 -- is the right type, or if it is a loop parameter covered by the 11787 -- original type (that's needed because loop parameters have an 11788 -- odd subtype coming from the bounds). 11789 11790 if (Is_Entity_Name (Orig_N) 11791 and then Present (Entity (Orig_N)) 11792 and then 11793 (Etype (Entity (Orig_N)) = Orig_T 11794 or else 11795 (Ekind (Entity (Orig_N)) = E_Loop_Parameter 11796 and then Covers (Orig_T, Etype (Entity (Orig_N)))))) 11797 11798 -- If not an entity, then type of expression must match 11799 11800 or else Etype (Orig_N) = Orig_T 11801 then 11802 -- One more check, do not give warning if the analyzed conversion 11803 -- has an expression with non-static bounds, and the bounds of the 11804 -- target are static. This avoids junk warnings in cases where the 11805 -- conversion is necessary to establish staticness, for example in 11806 -- a case statement. 11807 11808 if not Is_OK_Static_Subtype (Operand_Typ) 11809 and then Is_OK_Static_Subtype (Target_Typ) 11810 then 11811 null; 11812 11813 -- Finally, if this type conversion occurs in a context requiring 11814 -- a prefix, and the expression is a qualified expression then the 11815 -- type conversion is not redundant, since a qualified expression 11816 -- is not a prefix, whereas a type conversion is. For example, "X 11817 -- := T'(Funx(...)).Y;" is illegal because a selected component 11818 -- requires a prefix, but a type conversion makes it legal: "X := 11819 -- T(T'(Funx(...))).Y;" 11820 11821 -- In Ada 2012, a qualified expression is a name, so this idiom is 11822 -- no longer needed, but we still suppress the warning because it 11823 -- seems unfriendly for warnings to pop up when you switch to the 11824 -- newer language version. 11825 11826 elsif Nkind (Orig_N) = N_Qualified_Expression 11827 and then Nkind (Parent (N)) in N_Attribute_Reference 11828 | N_Indexed_Component 11829 | N_Selected_Component 11830 | N_Slice 11831 | N_Explicit_Dereference 11832 then 11833 null; 11834 11835 -- Never warn on conversion to Long_Long_Integer'Base since 11836 -- that is most likely an artifact of the extended overflow 11837 -- checking and comes from complex expanded code. 11838 11839 elsif Orig_T = Base_Type (Standard_Long_Long_Integer) then 11840 null; 11841 11842 -- Here we give the redundant conversion warning. If it is an 11843 -- entity, give the name of the entity in the message. If not, 11844 -- just mention the expression. 11845 11846 else 11847 if Is_Entity_Name (Orig_N) then 11848 Error_Msg_Node_2 := Orig_T; 11849 Error_Msg_NE -- CODEFIX 11850 ("?r?redundant conversion, & is of type &!", 11851 N, Entity (Orig_N)); 11852 else 11853 Error_Msg_NE 11854 ("?r?redundant conversion, expression is of type&!", 11855 N, Orig_T); 11856 end if; 11857 end if; 11858 end if; 11859 end if; 11860 11861 -- Ada 2005 (AI-251): Handle class-wide interface type conversions. 11862 -- No need to perform any interface conversion if the type of the 11863 -- expression coincides with the target type. 11864 11865 if Ada_Version >= Ada_2005 11866 and then Expander_Active 11867 and then Operand_Typ /= Target_Typ 11868 then 11869 declare 11870 Opnd : Entity_Id := Operand_Typ; 11871 Target : Entity_Id := Target_Typ; 11872 11873 begin 11874 -- If the type of the operand is a limited view, use nonlimited 11875 -- view when available. If it is a class-wide type, recover the 11876 -- class-wide type of the nonlimited view. 11877 11878 if From_Limited_With (Opnd) 11879 and then Has_Non_Limited_View (Opnd) 11880 then 11881 Opnd := Non_Limited_View (Opnd); 11882 Set_Etype (Expression (N), Opnd); 11883 end if; 11884 11885 -- It seems that Non_Limited_View should also be applied for 11886 -- Target when it has a limited view, but that leads to missing 11887 -- error checks on interface conversions further below. ??? 11888 11889 if Is_Access_Type (Opnd) then 11890 Opnd := Designated_Type (Opnd); 11891 11892 -- If the type of the operand is a limited view, use nonlimited 11893 -- view when available. If it is a class-wide type, recover the 11894 -- class-wide type of the nonlimited view. 11895 11896 if From_Limited_With (Opnd) 11897 and then Has_Non_Limited_View (Opnd) 11898 then 11899 Opnd := Non_Limited_View (Opnd); 11900 end if; 11901 end if; 11902 11903 if Is_Access_Type (Target_Typ) then 11904 Target := Designated_Type (Target); 11905 11906 -- If the target type is a limited view, use nonlimited view 11907 -- when available. 11908 11909 if From_Limited_With (Target) 11910 and then Has_Non_Limited_View (Target) 11911 then 11912 Target := Non_Limited_View (Target); 11913 end if; 11914 end if; 11915 11916 if Opnd = Target then 11917 null; 11918 11919 -- Conversion from interface type 11920 11921 -- It seems that it would be better for the error checks below 11922 -- to be performed as part of Validate_Conversion (and maybe some 11923 -- of the error checks above could be moved as well?). ??? 11924 11925 elsif Is_Interface (Opnd) then 11926 11927 -- Ada 2005 (AI-217): Handle entities from limited views 11928 11929 if From_Limited_With (Opnd) then 11930 Error_Msg_Qual_Level := 99; 11931 Error_Msg_NE -- CODEFIX 11932 ("missing WITH clause on package &", N, 11933 Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); 11934 Error_Msg_N 11935 ("type conversions require visibility of the full view", 11936 N); 11937 11938 elsif From_Limited_With (Target) 11939 and then not 11940 (Is_Access_Type (Target_Typ) 11941 and then Present (Non_Limited_View (Etype (Target)))) 11942 then 11943 Error_Msg_Qual_Level := 99; 11944 Error_Msg_NE -- CODEFIX 11945 ("missing WITH clause on package &", N, 11946 Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); 11947 Error_Msg_N 11948 ("type conversions require visibility of the full view", 11949 N); 11950 11951 else 11952 Expand_Interface_Conversion (N); 11953 end if; 11954 11955 -- Conversion to interface type 11956 11957 elsif Is_Interface (Target) then 11958 11959 -- Handle subtypes 11960 11961 if Ekind (Opnd) in E_Protected_Subtype | E_Task_Subtype then 11962 Opnd := Etype (Opnd); 11963 end if; 11964 11965 if Is_Class_Wide_Type (Opnd) 11966 or else Interface_Present_In_Ancestor 11967 (Typ => Opnd, 11968 Iface => Target) 11969 then 11970 Expand_Interface_Conversion (N); 11971 else 11972 Error_Msg_Name_1 := Chars (Etype (Target)); 11973 Error_Msg_Name_2 := Chars (Opnd); 11974 Error_Msg_N 11975 ("wrong interface conversion (% is not a progenitor " 11976 & "of %)", N); 11977 end if; 11978 end if; 11979 end; 11980 end if; 11981 11982 -- Ada 2012: Once the type conversion is resolved, check whether the 11983 -- operand statisfies a static predicate of the target subtype, if any. 11984 -- In the static expression case, a predicate check failure is an error. 11985 11986 if Has_Predicates (Target_Typ) then 11987 Check_Expression_Against_Static_Predicate 11988 (N, Target_Typ, Static_Failure_Is_Error => True); 11989 end if; 11990 11991 -- If at this stage we have a fixed to integer conversion, make sure the 11992 -- Do_Range_Check flag is set, because such conversions in general need 11993 -- a range check. We only need this if expansion is off, see above why. 11994 11995 if Nkind (N) = N_Type_Conversion 11996 and then not Expander_Active 11997 and then Is_Integer_Type (Target_Typ) 11998 and then Is_Fixed_Point_Type (Operand_Typ) 11999 and then not Range_Checks_Suppressed (Target_Typ) 12000 and then not Range_Checks_Suppressed (Operand_Typ) 12001 then 12002 Set_Do_Range_Check (Operand); 12003 end if; 12004 12005 -- Generating C code a type conversion of an access to constrained 12006 -- array type to access to unconstrained array type involves building 12007 -- a fat pointer which in general cannot be generated on the fly. We 12008 -- remove side effects in order to store the result of the conversion 12009 -- into a temporary. 12010 12011 if Modify_Tree_For_C 12012 and then Nkind (N) = N_Type_Conversion 12013 and then Nkind (Parent (N)) /= N_Object_Declaration 12014 and then Is_Access_Type (Etype (N)) 12015 and then Is_Array_Type (Designated_Type (Etype (N))) 12016 and then not Is_Constrained (Designated_Type (Etype (N))) 12017 and then Is_Constrained (Designated_Type (Etype (Expression (N)))) 12018 then 12019 Remove_Side_Effects (N); 12020 end if; 12021 end Resolve_Type_Conversion; 12022 12023 ---------------------- 12024 -- Resolve_Unary_Op -- 12025 ---------------------- 12026 12027 procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is 12028 B_Typ : constant Entity_Id := Base_Type (Typ); 12029 R : constant Node_Id := Right_Opnd (N); 12030 OK : Boolean; 12031 Lo : Uint; 12032 Hi : Uint; 12033 12034 begin 12035 -- Deal with intrinsic unary operators 12036 12037 if Comes_From_Source (N) 12038 and then Ekind (Entity (N)) = E_Function 12039 and then Is_Imported (Entity (N)) 12040 and then Is_Intrinsic_Subprogram (Entity (N)) 12041 then 12042 Resolve_Intrinsic_Unary_Operator (N, Typ); 12043 return; 12044 end if; 12045 12046 -- Deal with universal cases 12047 12048 if Etype (R) = Universal_Integer 12049 or else 12050 Etype (R) = Universal_Real 12051 then 12052 Check_For_Visible_Operator (N, B_Typ); 12053 end if; 12054 12055 Set_Etype (N, B_Typ); 12056 Resolve (R, B_Typ); 12057 12058 -- Generate warning for expressions like abs (x mod 2) 12059 12060 if Warn_On_Redundant_Constructs 12061 and then Nkind (N) = N_Op_Abs 12062 then 12063 Determine_Range (Right_Opnd (N), OK, Lo, Hi); 12064 12065 if OK and then Hi >= Lo and then Lo >= 0 then 12066 Error_Msg_N -- CODEFIX 12067 ("?r?abs applied to known non-negative value has no effect", N); 12068 end if; 12069 end if; 12070 12071 -- Deal with reference generation 12072 12073 Check_Unset_Reference (R); 12074 Generate_Operator_Reference (N, B_Typ); 12075 Analyze_Dimension (N); 12076 Eval_Unary_Op (N); 12077 12078 -- Set overflow checking bit. Much cleverer code needed here eventually 12079 -- and perhaps the Resolve routines should be separated for the various 12080 -- arithmetic operations, since they will need different processing ??? 12081 12082 if Nkind (N) in N_Op then 12083 if not Overflow_Checks_Suppressed (Etype (N)) then 12084 Enable_Overflow_Check (N); 12085 end if; 12086 end if; 12087 12088 -- Generate warning for expressions like -5 mod 3 for integers. No need 12089 -- to worry in the floating-point case, since parens do not affect the 12090 -- result so there is no point in giving in a warning. 12091 12092 declare 12093 Norig : constant Node_Id := Original_Node (N); 12094 Rorig : Node_Id; 12095 Val : Uint; 12096 HB : Uint; 12097 LB : Uint; 12098 Lval : Uint; 12099 Opnd : Node_Id; 12100 12101 begin 12102 if Warn_On_Questionable_Missing_Parens 12103 and then Comes_From_Source (Norig) 12104 and then Is_Integer_Type (Typ) 12105 and then Nkind (Norig) = N_Op_Minus 12106 then 12107 Rorig := Original_Node (Right_Opnd (Norig)); 12108 12109 -- We are looking for cases where the right operand is not 12110 -- parenthesized, and is a binary operator, multiply, divide, or 12111 -- mod. These are the cases where the grouping can affect results. 12112 12113 if Paren_Count (Rorig) = 0 12114 and then Nkind (Rorig) in N_Op_Mod | N_Op_Multiply | N_Op_Divide 12115 then 12116 -- For mod, we always give the warning, since the value is 12117 -- affected by the parenthesization (e.g. (-5) mod 315 /= 12118 -- -(5 mod 315)). But for the other cases, the only concern is 12119 -- overflow, e.g. for the case of 8 big signed (-(2 * 64) 12120 -- overflows, but (-2) * 64 does not). So we try to give the 12121 -- message only when overflow is possible. 12122 12123 if Nkind (Rorig) /= N_Op_Mod 12124 and then Compile_Time_Known_Value (R) 12125 then 12126 Val := Expr_Value (R); 12127 12128 if Compile_Time_Known_Value (Type_High_Bound (Typ)) then 12129 HB := Expr_Value (Type_High_Bound (Typ)); 12130 else 12131 HB := Expr_Value (Type_High_Bound (Base_Type (Typ))); 12132 end if; 12133 12134 if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then 12135 LB := Expr_Value (Type_Low_Bound (Typ)); 12136 else 12137 LB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); 12138 end if; 12139 12140 -- Note that the test below is deliberately excluding the 12141 -- largest negative number, since that is a potentially 12142 -- troublesome case (e.g. -2 * x, where the result is the 12143 -- largest negative integer has an overflow with 2 * x). 12144 12145 if Val > LB and then Val <= HB then 12146 return; 12147 end if; 12148 end if; 12149 12150 -- For the multiplication case, the only case we have to worry 12151 -- about is when (-a)*b is exactly the largest negative number 12152 -- so that -(a*b) can cause overflow. This can only happen if 12153 -- a is a power of 2, and more generally if any operand is a 12154 -- constant that is not a power of 2, then the parentheses 12155 -- cannot affect whether overflow occurs. We only bother to 12156 -- test the left most operand 12157 12158 -- Loop looking at left operands for one that has known value 12159 12160 Opnd := Rorig; 12161 Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop 12162 if Compile_Time_Known_Value (Left_Opnd (Opnd)) then 12163 Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd))); 12164 12165 -- Operand value of 0 or 1 skips warning 12166 12167 if Lval <= 1 then 12168 return; 12169 12170 -- Otherwise check power of 2, if power of 2, warn, if 12171 -- anything else, skip warning. 12172 12173 else 12174 while Lval /= 2 loop 12175 if Lval mod 2 = 1 then 12176 return; 12177 else 12178 Lval := Lval / 2; 12179 end if; 12180 end loop; 12181 12182 exit Opnd_Loop; 12183 end if; 12184 end if; 12185 12186 -- Keep looking at left operands 12187 12188 Opnd := Left_Opnd (Opnd); 12189 end loop Opnd_Loop; 12190 12191 -- For rem or "/" we can only have a problematic situation 12192 -- if the divisor has a value of minus one or one. Otherwise 12193 -- overflow is impossible (divisor > 1) or we have a case of 12194 -- division by zero in any case. 12195 12196 if Nkind (Rorig) in N_Op_Divide | N_Op_Rem 12197 and then Compile_Time_Known_Value (Right_Opnd (Rorig)) 12198 and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 12199 then 12200 return; 12201 end if; 12202 12203 -- If we fall through warning should be issued 12204 12205 -- Shouldn't we test Warn_On_Questionable_Missing_Parens ??? 12206 12207 Error_Msg_N 12208 ("??unary minus expression should be parenthesized here!", N); 12209 end if; 12210 end if; 12211 end; 12212 end Resolve_Unary_Op; 12213 12214 ---------------------------------- 12215 -- Resolve_Unchecked_Expression -- 12216 ---------------------------------- 12217 12218 procedure Resolve_Unchecked_Expression 12219 (N : Node_Id; 12220 Typ : Entity_Id) 12221 is 12222 begin 12223 Resolve (Expression (N), Typ, Suppress => All_Checks); 12224 Set_Etype (N, Typ); 12225 end Resolve_Unchecked_Expression; 12226 12227 --------------------------------------- 12228 -- Resolve_Unchecked_Type_Conversion -- 12229 --------------------------------------- 12230 12231 procedure Resolve_Unchecked_Type_Conversion 12232 (N : Node_Id; 12233 Typ : Entity_Id) 12234 is 12235 pragma Warnings (Off, Typ); 12236 12237 Operand : constant Node_Id := Expression (N); 12238 Opnd_Type : constant Entity_Id := Etype (Operand); 12239 12240 begin 12241 -- Resolve operand using its own type 12242 12243 Resolve (Operand, Opnd_Type); 12244 12245 -- If the expression is a conversion to universal integer of an 12246 -- an expression with an integer type, then we can eliminate the 12247 -- intermediate conversion to universal integer. 12248 12249 if Nkind (Operand) = N_Type_Conversion 12250 and then Entity (Subtype_Mark (Operand)) = Universal_Integer 12251 and then Is_Integer_Type (Etype (Expression (Operand))) 12252 then 12253 Rewrite (Operand, Relocate_Node (Expression (Operand))); 12254 Analyze_And_Resolve (Operand); 12255 end if; 12256 12257 -- In an inlined context, the unchecked conversion may be applied 12258 -- to a literal, in which case its type is the type of the context. 12259 -- (In other contexts conversions cannot apply to literals). 12260 12261 if In_Inlined_Body 12262 and then (Opnd_Type = Any_Character or else 12263 Opnd_Type = Any_Integer or else 12264 Opnd_Type = Any_Real) 12265 then 12266 Set_Etype (Operand, Typ); 12267 end if; 12268 12269 Analyze_Dimension (N); 12270 Eval_Unchecked_Conversion (N); 12271 end Resolve_Unchecked_Type_Conversion; 12272 12273 ------------------------------ 12274 -- Rewrite_Operator_As_Call -- 12275 ------------------------------ 12276 12277 procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is 12278 Loc : constant Source_Ptr := Sloc (N); 12279 Actuals : constant List_Id := New_List; 12280 New_N : Node_Id; 12281 12282 begin 12283 if Nkind (N) in N_Binary_Op then 12284 Append (Left_Opnd (N), Actuals); 12285 end if; 12286 12287 Append (Right_Opnd (N), Actuals); 12288 12289 New_N := 12290 Make_Function_Call (Sloc => Loc, 12291 Name => New_Occurrence_Of (Nam, Loc), 12292 Parameter_Associations => Actuals); 12293 12294 Preserve_Comes_From_Source (New_N, N); 12295 Preserve_Comes_From_Source (Name (New_N), N); 12296 Rewrite (N, New_N); 12297 Set_Etype (N, Etype (Nam)); 12298 end Rewrite_Operator_As_Call; 12299 12300 ------------------------------ 12301 -- Rewrite_Renamed_Operator -- 12302 ------------------------------ 12303 12304 procedure Rewrite_Renamed_Operator 12305 (N : Node_Id; 12306 Op : Entity_Id; 12307 Typ : Entity_Id) 12308 is 12309 Nam : constant Name_Id := Chars (Op); 12310 Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op; 12311 Op_Node : Node_Id; 12312 12313 begin 12314 -- Do not perform this transformation within a pre/postcondition, 12315 -- because the expression will be reanalyzed, and the transformation 12316 -- might affect the visibility of the operator, e.g. in an instance. 12317 -- Note that fully analyzed and expanded pre/postconditions appear as 12318 -- pragma Check equivalents. 12319 12320 if In_Pre_Post_Condition (N) then 12321 return; 12322 end if; 12323 12324 -- Likewise when an expression function is being preanalyzed, since the 12325 -- expression will be reanalyzed as part of the generated body. 12326 12327 if In_Spec_Expression then 12328 declare 12329 S : constant Entity_Id := Current_Scope_No_Loops; 12330 begin 12331 if Ekind (S) = E_Function 12332 and then Nkind (Original_Node (Unit_Declaration_Node (S))) = 12333 N_Expression_Function 12334 then 12335 return; 12336 end if; 12337 end; 12338 end if; 12339 12340 -- Rewrite the operator node using the real operator, not its renaming. 12341 -- Exclude user-defined intrinsic operations of the same name, which are 12342 -- treated separately and rewritten as calls. 12343 12344 if Ekind (Op) /= E_Function or else Chars (N) /= Nam then 12345 Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); 12346 Set_Chars (Op_Node, Nam); 12347 Set_Etype (Op_Node, Etype (N)); 12348 Set_Entity (Op_Node, Op); 12349 Set_Right_Opnd (Op_Node, Right_Opnd (N)); 12350 12351 -- Indicate that both the original entity and its renaming are 12352 -- referenced at this point. 12353 12354 Generate_Reference (Entity (N), N); 12355 Generate_Reference (Op, N); 12356 12357 if Is_Binary then 12358 Set_Left_Opnd (Op_Node, Left_Opnd (N)); 12359 end if; 12360 12361 Rewrite (N, Op_Node); 12362 12363 -- If the context type is private, add the appropriate conversions so 12364 -- that the operator is applied to the full view. This is done in the 12365 -- routines that resolve intrinsic operators. 12366 12367 if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) then 12368 case Nkind (N) is 12369 when N_Op_Add 12370 | N_Op_Divide 12371 | N_Op_Expon 12372 | N_Op_Mod 12373 | N_Op_Multiply 12374 | N_Op_Rem 12375 | N_Op_Subtract 12376 => 12377 Resolve_Intrinsic_Operator (N, Typ); 12378 12379 when N_Op_Abs 12380 | N_Op_Minus 12381 | N_Op_Plus 12382 => 12383 Resolve_Intrinsic_Unary_Operator (N, Typ); 12384 12385 when others => 12386 Resolve (N, Typ); 12387 end case; 12388 end if; 12389 12390 elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then 12391 12392 -- Operator renames a user-defined operator of the same name. Use the 12393 -- original operator in the node, which is the one Gigi knows about. 12394 12395 Set_Entity (N, Op); 12396 Set_Is_Overloaded (N, False); 12397 end if; 12398 end Rewrite_Renamed_Operator; 12399 12400 ----------------------- 12401 -- Set_Slice_Subtype -- 12402 ----------------------- 12403 12404 -- Build an implicit subtype declaration to represent the type delivered by 12405 -- the slice. This is an abbreviated version of an array subtype. We define 12406 -- an index subtype for the slice, using either the subtype name or the 12407 -- discrete range of the slice. To be consistent with index usage elsewhere 12408 -- we create a list header to hold the single index. This list is not 12409 -- otherwise attached to the syntax tree. 12410 12411 procedure Set_Slice_Subtype (N : Node_Id) is 12412 Loc : constant Source_Ptr := Sloc (N); 12413 Index_List : constant List_Id := New_List; 12414 Index : Node_Id; 12415 Index_Subtype : Entity_Id; 12416 Index_Type : Entity_Id; 12417 Slice_Subtype : Entity_Id; 12418 Drange : constant Node_Id := Discrete_Range (N); 12419 12420 begin 12421 Index_Type := Base_Type (Etype (Drange)); 12422 12423 if Is_Entity_Name (Drange) then 12424 Index_Subtype := Entity (Drange); 12425 12426 else 12427 -- We force the evaluation of a range. This is definitely needed in 12428 -- the renamed case, and seems safer to do unconditionally. Note in 12429 -- any case that since we will create and insert an Itype referring 12430 -- to this range, we must make sure any side effect removal actions 12431 -- are inserted before the Itype definition. 12432 12433 if Nkind (Drange) = N_Range then 12434 Force_Evaluation (Low_Bound (Drange)); 12435 Force_Evaluation (High_Bound (Drange)); 12436 12437 -- If the discrete range is given by a subtype indication, the 12438 -- type of the slice is the base of the subtype mark. 12439 12440 elsif Nkind (Drange) = N_Subtype_Indication then 12441 declare 12442 R : constant Node_Id := Range_Expression (Constraint (Drange)); 12443 begin 12444 Index_Type := Base_Type (Entity (Subtype_Mark (Drange))); 12445 Force_Evaluation (Low_Bound (R)); 12446 Force_Evaluation (High_Bound (R)); 12447 end; 12448 end if; 12449 12450 Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); 12451 12452 -- Take a new copy of Drange (where bounds have been rewritten to 12453 -- reference side-effect-free names). Using a separate tree ensures 12454 -- that further expansion (e.g. while rewriting a slice assignment 12455 -- into a FOR loop) does not attempt to remove side effects on the 12456 -- bounds again (which would cause the bounds in the index subtype 12457 -- definition to refer to temporaries before they are defined) (the 12458 -- reason is that some names are considered side effect free here 12459 -- for the subtype, but not in the context of a loop iteration 12460 -- scheme). 12461 12462 Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange)); 12463 Set_Parent (Scalar_Range (Index_Subtype), Index_Subtype); 12464 Set_Etype (Index_Subtype, Index_Type); 12465 Set_Size_Info (Index_Subtype, Index_Type); 12466 Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); 12467 Set_Is_Constrained (Index_Subtype); 12468 end if; 12469 12470 Slice_Subtype := Create_Itype (E_Array_Subtype, N); 12471 12472 Index := New_Occurrence_Of (Index_Subtype, Loc); 12473 Set_Etype (Index, Index_Subtype); 12474 Append (Index, Index_List); 12475 12476 Set_First_Index (Slice_Subtype, Index); 12477 Set_Etype (Slice_Subtype, Base_Type (Etype (N))); 12478 Set_Is_Constrained (Slice_Subtype, True); 12479 12480 Check_Compile_Time_Size (Slice_Subtype); 12481 12482 -- The Etype of the existing Slice node is reset to this slice subtype. 12483 -- Its bounds are obtained from its first index. 12484 12485 Set_Etype (N, Slice_Subtype); 12486 12487 -- For bit-packed slice subtypes, freeze immediately (except in the case 12488 -- of being in a "spec expression" where we never freeze when we first 12489 -- see the expression). 12490 12491 if Is_Bit_Packed_Array (Slice_Subtype) and not In_Spec_Expression then 12492 Freeze_Itype (Slice_Subtype, N); 12493 12494 -- For all other cases insert an itype reference in the slice's actions 12495 -- so that the itype is frozen at the proper place in the tree (i.e. at 12496 -- the point where actions for the slice are analyzed). Note that this 12497 -- is different from freezing the itype immediately, which might be 12498 -- premature (e.g. if the slice is within a transient scope). This needs 12499 -- to be done only if expansion is enabled, or in GNATprove mode to 12500 -- capture the associated run-time exceptions if any. 12501 12502 elsif Expander_Active or GNATprove_Mode then 12503 Ensure_Defined (Typ => Slice_Subtype, N => N); 12504 end if; 12505 end Set_Slice_Subtype; 12506 12507 -------------------------------- 12508 -- Set_String_Literal_Subtype -- 12509 -------------------------------- 12510 12511 procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is 12512 Loc : constant Source_Ptr := Sloc (N); 12513 Low_Bound : constant Node_Id := 12514 Type_Low_Bound (Etype (First_Index (Typ))); 12515 Subtype_Id : Entity_Id; 12516 12517 begin 12518 if Nkind (N) /= N_String_Literal then 12519 return; 12520 end if; 12521 12522 Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); 12523 Set_String_Literal_Length (Subtype_Id, UI_From_Int 12524 (String_Length (Strval (N)))); 12525 Set_Etype (Subtype_Id, Base_Type (Typ)); 12526 Set_Is_Constrained (Subtype_Id); 12527 Set_Etype (N, Subtype_Id); 12528 12529 -- The low bound is set from the low bound of the corresponding index 12530 -- type. Note that we do not store the high bound in the string literal 12531 -- subtype, but it can be deduced if necessary from the length and the 12532 -- low bound. 12533 12534 if Is_OK_Static_Expression (Low_Bound) then 12535 Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); 12536 12537 -- If the lower bound is not static we create a range for the string 12538 -- literal, using the index type and the known length of the literal. 12539 -- If the length is 1, then the upper bound is set to a mere copy of 12540 -- the lower bound; or else, if the index type is a signed integer, 12541 -- then the upper bound is computed as Low_Bound + L - 1; otherwise, 12542 -- the upper bound is computed as T'Val (T'Pos (Low_Bound) + L - 1). 12543 12544 else 12545 declare 12546 Length : constant Nat := String_Length (Strval (N)); 12547 Index_List : constant List_Id := New_List; 12548 Index_Type : constant Entity_Id := Etype (First_Index (Typ)); 12549 Array_Subtype : Entity_Id; 12550 Drange : Node_Id; 12551 High_Bound : Node_Id; 12552 Index : Node_Id; 12553 Index_Subtype : Entity_Id; 12554 12555 begin 12556 if Length = 1 then 12557 High_Bound := New_Copy_Tree (Low_Bound); 12558 12559 elsif Is_Signed_Integer_Type (Index_Type) then 12560 High_Bound := 12561 Make_Op_Add (Loc, 12562 Left_Opnd => New_Copy_Tree (Low_Bound), 12563 Right_Opnd => Make_Integer_Literal (Loc, Length - 1)); 12564 12565 else 12566 High_Bound := 12567 Make_Attribute_Reference (Loc, 12568 Attribute_Name => Name_Val, 12569 Prefix => 12570 New_Occurrence_Of (Index_Type, Loc), 12571 Expressions => New_List ( 12572 Make_Op_Add (Loc, 12573 Left_Opnd => 12574 Make_Attribute_Reference (Loc, 12575 Attribute_Name => Name_Pos, 12576 Prefix => 12577 New_Occurrence_Of (Index_Type, Loc), 12578 Expressions => 12579 New_List (New_Copy_Tree (Low_Bound))), 12580 Right_Opnd => 12581 Make_Integer_Literal (Loc, Length - 1)))); 12582 end if; 12583 12584 if Is_Integer_Type (Index_Type) then 12585 Set_String_Literal_Low_Bound 12586 (Subtype_Id, Make_Integer_Literal (Loc, 1)); 12587 12588 else 12589 -- If the index type is an enumeration type, build bounds 12590 -- expression with attributes. 12591 12592 Set_String_Literal_Low_Bound 12593 (Subtype_Id, 12594 Make_Attribute_Reference (Loc, 12595 Attribute_Name => Name_First, 12596 Prefix => 12597 New_Occurrence_Of (Base_Type (Index_Type), Loc))); 12598 end if; 12599 12600 Analyze_And_Resolve 12601 (String_Literal_Low_Bound (Subtype_Id), Base_Type (Index_Type)); 12602 12603 -- Build bona fide subtype for the string, and wrap it in an 12604 -- unchecked conversion, because the back end expects the 12605 -- String_Literal_Subtype to have a static lower bound. 12606 12607 Index_Subtype := 12608 Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); 12609 Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound); 12610 Set_Scalar_Range (Index_Subtype, Drange); 12611 Set_Parent (Drange, N); 12612 Analyze_And_Resolve (Drange, Index_Type); 12613 12614 -- In this context, the Index_Type may already have a constraint, 12615 -- so use common base type on string subtype. The base type may 12616 -- be used when generating attributes of the string, for example 12617 -- in the context of a slice assignment. 12618 12619 Set_Etype (Index_Subtype, Base_Type (Index_Type)); 12620 Set_Size_Info (Index_Subtype, Index_Type); 12621 Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); 12622 12623 Array_Subtype := Create_Itype (E_Array_Subtype, N); 12624 12625 Index := New_Occurrence_Of (Index_Subtype, Loc); 12626 Set_Etype (Index, Index_Subtype); 12627 Append (Index, Index_List); 12628 12629 Set_First_Index (Array_Subtype, Index); 12630 Set_Etype (Array_Subtype, Base_Type (Typ)); 12631 Set_Is_Constrained (Array_Subtype, True); 12632 12633 Rewrite (N, 12634 Make_Unchecked_Type_Conversion (Loc, 12635 Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc), 12636 Expression => Relocate_Node (N))); 12637 Set_Etype (N, Array_Subtype); 12638 end; 12639 end if; 12640 end Set_String_Literal_Subtype; 12641 12642 ------------------------------ 12643 -- Simplify_Type_Conversion -- 12644 ------------------------------ 12645 12646 procedure Simplify_Type_Conversion (N : Node_Id) is 12647 begin 12648 if Nkind (N) = N_Type_Conversion then 12649 declare 12650 Operand : constant Node_Id := Expression (N); 12651 Target_Typ : constant Entity_Id := Etype (N); 12652 Opnd_Typ : constant Entity_Id := Etype (Operand); 12653 12654 begin 12655 -- Special processing if the conversion is the expression of a 12656 -- Rounding or Truncation attribute reference. In this case we 12657 -- replace: 12658 12659 -- ityp (ftyp'Rounding (x)) or ityp (ftyp'Truncation (x)) 12660 12661 -- by 12662 12663 -- ityp (x) 12664 12665 -- with the Float_Truncate flag set to False or True respectively, 12666 -- which is more efficient. We reuse Rounding for Machine_Rounding 12667 -- as System.Fat_Gen, which is a permissible behavior. 12668 12669 if Is_Floating_Point_Type (Opnd_Typ) 12670 and then 12671 (Is_Integer_Type (Target_Typ) 12672 or else (Is_Fixed_Point_Type (Target_Typ) 12673 and then Conversion_OK (N))) 12674 and then Nkind (Operand) = N_Attribute_Reference 12675 and then Attribute_Name (Operand) in Name_Rounding 12676 | Name_Machine_Rounding 12677 | Name_Truncation 12678 then 12679 declare 12680 Truncate : constant Boolean := 12681 Attribute_Name (Operand) = Name_Truncation; 12682 begin 12683 Rewrite (Operand, 12684 Relocate_Node (First (Expressions (Operand)))); 12685 Set_Float_Truncate (N, Truncate); 12686 end; 12687 12688 -- Special processing for the conversion of an integer literal to 12689 -- a dynamic type: we first convert the literal to the root type 12690 -- and then convert the result to the target type, the goal being 12691 -- to avoid doing range checks in universal integer. 12692 12693 elsif Is_Integer_Type (Target_Typ) 12694 and then not Is_Generic_Type (Root_Type (Target_Typ)) 12695 and then Nkind (Operand) = N_Integer_Literal 12696 and then Opnd_Typ = Universal_Integer 12697 then 12698 Convert_To_And_Rewrite (Root_Type (Target_Typ), Operand); 12699 Analyze_And_Resolve (Operand); 12700 12701 -- If the expression is a conversion to universal integer of an 12702 -- an expression with an integer type, then we can eliminate the 12703 -- intermediate conversion to universal integer. 12704 12705 elsif Nkind (Operand) = N_Type_Conversion 12706 and then Entity (Subtype_Mark (Operand)) = Universal_Integer 12707 and then Is_Integer_Type (Etype (Expression (Operand))) 12708 then 12709 Rewrite (Operand, Relocate_Node (Expression (Operand))); 12710 Analyze_And_Resolve (Operand); 12711 end if; 12712 end; 12713 end if; 12714 end Simplify_Type_Conversion; 12715 12716 ----------------------------- 12717 -- Unique_Fixed_Point_Type -- 12718 ----------------------------- 12719 12720 function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is 12721 procedure Fixed_Point_Error (T1 : Entity_Id; T2 : Entity_Id); 12722 -- Give error messages for true ambiguity. Messages are posted on node 12723 -- N, and entities T1, T2 are the possible interpretations. 12724 12725 ----------------------- 12726 -- Fixed_Point_Error -- 12727 ----------------------- 12728 12729 procedure Fixed_Point_Error (T1 : Entity_Id; T2 : Entity_Id) is 12730 begin 12731 Error_Msg_N ("ambiguous universal_fixed_expression", N); 12732 Error_Msg_NE ("\\possible interpretation as}", N, T1); 12733 Error_Msg_NE ("\\possible interpretation as}", N, T2); 12734 end Fixed_Point_Error; 12735 12736 -- Local variables 12737 12738 ErrN : Node_Id; 12739 Item : Node_Id; 12740 Scop : Entity_Id; 12741 T1 : Entity_Id; 12742 T2 : Entity_Id; 12743 12744 -- Start of processing for Unique_Fixed_Point_Type 12745 12746 begin 12747 -- The operations on Duration are visible, so Duration is always a 12748 -- possible interpretation. 12749 12750 T1 := Standard_Duration; 12751 12752 -- Look for fixed-point types in enclosing scopes 12753 12754 Scop := Current_Scope; 12755 while Scop /= Standard_Standard loop 12756 T2 := First_Entity (Scop); 12757 while Present (T2) loop 12758 if Is_Fixed_Point_Type (T2) 12759 and then Current_Entity (T2) = T2 12760 and then Scope (Base_Type (T2)) = Scop 12761 then 12762 if Present (T1) then 12763 Fixed_Point_Error (T1, T2); 12764 return Any_Type; 12765 else 12766 T1 := T2; 12767 end if; 12768 end if; 12769 12770 Next_Entity (T2); 12771 end loop; 12772 12773 Scop := Scope (Scop); 12774 end loop; 12775 12776 -- Look for visible fixed type declarations in the context 12777 12778 Item := First (Context_Items (Cunit (Current_Sem_Unit))); 12779 while Present (Item) loop 12780 if Nkind (Item) = N_With_Clause then 12781 Scop := Entity (Name (Item)); 12782 T2 := First_Entity (Scop); 12783 while Present (T2) loop 12784 if Is_Fixed_Point_Type (T2) 12785 and then Scope (Base_Type (T2)) = Scop 12786 and then (Is_Potentially_Use_Visible (T2) or else In_Use (T2)) 12787 then 12788 if Present (T1) then 12789 Fixed_Point_Error (T1, T2); 12790 return Any_Type; 12791 else 12792 T1 := T2; 12793 end if; 12794 end if; 12795 12796 Next_Entity (T2); 12797 end loop; 12798 end if; 12799 12800 Next (Item); 12801 end loop; 12802 12803 if Nkind (N) = N_Real_Literal then 12804 Error_Msg_NE ("??real literal interpreted as }!", N, T1); 12805 12806 else 12807 -- When the context is a type conversion, issue the warning on the 12808 -- expression of the conversion because it is the actual operation. 12809 12810 if Nkind (N) in N_Type_Conversion | N_Unchecked_Type_Conversion then 12811 ErrN := Expression (N); 12812 else 12813 ErrN := N; 12814 end if; 12815 12816 Error_Msg_NE 12817 ("??universal_fixed expression interpreted as }!", ErrN, T1); 12818 end if; 12819 12820 return T1; 12821 end Unique_Fixed_Point_Type; 12822 12823 ---------------------- 12824 -- Valid_Conversion -- 12825 ---------------------- 12826 12827 function Valid_Conversion 12828 (N : Node_Id; 12829 Target : Entity_Id; 12830 Operand : Node_Id; 12831 Report_Errs : Boolean := True) return Boolean 12832 is 12833 Target_Type : constant Entity_Id := Base_Type (Target); 12834 Opnd_Type : Entity_Id := Etype (Operand); 12835 Inc_Ancestor : Entity_Id; 12836 12837 function Conversion_Check 12838 (Valid : Boolean; 12839 Msg : String) return Boolean; 12840 -- Little routine to post Msg if Valid is False, returns Valid value 12841 12842 procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id); 12843 -- If Report_Errs, then calls Errout.Error_Msg_N with its arguments 12844 12845 procedure Conversion_Error_NE 12846 (Msg : String; 12847 N : Node_Or_Entity_Id; 12848 E : Node_Or_Entity_Id); 12849 -- If Report_Errs, then calls Errout.Error_Msg_NE with its arguments 12850 12851 function In_Instance_Code return Boolean; 12852 -- Return True if expression is within an instance but is not in one of 12853 -- the actuals of the instantiation. Type conversions within an instance 12854 -- are not rechecked because type visbility may lead to spurious errors, 12855 -- but conversions in an actual for a formal object must be checked. 12856 12857 function Is_Discrim_Of_Bad_Access_Conversion_Argument 12858 (Expr : Node_Id) return Boolean; 12859 -- Implicit anonymous-to-named access type conversions are not allowed 12860 -- if the "statically deeper than" relationship does not apply to the 12861 -- type of the conversion operand. See RM 8.6(28.1) and AARM 8.6(28.d). 12862 -- We deal with most such cases elsewhere so that we can emit more 12863 -- specific error messages (e.g., if the operand is an access parameter 12864 -- or a saooaaat (stand-alone object of an anonymous access type)), but 12865 -- here is where we catch the case where the operand is an access 12866 -- discriminant selected from a dereference of another such "bad" 12867 -- conversion argument. 12868 12869 function Valid_Tagged_Conversion 12870 (Target_Type : Entity_Id; 12871 Opnd_Type : Entity_Id) return Boolean; 12872 -- Specifically test for validity of tagged conversions 12873 12874 function Valid_Array_Conversion return Boolean; 12875 -- Check index and component conformance, and accessibility levels if 12876 -- the component types are anonymous access types (Ada 2005). 12877 12878 ---------------------- 12879 -- Conversion_Check -- 12880 ---------------------- 12881 12882 function Conversion_Check 12883 (Valid : Boolean; 12884 Msg : String) return Boolean 12885 is 12886 begin 12887 if not Valid 12888 12889 -- A generic unit has already been analyzed and we have verified 12890 -- that a particular conversion is OK in that context. Since the 12891 -- instance is reanalyzed without relying on the relationships 12892 -- established during the analysis of the generic, it is possible 12893 -- to end up with inconsistent views of private types. Do not emit 12894 -- the error message in such cases. The rest of the machinery in 12895 -- Valid_Conversion still ensures the proper compatibility of 12896 -- target and operand types. 12897 12898 and then not In_Instance_Code 12899 then 12900 Conversion_Error_N (Msg, Operand); 12901 end if; 12902 12903 return Valid; 12904 end Conversion_Check; 12905 12906 ------------------------ 12907 -- Conversion_Error_N -- 12908 ------------------------ 12909 12910 procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id) is 12911 begin 12912 if Report_Errs then 12913 Error_Msg_N (Msg, N); 12914 end if; 12915 end Conversion_Error_N; 12916 12917 ------------------------- 12918 -- Conversion_Error_NE -- 12919 ------------------------- 12920 12921 procedure Conversion_Error_NE 12922 (Msg : String; 12923 N : Node_Or_Entity_Id; 12924 E : Node_Or_Entity_Id) 12925 is 12926 begin 12927 if Report_Errs then 12928 Error_Msg_NE (Msg, N, E); 12929 end if; 12930 end Conversion_Error_NE; 12931 12932 ---------------------- 12933 -- In_Instance_Code -- 12934 ---------------------- 12935 12936 function In_Instance_Code return Boolean is 12937 Par : Node_Id; 12938 12939 begin 12940 if not In_Instance then 12941 return False; 12942 12943 else 12944 Par := Parent (N); 12945 while Present (Par) loop 12946 12947 -- The expression is part of an actual object if it appears in 12948 -- the generated object declaration in the instance. 12949 12950 if Nkind (Par) = N_Object_Declaration 12951 and then Present (Corresponding_Generic_Association (Par)) 12952 then 12953 return False; 12954 12955 else 12956 exit when 12957 Nkind (Par) in N_Statement_Other_Than_Procedure_Call 12958 or else Nkind (Par) in N_Subprogram_Call 12959 or else Nkind (Par) in N_Declaration; 12960 end if; 12961 12962 Par := Parent (Par); 12963 end loop; 12964 12965 -- Otherwise the expression appears within the instantiated unit 12966 12967 return True; 12968 end if; 12969 end In_Instance_Code; 12970 12971 -------------------------------------------------- 12972 -- Is_Discrim_Of_Bad_Access_Conversion_Argument -- 12973 -------------------------------------------------- 12974 12975 function Is_Discrim_Of_Bad_Access_Conversion_Argument 12976 (Expr : Node_Id) return Boolean 12977 is 12978 Exp_Type : Entity_Id := Base_Type (Etype (Expr)); 12979 pragma Assert (Is_Access_Type (Exp_Type)); 12980 12981 Associated_Node : Node_Id; 12982 Deref_Prefix : Node_Id; 12983 begin 12984 if not Is_Anonymous_Access_Type (Exp_Type) then 12985 return False; 12986 end if; 12987 12988 pragma Assert (Is_Itype (Exp_Type)); 12989 Associated_Node := Associated_Node_For_Itype (Exp_Type); 12990 12991 if Nkind (Associated_Node) /= N_Discriminant_Specification then 12992 return False; -- not the type of an access discriminant 12993 end if; 12994 12995 -- return False if Expr not of form <prefix>.all.Some_Component 12996 12997 if (Nkind (Expr) /= N_Selected_Component) 12998 or else (Nkind (Prefix (Expr)) /= N_Explicit_Dereference) 12999 then 13000 -- conditional expressions, declare expressions ??? 13001 return False; 13002 end if; 13003 13004 Deref_Prefix := Prefix (Prefix (Expr)); 13005 Exp_Type := Base_Type (Etype (Deref_Prefix)); 13006 13007 -- The "statically deeper relationship" does not apply 13008 -- to generic formal access types, so a prefix of such 13009 -- a type is a "bad" prefix. 13010 13011 if Is_Generic_Formal (Exp_Type) then 13012 return True; 13013 13014 -- The "statically deeper relationship" does apply to 13015 -- any other named access type. 13016 13017 elsif not Is_Anonymous_Access_Type (Exp_Type) then 13018 return False; 13019 end if; 13020 13021 pragma Assert (Is_Itype (Exp_Type)); 13022 Associated_Node := Associated_Node_For_Itype (Exp_Type); 13023 13024 -- The "statically deeper relationship" applies to some 13025 -- anonymous access types and not to others. Return 13026 -- True for the cases where it does not apply. Also check 13027 -- recursively for the 13028 -- <prefix>.all.Access_Discrim.all.Access_Discrim case, 13029 -- where the correct result depends on <prefix>. 13030 13031 return Nkind (Associated_Node) in 13032 N_Procedure_Specification | -- access parameter 13033 N_Function_Specification | -- access parameter 13034 N_Object_Declaration -- saooaaat 13035 or else Is_Discrim_Of_Bad_Access_Conversion_Argument (Deref_Prefix); 13036 end Is_Discrim_Of_Bad_Access_Conversion_Argument; 13037 13038 ---------------------------- 13039 -- Valid_Array_Conversion -- 13040 ---------------------------- 13041 13042 function Valid_Array_Conversion return Boolean is 13043 Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type); 13044 Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type); 13045 13046 Opnd_Index : Node_Id; 13047 Opnd_Index_Type : Entity_Id; 13048 13049 Target_Comp_Type : constant Entity_Id := 13050 Component_Type (Target_Type); 13051 Target_Comp_Base : constant Entity_Id := 13052 Base_Type (Target_Comp_Type); 13053 13054 Target_Index : Node_Id; 13055 Target_Index_Type : Entity_Id; 13056 13057 begin 13058 -- Error if wrong number of dimensions 13059 13060 if 13061 Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type) 13062 then 13063 Conversion_Error_N 13064 ("incompatible number of dimensions for conversion", Operand); 13065 return False; 13066 13067 -- Number of dimensions matches 13068 13069 else 13070 -- Loop through indexes of the two arrays 13071 13072 Target_Index := First_Index (Target_Type); 13073 Opnd_Index := First_Index (Opnd_Type); 13074 while Present (Target_Index) and then Present (Opnd_Index) loop 13075 Target_Index_Type := Etype (Target_Index); 13076 Opnd_Index_Type := Etype (Opnd_Index); 13077 13078 -- Error if index types are incompatible 13079 13080 if not (Is_Integer_Type (Target_Index_Type) 13081 and then Is_Integer_Type (Opnd_Index_Type)) 13082 and then (Root_Type (Target_Index_Type) 13083 /= Root_Type (Opnd_Index_Type)) 13084 then 13085 Conversion_Error_N 13086 ("incompatible index types for array conversion", 13087 Operand); 13088 return False; 13089 end if; 13090 13091 Next_Index (Target_Index); 13092 Next_Index (Opnd_Index); 13093 end loop; 13094 13095 -- If component types have same base type, all set 13096 13097 if Target_Comp_Base = Opnd_Comp_Base then 13098 null; 13099 13100 -- Here if base types of components are not the same. The only 13101 -- time this is allowed is if we have anonymous access types. 13102 13103 -- The conversion of arrays of anonymous access types can lead 13104 -- to dangling pointers. AI-392 formalizes the accessibility 13105 -- checks that must be applied to such conversions to prevent 13106 -- out-of-scope references. 13107 13108 elsif Ekind (Target_Comp_Base) in 13109 E_Anonymous_Access_Type 13110 | E_Anonymous_Access_Subprogram_Type 13111 and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) 13112 and then 13113 Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) 13114 then 13115 if Type_Access_Level (Target_Type) < 13116 Deepest_Type_Access_Level (Opnd_Type) 13117 then 13118 if In_Instance_Body then 13119 Error_Msg_Warn := SPARK_Mode /= On; 13120 Conversion_Error_N 13121 ("source array type has deeper accessibility " 13122 & "level than target<<", Operand); 13123 Conversion_Error_N ("\Program_Error [<<", Operand); 13124 Rewrite (N, 13125 Make_Raise_Program_Error (Sloc (N), 13126 Reason => PE_Accessibility_Check_Failed)); 13127 Set_Etype (N, Target_Type); 13128 return False; 13129 13130 -- Conversion not allowed because of accessibility levels 13131 13132 else 13133 Conversion_Error_N 13134 ("source array type has deeper accessibility " 13135 & "level than target", Operand); 13136 return False; 13137 end if; 13138 13139 else 13140 null; 13141 end if; 13142 13143 -- All other cases where component base types do not match 13144 13145 else 13146 Conversion_Error_N 13147 ("incompatible component types for array conversion", 13148 Operand); 13149 return False; 13150 end if; 13151 13152 -- Check that component subtypes statically match. For numeric 13153 -- types this means that both must be either constrained or 13154 -- unconstrained. For enumeration types the bounds must match. 13155 -- All of this is checked in Subtypes_Statically_Match. 13156 13157 if not Subtypes_Statically_Match 13158 (Target_Comp_Type, Opnd_Comp_Type) 13159 then 13160 Conversion_Error_N 13161 ("component subtypes must statically match", Operand); 13162 return False; 13163 end if; 13164 end if; 13165 13166 return True; 13167 end Valid_Array_Conversion; 13168 13169 ----------------------------- 13170 -- Valid_Tagged_Conversion -- 13171 ----------------------------- 13172 13173 function Valid_Tagged_Conversion 13174 (Target_Type : Entity_Id; 13175 Opnd_Type : Entity_Id) return Boolean 13176 is 13177 begin 13178 -- Upward conversions are allowed (RM 4.6(22)) 13179 13180 if Covers (Target_Type, Opnd_Type) 13181 or else Is_Ancestor (Target_Type, Opnd_Type) 13182 then 13183 return True; 13184 13185 -- Downward conversion are allowed if the operand is class-wide 13186 -- (RM 4.6(23)). 13187 13188 elsif Is_Class_Wide_Type (Opnd_Type) 13189 and then Covers (Opnd_Type, Target_Type) 13190 then 13191 return True; 13192 13193 elsif Covers (Opnd_Type, Target_Type) 13194 or else Is_Ancestor (Opnd_Type, Target_Type) 13195 then 13196 return 13197 Conversion_Check (False, 13198 "downward conversion of tagged objects not allowed"); 13199 13200 -- Ada 2005 (AI-251): The conversion to/from interface types is 13201 -- always valid. The types involved may be class-wide (sub)types. 13202 13203 elsif Is_Interface (Etype (Base_Type (Target_Type))) 13204 or else Is_Interface (Etype (Base_Type (Opnd_Type))) 13205 then 13206 return True; 13207 13208 -- If the operand is a class-wide type obtained through a limited_ 13209 -- with clause, and the context includes the nonlimited view, use 13210 -- it to determine whether the conversion is legal. 13211 13212 elsif Is_Class_Wide_Type (Opnd_Type) 13213 and then From_Limited_With (Opnd_Type) 13214 and then Present (Non_Limited_View (Etype (Opnd_Type))) 13215 and then Is_Interface (Non_Limited_View (Etype (Opnd_Type))) 13216 then 13217 return True; 13218 13219 elsif Is_Access_Type (Opnd_Type) 13220 and then Is_Interface (Directly_Designated_Type (Opnd_Type)) 13221 then 13222 return True; 13223 13224 else 13225 Conversion_Error_NE 13226 ("invalid tagged conversion, not compatible with}", 13227 N, First_Subtype (Opnd_Type)); 13228 return False; 13229 end if; 13230 end Valid_Tagged_Conversion; 13231 13232 -- Start of processing for Valid_Conversion 13233 13234 begin 13235 Check_Parameterless_Call (Operand); 13236 13237 if Is_Overloaded (Operand) then 13238 declare 13239 I : Interp_Index; 13240 I1 : Interp_Index; 13241 It : Interp; 13242 It1 : Interp; 13243 N1 : Entity_Id; 13244 T1 : Entity_Id; 13245 13246 begin 13247 -- Remove procedure calls, which syntactically cannot appear in 13248 -- this context, but which cannot be removed by type checking, 13249 -- because the context does not impose a type. 13250 13251 -- The node may be labelled overloaded, but still contain only one 13252 -- interpretation because others were discarded earlier. If this 13253 -- is the case, retain the single interpretation if legal. 13254 13255 Get_First_Interp (Operand, I, It); 13256 Opnd_Type := It.Typ; 13257 Get_Next_Interp (I, It); 13258 13259 if Present (It.Typ) 13260 and then Opnd_Type /= Standard_Void_Type 13261 then 13262 -- More than one candidate interpretation is available 13263 13264 Get_First_Interp (Operand, I, It); 13265 while Present (It.Typ) loop 13266 if It.Typ = Standard_Void_Type then 13267 Remove_Interp (I); 13268 end if; 13269 13270 -- When compiling for a system where Address is of a visible 13271 -- integer type, spurious ambiguities can be produced when 13272 -- arithmetic operations have a literal operand and return 13273 -- System.Address or a descendant of it. These ambiguities 13274 -- are usually resolved by the context, but for conversions 13275 -- there is no context type and the removal of the spurious 13276 -- operations must be done explicitly here. 13277 13278 if not Address_Is_Private 13279 and then Is_Descendant_Of_Address (It.Typ) 13280 then 13281 Remove_Interp (I); 13282 end if; 13283 13284 Get_Next_Interp (I, It); 13285 end loop; 13286 end if; 13287 13288 Get_First_Interp (Operand, I, It); 13289 I1 := I; 13290 It1 := It; 13291 13292 if No (It.Typ) then 13293 Conversion_Error_N ("illegal operand in conversion", Operand); 13294 return False; 13295 end if; 13296 13297 Get_Next_Interp (I, It); 13298 13299 if Present (It.Typ) then 13300 N1 := It1.Nam; 13301 T1 := It1.Typ; 13302 It1 := Disambiguate (Operand, I1, I, Any_Type); 13303 13304 if It1 = No_Interp then 13305 Conversion_Error_N 13306 ("ambiguous operand in conversion", Operand); 13307 13308 -- If the interpretation involves a standard operator, use 13309 -- the location of the type, which may be user-defined. 13310 13311 if Sloc (It.Nam) = Standard_Location then 13312 Error_Msg_Sloc := Sloc (It.Typ); 13313 else 13314 Error_Msg_Sloc := Sloc (It.Nam); 13315 end if; 13316 13317 Conversion_Error_N -- CODEFIX 13318 ("\\possible interpretation#!", Operand); 13319 13320 if Sloc (N1) = Standard_Location then 13321 Error_Msg_Sloc := Sloc (T1); 13322 else 13323 Error_Msg_Sloc := Sloc (N1); 13324 end if; 13325 13326 Conversion_Error_N -- CODEFIX 13327 ("\\possible interpretation#!", Operand); 13328 13329 return False; 13330 end if; 13331 end if; 13332 13333 Set_Etype (Operand, It1.Typ); 13334 Opnd_Type := It1.Typ; 13335 end; 13336 end if; 13337 13338 -- Deal with conversion of integer type to address if the pragma 13339 -- Allow_Integer_Address is in effect. We convert the conversion to 13340 -- an unchecked conversion in this case and we are all done. 13341 13342 if Address_Integer_Convert_OK (Opnd_Type, Target_Type) then 13343 Rewrite (N, Unchecked_Convert_To (Target_Type, Expression (N))); 13344 Analyze_And_Resolve (N, Target_Type); 13345 return True; 13346 end if; 13347 13348 -- If we are within a child unit, check whether the type of the 13349 -- expression has an ancestor in a parent unit, in which case it 13350 -- belongs to its derivation class even if the ancestor is private. 13351 -- See RM 7.3.1 (5.2/3). 13352 13353 Inc_Ancestor := Get_Incomplete_View_Of_Ancestor (Opnd_Type); 13354 13355 -- Numeric types 13356 13357 if Is_Numeric_Type (Target_Type) then 13358 13359 -- A universal fixed expression can be converted to any numeric type 13360 13361 if Opnd_Type = Universal_Fixed then 13362 return True; 13363 13364 -- Also no need to check when in an instance or inlined body, because 13365 -- the legality has been established when the template was analyzed. 13366 -- Furthermore, numeric conversions may occur where only a private 13367 -- view of the operand type is visible at the instantiation point. 13368 -- This results in a spurious error if we check that the operand type 13369 -- is a numeric type. 13370 13371 -- Note: in a previous version of this unit, the following tests were 13372 -- applied only for generated code (Comes_From_Source set to False), 13373 -- but in fact the test is required for source code as well, since 13374 -- this situation can arise in source code. 13375 13376 elsif In_Instance_Code or else In_Inlined_Body then 13377 return True; 13378 13379 -- Otherwise we need the conversion check 13380 13381 else 13382 return Conversion_Check 13383 (Is_Numeric_Type (Opnd_Type) 13384 or else 13385 (Present (Inc_Ancestor) 13386 and then Is_Numeric_Type (Inc_Ancestor)), 13387 "illegal operand for numeric conversion"); 13388 end if; 13389 13390 -- Array types 13391 13392 elsif Is_Array_Type (Target_Type) then 13393 if not Is_Array_Type (Opnd_Type) 13394 or else Opnd_Type = Any_Composite 13395 or else Opnd_Type = Any_String 13396 then 13397 Conversion_Error_N 13398 ("illegal operand for array conversion", Operand); 13399 return False; 13400 13401 else 13402 return Valid_Array_Conversion; 13403 end if; 13404 13405 -- Ada 2005 (AI-251): Internally generated conversions of access to 13406 -- interface types added to force the displacement of the pointer to 13407 -- reference the corresponding dispatch table. 13408 13409 elsif not Comes_From_Source (N) 13410 and then Is_Access_Type (Target_Type) 13411 and then Is_Interface (Designated_Type (Target_Type)) 13412 then 13413 return True; 13414 13415 -- Ada 2005 (AI-251): Anonymous access types where target references an 13416 -- interface type. 13417 13418 elsif Is_Access_Type (Opnd_Type) 13419 and then Ekind (Target_Type) in 13420 E_General_Access_Type | E_Anonymous_Access_Type 13421 and then Is_Interface (Directly_Designated_Type (Target_Type)) 13422 then 13423 -- Check the static accessibility rule of 4.6(17). Note that the 13424 -- check is not enforced when within an instance body, since the 13425 -- RM requires such cases to be caught at run time. 13426 13427 -- If the operand is a rewriting of an allocator no check is needed 13428 -- because there are no accessibility issues. 13429 13430 if Nkind (Original_Node (N)) = N_Allocator then 13431 null; 13432 13433 elsif Ekind (Target_Type) /= E_Anonymous_Access_Type then 13434 if Type_Access_Level (Opnd_Type) > 13435 Deepest_Type_Access_Level (Target_Type) 13436 then 13437 -- In an instance, this is a run-time check, but one we know 13438 -- will fail, so generate an appropriate warning. The raise 13439 -- will be generated by Expand_N_Type_Conversion. 13440 13441 if In_Instance_Body then 13442 Error_Msg_Warn := SPARK_Mode /= On; 13443 Conversion_Error_N 13444 ("cannot convert local pointer to non-local access type<<", 13445 Operand); 13446 Conversion_Error_N ("\Program_Error [<<", Operand); 13447 13448 else 13449 Conversion_Error_N 13450 ("cannot convert local pointer to non-local access type", 13451 Operand); 13452 return False; 13453 end if; 13454 13455 -- Special accessibility checks are needed in the case of access 13456 -- discriminants declared for a limited type. 13457 13458 elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type 13459 and then not Is_Local_Anonymous_Access (Opnd_Type) 13460 then 13461 -- When the operand is a selected access discriminant the check 13462 -- needs to be made against the level of the object denoted by 13463 -- the prefix of the selected name (Accessibility_Level handles 13464 -- checking the prefix of the operand for this case). 13465 13466 if Nkind (Operand) = N_Selected_Component 13467 and then Static_Accessibility_Level 13468 (Operand, Zero_On_Dynamic_Level) 13469 > Deepest_Type_Access_Level (Target_Type) 13470 then 13471 -- In an instance, this is a run-time check, but one we know 13472 -- will fail, so generate an appropriate warning. The raise 13473 -- will be generated by Expand_N_Type_Conversion. 13474 13475 if In_Instance_Body then 13476 Error_Msg_Warn := SPARK_Mode /= On; 13477 Conversion_Error_N 13478 ("cannot convert access discriminant to non-local " 13479 & "access type<<", Operand); 13480 Conversion_Error_N ("\Program_Error [<<", Operand); 13481 13482 -- Real error if not in instance body 13483 13484 else 13485 Conversion_Error_N 13486 ("cannot convert access discriminant to non-local " 13487 & "access type", Operand); 13488 return False; 13489 end if; 13490 end if; 13491 13492 -- The case of a reference to an access discriminant from 13493 -- within a limited type declaration (which will appear as 13494 -- a discriminal) is always illegal because the level of the 13495 -- discriminant is considered to be deeper than any (nameable) 13496 -- access type. 13497 13498 if Is_Entity_Name (Operand) 13499 and then not Is_Local_Anonymous_Access (Opnd_Type) 13500 and then 13501 Ekind (Entity (Operand)) in E_In_Parameter | E_Constant 13502 and then Present (Discriminal_Link (Entity (Operand))) 13503 then 13504 Conversion_Error_N 13505 ("discriminant has deeper accessibility level than target", 13506 Operand); 13507 return False; 13508 end if; 13509 end if; 13510 end if; 13511 13512 return True; 13513 13514 -- General and anonymous access types 13515 13516 elsif Ekind (Target_Type) in 13517 E_General_Access_Type | E_Anonymous_Access_Type 13518 and then 13519 Conversion_Check 13520 (Is_Access_Type (Opnd_Type) 13521 and then 13522 Ekind (Opnd_Type) not in 13523 E_Access_Subprogram_Type | 13524 E_Access_Protected_Subprogram_Type, 13525 "must be an access-to-object type") 13526 then 13527 if Is_Access_Constant (Opnd_Type) 13528 and then not Is_Access_Constant (Target_Type) 13529 then 13530 Conversion_Error_N 13531 ("access-to-constant operand type not allowed", Operand); 13532 return False; 13533 end if; 13534 13535 -- Check the static accessibility rule of 4.6(17). Note that the 13536 -- check is not enforced when within an instance body, since the RM 13537 -- requires such cases to be caught at run time. 13538 13539 if Ekind (Target_Type) /= E_Anonymous_Access_Type 13540 or else Is_Local_Anonymous_Access (Target_Type) 13541 or else Nkind (Associated_Node_For_Itype (Target_Type)) = 13542 N_Object_Declaration 13543 then 13544 -- Ada 2012 (AI05-0149): Perform legality checking on implicit 13545 -- conversions from an anonymous access type to a named general 13546 -- access type. Such conversions are not allowed in the case of 13547 -- access parameters and stand-alone objects of an anonymous 13548 -- access type. The implicit conversion case is recognized by 13549 -- testing that Comes_From_Source is False and that it's been 13550 -- rewritten. The Comes_From_Source test isn't sufficient because 13551 -- nodes in inlined calls to predefined library routines can have 13552 -- Comes_From_Source set to False. (Is there a better way to test 13553 -- for implicit conversions???). 13554 -- 13555 -- Do not treat a rewritten 'Old attribute reference like other 13556 -- rewrite substitutions. This makes a difference, for example, 13557 -- in the case where we are generating the expansion of a 13558 -- membership test of the form 13559 -- Saooaaat'Old in Named_Access_Type 13560 -- because in this case Valid_Conversion needs to return True 13561 -- (otherwise the expansion will be False - see the call site 13562 -- in exp_ch4.adb). 13563 13564 if Ada_Version >= Ada_2012 13565 and then not Comes_From_Source (N) 13566 and then Is_Rewrite_Substitution (N) 13567 and then not Is_Attribute_Old (Original_Node (N)) 13568 and then Ekind (Base_Type (Target_Type)) = E_General_Access_Type 13569 and then Ekind (Opnd_Type) = E_Anonymous_Access_Type 13570 then 13571 if Is_Itype (Opnd_Type) then 13572 13573 -- Implicit conversions aren't allowed for objects of an 13574 -- anonymous access type, since such objects have nonstatic 13575 -- levels in Ada 2012. 13576 13577 if Nkind (Associated_Node_For_Itype (Opnd_Type)) = 13578 N_Object_Declaration 13579 then 13580 Conversion_Error_N 13581 ("implicit conversion of stand-alone anonymous " 13582 & "access object not allowed", Operand); 13583 return False; 13584 13585 -- Implicit conversions aren't allowed for anonymous access 13586 -- parameters. We exclude anonymous access results as well 13587 -- as universal_access "=". 13588 13589 elsif not Is_Local_Anonymous_Access (Opnd_Type) 13590 and then Nkind (Associated_Node_For_Itype (Opnd_Type)) in 13591 N_Function_Specification | 13592 N_Procedure_Specification 13593 and then Nkind (Parent (N)) not in N_Op_Eq | N_Op_Ne 13594 then 13595 Conversion_Error_N 13596 ("implicit conversion of anonymous access parameter " 13597 & "not allowed", Operand); 13598 return False; 13599 13600 -- Detect access discriminant values that are illegal 13601 -- implicit anonymous-to-named access conversion operands. 13602 13603 elsif Is_Discrim_Of_Bad_Access_Conversion_Argument (Operand) 13604 then 13605 Conversion_Error_N 13606 ("implicit conversion of anonymous access value " 13607 & "not allowed", Operand); 13608 return False; 13609 13610 -- In other cases, the level of the operand's type must be 13611 -- statically less deep than that of the target type, else 13612 -- implicit conversion is disallowed (by RM12-8.6(27.1/3)). 13613 13614 elsif Type_Access_Level (Opnd_Type) > 13615 Deepest_Type_Access_Level (Target_Type) 13616 then 13617 Conversion_Error_N 13618 ("implicit conversion of anonymous access value " 13619 & "violates accessibility", Operand); 13620 return False; 13621 end if; 13622 end if; 13623 13624 -- Check if the operand is deeper than the target type, taking 13625 -- care to avoid the case where we are converting a result of a 13626 -- function returning an anonymous access type since the "master 13627 -- of the call" would be target type of the conversion unless 13628 -- the target type is anonymous access as well - see RM 3.10.2 13629 -- (10.3/3). 13630 13631 elsif Type_Access_Level (Opnd_Type) > 13632 Deepest_Type_Access_Level (Target_Type) 13633 and then (Nkind (Associated_Node_For_Itype (Opnd_Type)) /= 13634 N_Function_Specification 13635 or else Ekind (Target_Type) in 13636 Anonymous_Access_Kind) 13637 13638 -- Check we are not in a return value ??? 13639 13640 and then (not In_Return_Value (N) 13641 or else 13642 Nkind (Associated_Node_For_Itype (Target_Type)) 13643 = N_Component_Declaration) 13644 then 13645 -- In an instance, this is a run-time check, but one we know 13646 -- will fail, so generate an appropriate warning. The raise 13647 -- will be generated by Expand_N_Type_Conversion. 13648 13649 if In_Instance_Body then 13650 Error_Msg_Warn := SPARK_Mode /= On; 13651 Conversion_Error_N 13652 ("cannot convert local pointer to non-local access type<<", 13653 Operand); 13654 Conversion_Error_N ("\Program_Error [<<", Operand); 13655 13656 -- If not in an instance body, this is a real error 13657 13658 else 13659 -- Avoid generation of spurious error message 13660 13661 if not Error_Posted (N) then 13662 Conversion_Error_N 13663 ("cannot convert local pointer to non-local access type", 13664 Operand); 13665 end if; 13666 13667 return False; 13668 end if; 13669 13670 -- Special accessibility checks are needed in the case of access 13671 -- discriminants declared for a limited type. 13672 13673 elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type 13674 and then not Is_Local_Anonymous_Access (Opnd_Type) 13675 then 13676 -- When the operand is a selected access discriminant the check 13677 -- needs to be made against the level of the object denoted by 13678 -- the prefix of the selected name (Accessibility_Level handles 13679 -- checking the prefix of the operand for this case). 13680 13681 if Nkind (Operand) = N_Selected_Component 13682 and then Static_Accessibility_Level 13683 (Operand, Zero_On_Dynamic_Level) 13684 > Deepest_Type_Access_Level (Target_Type) 13685 then 13686 -- In an instance, this is a run-time check, but one we know 13687 -- will fail, so generate an appropriate warning. The raise 13688 -- will be generated by Expand_N_Type_Conversion. 13689 13690 if In_Instance_Body then 13691 Error_Msg_Warn := SPARK_Mode /= On; 13692 Conversion_Error_N 13693 ("cannot convert access discriminant to non-local " 13694 & "access type<<", Operand); 13695 Conversion_Error_N ("\Program_Error [<<", Operand); 13696 13697 -- If not in an instance body, this is a real error 13698 13699 else 13700 Conversion_Error_N 13701 ("cannot convert access discriminant to non-local " 13702 & "access type", Operand); 13703 return False; 13704 end if; 13705 end if; 13706 13707 -- The case of a reference to an access discriminant from 13708 -- within a limited type declaration (which will appear as 13709 -- a discriminal) is always illegal because the level of the 13710 -- discriminant is considered to be deeper than any (nameable) 13711 -- access type. 13712 13713 if Is_Entity_Name (Operand) 13714 and then 13715 Ekind (Entity (Operand)) in E_In_Parameter | E_Constant 13716 and then Present (Discriminal_Link (Entity (Operand))) 13717 then 13718 Conversion_Error_N 13719 ("discriminant has deeper accessibility level than target", 13720 Operand); 13721 return False; 13722 end if; 13723 end if; 13724 end if; 13725 13726 -- In the presence of limited_with clauses we have to use nonlimited 13727 -- views, if available. 13728 13729 Check_Limited : declare 13730 function Full_Designated_Type (T : Entity_Id) return Entity_Id; 13731 -- Helper function to handle limited views 13732 13733 -------------------------- 13734 -- Full_Designated_Type -- 13735 -------------------------- 13736 13737 function Full_Designated_Type (T : Entity_Id) return Entity_Id is 13738 Desig : constant Entity_Id := Designated_Type (T); 13739 13740 begin 13741 -- Handle the limited view of a type 13742 13743 if From_Limited_With (Desig) 13744 and then Has_Non_Limited_View (Desig) 13745 then 13746 return Available_View (Desig); 13747 else 13748 return Desig; 13749 end if; 13750 end Full_Designated_Type; 13751 13752 -- Local Declarations 13753 13754 Target : constant Entity_Id := Full_Designated_Type (Target_Type); 13755 Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type); 13756 13757 Same_Base : constant Boolean := 13758 Base_Type (Target) = Base_Type (Opnd); 13759 13760 -- Start of processing for Check_Limited 13761 13762 begin 13763 if Is_Tagged_Type (Target) then 13764 return Valid_Tagged_Conversion (Target, Opnd); 13765 13766 else 13767 if not Same_Base then 13768 Conversion_Error_NE 13769 ("target designated type not compatible with }", 13770 N, Base_Type (Opnd)); 13771 return False; 13772 13773 -- Ada 2005 AI-384: legality rule is symmetric in both 13774 -- designated types. The conversion is legal (with possible 13775 -- constraint check) if either designated type is 13776 -- unconstrained. 13777 13778 elsif Subtypes_Statically_Match (Target, Opnd) 13779 or else 13780 (Has_Discriminants (Target) 13781 and then 13782 (not Is_Constrained (Opnd) 13783 or else not Is_Constrained (Target))) 13784 then 13785 -- Special case, if Value_Size has been used to make the 13786 -- sizes different, the conversion is not allowed even 13787 -- though the subtypes statically match. 13788 13789 if Known_Static_RM_Size (Target) 13790 and then Known_Static_RM_Size (Opnd) 13791 and then RM_Size (Target) /= RM_Size (Opnd) 13792 then 13793 Conversion_Error_NE 13794 ("target designated subtype not compatible with }", 13795 N, Opnd); 13796 Conversion_Error_NE 13797 ("\because sizes of the two designated subtypes differ", 13798 N, Opnd); 13799 return False; 13800 13801 -- Normal case where conversion is allowed 13802 13803 else 13804 return True; 13805 end if; 13806 13807 else 13808 Error_Msg_NE 13809 ("target designated subtype not compatible with }", 13810 N, Opnd); 13811 return False; 13812 end if; 13813 end if; 13814 end Check_Limited; 13815 13816 -- Access to subprogram types. If the operand is an access parameter, 13817 -- the type has a deeper accessibility that any master, and cannot be 13818 -- assigned. We must make an exception if the conversion is part of an 13819 -- assignment and the target is the return object of an extended return 13820 -- statement, because in that case the accessibility check takes place 13821 -- after the return. 13822 13823 elsif Is_Access_Subprogram_Type (Target_Type) 13824 13825 -- Note: this test of Opnd_Type is there to prevent entering this 13826 -- branch in the case of a remote access to subprogram type, which 13827 -- is internally represented as an E_Record_Type. 13828 13829 and then Is_Access_Type (Opnd_Type) 13830 then 13831 if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type 13832 and then Is_Entity_Name (Operand) 13833 and then Ekind (Entity (Operand)) = E_In_Parameter 13834 and then 13835 (Nkind (Parent (N)) /= N_Assignment_Statement 13836 or else not Is_Entity_Name (Name (Parent (N))) 13837 or else not Is_Return_Object (Entity (Name (Parent (N))))) 13838 then 13839 Conversion_Error_N 13840 ("illegal attempt to store anonymous access to subprogram", 13841 Operand); 13842 Conversion_Error_N 13843 ("\value has deeper accessibility than any master " 13844 & "(RM 3.10.2 (13))", 13845 Operand); 13846 13847 Error_Msg_NE 13848 ("\use named access type for& instead of access parameter", 13849 Operand, Entity (Operand)); 13850 end if; 13851 13852 -- Check that the designated types are subtype conformant 13853 13854 Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type), 13855 Old_Id => Designated_Type (Opnd_Type), 13856 Err_Loc => N); 13857 13858 -- Check the static accessibility rule of 4.6(20) 13859 13860 if Type_Access_Level (Opnd_Type) > 13861 Deepest_Type_Access_Level (Target_Type) 13862 then 13863 Conversion_Error_N 13864 ("operand type has deeper accessibility level than target", 13865 Operand); 13866 13867 -- Check that if the operand type is declared in a generic body, 13868 -- then the target type must be declared within that same body 13869 -- (enforces last sentence of 4.6(20)). 13870 13871 elsif Present (Enclosing_Generic_Body (Opnd_Type)) then 13872 declare 13873 O_Gen : constant Node_Id := 13874 Enclosing_Generic_Body (Opnd_Type); 13875 13876 T_Gen : Node_Id; 13877 13878 begin 13879 T_Gen := Enclosing_Generic_Body (Target_Type); 13880 while Present (T_Gen) and then T_Gen /= O_Gen loop 13881 T_Gen := Enclosing_Generic_Body (T_Gen); 13882 end loop; 13883 13884 if T_Gen /= O_Gen then 13885 Conversion_Error_N 13886 ("target type must be declared in same generic body " 13887 & "as operand type", N); 13888 end if; 13889 end; 13890 end if; 13891 13892 return True; 13893 13894 -- Remote access to subprogram types 13895 13896 elsif Is_Remote_Access_To_Subprogram_Type (Target_Type) 13897 and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type) 13898 then 13899 -- It is valid to convert from one RAS type to another provided 13900 -- that their specification statically match. 13901 13902 -- Note: at this point, remote access to subprogram types have been 13903 -- expanded to their E_Record_Type representation, and we need to 13904 -- go back to the original access type definition using the 13905 -- Corresponding_Remote_Type attribute in order to check that the 13906 -- designated profiles match. 13907 13908 pragma Assert (Ekind (Target_Type) = E_Record_Type); 13909 pragma Assert (Ekind (Opnd_Type) = E_Record_Type); 13910 13911 Check_Subtype_Conformant 13912 (New_Id => 13913 Designated_Type (Corresponding_Remote_Type (Target_Type)), 13914 Old_Id => 13915 Designated_Type (Corresponding_Remote_Type (Opnd_Type)), 13916 Err_Loc => 13917 N); 13918 return True; 13919 13920 -- If it was legal in the generic, it's legal in the instance 13921 13922 elsif In_Instance_Body then 13923 return True; 13924 13925 -- If both are tagged types, check legality of view conversions 13926 13927 elsif Is_Tagged_Type (Target_Type) 13928 and then 13929 Is_Tagged_Type (Opnd_Type) 13930 then 13931 return Valid_Tagged_Conversion (Target_Type, Opnd_Type); 13932 13933 -- Types derived from the same root type are convertible 13934 13935 elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then 13936 return True; 13937 13938 -- In an instance or an inlined body, there may be inconsistent views of 13939 -- the same type, or of types derived from a common root. 13940 13941 elsif (In_Instance or In_Inlined_Body) 13942 and then 13943 Root_Type (Underlying_Type (Target_Type)) = 13944 Root_Type (Underlying_Type (Opnd_Type)) 13945 then 13946 return True; 13947 13948 -- Special check for common access type error case 13949 13950 elsif Ekind (Target_Type) = E_Access_Type 13951 and then Is_Access_Type (Opnd_Type) 13952 then 13953 Conversion_Error_N ("target type must be general access type!", N); 13954 Conversion_Error_NE -- CODEFIX 13955 ("add ALL to }!", N, Target_Type); 13956 return False; 13957 13958 -- Here we have a real conversion error 13959 13960 else 13961 -- Check for missing regular with_clause when only a limited view of 13962 -- target is available. 13963 13964 if From_Limited_With (Opnd_Type) and then In_Package_Body then 13965 Conversion_Error_NE 13966 ("invalid conversion, not compatible with limited view of }", 13967 N, Opnd_Type); 13968 Conversion_Error_NE 13969 ("\add with_clause for& to current unit!", N, Scope (Opnd_Type)); 13970 13971 elsif Is_Access_Type (Opnd_Type) 13972 and then From_Limited_With (Designated_Type (Opnd_Type)) 13973 and then In_Package_Body 13974 then 13975 Conversion_Error_NE 13976 ("invalid conversion, not compatible with }", N, Opnd_Type); 13977 Conversion_Error_NE 13978 ("\add with_clause for& to current unit!", 13979 N, Scope (Designated_Type (Opnd_Type))); 13980 13981 else 13982 Conversion_Error_NE 13983 ("invalid conversion, not compatible with }", N, Opnd_Type); 13984 end if; 13985 13986 return False; 13987 end if; 13988 end Valid_Conversion; 13989 13990end Sem_Res; 13991