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