1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2004, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Casing; use Casing; 29with Checks; use Checks; 30with Debug; use Debug; 31with Errout; use Errout; 32with Elists; use Elists; 33with Exp_Tss; use Exp_Tss; 34with Exp_Util; use Exp_Util; 35with Fname; use Fname; 36with Freeze; use Freeze; 37with Lib; use Lib; 38with Lib.Xref; use Lib.Xref; 39with Namet; use Namet; 40with Nlists; use Nlists; 41with Nmake; use Nmake; 42with Output; use Output; 43with Opt; use Opt; 44with Restrict; use Restrict; 45with Scans; use Scans; 46with Scn; use Scn; 47with Sem; use Sem; 48with Sem_Ch8; use Sem_Ch8; 49with Sem_Eval; use Sem_Eval; 50with Sem_Res; use Sem_Res; 51with Sem_Type; use Sem_Type; 52with Sinfo; use Sinfo; 53with Sinput; use Sinput; 54with Snames; use Snames; 55with Stand; use Stand; 56with Style; 57with Stringt; use Stringt; 58with Targparm; use Targparm; 59with Tbuild; use Tbuild; 60with Ttypes; use Ttypes; 61 62package body Sem_Util is 63 64 ----------------------- 65 -- Local Subprograms -- 66 ----------------------- 67 68 function Build_Component_Subtype 69 (C : List_Id; 70 Loc : Source_Ptr; 71 T : Entity_Id) return Node_Id; 72 -- This function builds the subtype for Build_Actual_Subtype_Of_Component 73 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, 74 -- Loc is the source location, T is the original subtype. 75 76 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; 77 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type 78 -- with discriminants whose default values are static, examine only the 79 -- components in the selected variant to determine whether all of them 80 -- have a default. 81 82 function Has_Null_Extension (T : Entity_Id) return Boolean; 83 -- T is a derived tagged type. Check whether the type extension is null. 84 -- If the parent type is fully initialized, T can be treated as such. 85 86 -------------------------------- 87 -- Add_Access_Type_To_Process -- 88 -------------------------------- 89 90 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is 91 L : Elist_Id; 92 93 begin 94 Ensure_Freeze_Node (E); 95 L := Access_Types_To_Process (Freeze_Node (E)); 96 97 if No (L) then 98 L := New_Elmt_List; 99 Set_Access_Types_To_Process (Freeze_Node (E), L); 100 end if; 101 102 Append_Elmt (A, L); 103 end Add_Access_Type_To_Process; 104 105 ----------------------- 106 -- Alignment_In_Bits -- 107 ----------------------- 108 109 function Alignment_In_Bits (E : Entity_Id) return Uint is 110 begin 111 return Alignment (E) * System_Storage_Unit; 112 end Alignment_In_Bits; 113 114 ----------------------------------------- 115 -- Apply_Compile_Time_Constraint_Error -- 116 ----------------------------------------- 117 118 procedure Apply_Compile_Time_Constraint_Error 119 (N : Node_Id; 120 Msg : String; 121 Reason : RT_Exception_Code; 122 Ent : Entity_Id := Empty; 123 Typ : Entity_Id := Empty; 124 Loc : Source_Ptr := No_Location; 125 Rep : Boolean := True; 126 Warn : Boolean := False) 127 is 128 Stat : constant Boolean := Is_Static_Expression (N); 129 Rtyp : Entity_Id; 130 131 begin 132 if No (Typ) then 133 Rtyp := Etype (N); 134 else 135 Rtyp := Typ; 136 end if; 137 138 if No (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)) 139 or else not Rep 140 then 141 return; 142 end if; 143 144 -- Now we replace the node by an N_Raise_Constraint_Error node 145 -- This does not need reanalyzing, so set it as analyzed now. 146 147 Rewrite (N, 148 Make_Raise_Constraint_Error (Sloc (N), 149 Reason => Reason)); 150 Set_Analyzed (N, True); 151 Set_Etype (N, Rtyp); 152 Set_Raises_Constraint_Error (N); 153 154 -- If the original expression was marked as static, the result is 155 -- still marked as static, but the Raises_Constraint_Error flag is 156 -- always set so that further static evaluation is not attempted. 157 158 if Stat then 159 Set_Is_Static_Expression (N); 160 end if; 161 end Apply_Compile_Time_Constraint_Error; 162 163 -------------------------- 164 -- Build_Actual_Subtype -- 165 -------------------------- 166 167 function Build_Actual_Subtype 168 (T : Entity_Id; 169 N : Node_Or_Entity_Id) return Node_Id 170 is 171 Obj : Node_Id; 172 173 Loc : constant Source_Ptr := Sloc (N); 174 Constraints : List_Id; 175 Decl : Node_Id; 176 Discr : Entity_Id; 177 Hi : Node_Id; 178 Lo : Node_Id; 179 Subt : Entity_Id; 180 Disc_Type : Entity_Id; 181 182 begin 183 if Nkind (N) = N_Defining_Identifier then 184 Obj := New_Reference_To (N, Loc); 185 else 186 Obj := N; 187 end if; 188 189 if Is_Array_Type (T) then 190 Constraints := New_List; 191 192 for J in 1 .. Number_Dimensions (T) loop 193 194 -- Build an array subtype declaration with the nominal 195 -- subtype and the bounds of the actual. Add the declaration 196 -- in front of the local declarations for the subprogram, for 197 -- analysis before any reference to the formal in the body. 198 199 Lo := 200 Make_Attribute_Reference (Loc, 201 Prefix => 202 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 203 Attribute_Name => Name_First, 204 Expressions => New_List ( 205 Make_Integer_Literal (Loc, J))); 206 207 Hi := 208 Make_Attribute_Reference (Loc, 209 Prefix => 210 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 211 Attribute_Name => Name_Last, 212 Expressions => New_List ( 213 Make_Integer_Literal (Loc, J))); 214 215 Append (Make_Range (Loc, Lo, Hi), Constraints); 216 end loop; 217 218 -- If the type has unknown discriminants there is no constrained 219 -- subtype to build. This is never called for a formal or for a 220 -- lhs, so returning the type is ok ??? 221 222 elsif Has_Unknown_Discriminants (T) then 223 return T; 224 225 else 226 Constraints := New_List; 227 228 if Is_Private_Type (T) and then No (Full_View (T)) then 229 230 -- Type is a generic derived type. Inherit discriminants from 231 -- Parent type. 232 233 Disc_Type := Etype (Base_Type (T)); 234 else 235 Disc_Type := T; 236 end if; 237 238 Discr := First_Discriminant (Disc_Type); 239 240 while Present (Discr) loop 241 Append_To (Constraints, 242 Make_Selected_Component (Loc, 243 Prefix => 244 Duplicate_Subexpr_No_Checks (Obj), 245 Selector_Name => New_Occurrence_Of (Discr, Loc))); 246 Next_Discriminant (Discr); 247 end loop; 248 end if; 249 250 Subt := 251 Make_Defining_Identifier (Loc, 252 Chars => New_Internal_Name ('S')); 253 Set_Is_Internal (Subt); 254 255 Decl := 256 Make_Subtype_Declaration (Loc, 257 Defining_Identifier => Subt, 258 Subtype_Indication => 259 Make_Subtype_Indication (Loc, 260 Subtype_Mark => New_Reference_To (T, Loc), 261 Constraint => 262 Make_Index_Or_Discriminant_Constraint (Loc, 263 Constraints => Constraints))); 264 265 Mark_Rewrite_Insertion (Decl); 266 return Decl; 267 end Build_Actual_Subtype; 268 269 --------------------------------------- 270 -- Build_Actual_Subtype_Of_Component -- 271 --------------------------------------- 272 273 function Build_Actual_Subtype_Of_Component 274 (T : Entity_Id; 275 N : Node_Id) return Node_Id 276 is 277 Loc : constant Source_Ptr := Sloc (N); 278 P : constant Node_Id := Prefix (N); 279 D : Elmt_Id; 280 Id : Node_Id; 281 Indx_Type : Entity_Id; 282 283 Deaccessed_T : Entity_Id; 284 -- This is either a copy of T, or if T is an access type, then it is 285 -- the directly designated type of this access type. 286 287 function Build_Actual_Array_Constraint return List_Id; 288 -- If one or more of the bounds of the component depends on 289 -- discriminants, build actual constraint using the discriminants 290 -- of the prefix. 291 292 function Build_Actual_Record_Constraint return List_Id; 293 -- Similar to previous one, for discriminated components constrained 294 -- by the discriminant of the enclosing object. 295 296 ----------------------------------- 297 -- Build_Actual_Array_Constraint -- 298 ----------------------------------- 299 300 function Build_Actual_Array_Constraint return List_Id is 301 Constraints : constant List_Id := New_List; 302 Indx : Node_Id; 303 Hi : Node_Id; 304 Lo : Node_Id; 305 Old_Hi : Node_Id; 306 Old_Lo : Node_Id; 307 308 begin 309 Indx := First_Index (Deaccessed_T); 310 while Present (Indx) loop 311 Old_Lo := Type_Low_Bound (Etype (Indx)); 312 Old_Hi := Type_High_Bound (Etype (Indx)); 313 314 if Denotes_Discriminant (Old_Lo) then 315 Lo := 316 Make_Selected_Component (Loc, 317 Prefix => New_Copy_Tree (P), 318 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); 319 320 else 321 Lo := New_Copy_Tree (Old_Lo); 322 323 -- The new bound will be reanalyzed in the enclosing 324 -- declaration. For literal bounds that come from a type 325 -- declaration, the type of the context must be imposed, so 326 -- insure that analysis will take place. For non-universal 327 -- types this is not strictly necessary. 328 329 Set_Analyzed (Lo, False); 330 end if; 331 332 if Denotes_Discriminant (Old_Hi) then 333 Hi := 334 Make_Selected_Component (Loc, 335 Prefix => New_Copy_Tree (P), 336 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); 337 338 else 339 Hi := New_Copy_Tree (Old_Hi); 340 Set_Analyzed (Hi, False); 341 end if; 342 343 Append (Make_Range (Loc, Lo, Hi), Constraints); 344 Next_Index (Indx); 345 end loop; 346 347 return Constraints; 348 end Build_Actual_Array_Constraint; 349 350 ------------------------------------ 351 -- Build_Actual_Record_Constraint -- 352 ------------------------------------ 353 354 function Build_Actual_Record_Constraint return List_Id is 355 Constraints : constant List_Id := New_List; 356 D : Elmt_Id; 357 D_Val : Node_Id; 358 359 begin 360 D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); 361 while Present (D) loop 362 363 if Denotes_Discriminant (Node (D)) then 364 D_Val := Make_Selected_Component (Loc, 365 Prefix => New_Copy_Tree (P), 366 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); 367 368 else 369 D_Val := New_Copy_Tree (Node (D)); 370 end if; 371 372 Append (D_Val, Constraints); 373 Next_Elmt (D); 374 end loop; 375 376 return Constraints; 377 end Build_Actual_Record_Constraint; 378 379 -- Start of processing for Build_Actual_Subtype_Of_Component 380 381 begin 382 if In_Default_Expression then 383 return Empty; 384 385 elsif Nkind (N) = N_Explicit_Dereference then 386 if Is_Composite_Type (T) 387 and then not Is_Constrained (T) 388 and then not (Is_Class_Wide_Type (T) 389 and then Is_Constrained (Root_Type (T))) 390 and then not Has_Unknown_Discriminants (T) 391 then 392 -- If the type of the dereference is already constrained, it 393 -- is an actual subtype. 394 395 if Is_Array_Type (Etype (N)) 396 and then Is_Constrained (Etype (N)) 397 then 398 return Empty; 399 else 400 Remove_Side_Effects (P); 401 return Build_Actual_Subtype (T, N); 402 end if; 403 else 404 return Empty; 405 end if; 406 end if; 407 408 if Ekind (T) = E_Access_Subtype then 409 Deaccessed_T := Designated_Type (T); 410 else 411 Deaccessed_T := T; 412 end if; 413 414 if Ekind (Deaccessed_T) = E_Array_Subtype then 415 Id := First_Index (Deaccessed_T); 416 Indx_Type := Underlying_Type (Etype (Id)); 417 418 while Present (Id) loop 419 420 if Denotes_Discriminant (Type_Low_Bound (Indx_Type)) or else 421 Denotes_Discriminant (Type_High_Bound (Indx_Type)) 422 then 423 Remove_Side_Effects (P); 424 return 425 Build_Component_Subtype ( 426 Build_Actual_Array_Constraint, Loc, Base_Type (T)); 427 end if; 428 429 Next_Index (Id); 430 end loop; 431 432 elsif Is_Composite_Type (Deaccessed_T) 433 and then Has_Discriminants (Deaccessed_T) 434 and then not Has_Unknown_Discriminants (Deaccessed_T) 435 then 436 D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); 437 while Present (D) loop 438 439 if Denotes_Discriminant (Node (D)) then 440 Remove_Side_Effects (P); 441 return 442 Build_Component_Subtype ( 443 Build_Actual_Record_Constraint, Loc, Base_Type (T)); 444 end if; 445 446 Next_Elmt (D); 447 end loop; 448 end if; 449 450 -- If none of the above, the actual and nominal subtypes are the same. 451 452 return Empty; 453 end Build_Actual_Subtype_Of_Component; 454 455 ----------------------------- 456 -- Build_Component_Subtype -- 457 ----------------------------- 458 459 function Build_Component_Subtype 460 (C : List_Id; 461 Loc : Source_Ptr; 462 T : Entity_Id) return Node_Id 463 is 464 Subt : Entity_Id; 465 Decl : Node_Id; 466 467 begin 468 Subt := 469 Make_Defining_Identifier (Loc, 470 Chars => New_Internal_Name ('S')); 471 Set_Is_Internal (Subt); 472 473 Decl := 474 Make_Subtype_Declaration (Loc, 475 Defining_Identifier => Subt, 476 Subtype_Indication => 477 Make_Subtype_Indication (Loc, 478 Subtype_Mark => New_Reference_To (Base_Type (T), Loc), 479 Constraint => 480 Make_Index_Or_Discriminant_Constraint (Loc, 481 Constraints => C))); 482 483 Mark_Rewrite_Insertion (Decl); 484 return Decl; 485 end Build_Component_Subtype; 486 487 -------------------------------------------- 488 -- Build_Discriminal_Subtype_Of_Component -- 489 -------------------------------------------- 490 491 function Build_Discriminal_Subtype_Of_Component 492 (T : Entity_Id) return Node_Id 493 is 494 Loc : constant Source_Ptr := Sloc (T); 495 D : Elmt_Id; 496 Id : Node_Id; 497 498 function Build_Discriminal_Array_Constraint return List_Id; 499 -- If one or more of the bounds of the component depends on 500 -- discriminants, build actual constraint using the discriminants 501 -- of the prefix. 502 503 function Build_Discriminal_Record_Constraint return List_Id; 504 -- Similar to previous one, for discriminated components constrained 505 -- by the discriminant of the enclosing object. 506 507 ---------------------------------------- 508 -- Build_Discriminal_Array_Constraint -- 509 ---------------------------------------- 510 511 function Build_Discriminal_Array_Constraint return List_Id is 512 Constraints : constant List_Id := New_List; 513 Indx : Node_Id; 514 Hi : Node_Id; 515 Lo : Node_Id; 516 Old_Hi : Node_Id; 517 Old_Lo : Node_Id; 518 519 begin 520 Indx := First_Index (T); 521 while Present (Indx) loop 522 Old_Lo := Type_Low_Bound (Etype (Indx)); 523 Old_Hi := Type_High_Bound (Etype (Indx)); 524 525 if Denotes_Discriminant (Old_Lo) then 526 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); 527 528 else 529 Lo := New_Copy_Tree (Old_Lo); 530 end if; 531 532 if Denotes_Discriminant (Old_Hi) then 533 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); 534 535 else 536 Hi := New_Copy_Tree (Old_Hi); 537 end if; 538 539 Append (Make_Range (Loc, Lo, Hi), Constraints); 540 Next_Index (Indx); 541 end loop; 542 543 return Constraints; 544 end Build_Discriminal_Array_Constraint; 545 546 ----------------------------------------- 547 -- Build_Discriminal_Record_Constraint -- 548 ----------------------------------------- 549 550 function Build_Discriminal_Record_Constraint return List_Id is 551 Constraints : constant List_Id := New_List; 552 D : Elmt_Id; 553 D_Val : Node_Id; 554 555 begin 556 D := First_Elmt (Discriminant_Constraint (T)); 557 while Present (D) loop 558 if Denotes_Discriminant (Node (D)) then 559 D_Val := 560 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); 561 562 else 563 D_Val := New_Copy_Tree (Node (D)); 564 end if; 565 566 Append (D_Val, Constraints); 567 Next_Elmt (D); 568 end loop; 569 570 return Constraints; 571 end Build_Discriminal_Record_Constraint; 572 573 -- Start of processing for Build_Discriminal_Subtype_Of_Component 574 575 begin 576 if Ekind (T) = E_Array_Subtype then 577 Id := First_Index (T); 578 579 while Present (Id) loop 580 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else 581 Denotes_Discriminant (Type_High_Bound (Etype (Id))) 582 then 583 return Build_Component_Subtype 584 (Build_Discriminal_Array_Constraint, Loc, T); 585 end if; 586 587 Next_Index (Id); 588 end loop; 589 590 elsif Ekind (T) = E_Record_Subtype 591 and then Has_Discriminants (T) 592 and then not Has_Unknown_Discriminants (T) 593 then 594 D := First_Elmt (Discriminant_Constraint (T)); 595 while Present (D) loop 596 if Denotes_Discriminant (Node (D)) then 597 return Build_Component_Subtype 598 (Build_Discriminal_Record_Constraint, Loc, T); 599 end if; 600 601 Next_Elmt (D); 602 end loop; 603 end if; 604 605 -- If none of the above, the actual and nominal subtypes are the same. 606 607 return Empty; 608 end Build_Discriminal_Subtype_Of_Component; 609 610 ------------------------------ 611 -- Build_Elaboration_Entity -- 612 ------------------------------ 613 614 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is 615 Loc : constant Source_Ptr := Sloc (N); 616 Unum : constant Unit_Number_Type := Get_Source_Unit (Loc); 617 Decl : Node_Id; 618 P : Natural; 619 Elab_Ent : Entity_Id; 620 621 begin 622 -- Ignore if already constructed 623 624 if Present (Elaboration_Entity (Spec_Id)) then 625 return; 626 end if; 627 628 -- Construct name of elaboration entity as xxx_E, where xxx 629 -- is the unit name with dots replaced by double underscore. 630 -- We have to manually construct this name, since it will 631 -- be elaborated in the outer scope, and thus will not have 632 -- the unit name automatically prepended. 633 634 Get_Name_String (Unit_Name (Unum)); 635 636 -- Replace the %s by _E 637 638 Name_Buffer (Name_Len - 1 .. Name_Len) := "_E"; 639 640 -- Replace dots by double underscore 641 642 P := 2; 643 while P < Name_Len - 2 loop 644 if Name_Buffer (P) = '.' then 645 Name_Buffer (P + 2 .. Name_Len + 1) := 646 Name_Buffer (P + 1 .. Name_Len); 647 Name_Len := Name_Len + 1; 648 Name_Buffer (P) := '_'; 649 Name_Buffer (P + 1) := '_'; 650 P := P + 3; 651 else 652 P := P + 1; 653 end if; 654 end loop; 655 656 -- Create elaboration flag 657 658 Elab_Ent := 659 Make_Defining_Identifier (Loc, Chars => Name_Find); 660 Set_Elaboration_Entity (Spec_Id, Elab_Ent); 661 662 if No (Declarations (Aux_Decls_Node (N))) then 663 Set_Declarations (Aux_Decls_Node (N), New_List); 664 end if; 665 666 Decl := 667 Make_Object_Declaration (Loc, 668 Defining_Identifier => Elab_Ent, 669 Object_Definition => 670 New_Occurrence_Of (Standard_Boolean, Loc), 671 Expression => 672 New_Occurrence_Of (Standard_False, Loc)); 673 674 Append_To (Declarations (Aux_Decls_Node (N)), Decl); 675 Analyze (Decl); 676 677 -- Reset True_Constant indication, since we will indeed 678 -- assign a value to the variable in the binder main. 679 680 Set_Is_True_Constant (Elab_Ent, False); 681 Set_Current_Value (Elab_Ent, Empty); 682 683 -- We do not want any further qualification of the name (if we did 684 -- not do this, we would pick up the name of the generic package 685 -- in the case of a library level generic instantiation). 686 687 Set_Has_Qualified_Name (Elab_Ent); 688 Set_Has_Fully_Qualified_Name (Elab_Ent); 689 end Build_Elaboration_Entity; 690 691 ----------------------------------- 692 -- Cannot_Raise_Constraint_Error -- 693 ----------------------------------- 694 695 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is 696 begin 697 if Compile_Time_Known_Value (Expr) then 698 return True; 699 700 elsif Do_Range_Check (Expr) then 701 return False; 702 703 elsif Raises_Constraint_Error (Expr) then 704 return False; 705 706 else 707 case Nkind (Expr) is 708 when N_Identifier => 709 return True; 710 711 when N_Expanded_Name => 712 return True; 713 714 when N_Selected_Component => 715 return not Do_Discriminant_Check (Expr); 716 717 when N_Attribute_Reference => 718 if Do_Overflow_Check (Expr) then 719 return False; 720 721 elsif No (Expressions (Expr)) then 722 return True; 723 724 else 725 declare 726 N : Node_Id := First (Expressions (Expr)); 727 728 begin 729 while Present (N) loop 730 if Cannot_Raise_Constraint_Error (N) then 731 Next (N); 732 else 733 return False; 734 end if; 735 end loop; 736 737 return True; 738 end; 739 end if; 740 741 when N_Type_Conversion => 742 if Do_Overflow_Check (Expr) 743 or else Do_Length_Check (Expr) 744 or else Do_Tag_Check (Expr) 745 then 746 return False; 747 else 748 return 749 Cannot_Raise_Constraint_Error (Expression (Expr)); 750 end if; 751 752 when N_Unchecked_Type_Conversion => 753 return Cannot_Raise_Constraint_Error (Expression (Expr)); 754 755 when N_Unary_Op => 756 if Do_Overflow_Check (Expr) then 757 return False; 758 else 759 return 760 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 761 end if; 762 763 when N_Op_Divide | 764 N_Op_Mod | 765 N_Op_Rem 766 => 767 if Do_Division_Check (Expr) 768 or else Do_Overflow_Check (Expr) 769 then 770 return False; 771 else 772 return 773 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 774 and then 775 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 776 end if; 777 778 when N_Op_Add | 779 N_Op_And | 780 N_Op_Concat | 781 N_Op_Eq | 782 N_Op_Expon | 783 N_Op_Ge | 784 N_Op_Gt | 785 N_Op_Le | 786 N_Op_Lt | 787 N_Op_Multiply | 788 N_Op_Ne | 789 N_Op_Or | 790 N_Op_Rotate_Left | 791 N_Op_Rotate_Right | 792 N_Op_Shift_Left | 793 N_Op_Shift_Right | 794 N_Op_Shift_Right_Arithmetic | 795 N_Op_Subtract | 796 N_Op_Xor 797 => 798 if Do_Overflow_Check (Expr) then 799 return False; 800 else 801 return 802 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 803 and then 804 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 805 end if; 806 807 when others => 808 return False; 809 end case; 810 end if; 811 end Cannot_Raise_Constraint_Error; 812 813 -------------------------- 814 -- Check_Fully_Declared -- 815 -------------------------- 816 817 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is 818 begin 819 if Ekind (T) = E_Incomplete_Type then 820 821 -- Ada0Y (AI-50217): If the type is available through a limited 822 -- with_clause, verify that its full view has been analyzed. 823 824 if From_With_Type (T) 825 and then Present (Non_Limited_View (T)) 826 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type 827 then 828 -- The non-limited view is fully declared 829 null; 830 831 else 832 Error_Msg_NE 833 ("premature usage of incomplete}", N, First_Subtype (T)); 834 end if; 835 836 elsif Has_Private_Component (T) 837 and then not Is_Generic_Type (Root_Type (T)) 838 and then not In_Default_Expression 839 then 840 841 -- Special case: if T is the anonymous type created for a single 842 -- task or protected object, use the name of the source object. 843 844 if Is_Concurrent_Type (T) 845 and then not Comes_From_Source (T) 846 and then Nkind (N) = N_Object_Declaration 847 then 848 Error_Msg_NE ("type of& has incomplete component", N, 849 Defining_Identifier (N)); 850 851 else 852 Error_Msg_NE 853 ("premature usage of incomplete}", N, First_Subtype (T)); 854 end if; 855 end if; 856 end Check_Fully_Declared; 857 858 ------------------------------------------ 859 -- Check_Potentially_Blocking_Operation -- 860 ------------------------------------------ 861 862 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is 863 S : Entity_Id; 864 Loc : constant Source_Ptr := Sloc (N); 865 866 begin 867 -- N is one of the potentially blocking operations listed in 868 -- 9.5.1 (8). When using the Ravenscar profile, raise Program_Error 869 -- before N if the context is a protected action. Otherwise, only issue 870 -- a warning, since some users are relying on blocking operations 871 -- inside protected objects. 872 -- Indirect blocking through a subprogram call 873 -- cannot be diagnosed statically without interprocedural analysis, 874 -- so we do not attempt to do it here. 875 876 S := Scope (Current_Scope); 877 878 while Present (S) and then S /= Standard_Standard loop 879 if Is_Protected_Type (S) then 880 if Restricted_Profile then 881 Insert_Before_And_Analyze (N, 882 Make_Raise_Program_Error (Loc, 883 Reason => PE_Potentially_Blocking_Operation)); 884 Error_Msg_N ("potentially blocking operation, " & 885 " Program Error will be raised at run time?", N); 886 887 else 888 Error_Msg_N 889 ("potentially blocking operation in protected operation?", N); 890 end if; 891 892 return; 893 end if; 894 895 S := Scope (S); 896 end loop; 897 end Check_Potentially_Blocking_Operation; 898 899 --------------- 900 -- Check_VMS -- 901 --------------- 902 903 procedure Check_VMS (Construct : Node_Id) is 904 begin 905 if not OpenVMS_On_Target then 906 Error_Msg_N 907 ("this construct is allowed only in Open'V'M'S", Construct); 908 end if; 909 end Check_VMS; 910 911 ---------------------------------- 912 -- Collect_Primitive_Operations -- 913 ---------------------------------- 914 915 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is 916 B_Type : constant Entity_Id := Base_Type (T); 917 B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); 918 B_Scope : Entity_Id := Scope (B_Type); 919 Op_List : Elist_Id; 920 Formal : Entity_Id; 921 Is_Prim : Boolean; 922 Formal_Derived : Boolean := False; 923 Id : Entity_Id; 924 925 begin 926 -- For tagged types, the primitive operations are collected as they 927 -- are declared, and held in an explicit list which is simply returned. 928 929 if Is_Tagged_Type (B_Type) then 930 return Primitive_Operations (B_Type); 931 932 -- An untagged generic type that is a derived type inherits the 933 -- primitive operations of its parent type. Other formal types only 934 -- have predefined operators, which are not explicitly represented. 935 936 elsif Is_Generic_Type (B_Type) then 937 if Nkind (B_Decl) = N_Formal_Type_Declaration 938 and then Nkind (Formal_Type_Definition (B_Decl)) 939 = N_Formal_Derived_Type_Definition 940 then 941 Formal_Derived := True; 942 else 943 return New_Elmt_List; 944 end if; 945 end if; 946 947 Op_List := New_Elmt_List; 948 949 if B_Scope = Standard_Standard then 950 if B_Type = Standard_String then 951 Append_Elmt (Standard_Op_Concat, Op_List); 952 953 elsif B_Type = Standard_Wide_String then 954 Append_Elmt (Standard_Op_Concatw, Op_List); 955 956 else 957 null; 958 end if; 959 960 elsif (Is_Package (B_Scope) 961 and then Nkind ( 962 Parent (Declaration_Node (First_Subtype (T)))) 963 /= N_Package_Body) 964 965 or else Is_Derived_Type (B_Type) 966 then 967 -- The primitive operations appear after the base type, except 968 -- if the derivation happens within the private part of B_Scope 969 -- and the type is a private type, in which case both the type 970 -- and some primitive operations may appear before the base 971 -- type, and the list of candidates starts after the type. 972 973 if In_Open_Scopes (B_Scope) 974 and then Scope (T) = B_Scope 975 and then In_Private_Part (B_Scope) 976 then 977 Id := Next_Entity (T); 978 else 979 Id := Next_Entity (B_Type); 980 end if; 981 982 while Present (Id) loop 983 984 -- Note that generic formal subprograms are not 985 -- considered to be primitive operations and thus 986 -- are never inherited. 987 988 if Is_Overloadable (Id) 989 and then Nkind (Parent (Parent (Id))) 990 /= N_Formal_Subprogram_Declaration 991 then 992 Is_Prim := False; 993 994 if Base_Type (Etype (Id)) = B_Type then 995 Is_Prim := True; 996 else 997 Formal := First_Formal (Id); 998 while Present (Formal) loop 999 if Base_Type (Etype (Formal)) = B_Type then 1000 Is_Prim := True; 1001 exit; 1002 1003 elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type 1004 and then Base_Type 1005 (Designated_Type (Etype (Formal))) = B_Type 1006 then 1007 Is_Prim := True; 1008 exit; 1009 end if; 1010 1011 Next_Formal (Formal); 1012 end loop; 1013 end if; 1014 1015 -- For a formal derived type, the only primitives are the 1016 -- ones inherited from the parent type. Operations appearing 1017 -- in the package declaration are not primitive for it. 1018 1019 if Is_Prim 1020 and then (not Formal_Derived 1021 or else Present (Alias (Id))) 1022 then 1023 Append_Elmt (Id, Op_List); 1024 end if; 1025 end if; 1026 1027 Next_Entity (Id); 1028 1029 -- For a type declared in System, some of its operations 1030 -- may appear in the target-specific extension to System. 1031 1032 if No (Id) 1033 and then Chars (B_Scope) = Name_System 1034 and then Scope (B_Scope) = Standard_Standard 1035 and then Present_System_Aux 1036 then 1037 B_Scope := System_Aux_Id; 1038 Id := First_Entity (System_Aux_Id); 1039 end if; 1040 end loop; 1041 end if; 1042 1043 return Op_List; 1044 end Collect_Primitive_Operations; 1045 1046 ----------------------------------- 1047 -- Compile_Time_Constraint_Error -- 1048 ----------------------------------- 1049 1050 function Compile_Time_Constraint_Error 1051 (N : Node_Id; 1052 Msg : String; 1053 Ent : Entity_Id := Empty; 1054 Loc : Source_Ptr := No_Location; 1055 Warn : Boolean := False) return Node_Id 1056 is 1057 Msgc : String (1 .. Msg'Length + 2); 1058 Msgl : Natural; 1059 Wmsg : Boolean; 1060 P : Node_Id; 1061 Msgs : Boolean; 1062 Eloc : Source_Ptr; 1063 1064 begin 1065 -- A static constraint error in an instance body is not a fatal error. 1066 -- we choose to inhibit the message altogether, because there is no 1067 -- obvious node (for now) on which to post it. On the other hand the 1068 -- offending node must be replaced with a constraint_error in any case. 1069 1070 -- No messages are generated if we already posted an error on this node 1071 1072 if not Error_Posted (N) then 1073 if Loc /= No_Location then 1074 Eloc := Loc; 1075 else 1076 Eloc := Sloc (N); 1077 end if; 1078 1079 -- Make all such messages unconditional 1080 1081 Msgc (1 .. Msg'Length) := Msg; 1082 Msgc (Msg'Length + 1) := '!'; 1083 Msgl := Msg'Length + 1; 1084 1085 -- Message is a warning, even in Ada 95 case 1086 1087 if Msg (Msg'Length) = '?' then 1088 Wmsg := True; 1089 1090 -- In Ada 83, all messages are warnings. In the private part and 1091 -- the body of an instance, constraint_checks are only warnings. 1092 -- We also make this a warning if the Warn parameter is set. 1093 1094 elsif Warn or else (Ada_83 and then Comes_From_Source (N)) then 1095 Msgl := Msgl + 1; 1096 Msgc (Msgl) := '?'; 1097 Wmsg := True; 1098 1099 elsif In_Instance_Not_Visible then 1100 Msgl := Msgl + 1; 1101 Msgc (Msgl) := '?'; 1102 Wmsg := True; 1103 1104 -- Otherwise we have a real error message (Ada 95 static case) 1105 1106 else 1107 Wmsg := False; 1108 end if; 1109 1110 -- Should we generate a warning? The answer is not quite yes. The 1111 -- very annoying exception occurs in the case of a short circuit 1112 -- operator where the left operand is static and decisive. Climb 1113 -- parents to see if that is the case we have here. 1114 1115 Msgs := True; 1116 P := N; 1117 1118 loop 1119 P := Parent (P); 1120 1121 if (Nkind (P) = N_And_Then 1122 and then Compile_Time_Known_Value (Left_Opnd (P)) 1123 and then Is_False (Expr_Value (Left_Opnd (P)))) 1124 or else (Nkind (P) = N_Or_Else 1125 and then Compile_Time_Known_Value (Left_Opnd (P)) 1126 and then Is_True (Expr_Value (Left_Opnd (P)))) 1127 then 1128 Msgs := False; 1129 exit; 1130 1131 elsif Nkind (P) = N_Component_Association 1132 and then Nkind (Parent (P)) = N_Aggregate 1133 then 1134 null; -- Keep going. 1135 1136 else 1137 exit when Nkind (P) not in N_Subexpr; 1138 end if; 1139 end loop; 1140 1141 if Msgs then 1142 if Present (Ent) then 1143 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); 1144 else 1145 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); 1146 end if; 1147 1148 if Wmsg then 1149 if Inside_Init_Proc then 1150 Error_Msg_NEL 1151 ("\& will be raised for objects of this type!?", 1152 N, Standard_Constraint_Error, Eloc); 1153 else 1154 Error_Msg_NEL 1155 ("\& will be raised at run time!?", 1156 N, Standard_Constraint_Error, Eloc); 1157 end if; 1158 else 1159 Error_Msg_NEL 1160 ("\static expression raises&!", 1161 N, Standard_Constraint_Error, Eloc); 1162 end if; 1163 end if; 1164 end if; 1165 1166 return N; 1167 end Compile_Time_Constraint_Error; 1168 1169 ----------------------- 1170 -- Conditional_Delay -- 1171 ----------------------- 1172 1173 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is 1174 begin 1175 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then 1176 Set_Has_Delayed_Freeze (New_Ent); 1177 end if; 1178 end Conditional_Delay; 1179 1180 -------------------- 1181 -- Current_Entity -- 1182 -------------------- 1183 1184 -- The currently visible definition for a given identifier is the 1185 -- one most chained at the start of the visibility chain, i.e. the 1186 -- one that is referenced by the Node_Id value of the name of the 1187 -- given identifier. 1188 1189 function Current_Entity (N : Node_Id) return Entity_Id is 1190 begin 1191 return Get_Name_Entity_Id (Chars (N)); 1192 end Current_Entity; 1193 1194 ----------------------------- 1195 -- Current_Entity_In_Scope -- 1196 ----------------------------- 1197 1198 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is 1199 E : Entity_Id; 1200 CS : constant Entity_Id := Current_Scope; 1201 1202 Transient_Case : constant Boolean := Scope_Is_Transient; 1203 1204 begin 1205 E := Get_Name_Entity_Id (Chars (N)); 1206 1207 while Present (E) 1208 and then Scope (E) /= CS 1209 and then (not Transient_Case or else Scope (E) /= Scope (CS)) 1210 loop 1211 E := Homonym (E); 1212 end loop; 1213 1214 return E; 1215 end Current_Entity_In_Scope; 1216 1217 ------------------- 1218 -- Current_Scope -- 1219 ------------------- 1220 1221 function Current_Scope return Entity_Id is 1222 begin 1223 if Scope_Stack.Last = -1 then 1224 return Standard_Standard; 1225 else 1226 declare 1227 C : constant Entity_Id := 1228 Scope_Stack.Table (Scope_Stack.Last).Entity; 1229 begin 1230 if Present (C) then 1231 return C; 1232 else 1233 return Standard_Standard; 1234 end if; 1235 end; 1236 end if; 1237 end Current_Scope; 1238 1239 ------------------------ 1240 -- Current_Subprogram -- 1241 ------------------------ 1242 1243 function Current_Subprogram return Entity_Id is 1244 Scop : constant Entity_Id := Current_Scope; 1245 1246 begin 1247 if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then 1248 return Scop; 1249 else 1250 return Enclosing_Subprogram (Scop); 1251 end if; 1252 end Current_Subprogram; 1253 1254 --------------------- 1255 -- Defining_Entity -- 1256 --------------------- 1257 1258 function Defining_Entity (N : Node_Id) return Entity_Id is 1259 K : constant Node_Kind := Nkind (N); 1260 Err : Entity_Id := Empty; 1261 1262 begin 1263 case K is 1264 when 1265 N_Subprogram_Declaration | 1266 N_Abstract_Subprogram_Declaration | 1267 N_Subprogram_Body | 1268 N_Package_Declaration | 1269 N_Subprogram_Renaming_Declaration | 1270 N_Subprogram_Body_Stub | 1271 N_Generic_Subprogram_Declaration | 1272 N_Generic_Package_Declaration | 1273 N_Formal_Subprogram_Declaration 1274 => 1275 return Defining_Entity (Specification (N)); 1276 1277 when 1278 N_Component_Declaration | 1279 N_Defining_Program_Unit_Name | 1280 N_Discriminant_Specification | 1281 N_Entry_Body | 1282 N_Entry_Declaration | 1283 N_Entry_Index_Specification | 1284 N_Exception_Declaration | 1285 N_Exception_Renaming_Declaration | 1286 N_Formal_Object_Declaration | 1287 N_Formal_Package_Declaration | 1288 N_Formal_Type_Declaration | 1289 N_Full_Type_Declaration | 1290 N_Implicit_Label_Declaration | 1291 N_Incomplete_Type_Declaration | 1292 N_Loop_Parameter_Specification | 1293 N_Number_Declaration | 1294 N_Object_Declaration | 1295 N_Object_Renaming_Declaration | 1296 N_Package_Body_Stub | 1297 N_Parameter_Specification | 1298 N_Private_Extension_Declaration | 1299 N_Private_Type_Declaration | 1300 N_Protected_Body | 1301 N_Protected_Body_Stub | 1302 N_Protected_Type_Declaration | 1303 N_Single_Protected_Declaration | 1304 N_Single_Task_Declaration | 1305 N_Subtype_Declaration | 1306 N_Task_Body | 1307 N_Task_Body_Stub | 1308 N_Task_Type_Declaration 1309 => 1310 return Defining_Identifier (N); 1311 1312 when N_Subunit => 1313 return Defining_Entity (Proper_Body (N)); 1314 1315 when 1316 N_Function_Instantiation | 1317 N_Function_Specification | 1318 N_Generic_Function_Renaming_Declaration | 1319 N_Generic_Package_Renaming_Declaration | 1320 N_Generic_Procedure_Renaming_Declaration | 1321 N_Package_Body | 1322 N_Package_Instantiation | 1323 N_Package_Renaming_Declaration | 1324 N_Package_Specification | 1325 N_Procedure_Instantiation | 1326 N_Procedure_Specification 1327 => 1328 declare 1329 Nam : constant Node_Id := Defining_Unit_Name (N); 1330 1331 begin 1332 if Nkind (Nam) in N_Entity then 1333 return Nam; 1334 1335 -- For Error, make up a name and attach to declaration 1336 -- so we can continue semantic analysis 1337 1338 elsif Nam = Error then 1339 Err := 1340 Make_Defining_Identifier (Sloc (N), 1341 Chars => New_Internal_Name ('T')); 1342 Set_Defining_Unit_Name (N, Err); 1343 1344 return Err; 1345 -- If not an entity, get defining identifier 1346 1347 else 1348 return Defining_Identifier (Nam); 1349 end if; 1350 end; 1351 1352 when N_Block_Statement => 1353 return Entity (Identifier (N)); 1354 1355 when others => 1356 raise Program_Error; 1357 1358 end case; 1359 end Defining_Entity; 1360 1361 -------------------------- 1362 -- Denotes_Discriminant -- 1363 -------------------------- 1364 1365 function Denotes_Discriminant 1366 (N : Node_Id; 1367 Check_Protected : Boolean := False) return Boolean 1368 is 1369 E : Entity_Id; 1370 begin 1371 if not Is_Entity_Name (N) 1372 or else No (Entity (N)) 1373 then 1374 return False; 1375 else 1376 E := Entity (N); 1377 end if; 1378 1379 -- If we are checking for a protected type, the discriminant may have 1380 -- been rewritten as the corresponding discriminal of the original type 1381 -- or of the corresponding concurrent record, depending on whether we 1382 -- are in the spec or body of the protected type. 1383 1384 return Ekind (E) = E_Discriminant 1385 or else 1386 (Check_Protected 1387 and then Ekind (E) = E_In_Parameter 1388 and then Present (Discriminal_Link (E)) 1389 and then 1390 (Is_Protected_Type (Scope (Discriminal_Link (E))) 1391 or else 1392 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 1393 1394 end Denotes_Discriminant; 1395 1396 ----------------------------- 1397 -- Depends_On_Discriminant -- 1398 ----------------------------- 1399 1400 function Depends_On_Discriminant (N : Node_Id) return Boolean is 1401 L : Node_Id; 1402 H : Node_Id; 1403 1404 begin 1405 Get_Index_Bounds (N, L, H); 1406 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 1407 end Depends_On_Discriminant; 1408 1409 ------------------------- 1410 -- Designate_Same_Unit -- 1411 ------------------------- 1412 1413 function Designate_Same_Unit 1414 (Name1 : Node_Id; 1415 Name2 : Node_Id) return Boolean 1416 is 1417 K1 : constant Node_Kind := Nkind (Name1); 1418 K2 : constant Node_Kind := Nkind (Name2); 1419 1420 function Prefix_Node (N : Node_Id) return Node_Id; 1421 -- Returns the parent unit name node of a defining program unit name 1422 -- or the prefix if N is a selected component or an expanded name. 1423 1424 function Select_Node (N : Node_Id) return Node_Id; 1425 -- Returns the defining identifier node of a defining program unit 1426 -- name or the selector node if N is a selected component or an 1427 -- expanded name. 1428 1429 ----------------- 1430 -- Prefix_Node -- 1431 ----------------- 1432 1433 function Prefix_Node (N : Node_Id) return Node_Id is 1434 begin 1435 if Nkind (N) = N_Defining_Program_Unit_Name then 1436 return Name (N); 1437 1438 else 1439 return Prefix (N); 1440 end if; 1441 end Prefix_Node; 1442 1443 ----------------- 1444 -- Select_Node -- 1445 ----------------- 1446 1447 function Select_Node (N : Node_Id) return Node_Id is 1448 begin 1449 if Nkind (N) = N_Defining_Program_Unit_Name then 1450 return Defining_Identifier (N); 1451 1452 else 1453 return Selector_Name (N); 1454 end if; 1455 end Select_Node; 1456 1457 -- Start of processing for Designate_Next_Unit 1458 1459 begin 1460 if (K1 = N_Identifier or else 1461 K1 = N_Defining_Identifier) 1462 and then 1463 (K2 = N_Identifier or else 1464 K2 = N_Defining_Identifier) 1465 then 1466 return Chars (Name1) = Chars (Name2); 1467 1468 elsif 1469 (K1 = N_Expanded_Name or else 1470 K1 = N_Selected_Component or else 1471 K1 = N_Defining_Program_Unit_Name) 1472 and then 1473 (K2 = N_Expanded_Name or else 1474 K2 = N_Selected_Component or else 1475 K2 = N_Defining_Program_Unit_Name) 1476 then 1477 return 1478 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 1479 and then 1480 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 1481 1482 else 1483 return False; 1484 end if; 1485 end Designate_Same_Unit; 1486 1487 ---------------------------- 1488 -- Enclosing_Generic_Body -- 1489 ---------------------------- 1490 1491 function Enclosing_Generic_Body 1492 (E : Entity_Id) return Node_Id 1493 is 1494 P : Node_Id; 1495 Decl : Node_Id; 1496 Spec : Node_Id; 1497 1498 begin 1499 P := Parent (E); 1500 1501 while Present (P) loop 1502 if Nkind (P) = N_Package_Body 1503 or else Nkind (P) = N_Subprogram_Body 1504 then 1505 Spec := Corresponding_Spec (P); 1506 1507 if Present (Spec) then 1508 Decl := Unit_Declaration_Node (Spec); 1509 1510 if Nkind (Decl) = N_Generic_Package_Declaration 1511 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 1512 then 1513 return P; 1514 end if; 1515 end if; 1516 end if; 1517 1518 P := Parent (P); 1519 end loop; 1520 1521 return Empty; 1522 end Enclosing_Generic_Body; 1523 1524 ------------------------------- 1525 -- Enclosing_Lib_Unit_Entity -- 1526 ------------------------------- 1527 1528 function Enclosing_Lib_Unit_Entity return Entity_Id is 1529 Unit_Entity : Entity_Id := Current_Scope; 1530 1531 begin 1532 -- Look for enclosing library unit entity by following scope links. 1533 -- Equivalent to, but faster than indexing through the scope stack. 1534 1535 while (Present (Scope (Unit_Entity)) 1536 and then Scope (Unit_Entity) /= Standard_Standard) 1537 and not Is_Child_Unit (Unit_Entity) 1538 loop 1539 Unit_Entity := Scope (Unit_Entity); 1540 end loop; 1541 1542 return Unit_Entity; 1543 end Enclosing_Lib_Unit_Entity; 1544 1545 ----------------------------- 1546 -- Enclosing_Lib_Unit_Node -- 1547 ----------------------------- 1548 1549 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is 1550 Current_Node : Node_Id := N; 1551 1552 begin 1553 while Present (Current_Node) 1554 and then Nkind (Current_Node) /= N_Compilation_Unit 1555 loop 1556 Current_Node := Parent (Current_Node); 1557 end loop; 1558 1559 if Nkind (Current_Node) /= N_Compilation_Unit then 1560 return Empty; 1561 end if; 1562 1563 return Current_Node; 1564 end Enclosing_Lib_Unit_Node; 1565 1566 -------------------------- 1567 -- Enclosing_Subprogram -- 1568 -------------------------- 1569 1570 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 1571 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 1572 1573 begin 1574 if Dynamic_Scope = Standard_Standard then 1575 return Empty; 1576 1577 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then 1578 return Corresponding_Spec (Parent (Parent (Dynamic_Scope))); 1579 1580 elsif Ekind (Dynamic_Scope) = E_Block then 1581 return Enclosing_Subprogram (Dynamic_Scope); 1582 1583 elsif Ekind (Dynamic_Scope) = E_Task_Type then 1584 return Get_Task_Body_Procedure (Dynamic_Scope); 1585 1586 elsif Convention (Dynamic_Scope) = Convention_Protected then 1587 return Protected_Body_Subprogram (Dynamic_Scope); 1588 1589 else 1590 return Dynamic_Scope; 1591 end if; 1592 end Enclosing_Subprogram; 1593 1594 ------------------------ 1595 -- Ensure_Freeze_Node -- 1596 ------------------------ 1597 1598 procedure Ensure_Freeze_Node (E : Entity_Id) is 1599 FN : Node_Id; 1600 1601 begin 1602 if No (Freeze_Node (E)) then 1603 FN := Make_Freeze_Entity (Sloc (E)); 1604 Set_Has_Delayed_Freeze (E); 1605 Set_Freeze_Node (E, FN); 1606 Set_Access_Types_To_Process (FN, No_Elist); 1607 Set_TSS_Elist (FN, No_Elist); 1608 Set_Entity (FN, E); 1609 end if; 1610 end Ensure_Freeze_Node; 1611 1612 ---------------- 1613 -- Enter_Name -- 1614 ---------------- 1615 1616 procedure Enter_Name (Def_Id : Node_Id) is 1617 C : constant Entity_Id := Current_Entity (Def_Id); 1618 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 1619 S : constant Entity_Id := Current_Scope; 1620 1621 begin 1622 Generate_Definition (Def_Id); 1623 1624 -- Add new name to current scope declarations. Check for duplicate 1625 -- declaration, which may or may not be a genuine error. 1626 1627 if Present (E) then 1628 1629 -- Case of previous entity entered because of a missing declaration 1630 -- or else a bad subtype indication. Best is to use the new entity, 1631 -- and make the previous one invisible. 1632 1633 if Etype (E) = Any_Type then 1634 Set_Is_Immediately_Visible (E, False); 1635 1636 -- Case of renaming declaration constructed for package instances. 1637 -- if there is an explicit declaration with the same identifier, 1638 -- the renaming is not immediately visible any longer, but remains 1639 -- visible through selected component notation. 1640 1641 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 1642 and then not Comes_From_Source (E) 1643 then 1644 Set_Is_Immediately_Visible (E, False); 1645 1646 -- The new entity may be the package renaming, which has the same 1647 -- same name as a generic formal which has been seen already. 1648 1649 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 1650 and then not Comes_From_Source (Def_Id) 1651 then 1652 Set_Is_Immediately_Visible (E, False); 1653 1654 -- For a fat pointer corresponding to a remote access to subprogram, 1655 -- we use the same identifier as the RAS type, so that the proper 1656 -- name appears in the stub. This type is only retrieved through 1657 -- the RAS type and never by visibility, and is not added to the 1658 -- visibility list (see below). 1659 1660 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 1661 and then Present (Corresponding_Remote_Type (Def_Id)) 1662 then 1663 null; 1664 1665 -- A controller component for a type extension overrides the 1666 -- inherited component. 1667 1668 elsif Chars (E) = Name_uController then 1669 null; 1670 1671 -- Case of an implicit operation or derived literal. The new entity 1672 -- hides the implicit one, which is removed from all visibility, 1673 -- i.e. the entity list of its scope, and homonym chain of its name. 1674 1675 elsif (Is_Overloadable (E) and then Present (Alias (E))) 1676 or else Is_Internal (E) 1677 or else (Ekind (E) = E_Enumeration_Literal 1678 and then Is_Derived_Type (Etype (E))) 1679 then 1680 declare 1681 Prev : Entity_Id; 1682 Prev_Vis : Entity_Id; 1683 Decl : constant Node_Id := Parent (E); 1684 1685 begin 1686 -- If E is an implicit declaration, it cannot be the first 1687 -- entity in the scope. 1688 1689 Prev := First_Entity (Current_Scope); 1690 1691 while Present (Prev) 1692 and then Next_Entity (Prev) /= E 1693 loop 1694 Next_Entity (Prev); 1695 end loop; 1696 1697 if No (Prev) then 1698 1699 -- If E is not on the entity chain of the current scope, 1700 -- it is an implicit declaration in the generic formal 1701 -- part of a generic subprogram. When analyzing the body, 1702 -- the generic formals are visible but not on the entity 1703 -- chain of the subprogram. The new entity will become 1704 -- the visible one in the body. 1705 1706 pragma Assert 1707 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 1708 null; 1709 1710 else 1711 Set_Next_Entity (Prev, Next_Entity (E)); 1712 1713 if No (Next_Entity (Prev)) then 1714 Set_Last_Entity (Current_Scope, Prev); 1715 end if; 1716 1717 if E = Current_Entity (E) then 1718 Prev_Vis := Empty; 1719 1720 else 1721 Prev_Vis := Current_Entity (E); 1722 while Homonym (Prev_Vis) /= E loop 1723 Prev_Vis := Homonym (Prev_Vis); 1724 end loop; 1725 end if; 1726 1727 if Present (Prev_Vis) then 1728 1729 -- Skip E in the visibility chain 1730 1731 Set_Homonym (Prev_Vis, Homonym (E)); 1732 1733 else 1734 Set_Name_Entity_Id (Chars (E), Homonym (E)); 1735 end if; 1736 end if; 1737 end; 1738 1739 -- This section of code could use a comment ??? 1740 1741 elsif Present (Etype (E)) 1742 and then Is_Concurrent_Type (Etype (E)) 1743 and then E = Def_Id 1744 then 1745 return; 1746 1747 -- In the body or private part of an instance, a type extension 1748 -- may introduce a component with the same name as that of an 1749 -- actual. The legality rule is not enforced, but the semantics 1750 -- of the full type with two components of the same name are not 1751 -- clear at this point ??? 1752 1753 elsif In_Instance_Not_Visible then 1754 null; 1755 1756 -- When compiling a package body, some child units may have become 1757 -- visible. They cannot conflict with local entities that hide them. 1758 1759 elsif Is_Child_Unit (E) 1760 and then In_Open_Scopes (Scope (E)) 1761 and then not Is_Immediately_Visible (E) 1762 then 1763 null; 1764 1765 -- Conversely, with front-end inlining we may compile the parent 1766 -- body first, and a child unit subsequently. The context is now 1767 -- the parent spec, and body entities are not visible. 1768 1769 elsif Is_Child_Unit (Def_Id) 1770 and then Is_Package_Body_Entity (E) 1771 and then not In_Package_Body (Current_Scope) 1772 then 1773 null; 1774 1775 -- Case of genuine duplicate declaration 1776 1777 else 1778 Error_Msg_Sloc := Sloc (E); 1779 1780 -- If the previous declaration is an incomplete type declaration 1781 -- this may be an attempt to complete it with a private type. 1782 -- The following avoids confusing cascaded errors. 1783 1784 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 1785 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 1786 then 1787 Error_Msg_N 1788 ("incomplete type cannot be completed" & 1789 " with a private declaration", 1790 Parent (Def_Id)); 1791 Set_Is_Immediately_Visible (E, False); 1792 Set_Full_View (E, Def_Id); 1793 1794 elsif Ekind (E) = E_Discriminant 1795 and then Present (Scope (Def_Id)) 1796 and then Scope (Def_Id) /= Current_Scope 1797 then 1798 -- An inherited component of a record conflicts with 1799 -- a new discriminant. The discriminant is inserted first 1800 -- in the scope, but the error should be posted on it, not 1801 -- on the component. 1802 1803 Error_Msg_Sloc := Sloc (Def_Id); 1804 Error_Msg_N ("& conflicts with declaration#", E); 1805 return; 1806 1807 -- If the name of the unit appears in its own context clause, 1808 -- a dummy package with the name has already been created, and 1809 -- the error emitted. Try to continue quietly. 1810 1811 elsif Error_Posted (E) 1812 and then Sloc (E) = No_Location 1813 and then Nkind (Parent (E)) = N_Package_Specification 1814 and then Current_Scope = Standard_Standard 1815 then 1816 Set_Scope (Def_Id, Current_Scope); 1817 return; 1818 1819 else 1820 Error_Msg_N ("& conflicts with declaration#", Def_Id); 1821 1822 -- Avoid cascaded messages with duplicate components in 1823 -- derived types. 1824 1825 if Ekind (E) = E_Component 1826 or else Ekind (E) = E_Discriminant 1827 then 1828 return; 1829 end if; 1830 end if; 1831 1832 if Nkind (Parent (Parent (Def_Id))) 1833 = N_Generic_Subprogram_Declaration 1834 and then Def_Id = 1835 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 1836 then 1837 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 1838 end if; 1839 1840 -- If entity is in standard, then we are in trouble, because 1841 -- it means that we have a library package with a duplicated 1842 -- name. That's hard to recover from, so abort! 1843 1844 if S = Standard_Standard then 1845 raise Unrecoverable_Error; 1846 1847 -- Otherwise we continue with the declaration. Having two 1848 -- identical declarations should not cause us too much trouble! 1849 1850 else 1851 null; 1852 end if; 1853 end if; 1854 end if; 1855 1856 -- If we fall through, declaration is OK , or OK enough to continue 1857 1858 -- If Def_Id is a discriminant or a record component we are in the 1859 -- midst of inheriting components in a derived record definition. 1860 -- Preserve their Ekind and Etype. 1861 1862 if Ekind (Def_Id) = E_Discriminant 1863 or else Ekind (Def_Id) = E_Component 1864 then 1865 null; 1866 1867 -- If a type is already set, leave it alone (happens whey a type 1868 -- declaration is reanalyzed following a call to the optimizer) 1869 1870 elsif Present (Etype (Def_Id)) then 1871 null; 1872 1873 -- Otherwise, the kind E_Void insures that premature uses of the entity 1874 -- will be detected. Any_Type insures that no cascaded errors will occur 1875 1876 else 1877 Set_Ekind (Def_Id, E_Void); 1878 Set_Etype (Def_Id, Any_Type); 1879 end if; 1880 1881 -- Inherited discriminants and components in derived record types are 1882 -- immediately visible. Itypes are not. 1883 1884 if Ekind (Def_Id) = E_Discriminant 1885 or else Ekind (Def_Id) = E_Component 1886 or else (No (Corresponding_Remote_Type (Def_Id)) 1887 and then not Is_Itype (Def_Id)) 1888 then 1889 Set_Is_Immediately_Visible (Def_Id); 1890 Set_Current_Entity (Def_Id); 1891 end if; 1892 1893 Set_Homonym (Def_Id, C); 1894 Append_Entity (Def_Id, S); 1895 Set_Public_Status (Def_Id); 1896 1897 -- Warn if new entity hides an old one 1898 1899 if Warn_On_Hiding 1900 and then Present (C) 1901 and then Length_Of_Name (Chars (C)) /= 1 1902 and then Comes_From_Source (C) 1903 and then Comes_From_Source (Def_Id) 1904 and then In_Extended_Main_Source_Unit (Def_Id) 1905 then 1906 Error_Msg_Sloc := Sloc (C); 1907 Error_Msg_N ("declaration hides &#?", Def_Id); 1908 end if; 1909 end Enter_Name; 1910 1911 -------------------------- 1912 -- Explain_Limited_Type -- 1913 -------------------------- 1914 1915 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 1916 C : Entity_Id; 1917 1918 begin 1919 -- For array, component type must be limited 1920 1921 if Is_Array_Type (T) then 1922 Error_Msg_Node_2 := T; 1923 Error_Msg_NE 1924 ("component type& of type& is limited", N, Component_Type (T)); 1925 Explain_Limited_Type (Component_Type (T), N); 1926 1927 elsif Is_Record_Type (T) then 1928 1929 -- No need for extra messages if explicit limited record 1930 1931 if Is_Limited_Record (Base_Type (T)) then 1932 return; 1933 end if; 1934 1935 -- Otherwise find a limited component 1936 1937 C := First_Component (T); 1938 while Present (C) loop 1939 if Is_Limited_Type (Etype (C)) then 1940 Error_Msg_Node_2 := T; 1941 Error_Msg_NE ("\component& of type& has limited type", N, C); 1942 Explain_Limited_Type (Etype (C), N); 1943 return; 1944 end if; 1945 1946 Next_Component (C); 1947 end loop; 1948 1949 -- It's odd if the loop falls through, but this is only an extra 1950 -- error message, so we just let it go and ignore the situation. 1951 1952 return; 1953 end if; 1954 end Explain_Limited_Type; 1955 1956 ------------------------------------- 1957 -- Find_Corresponding_Discriminant -- 1958 ------------------------------------- 1959 1960 function Find_Corresponding_Discriminant 1961 (Id : Node_Id; 1962 Typ : Entity_Id) return Entity_Id 1963 is 1964 Par_Disc : Entity_Id; 1965 Old_Disc : Entity_Id; 1966 New_Disc : Entity_Id; 1967 1968 begin 1969 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 1970 1971 -- The original type may currently be private, and the discriminant 1972 -- only appear on its full view. 1973 1974 if Is_Private_Type (Scope (Par_Disc)) 1975 and then not Has_Discriminants (Scope (Par_Disc)) 1976 and then Present (Full_View (Scope (Par_Disc))) 1977 then 1978 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 1979 else 1980 Old_Disc := First_Discriminant (Scope (Par_Disc)); 1981 end if; 1982 1983 if Is_Class_Wide_Type (Typ) then 1984 New_Disc := First_Discriminant (Root_Type (Typ)); 1985 else 1986 New_Disc := First_Discriminant (Typ); 1987 end if; 1988 1989 while Present (Old_Disc) and then Present (New_Disc) loop 1990 if Old_Disc = Par_Disc then 1991 return New_Disc; 1992 else 1993 Next_Discriminant (Old_Disc); 1994 Next_Discriminant (New_Disc); 1995 end if; 1996 end loop; 1997 1998 -- Should always find it 1999 2000 raise Program_Error; 2001 end Find_Corresponding_Discriminant; 2002 2003 ----------------------------- 2004 -- Find_Static_Alternative -- 2005 ----------------------------- 2006 2007 function Find_Static_Alternative (N : Node_Id) return Node_Id is 2008 Expr : constant Node_Id := Expression (N); 2009 Val : constant Uint := Expr_Value (Expr); 2010 Alt : Node_Id; 2011 Choice : Node_Id; 2012 2013 begin 2014 Alt := First (Alternatives (N)); 2015 2016 Search : loop 2017 if Nkind (Alt) /= N_Pragma then 2018 Choice := First (Discrete_Choices (Alt)); 2019 2020 while Present (Choice) loop 2021 2022 -- Others choice, always matches 2023 2024 if Nkind (Choice) = N_Others_Choice then 2025 exit Search; 2026 2027 -- Range, check if value is in the range 2028 2029 elsif Nkind (Choice) = N_Range then 2030 exit Search when 2031 Val >= Expr_Value (Low_Bound (Choice)) 2032 and then 2033 Val <= Expr_Value (High_Bound (Choice)); 2034 2035 -- Choice is a subtype name. Note that we know it must 2036 -- be a static subtype, since otherwise it would have 2037 -- been diagnosed as illegal. 2038 2039 elsif Is_Entity_Name (Choice) 2040 and then Is_Type (Entity (Choice)) 2041 then 2042 exit Search when Is_In_Range (Expr, Etype (Choice)); 2043 2044 -- Choice is a subtype indication 2045 2046 elsif Nkind (Choice) = N_Subtype_Indication then 2047 declare 2048 C : constant Node_Id := Constraint (Choice); 2049 R : constant Node_Id := Range_Expression (C); 2050 2051 begin 2052 exit Search when 2053 Val >= Expr_Value (Low_Bound (R)) 2054 and then 2055 Val <= Expr_Value (High_Bound (R)); 2056 end; 2057 2058 -- Choice is a simple expression 2059 2060 else 2061 exit Search when Val = Expr_Value (Choice); 2062 end if; 2063 2064 Next (Choice); 2065 end loop; 2066 end if; 2067 2068 Next (Alt); 2069 pragma Assert (Present (Alt)); 2070 end loop Search; 2071 2072 -- The above loop *must* terminate by finding a match, since 2073 -- we know the case statement is valid, and the value of the 2074 -- expression is known at compile time. When we fall out of 2075 -- the loop, Alt points to the alternative that we know will 2076 -- be selected at run time. 2077 2078 return Alt; 2079 end Find_Static_Alternative; 2080 2081 ------------------ 2082 -- First_Actual -- 2083 ------------------ 2084 2085 function First_Actual (Node : Node_Id) return Node_Id is 2086 N : Node_Id; 2087 2088 begin 2089 if No (Parameter_Associations (Node)) then 2090 return Empty; 2091 end if; 2092 2093 N := First (Parameter_Associations (Node)); 2094 2095 if Nkind (N) = N_Parameter_Association then 2096 return First_Named_Actual (Node); 2097 else 2098 return N; 2099 end if; 2100 end First_Actual; 2101 2102 ------------------------- 2103 -- Full_Qualified_Name -- 2104 ------------------------- 2105 2106 function Full_Qualified_Name (E : Entity_Id) return String_Id is 2107 Res : String_Id; 2108 pragma Warnings (Off, Res); 2109 2110 function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id; 2111 -- Compute recursively the qualified name without NUL at the end. 2112 2113 ---------------------------------- 2114 -- Internal_Full_Qualified_Name -- 2115 ---------------------------------- 2116 2117 function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is 2118 Ent : Entity_Id := E; 2119 Parent_Name : String_Id := No_String; 2120 2121 begin 2122 -- Deals properly with child units 2123 2124 if Nkind (Ent) = N_Defining_Program_Unit_Name then 2125 Ent := Defining_Identifier (Ent); 2126 end if; 2127 2128 -- Compute recursively the qualification. Only "Standard" has no 2129 -- scope. 2130 2131 if Present (Scope (Scope (Ent))) then 2132 Parent_Name := Internal_Full_Qualified_Name (Scope (Ent)); 2133 end if; 2134 2135 -- Every entity should have a name except some expanded blocks 2136 -- don't bother about those. 2137 2138 if Chars (Ent) = No_Name then 2139 return Parent_Name; 2140 end if; 2141 2142 -- Add a period between Name and qualification 2143 2144 if Parent_Name /= No_String then 2145 Start_String (Parent_Name); 2146 Store_String_Char (Get_Char_Code ('.')); 2147 2148 else 2149 Start_String; 2150 end if; 2151 2152 -- Generates the entity name in upper case 2153 2154 Get_Name_String (Chars (Ent)); 2155 Set_All_Upper_Case; 2156 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 2157 return End_String; 2158 end Internal_Full_Qualified_Name; 2159 2160 -- Start of processing for Full_Qualified_Name 2161 2162 begin 2163 Res := Internal_Full_Qualified_Name (E); 2164 Store_String_Char (Get_Char_Code (ASCII.nul)); 2165 return End_String; 2166 end Full_Qualified_Name; 2167 2168 ----------------------- 2169 -- Gather_Components -- 2170 ----------------------- 2171 2172 procedure Gather_Components 2173 (Typ : Entity_Id; 2174 Comp_List : Node_Id; 2175 Governed_By : List_Id; 2176 Into : Elist_Id; 2177 Report_Errors : out Boolean) 2178 is 2179 Assoc : Node_Id; 2180 Variant : Node_Id; 2181 Discrete_Choice : Node_Id; 2182 Comp_Item : Node_Id; 2183 2184 Discrim : Entity_Id; 2185 Discrim_Name : Node_Id; 2186 Discrim_Value : Node_Id; 2187 2188 begin 2189 Report_Errors := False; 2190 2191 if No (Comp_List) or else Null_Present (Comp_List) then 2192 return; 2193 2194 elsif Present (Component_Items (Comp_List)) then 2195 Comp_Item := First (Component_Items (Comp_List)); 2196 2197 else 2198 Comp_Item := Empty; 2199 end if; 2200 2201 while Present (Comp_Item) loop 2202 2203 -- Skip the tag of a tagged record, as well as all items 2204 -- that are not user components (anonymous types, rep clauses, 2205 -- Parent field, controller field). 2206 2207 if Nkind (Comp_Item) = N_Component_Declaration 2208 and then Chars (Defining_Identifier (Comp_Item)) /= Name_uTag 2209 and then Chars (Defining_Identifier (Comp_Item)) /= Name_uParent 2210 and then Chars (Defining_Identifier (Comp_Item)) /= Name_uController 2211 then 2212 Append_Elmt (Defining_Identifier (Comp_Item), Into); 2213 end if; 2214 2215 Next (Comp_Item); 2216 end loop; 2217 2218 if No (Variant_Part (Comp_List)) then 2219 return; 2220 else 2221 Discrim_Name := Name (Variant_Part (Comp_List)); 2222 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 2223 end if; 2224 2225 -- Look for the discriminant that governs this variant part. 2226 -- The discriminant *must* be in the Governed_By List 2227 2228 Assoc := First (Governed_By); 2229 Find_Constraint : loop 2230 Discrim := First (Choices (Assoc)); 2231 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) 2232 or else (Present (Corresponding_Discriminant (Entity (Discrim))) 2233 and then 2234 Chars (Corresponding_Discriminant (Entity (Discrim))) 2235 = Chars (Discrim_Name)) 2236 or else Chars (Original_Record_Component (Entity (Discrim))) 2237 = Chars (Discrim_Name); 2238 2239 if No (Next (Assoc)) then 2240 if not Is_Constrained (Typ) 2241 and then Is_Derived_Type (Typ) 2242 and then Present (Stored_Constraint (Typ)) 2243 then 2244 2245 -- If the type is a tagged type with inherited discriminants, 2246 -- use the stored constraint on the parent in order to find 2247 -- the values of discriminants that are otherwise hidden by an 2248 -- explicit constraint. Renamed discriminants are handled in 2249 -- the code above. 2250 2251 -- If several parent discriminants are renamed by a single 2252 -- discriminant of the derived type, the call to obtain the 2253 -- Corresponding_Discriminant field only retrieves the last 2254 -- of them. We recover the constraint on the others from the 2255 -- Stored_Constraint as well. 2256 2257 declare 2258 D : Entity_Id; 2259 C : Elmt_Id; 2260 2261 begin 2262 D := First_Discriminant (Etype (Typ)); 2263 C := First_Elmt (Stored_Constraint (Typ)); 2264 2265 while Present (D) 2266 and then Present (C) 2267 loop 2268 if Chars (Discrim_Name) = Chars (D) then 2269 if Is_Entity_Name (Node (C)) 2270 and then Entity (Node (C)) = Entity (Discrim) 2271 then 2272 -- D is renamed by Discrim, whose value is 2273 -- given in Assoc. 2274 2275 null; 2276 2277 else 2278 Assoc := 2279 Make_Component_Association (Sloc (Typ), 2280 New_List 2281 (New_Occurrence_Of (D, Sloc (Typ))), 2282 Duplicate_Subexpr_No_Checks (Node (C))); 2283 end if; 2284 exit Find_Constraint; 2285 end if; 2286 2287 D := Next_Discriminant (D); 2288 Next_Elmt (C); 2289 end loop; 2290 end; 2291 end if; 2292 end if; 2293 2294 if No (Next (Assoc)) then 2295 Error_Msg_NE (" missing value for discriminant&", 2296 First (Governed_By), Discrim_Name); 2297 Report_Errors := True; 2298 return; 2299 end if; 2300 2301 Next (Assoc); 2302 end loop Find_Constraint; 2303 2304 Discrim_Value := Expression (Assoc); 2305 2306 if not Is_OK_Static_Expression (Discrim_Value) then 2307 Error_Msg_FE 2308 ("value for discriminant & must be static!", 2309 Discrim_Value, Discrim); 2310 Why_Not_Static (Discrim_Value); 2311 Report_Errors := True; 2312 return; 2313 end if; 2314 2315 Search_For_Discriminant_Value : declare 2316 Low : Node_Id; 2317 High : Node_Id; 2318 2319 UI_High : Uint; 2320 UI_Low : Uint; 2321 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value); 2322 2323 begin 2324 Find_Discrete_Value : while Present (Variant) loop 2325 Discrete_Choice := First (Discrete_Choices (Variant)); 2326 while Present (Discrete_Choice) loop 2327 2328 exit Find_Discrete_Value when 2329 Nkind (Discrete_Choice) = N_Others_Choice; 2330 2331 Get_Index_Bounds (Discrete_Choice, Low, High); 2332 2333 UI_Low := Expr_Value (Low); 2334 UI_High := Expr_Value (High); 2335 2336 exit Find_Discrete_Value when 2337 UI_Low <= UI_Discrim_Value 2338 and then 2339 UI_High >= UI_Discrim_Value; 2340 2341 Next (Discrete_Choice); 2342 end loop; 2343 2344 Next_Non_Pragma (Variant); 2345 end loop Find_Discrete_Value; 2346 end Search_For_Discriminant_Value; 2347 2348 if No (Variant) then 2349 Error_Msg_NE 2350 ("value of discriminant & is out of range", Discrim_Value, Discrim); 2351 Report_Errors := True; 2352 return; 2353 end if; 2354 2355 -- If we have found the corresponding choice, recursively add its 2356 -- components to the Into list. 2357 2358 Gather_Components (Empty, 2359 Component_List (Variant), Governed_By, Into, Report_Errors); 2360 end Gather_Components; 2361 2362 ------------------------ 2363 -- Get_Actual_Subtype -- 2364 ------------------------ 2365 2366 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 2367 Typ : constant Entity_Id := Etype (N); 2368 Utyp : Entity_Id := Underlying_Type (Typ); 2369 Decl : Node_Id; 2370 Atyp : Entity_Id; 2371 2372 begin 2373 if not Present (Utyp) then 2374 Utyp := Typ; 2375 end if; 2376 2377 -- If what we have is an identifier that references a subprogram 2378 -- formal, or a variable or constant object, then we get the actual 2379 -- subtype from the referenced entity if one has been built. 2380 2381 if Nkind (N) = N_Identifier 2382 and then 2383 (Is_Formal (Entity (N)) 2384 or else Ekind (Entity (N)) = E_Constant 2385 or else Ekind (Entity (N)) = E_Variable) 2386 and then Present (Actual_Subtype (Entity (N))) 2387 then 2388 return Actual_Subtype (Entity (N)); 2389 2390 -- Actual subtype of unchecked union is always itself. We never need 2391 -- the "real" actual subtype. If we did, we couldn't get it anyway 2392 -- because the discriminant is not available. The restrictions on 2393 -- Unchecked_Union are designed to make sure that this is OK. 2394 2395 elsif Is_Unchecked_Union (Utyp) then 2396 return Typ; 2397 2398 -- Here for the unconstrained case, we must find actual subtype 2399 -- No actual subtype is available, so we must build it on the fly. 2400 2401 -- Checking the type, not the underlying type, for constrainedness 2402 -- seems to be necessary. Maybe all the tests should be on the type??? 2403 2404 elsif (not Is_Constrained (Typ)) 2405 and then (Is_Array_Type (Utyp) 2406 or else (Is_Record_Type (Utyp) 2407 and then Has_Discriminants (Utyp))) 2408 and then not Has_Unknown_Discriminants (Utyp) 2409 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 2410 then 2411 -- Nothing to do if in default expression 2412 2413 if In_Default_Expression then 2414 return Typ; 2415 2416 elsif Is_Private_Type (Typ) 2417 and then not Has_Discriminants (Typ) 2418 then 2419 -- If the type has no discriminants, there is no subtype to 2420 -- build, even if the underlying type is discriminated. 2421 2422 return Typ; 2423 2424 -- Else build the actual subtype 2425 2426 else 2427 Decl := Build_Actual_Subtype (Typ, N); 2428 Atyp := Defining_Identifier (Decl); 2429 2430 -- If Build_Actual_Subtype generated a new declaration then use it 2431 2432 if Atyp /= Typ then 2433 2434 -- The actual subtype is an Itype, so analyze the declaration, 2435 -- but do not attach it to the tree, to get the type defined. 2436 2437 Set_Parent (Decl, N); 2438 Set_Is_Itype (Atyp); 2439 Analyze (Decl, Suppress => All_Checks); 2440 Set_Associated_Node_For_Itype (Atyp, N); 2441 Set_Has_Delayed_Freeze (Atyp, False); 2442 2443 -- We need to freeze the actual subtype immediately. This is 2444 -- needed, because otherwise this Itype will not get frozen 2445 -- at all, and it is always safe to freeze on creation because 2446 -- any associated types must be frozen at this point. 2447 2448 Freeze_Itype (Atyp, N); 2449 return Atyp; 2450 2451 -- Otherwise we did not build a declaration, so return original 2452 2453 else 2454 return Typ; 2455 end if; 2456 end if; 2457 2458 -- For all remaining cases, the actual subtype is the same as 2459 -- the nominal type. 2460 2461 else 2462 return Typ; 2463 end if; 2464 end Get_Actual_Subtype; 2465 2466 ------------------------------------- 2467 -- Get_Actual_Subtype_If_Available -- 2468 ------------------------------------- 2469 2470 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 2471 Typ : constant Entity_Id := Etype (N); 2472 2473 begin 2474 -- If what we have is an identifier that references a subprogram 2475 -- formal, or a variable or constant object, then we get the actual 2476 -- subtype from the referenced entity if one has been built. 2477 2478 if Nkind (N) = N_Identifier 2479 and then 2480 (Is_Formal (Entity (N)) 2481 or else Ekind (Entity (N)) = E_Constant 2482 or else Ekind (Entity (N)) = E_Variable) 2483 and then Present (Actual_Subtype (Entity (N))) 2484 then 2485 return Actual_Subtype (Entity (N)); 2486 2487 -- Otherwise the Etype of N is returned unchanged 2488 2489 else 2490 return Typ; 2491 end if; 2492 end Get_Actual_Subtype_If_Available; 2493 2494 ------------------------------- 2495 -- Get_Default_External_Name -- 2496 ------------------------------- 2497 2498 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 2499 begin 2500 Get_Decoded_Name_String (Chars (E)); 2501 2502 if Opt.External_Name_Imp_Casing = Uppercase then 2503 Set_Casing (All_Upper_Case); 2504 else 2505 Set_Casing (All_Lower_Case); 2506 end if; 2507 2508 return 2509 Make_String_Literal (Sloc (E), 2510 Strval => String_From_Name_Buffer); 2511 end Get_Default_External_Name; 2512 2513 --------------------------- 2514 -- Get_Enum_Lit_From_Pos -- 2515 --------------------------- 2516 2517 function Get_Enum_Lit_From_Pos 2518 (T : Entity_Id; 2519 Pos : Uint; 2520 Loc : Source_Ptr) return Node_Id 2521 is 2522 Lit : Node_Id; 2523 P : constant Nat := UI_To_Int (Pos); 2524 2525 begin 2526 -- In the case where the literal is either of type Wide_Character 2527 -- or Character or of a type derived from them, there needs to be 2528 -- some special handling since there is no explicit chain of 2529 -- literals to search. Instead, an N_Character_Literal node is 2530 -- created with the appropriate Char_Code and Chars fields. 2531 2532 if Root_Type (T) = Standard_Character 2533 or else Root_Type (T) = Standard_Wide_Character 2534 then 2535 Set_Character_Literal_Name (Char_Code (P)); 2536 return 2537 Make_Character_Literal (Loc, 2538 Chars => Name_Find, 2539 Char_Literal_Value => Char_Code (P)); 2540 2541 -- For all other cases, we have a complete table of literals, and 2542 -- we simply iterate through the chain of literal until the one 2543 -- with the desired position value is found. 2544 -- 2545 2546 else 2547 Lit := First_Literal (Base_Type (T)); 2548 for J in 1 .. P loop 2549 Next_Literal (Lit); 2550 end loop; 2551 2552 return New_Occurrence_Of (Lit, Loc); 2553 end if; 2554 end Get_Enum_Lit_From_Pos; 2555 2556 ------------------------ 2557 -- Get_Generic_Entity -- 2558 ------------------------ 2559 2560 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 2561 Ent : constant Entity_Id := Entity (Name (N)); 2562 2563 begin 2564 if Present (Renamed_Object (Ent)) then 2565 return Renamed_Object (Ent); 2566 else 2567 return Ent; 2568 end if; 2569 end Get_Generic_Entity; 2570 2571 ---------------------- 2572 -- Get_Index_Bounds -- 2573 ---------------------- 2574 2575 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is 2576 Kind : constant Node_Kind := Nkind (N); 2577 R : Node_Id; 2578 2579 begin 2580 if Kind = N_Range then 2581 L := Low_Bound (N); 2582 H := High_Bound (N); 2583 2584 elsif Kind = N_Subtype_Indication then 2585 R := Range_Expression (Constraint (N)); 2586 2587 if R = Error then 2588 L := Error; 2589 H := Error; 2590 return; 2591 2592 else 2593 L := Low_Bound (Range_Expression (Constraint (N))); 2594 H := High_Bound (Range_Expression (Constraint (N))); 2595 end if; 2596 2597 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 2598 if Error_Posted (Scalar_Range (Entity (N))) then 2599 L := Error; 2600 H := Error; 2601 2602 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then 2603 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H); 2604 2605 else 2606 L := Low_Bound (Scalar_Range (Entity (N))); 2607 H := High_Bound (Scalar_Range (Entity (N))); 2608 end if; 2609 2610 else 2611 -- N is an expression, indicating a range with one value. 2612 2613 L := N; 2614 H := N; 2615 end if; 2616 end Get_Index_Bounds; 2617 2618 ------------------------ 2619 -- Get_Name_Entity_Id -- 2620 ------------------------ 2621 2622 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 2623 begin 2624 return Entity_Id (Get_Name_Table_Info (Id)); 2625 end Get_Name_Entity_Id; 2626 2627 --------------------------- 2628 -- Get_Referenced_Object -- 2629 --------------------------- 2630 2631 function Get_Referenced_Object (N : Node_Id) return Node_Id is 2632 R : Node_Id := N; 2633 2634 begin 2635 while Is_Entity_Name (R) 2636 and then Present (Renamed_Object (Entity (R))) 2637 loop 2638 R := Renamed_Object (Entity (R)); 2639 end loop; 2640 2641 return R; 2642 end Get_Referenced_Object; 2643 2644 ------------------------- 2645 -- Get_Subprogram_Body -- 2646 ------------------------- 2647 2648 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is 2649 Decl : Node_Id; 2650 2651 begin 2652 Decl := Unit_Declaration_Node (E); 2653 2654 if Nkind (Decl) = N_Subprogram_Body then 2655 return Decl; 2656 2657 else -- Nkind (Decl) = N_Subprogram_Declaration 2658 2659 if Present (Corresponding_Body (Decl)) then 2660 return Unit_Declaration_Node (Corresponding_Body (Decl)); 2661 2662 else -- imported subprogram. 2663 return Empty; 2664 end if; 2665 end if; 2666 end Get_Subprogram_Body; 2667 2668 ----------------------------- 2669 -- Get_Task_Body_Procedure -- 2670 ----------------------------- 2671 2672 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is 2673 begin 2674 return Task_Body_Procedure (Declaration_Node (Root_Type (E))); 2675 end Get_Task_Body_Procedure; 2676 2677 -------------------- 2678 -- Has_Infinities -- 2679 -------------------- 2680 2681 function Has_Infinities (E : Entity_Id) return Boolean is 2682 begin 2683 return 2684 Is_Floating_Point_Type (E) 2685 and then Nkind (Scalar_Range (E)) = N_Range 2686 and then Includes_Infinities (Scalar_Range (E)); 2687 end Has_Infinities; 2688 2689 ------------------------ 2690 -- Has_Null_Extension -- 2691 ------------------------ 2692 2693 function Has_Null_Extension (T : Entity_Id) return Boolean is 2694 B : constant Entity_Id := Base_Type (T); 2695 Comps : Node_Id; 2696 Ext : Node_Id; 2697 2698 begin 2699 if Nkind (Parent (B)) = N_Full_Type_Declaration 2700 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 2701 then 2702 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 2703 2704 if Present (Ext) then 2705 if Null_Present (Ext) then 2706 return True; 2707 else 2708 Comps := Component_List (Ext); 2709 2710 -- The null component list is rewritten during analysis to 2711 -- include the parent component. Any other component indicates 2712 -- that the extension was not originally null. 2713 2714 return Null_Present (Comps) 2715 or else No (Next (First (Component_Items (Comps)))); 2716 end if; 2717 else 2718 return False; 2719 end if; 2720 2721 else 2722 return False; 2723 end if; 2724 end Has_Null_Extension; 2725 2726 --------------------------- 2727 -- Has_Private_Component -- 2728 --------------------------- 2729 2730 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 2731 Btype : Entity_Id := Base_Type (Type_Id); 2732 Component : Entity_Id; 2733 2734 begin 2735 if Error_Posted (Type_Id) 2736 or else Error_Posted (Btype) 2737 then 2738 return False; 2739 end if; 2740 2741 if Is_Class_Wide_Type (Btype) then 2742 Btype := Root_Type (Btype); 2743 end if; 2744 2745 if Is_Private_Type (Btype) then 2746 declare 2747 UT : constant Entity_Id := Underlying_Type (Btype); 2748 begin 2749 if No (UT) then 2750 2751 if No (Full_View (Btype)) then 2752 return not Is_Generic_Type (Btype) 2753 and then not Is_Generic_Type (Root_Type (Btype)); 2754 2755 else 2756 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 2757 end if; 2758 2759 else 2760 return not Is_Frozen (UT) and then Has_Private_Component (UT); 2761 end if; 2762 end; 2763 elsif Is_Array_Type (Btype) then 2764 return Has_Private_Component (Component_Type (Btype)); 2765 2766 elsif Is_Record_Type (Btype) then 2767 2768 Component := First_Component (Btype); 2769 while Present (Component) loop 2770 2771 if Has_Private_Component (Etype (Component)) then 2772 return True; 2773 end if; 2774 2775 Next_Component (Component); 2776 end loop; 2777 2778 return False; 2779 2780 elsif Is_Protected_Type (Btype) 2781 and then Present (Corresponding_Record_Type (Btype)) 2782 then 2783 return Has_Private_Component (Corresponding_Record_Type (Btype)); 2784 2785 else 2786 return False; 2787 end if; 2788 end Has_Private_Component; 2789 2790 -------------------------- 2791 -- Has_Tagged_Component -- 2792 -------------------------- 2793 2794 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 2795 Comp : Entity_Id; 2796 2797 begin 2798 if Is_Private_Type (Typ) 2799 and then Present (Underlying_Type (Typ)) 2800 then 2801 return Has_Tagged_Component (Underlying_Type (Typ)); 2802 2803 elsif Is_Array_Type (Typ) then 2804 return Has_Tagged_Component (Component_Type (Typ)); 2805 2806 elsif Is_Tagged_Type (Typ) then 2807 return True; 2808 2809 elsif Is_Record_Type (Typ) then 2810 Comp := First_Component (Typ); 2811 2812 while Present (Comp) loop 2813 if Has_Tagged_Component (Etype (Comp)) then 2814 return True; 2815 end if; 2816 2817 Comp := Next_Component (Typ); 2818 end loop; 2819 2820 return False; 2821 2822 else 2823 return False; 2824 end if; 2825 end Has_Tagged_Component; 2826 2827 ----------------- 2828 -- In_Instance -- 2829 ----------------- 2830 2831 function In_Instance return Boolean is 2832 S : Entity_Id := Current_Scope; 2833 2834 begin 2835 while Present (S) 2836 and then S /= Standard_Standard 2837 loop 2838 if (Ekind (S) = E_Function 2839 or else Ekind (S) = E_Package 2840 or else Ekind (S) = E_Procedure) 2841 and then Is_Generic_Instance (S) 2842 then 2843 return True; 2844 end if; 2845 2846 S := Scope (S); 2847 end loop; 2848 2849 return False; 2850 end In_Instance; 2851 2852 ---------------------- 2853 -- In_Instance_Body -- 2854 ---------------------- 2855 2856 function In_Instance_Body return Boolean is 2857 S : Entity_Id := Current_Scope; 2858 2859 begin 2860 while Present (S) 2861 and then S /= Standard_Standard 2862 loop 2863 if (Ekind (S) = E_Function 2864 or else Ekind (S) = E_Procedure) 2865 and then Is_Generic_Instance (S) 2866 then 2867 return True; 2868 2869 elsif Ekind (S) = E_Package 2870 and then In_Package_Body (S) 2871 and then Is_Generic_Instance (S) 2872 then 2873 return True; 2874 end if; 2875 2876 S := Scope (S); 2877 end loop; 2878 2879 return False; 2880 end In_Instance_Body; 2881 2882 ----------------------------- 2883 -- In_Instance_Not_Visible -- 2884 ----------------------------- 2885 2886 function In_Instance_Not_Visible return Boolean is 2887 S : Entity_Id := Current_Scope; 2888 2889 begin 2890 while Present (S) 2891 and then S /= Standard_Standard 2892 loop 2893 if (Ekind (S) = E_Function 2894 or else Ekind (S) = E_Procedure) 2895 and then Is_Generic_Instance (S) 2896 then 2897 return True; 2898 2899 elsif Ekind (S) = E_Package 2900 and then (In_Package_Body (S) or else In_Private_Part (S)) 2901 and then Is_Generic_Instance (S) 2902 then 2903 return True; 2904 end if; 2905 2906 S := Scope (S); 2907 end loop; 2908 2909 return False; 2910 end In_Instance_Not_Visible; 2911 2912 ------------------------------ 2913 -- In_Instance_Visible_Part -- 2914 ------------------------------ 2915 2916 function In_Instance_Visible_Part return Boolean is 2917 S : Entity_Id := Current_Scope; 2918 2919 begin 2920 while Present (S) 2921 and then S /= Standard_Standard 2922 loop 2923 if Ekind (S) = E_Package 2924 and then Is_Generic_Instance (S) 2925 and then not In_Package_Body (S) 2926 and then not In_Private_Part (S) 2927 then 2928 return True; 2929 end if; 2930 2931 S := Scope (S); 2932 end loop; 2933 2934 return False; 2935 end In_Instance_Visible_Part; 2936 2937 ---------------------- 2938 -- In_Packiage_Body -- 2939 ---------------------- 2940 2941 function In_Package_Body return Boolean is 2942 S : Entity_Id := Current_Scope; 2943 2944 begin 2945 while Present (S) 2946 and then S /= Standard_Standard 2947 loop 2948 if Ekind (S) = E_Package 2949 and then In_Package_Body (S) 2950 then 2951 return True; 2952 else 2953 S := Scope (S); 2954 end if; 2955 end loop; 2956 2957 return False; 2958 end In_Package_Body; 2959 2960 -------------------------------------- 2961 -- In_Subprogram_Or_Concurrent_Unit -- 2962 -------------------------------------- 2963 2964 function In_Subprogram_Or_Concurrent_Unit return Boolean is 2965 E : Entity_Id; 2966 K : Entity_Kind; 2967 2968 begin 2969 -- Use scope chain to check successively outer scopes 2970 2971 E := Current_Scope; 2972 loop 2973 K := Ekind (E); 2974 2975 if K in Subprogram_Kind 2976 or else K in Concurrent_Kind 2977 or else K in Generic_Subprogram_Kind 2978 then 2979 return True; 2980 2981 elsif E = Standard_Standard then 2982 return False; 2983 end if; 2984 2985 E := Scope (E); 2986 end loop; 2987 end In_Subprogram_Or_Concurrent_Unit; 2988 2989 --------------------- 2990 -- In_Visible_Part -- 2991 --------------------- 2992 2993 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 2994 begin 2995 return 2996 Is_Package (Scope_Id) 2997 and then In_Open_Scopes (Scope_Id) 2998 and then not In_Package_Body (Scope_Id) 2999 and then not In_Private_Part (Scope_Id); 3000 end In_Visible_Part; 3001 3002 --------------------------------- 3003 -- Insert_Explicit_Dereference -- 3004 --------------------------------- 3005 3006 procedure Insert_Explicit_Dereference (N : Node_Id) is 3007 New_Prefix : constant Node_Id := Relocate_Node (N); 3008 I : Interp_Index; 3009 It : Interp; 3010 T : Entity_Id; 3011 3012 begin 3013 Save_Interps (N, New_Prefix); 3014 Rewrite (N, 3015 Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix)); 3016 3017 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 3018 3019 if Is_Overloaded (New_Prefix) then 3020 3021 -- The deference is also overloaded, and its interpretations are the 3022 -- designated types of the interpretations of the original node. 3023 3024 Set_Etype (N, Any_Type); 3025 Get_First_Interp (New_Prefix, I, It); 3026 3027 while Present (It.Nam) loop 3028 T := It.Typ; 3029 3030 if Is_Access_Type (T) then 3031 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 3032 end if; 3033 3034 Get_Next_Interp (I, It); 3035 end loop; 3036 3037 End_Interp_List; 3038 end if; 3039 end Insert_Explicit_Dereference; 3040 3041 ------------------- 3042 -- Is_AAMP_Float -- 3043 ------------------- 3044 3045 function Is_AAMP_Float (E : Entity_Id) return Boolean is 3046 begin 3047 pragma Assert (Is_Type (E)); 3048 3049 return AAMP_On_Target 3050 and then Is_Floating_Point_Type (E) 3051 and then E = Base_Type (E); 3052 end Is_AAMP_Float; 3053 3054 ------------------------- 3055 -- Is_Actual_Parameter -- 3056 ------------------------- 3057 3058 function Is_Actual_Parameter (N : Node_Id) return Boolean is 3059 PK : constant Node_Kind := Nkind (Parent (N)); 3060 3061 begin 3062 case PK is 3063 when N_Parameter_Association => 3064 return N = Explicit_Actual_Parameter (Parent (N)); 3065 3066 when N_Function_Call | N_Procedure_Call_Statement => 3067 return Is_List_Member (N) 3068 and then 3069 List_Containing (N) = Parameter_Associations (Parent (N)); 3070 3071 when others => 3072 return False; 3073 end case; 3074 end Is_Actual_Parameter; 3075 3076 --------------------- 3077 -- Is_Aliased_View -- 3078 --------------------- 3079 3080 function Is_Aliased_View (Obj : Node_Id) return Boolean is 3081 E : Entity_Id; 3082 3083 begin 3084 if Is_Entity_Name (Obj) then 3085 3086 -- Shouldn't we check that we really have an object here? 3087 -- If we do, then a-caldel.adb blows up mysteriously ??? 3088 3089 E := Entity (Obj); 3090 3091 return Is_Aliased (E) 3092 or else (Present (Renamed_Object (E)) 3093 and then Is_Aliased_View (Renamed_Object (E))) 3094 3095 or else ((Is_Formal (E) 3096 or else Ekind (E) = E_Generic_In_Out_Parameter 3097 or else Ekind (E) = E_Generic_In_Parameter) 3098 and then Is_Tagged_Type (Etype (E))) 3099 3100 or else ((Ekind (E) = E_Task_Type or else 3101 Ekind (E) = E_Protected_Type) 3102 and then In_Open_Scopes (E)) 3103 3104 -- Current instance of type 3105 3106 or else (Is_Type (E) and then E = Current_Scope) 3107 or else (Is_Incomplete_Or_Private_Type (E) 3108 and then Full_View (E) = Current_Scope); 3109 3110 elsif Nkind (Obj) = N_Selected_Component then 3111 return Is_Aliased (Entity (Selector_Name (Obj))); 3112 3113 elsif Nkind (Obj) = N_Indexed_Component then 3114 return Has_Aliased_Components (Etype (Prefix (Obj))) 3115 or else 3116 (Is_Access_Type (Etype (Prefix (Obj))) 3117 and then 3118 Has_Aliased_Components 3119 (Designated_Type (Etype (Prefix (Obj))))); 3120 3121 elsif Nkind (Obj) = N_Unchecked_Type_Conversion 3122 or else Nkind (Obj) = N_Type_Conversion 3123 then 3124 return Is_Tagged_Type (Etype (Obj)) 3125 and then Is_Aliased_View (Expression (Obj)); 3126 3127 elsif Nkind (Obj) = N_Explicit_Dereference then 3128 return Nkind (Original_Node (Obj)) /= N_Function_Call; 3129 3130 else 3131 return False; 3132 end if; 3133 end Is_Aliased_View; 3134 3135 ---------------------- 3136 -- Is_Atomic_Object -- 3137 ---------------------- 3138 3139 function Is_Atomic_Object (N : Node_Id) return Boolean is 3140 3141 function Object_Has_Atomic_Components (N : Node_Id) return Boolean; 3142 -- Determines if given object has atomic components 3143 3144 function Is_Atomic_Prefix (N : Node_Id) return Boolean; 3145 -- If prefix is an implicit dereference, examine designated type. 3146 3147 function Is_Atomic_Prefix (N : Node_Id) return Boolean is 3148 begin 3149 if Is_Access_Type (Etype (N)) then 3150 return 3151 Has_Atomic_Components (Designated_Type (Etype (N))); 3152 else 3153 return Object_Has_Atomic_Components (N); 3154 end if; 3155 end Is_Atomic_Prefix; 3156 3157 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is 3158 begin 3159 if Has_Atomic_Components (Etype (N)) 3160 or else Is_Atomic (Etype (N)) 3161 then 3162 return True; 3163 3164 elsif Is_Entity_Name (N) 3165 and then (Has_Atomic_Components (Entity (N)) 3166 or else Is_Atomic (Entity (N))) 3167 then 3168 return True; 3169 3170 elsif Nkind (N) = N_Indexed_Component 3171 or else Nkind (N) = N_Selected_Component 3172 then 3173 return Is_Atomic_Prefix (Prefix (N)); 3174 3175 else 3176 return False; 3177 end if; 3178 end Object_Has_Atomic_Components; 3179 3180 -- Start of processing for Is_Atomic_Object 3181 3182 begin 3183 if Is_Atomic (Etype (N)) 3184 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) 3185 then 3186 return True; 3187 3188 elsif Nkind (N) = N_Indexed_Component 3189 or else Nkind (N) = N_Selected_Component 3190 then 3191 return Is_Atomic_Prefix (Prefix (N)); 3192 3193 else 3194 return False; 3195 end if; 3196 end Is_Atomic_Object; 3197 3198 ---------------------------------------------- 3199 -- Is_Dependent_Component_Of_Mutable_Object -- 3200 ---------------------------------------------- 3201 3202 function Is_Dependent_Component_Of_Mutable_Object 3203 (Object : Node_Id) return Boolean 3204 is 3205 P : Node_Id; 3206 Prefix_Type : Entity_Id; 3207 P_Aliased : Boolean := False; 3208 Comp : Entity_Id; 3209 3210 function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean; 3211 -- Returns True if and only if Comp has a constrained subtype 3212 -- that depends on a discriminant. 3213 3214 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean; 3215 -- Returns True if and only if Comp is declared within a variant part. 3216 3217 ------------------------------ 3218 -- Has_Dependent_Constraint -- 3219 ------------------------------ 3220 3221 function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is 3222 Comp_Decl : constant Node_Id := Parent (Comp); 3223 Subt_Indic : constant Node_Id := 3224 Subtype_Indication (Component_Definition (Comp_Decl)); 3225 Constr : Node_Id; 3226 Assn : Node_Id; 3227 3228 begin 3229 if Nkind (Subt_Indic) = N_Subtype_Indication then 3230 Constr := Constraint (Subt_Indic); 3231 3232 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 3233 Assn := First (Constraints (Constr)); 3234 while Present (Assn) loop 3235 case Nkind (Assn) is 3236 when N_Subtype_Indication | 3237 N_Range | 3238 N_Identifier 3239 => 3240 if Depends_On_Discriminant (Assn) then 3241 return True; 3242 end if; 3243 3244 when N_Discriminant_Association => 3245 if Depends_On_Discriminant (Expression (Assn)) then 3246 return True; 3247 end if; 3248 3249 when others => 3250 null; 3251 3252 end case; 3253 3254 Next (Assn); 3255 end loop; 3256 end if; 3257 end if; 3258 3259 return False; 3260 end Has_Dependent_Constraint; 3261 3262 -------------------------------- 3263 -- Is_Declared_Within_Variant -- 3264 -------------------------------- 3265 3266 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 3267 Comp_Decl : constant Node_Id := Parent (Comp); 3268 Comp_List : constant Node_Id := Parent (Comp_Decl); 3269 3270 begin 3271 return Nkind (Parent (Comp_List)) = N_Variant; 3272 end Is_Declared_Within_Variant; 3273 3274 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 3275 3276 begin 3277 if Is_Variable (Object) then 3278 3279 if Nkind (Object) = N_Selected_Component then 3280 P := Prefix (Object); 3281 Prefix_Type := Etype (P); 3282 3283 if Is_Entity_Name (P) then 3284 3285 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 3286 Prefix_Type := Base_Type (Prefix_Type); 3287 end if; 3288 3289 if Is_Aliased (Entity (P)) then 3290 P_Aliased := True; 3291 end if; 3292 3293 else 3294 -- Check for prefix being an aliased component ??? 3295 null; 3296 end if; 3297 3298 if Is_Access_Type (Prefix_Type) 3299 or else Nkind (P) = N_Explicit_Dereference 3300 then 3301 return False; 3302 end if; 3303 3304 Comp := 3305 Original_Record_Component (Entity (Selector_Name (Object))); 3306 3307 -- As per AI-0017, the renaming is illegal in a generic body, 3308 -- even if the subtype is indefinite. 3309 3310 if not Is_Constrained (Prefix_Type) 3311 and then (not Is_Indefinite_Subtype (Prefix_Type) 3312 or else 3313 (Is_Generic_Type (Prefix_Type) 3314 and then Ekind (Current_Scope) = E_Generic_Package 3315 and then In_Package_Body (Current_Scope))) 3316 3317 and then (Is_Declared_Within_Variant (Comp) 3318 or else Has_Dependent_Constraint (Comp)) 3319 and then not P_Aliased 3320 then 3321 return True; 3322 3323 else 3324 return 3325 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 3326 3327 end if; 3328 3329 elsif Nkind (Object) = N_Indexed_Component 3330 or else Nkind (Object) = N_Slice 3331 then 3332 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 3333 end if; 3334 end if; 3335 3336 return False; 3337 end Is_Dependent_Component_Of_Mutable_Object; 3338 3339 --------------------- 3340 -- Is_Dereferenced -- 3341 --------------------- 3342 3343 function Is_Dereferenced (N : Node_Id) return Boolean is 3344 P : constant Node_Id := Parent (N); 3345 3346 begin 3347 return 3348 (Nkind (P) = N_Selected_Component 3349 or else 3350 Nkind (P) = N_Explicit_Dereference 3351 or else 3352 Nkind (P) = N_Indexed_Component 3353 or else 3354 Nkind (P) = N_Slice) 3355 and then Prefix (P) = N; 3356 end Is_Dereferenced; 3357 3358 -------------- 3359 -- Is_False -- 3360 -------------- 3361 3362 function Is_False (U : Uint) return Boolean is 3363 begin 3364 return (U = 0); 3365 end Is_False; 3366 3367 --------------------------- 3368 -- Is_Fixed_Model_Number -- 3369 --------------------------- 3370 3371 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 3372 S : constant Ureal := Small_Value (T); 3373 M : Urealp.Save_Mark; 3374 R : Boolean; 3375 3376 begin 3377 M := Urealp.Mark; 3378 R := (U = UR_Trunc (U / S) * S); 3379 Urealp.Release (M); 3380 return R; 3381 end Is_Fixed_Model_Number; 3382 3383 ------------------------------- 3384 -- Is_Fully_Initialized_Type -- 3385 ------------------------------- 3386 3387 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 3388 begin 3389 if Is_Scalar_Type (Typ) then 3390 return False; 3391 3392 elsif Is_Access_Type (Typ) then 3393 return True; 3394 3395 elsif Is_Array_Type (Typ) then 3396 if Is_Fully_Initialized_Type (Component_Type (Typ)) then 3397 return True; 3398 end if; 3399 3400 -- An interesting case, if we have a constrained type one of whose 3401 -- bounds is known to be null, then there are no elements to be 3402 -- initialized, so all the elements are initialized! 3403 3404 if Is_Constrained (Typ) then 3405 declare 3406 Indx : Node_Id; 3407 Indx_Typ : Entity_Id; 3408 Lbd, Hbd : Node_Id; 3409 3410 begin 3411 Indx := First_Index (Typ); 3412 while Present (Indx) loop 3413 3414 if Etype (Indx) = Any_Type then 3415 return False; 3416 3417 -- If index is a range, use directly. 3418 3419 elsif Nkind (Indx) = N_Range then 3420 Lbd := Low_Bound (Indx); 3421 Hbd := High_Bound (Indx); 3422 3423 else 3424 Indx_Typ := Etype (Indx); 3425 3426 if Is_Private_Type (Indx_Typ) then 3427 Indx_Typ := Full_View (Indx_Typ); 3428 end if; 3429 3430 if No (Indx_Typ) then 3431 return False; 3432 else 3433 Lbd := Type_Low_Bound (Indx_Typ); 3434 Hbd := Type_High_Bound (Indx_Typ); 3435 end if; 3436 end if; 3437 3438 if Compile_Time_Known_Value (Lbd) 3439 and then Compile_Time_Known_Value (Hbd) 3440 then 3441 if Expr_Value (Hbd) < Expr_Value (Lbd) then 3442 return True; 3443 end if; 3444 end if; 3445 3446 Next_Index (Indx); 3447 end loop; 3448 end; 3449 end if; 3450 3451 -- If no null indexes, then type is not fully initialized 3452 3453 return False; 3454 3455 -- Record types 3456 3457 elsif Is_Record_Type (Typ) then 3458 if Has_Discriminants (Typ) 3459 and then 3460 Present (Discriminant_Default_Value (First_Discriminant (Typ))) 3461 and then Is_Fully_Initialized_Variant (Typ) 3462 then 3463 return True; 3464 end if; 3465 3466 -- Controlled records are considered to be fully initialized if 3467 -- there is a user defined Initialize routine. This may not be 3468 -- entirely correct, but as the spec notes, we are guessing here 3469 -- what is best from the point of view of issuing warnings. 3470 3471 if Is_Controlled (Typ) then 3472 declare 3473 Utyp : constant Entity_Id := Underlying_Type (Typ); 3474 3475 begin 3476 if Present (Utyp) then 3477 declare 3478 Init : constant Entity_Id := 3479 (Find_Prim_Op 3480 (Underlying_Type (Typ), Name_Initialize)); 3481 3482 begin 3483 if Present (Init) 3484 and then Comes_From_Source (Init) 3485 and then not 3486 Is_Predefined_File_Name 3487 (File_Name (Get_Source_File_Index (Sloc (Init)))) 3488 then 3489 return True; 3490 3491 elsif Has_Null_Extension (Typ) 3492 and then 3493 Is_Fully_Initialized_Type 3494 (Etype (Base_Type (Typ))) 3495 then 3496 return True; 3497 end if; 3498 end; 3499 end if; 3500 end; 3501 end if; 3502 3503 -- Otherwise see if all record components are initialized 3504 3505 declare 3506 Ent : Entity_Id; 3507 3508 begin 3509 Ent := First_Entity (Typ); 3510 3511 while Present (Ent) loop 3512 if Chars (Ent) = Name_uController then 3513 null; 3514 3515 elsif Ekind (Ent) = E_Component 3516 and then (No (Parent (Ent)) 3517 or else No (Expression (Parent (Ent)))) 3518 and then not Is_Fully_Initialized_Type (Etype (Ent)) 3519 then 3520 return False; 3521 end if; 3522 3523 Next_Entity (Ent); 3524 end loop; 3525 end; 3526 3527 -- No uninitialized components, so type is fully initialized. 3528 -- Note that this catches the case of no components as well. 3529 3530 return True; 3531 3532 elsif Is_Concurrent_Type (Typ) then 3533 return True; 3534 3535 elsif Is_Private_Type (Typ) then 3536 declare 3537 U : constant Entity_Id := Underlying_Type (Typ); 3538 3539 begin 3540 if No (U) then 3541 return False; 3542 else 3543 return Is_Fully_Initialized_Type (U); 3544 end if; 3545 end; 3546 3547 else 3548 return False; 3549 end if; 3550 end Is_Fully_Initialized_Type; 3551 3552 ---------------------------------- 3553 -- Is_Fully_Initialized_Variant -- 3554 ---------------------------------- 3555 3556 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 3557 Loc : constant Source_Ptr := Sloc (Typ); 3558 Constraints : constant List_Id := New_List; 3559 Components : constant Elist_Id := New_Elmt_List; 3560 Comp_Elmt : Elmt_Id; 3561 Comp_Id : Node_Id; 3562 Comp_List : Node_Id; 3563 Discr : Entity_Id; 3564 Discr_Val : Node_Id; 3565 Report_Errors : Boolean; 3566 3567 begin 3568 if Serious_Errors_Detected > 0 then 3569 return False; 3570 end if; 3571 3572 if Is_Record_Type (Typ) 3573 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 3574 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 3575 then 3576 Comp_List := Component_List (Type_Definition (Parent (Typ))); 3577 Discr := First_Discriminant (Typ); 3578 3579 while Present (Discr) loop 3580 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 3581 Discr_Val := Expression (Parent (Discr)); 3582 if not Is_OK_Static_Expression (Discr_Val) then 3583 return False; 3584 else 3585 Append_To (Constraints, 3586 Make_Component_Association (Loc, 3587 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 3588 Expression => New_Copy (Discr_Val))); 3589 3590 end if; 3591 else 3592 return False; 3593 end if; 3594 3595 Next_Discriminant (Discr); 3596 end loop; 3597 3598 Gather_Components 3599 (Typ => Typ, 3600 Comp_List => Comp_List, 3601 Governed_By => Constraints, 3602 Into => Components, 3603 Report_Errors => Report_Errors); 3604 3605 -- Check that each component present is fully initialized. 3606 3607 Comp_Elmt := First_Elmt (Components); 3608 3609 while Present (Comp_Elmt) loop 3610 Comp_Id := Node (Comp_Elmt); 3611 3612 if Ekind (Comp_Id) = E_Component 3613 and then (No (Parent (Comp_Id)) 3614 or else No (Expression (Parent (Comp_Id)))) 3615 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 3616 then 3617 return False; 3618 end if; 3619 3620 Next_Elmt (Comp_Elmt); 3621 end loop; 3622 3623 return True; 3624 3625 elsif Is_Private_Type (Typ) then 3626 declare 3627 U : constant Entity_Id := Underlying_Type (Typ); 3628 3629 begin 3630 if No (U) then 3631 return False; 3632 else 3633 return Is_Fully_Initialized_Variant (U); 3634 end if; 3635 end; 3636 else 3637 return False; 3638 end if; 3639 end Is_Fully_Initialized_Variant; 3640 3641 ---------------------------- 3642 -- Is_Inherited_Operation -- 3643 ---------------------------- 3644 3645 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 3646 Kind : constant Node_Kind := Nkind (Parent (E)); 3647 3648 begin 3649 pragma Assert (Is_Overloadable (E)); 3650 return Kind = N_Full_Type_Declaration 3651 or else Kind = N_Private_Extension_Declaration 3652 or else Kind = N_Subtype_Declaration 3653 or else (Ekind (E) = E_Enumeration_Literal 3654 and then Is_Derived_Type (Etype (E))); 3655 end Is_Inherited_Operation; 3656 3657 ----------------------------- 3658 -- Is_Library_Level_Entity -- 3659 ----------------------------- 3660 3661 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 3662 begin 3663 -- The following is a small optimization, and it also handles 3664 -- properly discriminals, which in task bodies might appear in 3665 -- expressions before the corresponding procedure has been 3666 -- created, and which therefore do not have an assigned scope. 3667 3668 if Ekind (E) in Formal_Kind then 3669 return False; 3670 end if; 3671 3672 -- Normal test is simply that the enclosing dynamic scope is Standard 3673 3674 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 3675 end Is_Library_Level_Entity; 3676 3677 --------------------------------- 3678 -- Is_Local_Variable_Reference -- 3679 --------------------------------- 3680 3681 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 3682 begin 3683 if not Is_Entity_Name (Expr) then 3684 return False; 3685 3686 else 3687 declare 3688 Ent : constant Entity_Id := Entity (Expr); 3689 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 3690 3691 begin 3692 if Ekind (Ent) /= E_Variable 3693 and then 3694 Ekind (Ent) /= E_In_Out_Parameter 3695 then 3696 return False; 3697 3698 else 3699 return Present (Sub) and then Sub = Current_Subprogram; 3700 end if; 3701 end; 3702 end if; 3703 end Is_Local_Variable_Reference; 3704 3705 --------------- 3706 -- Is_Lvalue -- 3707 --------------- 3708 3709 function Is_Lvalue (N : Node_Id) return Boolean is 3710 P : constant Node_Id := Parent (N); 3711 3712 begin 3713 case Nkind (P) is 3714 3715 -- Test left side of assignment 3716 3717 when N_Assignment_Statement => 3718 return N = Name (P); 3719 3720 -- Test prefix of component or attribute 3721 3722 when N_Attribute_Reference | 3723 N_Expanded_Name | 3724 N_Explicit_Dereference | 3725 N_Indexed_Component | 3726 N_Reference | 3727 N_Selected_Component | 3728 N_Slice => 3729 return N = Prefix (P); 3730 3731 -- Test subprogram parameter (we really should check the 3732 -- parameter mode, but it is not worth the trouble) 3733 3734 when N_Function_Call | 3735 N_Procedure_Call_Statement | 3736 N_Accept_Statement | 3737 N_Parameter_Association => 3738 return True; 3739 3740 -- Test for appearing in a conversion that itself appears 3741 -- in an lvalue context, since this should be an lvalue. 3742 3743 when N_Type_Conversion => 3744 return Is_Lvalue (P); 3745 3746 -- Test for appearence in object renaming declaration 3747 3748 when N_Object_Renaming_Declaration => 3749 return True; 3750 3751 -- All other references are definitely not Lvalues 3752 3753 when others => 3754 return False; 3755 3756 end case; 3757 end Is_Lvalue; 3758 3759 ------------------------- 3760 -- Is_Object_Reference -- 3761 ------------------------- 3762 3763 function Is_Object_Reference (N : Node_Id) return Boolean is 3764 begin 3765 if Is_Entity_Name (N) then 3766 return Is_Object (Entity (N)); 3767 3768 else 3769 case Nkind (N) is 3770 when N_Indexed_Component | N_Slice => 3771 return Is_Object_Reference (Prefix (N)); 3772 3773 -- In Ada95, a function call is a constant object 3774 3775 when N_Function_Call => 3776 return True; 3777 3778 -- A reference to the stream attribute Input is a function call 3779 3780 when N_Attribute_Reference => 3781 return Attribute_Name (N) = Name_Input; 3782 3783 when N_Selected_Component => 3784 return Is_Object_Reference (Selector_Name (N)); 3785 3786 when N_Explicit_Dereference => 3787 return True; 3788 3789 -- An unchecked type conversion is considered to be an object if 3790 -- the operand is an object (this construction arises only as a 3791 -- result of expansion activities). 3792 3793 when N_Unchecked_Type_Conversion => 3794 return True; 3795 3796 when others => 3797 return False; 3798 end case; 3799 end if; 3800 end Is_Object_Reference; 3801 3802 ----------------------------------- 3803 -- Is_OK_Variable_For_Out_Formal -- 3804 ----------------------------------- 3805 3806 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 3807 begin 3808 Note_Possible_Modification (AV); 3809 3810 -- We must reject parenthesized variable names. The check for 3811 -- Comes_From_Source is present because there are currently 3812 -- cases where the compiler violates this rule (e.g. passing 3813 -- a task object to its controlled Initialize routine). 3814 3815 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 3816 return False; 3817 3818 -- A variable is always allowed 3819 3820 elsif Is_Variable (AV) then 3821 return True; 3822 3823 -- Unchecked conversions are allowed only if they come from the 3824 -- generated code, which sometimes uses unchecked conversions for 3825 -- out parameters in cases where code generation is unaffected. 3826 -- We tell source unchecked conversions by seeing if they are 3827 -- rewrites of an original UC function call, or of an explicit 3828 -- conversion of a function call. 3829 3830 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 3831 if Nkind (Original_Node (AV)) = N_Function_Call then 3832 return False; 3833 3834 elsif Comes_From_Source (AV) 3835 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 3836 then 3837 return False; 3838 3839 else 3840 return True; 3841 end if; 3842 3843 -- Normal type conversions are allowed if argument is a variable 3844 3845 elsif Nkind (AV) = N_Type_Conversion then 3846 if Is_Variable (Expression (AV)) 3847 and then Paren_Count (Expression (AV)) = 0 3848 then 3849 Note_Possible_Modification (Expression (AV)); 3850 return True; 3851 3852 -- We also allow a non-parenthesized expression that raises 3853 -- constraint error if it rewrites what used to be a variable 3854 3855 elsif Raises_Constraint_Error (Expression (AV)) 3856 and then Paren_Count (Expression (AV)) = 0 3857 and then Is_Variable (Original_Node (Expression (AV))) 3858 then 3859 return True; 3860 3861 -- Type conversion of something other than a variable 3862 3863 else 3864 return False; 3865 end if; 3866 3867 -- If this node is rewritten, then test the original form, if that is 3868 -- OK, then we consider the rewritten node OK (for example, if the 3869 -- original node is a conversion, then Is_Variable will not be true 3870 -- but we still want to allow the conversion if it converts a variable). 3871 3872 elsif Original_Node (AV) /= AV then 3873 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 3874 3875 -- All other non-variables are rejected 3876 3877 else 3878 return False; 3879 end if; 3880 end Is_OK_Variable_For_Out_Formal; 3881 3882 ----------------------------------- 3883 -- Is_Partially_Initialized_Type -- 3884 ----------------------------------- 3885 3886 function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is 3887 begin 3888 if Is_Scalar_Type (Typ) then 3889 return False; 3890 3891 elsif Is_Access_Type (Typ) then 3892 return True; 3893 3894 elsif Is_Array_Type (Typ) then 3895 3896 -- If component type is partially initialized, so is array type 3897 3898 if Is_Partially_Initialized_Type (Component_Type (Typ)) then 3899 return True; 3900 3901 -- Otherwise we are only partially initialized if we are fully 3902 -- initialized (this is the empty array case, no point in us 3903 -- duplicating that code here). 3904 3905 else 3906 return Is_Fully_Initialized_Type (Typ); 3907 end if; 3908 3909 elsif Is_Record_Type (Typ) then 3910 3911 -- A discriminated type is always partially initialized 3912 3913 if Has_Discriminants (Typ) then 3914 return True; 3915 3916 -- A tagged type is always partially initialized 3917 3918 elsif Is_Tagged_Type (Typ) then 3919 return True; 3920 3921 -- Case of non-discriminated record 3922 3923 else 3924 declare 3925 Ent : Entity_Id; 3926 3927 Component_Present : Boolean := False; 3928 -- Set True if at least one component is present. If no 3929 -- components are present, then record type is fully 3930 -- initialized (another odd case, like the null array). 3931 3932 begin 3933 -- Loop through components 3934 3935 Ent := First_Entity (Typ); 3936 while Present (Ent) loop 3937 if Ekind (Ent) = E_Component then 3938 Component_Present := True; 3939 3940 -- If a component has an initialization expression then 3941 -- the enclosing record type is partially initialized 3942 3943 if Present (Parent (Ent)) 3944 and then Present (Expression (Parent (Ent))) 3945 then 3946 return True; 3947 3948 -- If a component is of a type which is itself partially 3949 -- initialized, then the enclosing record type is also. 3950 3951 elsif Is_Partially_Initialized_Type (Etype (Ent)) then 3952 return True; 3953 end if; 3954 end if; 3955 3956 Next_Entity (Ent); 3957 end loop; 3958 3959 -- No initialized components found. If we found any components 3960 -- they were all uninitialized so the result is false. 3961 3962 if Component_Present then 3963 return False; 3964 3965 -- But if we found no components, then all the components are 3966 -- initialized so we consider the type to be initialized. 3967 3968 else 3969 return True; 3970 end if; 3971 end; 3972 end if; 3973 3974 -- Concurrent types are always fully initialized 3975 3976 elsif Is_Concurrent_Type (Typ) then 3977 return True; 3978 3979 -- For a private type, go to underlying type. If there is no underlying 3980 -- type then just assume this partially initialized. Not clear if this 3981 -- can happen in a non-error case, but no harm in testing for this. 3982 3983 elsif Is_Private_Type (Typ) then 3984 declare 3985 U : constant Entity_Id := Underlying_Type (Typ); 3986 3987 begin 3988 if No (U) then 3989 return True; 3990 else 3991 return Is_Partially_Initialized_Type (U); 3992 end if; 3993 end; 3994 3995 -- For any other type (are there any?) assume partially initialized 3996 3997 else 3998 return True; 3999 end if; 4000 end Is_Partially_Initialized_Type; 4001 4002 ----------------------------- 4003 -- Is_RCI_Pkg_Spec_Or_Body -- 4004 ----------------------------- 4005 4006 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 4007 4008 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 4009 -- Return True if the unit of Cunit is an RCI package declaration 4010 4011 --------------------------- 4012 -- Is_RCI_Pkg_Decl_Cunit -- 4013 --------------------------- 4014 4015 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 4016 The_Unit : constant Node_Id := Unit (Cunit); 4017 4018 begin 4019 if Nkind (The_Unit) /= N_Package_Declaration then 4020 return False; 4021 end if; 4022 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 4023 end Is_RCI_Pkg_Decl_Cunit; 4024 4025 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 4026 4027 begin 4028 return Is_RCI_Pkg_Decl_Cunit (Cunit) 4029 or else 4030 (Nkind (Unit (Cunit)) = N_Package_Body 4031 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 4032 end Is_RCI_Pkg_Spec_Or_Body; 4033 4034 ----------------------------------------- 4035 -- Is_Remote_Access_To_Class_Wide_Type -- 4036 ----------------------------------------- 4037 4038 function Is_Remote_Access_To_Class_Wide_Type 4039 (E : Entity_Id) return Boolean 4040 is 4041 D : Entity_Id; 4042 4043 function Comes_From_Limited_Private_Type_Declaration 4044 (E : Entity_Id) 4045 return Boolean; 4046 -- Check that the type is declared by a limited type declaration, 4047 -- or else is derived from a Remote_Type ancestor through private 4048 -- extensions. 4049 4050 ------------------------------------------------- 4051 -- Comes_From_Limited_Private_Type_Declaration -- 4052 ------------------------------------------------- 4053 4054 function Comes_From_Limited_Private_Type_Declaration (E : in Entity_Id) 4055 return Boolean 4056 is 4057 N : constant Node_Id := Declaration_Node (E); 4058 begin 4059 if Nkind (N) = N_Private_Type_Declaration 4060 and then Limited_Present (N) 4061 then 4062 return True; 4063 end if; 4064 4065 if Nkind (N) = N_Private_Extension_Declaration then 4066 return 4067 Comes_From_Limited_Private_Type_Declaration (Etype (E)) 4068 or else 4069 (Is_Remote_Types (Etype (E)) 4070 and then Is_Limited_Record (Etype (E)) 4071 and then Has_Private_Declaration (Etype (E))); 4072 end if; 4073 4074 return False; 4075 end Comes_From_Limited_Private_Type_Declaration; 4076 4077 -- Start of processing for Is_Remote_Access_To_Class_Wide_Type 4078 4079 begin 4080 if not (Is_Remote_Call_Interface (E) 4081 or else Is_Remote_Types (E)) 4082 or else Ekind (E) /= E_General_Access_Type 4083 then 4084 return False; 4085 end if; 4086 4087 D := Designated_Type (E); 4088 4089 if Ekind (D) /= E_Class_Wide_Type then 4090 return False; 4091 end if; 4092 4093 return Comes_From_Limited_Private_Type_Declaration 4094 (Defining_Identifier (Parent (D))); 4095 end Is_Remote_Access_To_Class_Wide_Type; 4096 4097 ----------------------------------------- 4098 -- Is_Remote_Access_To_Subprogram_Type -- 4099 ----------------------------------------- 4100 4101 function Is_Remote_Access_To_Subprogram_Type 4102 (E : Entity_Id) return Boolean 4103 is 4104 begin 4105 return (Ekind (E) = E_Access_Subprogram_Type 4106 or else (Ekind (E) = E_Record_Type 4107 and then Present (Corresponding_Remote_Type (E)))) 4108 and then (Is_Remote_Call_Interface (E) 4109 or else Is_Remote_Types (E)); 4110 end Is_Remote_Access_To_Subprogram_Type; 4111 4112 -------------------- 4113 -- Is_Remote_Call -- 4114 -------------------- 4115 4116 function Is_Remote_Call (N : Node_Id) return Boolean is 4117 begin 4118 if Nkind (N) /= N_Procedure_Call_Statement 4119 and then Nkind (N) /= N_Function_Call 4120 then 4121 -- An entry call cannot be remote 4122 4123 return False; 4124 4125 elsif Nkind (Name (N)) in N_Has_Entity 4126 and then Is_Remote_Call_Interface (Entity (Name (N))) 4127 then 4128 -- A subprogram declared in the spec of a RCI package is remote 4129 4130 return True; 4131 4132 elsif Nkind (Name (N)) = N_Explicit_Dereference 4133 and then Is_Remote_Access_To_Subprogram_Type 4134 (Etype (Prefix (Name (N)))) 4135 then 4136 -- The dereference of a RAS is a remote call 4137 4138 return True; 4139 4140 elsif Present (Controlling_Argument (N)) 4141 and then Is_Remote_Access_To_Class_Wide_Type 4142 (Etype (Controlling_Argument (N))) 4143 then 4144 -- Any primitive operation call with a controlling argument of 4145 -- a RACW type is a remote call. 4146 4147 return True; 4148 end if; 4149 4150 -- All other calls are local calls 4151 4152 return False; 4153 end Is_Remote_Call; 4154 4155 ---------------------- 4156 -- Is_Selector_Name -- 4157 ---------------------- 4158 4159 function Is_Selector_Name (N : Node_Id) return Boolean is 4160 4161 begin 4162 if not Is_List_Member (N) then 4163 declare 4164 P : constant Node_Id := Parent (N); 4165 K : constant Node_Kind := Nkind (P); 4166 4167 begin 4168 return 4169 (K = N_Expanded_Name or else 4170 K = N_Generic_Association or else 4171 K = N_Parameter_Association or else 4172 K = N_Selected_Component) 4173 and then Selector_Name (P) = N; 4174 end; 4175 4176 else 4177 declare 4178 L : constant List_Id := List_Containing (N); 4179 P : constant Node_Id := Parent (L); 4180 4181 begin 4182 return (Nkind (P) = N_Discriminant_Association 4183 and then Selector_Names (P) = L) 4184 or else 4185 (Nkind (P) = N_Component_Association 4186 and then Choices (P) = L); 4187 end; 4188 end if; 4189 end Is_Selector_Name; 4190 4191 ------------------ 4192 -- Is_Statement -- 4193 ------------------ 4194 4195 function Is_Statement (N : Node_Id) return Boolean is 4196 begin 4197 return 4198 Nkind (N) in N_Statement_Other_Than_Procedure_Call 4199 or else Nkind (N) = N_Procedure_Call_Statement; 4200 end Is_Statement; 4201 4202 ----------------- 4203 -- Is_Transfer -- 4204 ----------------- 4205 4206 function Is_Transfer (N : Node_Id) return Boolean is 4207 Kind : constant Node_Kind := Nkind (N); 4208 4209 begin 4210 if Kind = N_Return_Statement 4211 or else 4212 Kind = N_Goto_Statement 4213 or else 4214 Kind = N_Raise_Statement 4215 or else 4216 Kind = N_Requeue_Statement 4217 then 4218 return True; 4219 4220 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 4221 and then No (Condition (N)) 4222 then 4223 return True; 4224 4225 elsif Kind = N_Procedure_Call_Statement 4226 and then Is_Entity_Name (Name (N)) 4227 and then Present (Entity (Name (N))) 4228 and then No_Return (Entity (Name (N))) 4229 then 4230 return True; 4231 4232 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 4233 return True; 4234 4235 else 4236 return False; 4237 end if; 4238 end Is_Transfer; 4239 4240 ------------- 4241 -- Is_True -- 4242 ------------- 4243 4244 function Is_True (U : Uint) return Boolean is 4245 begin 4246 return (U /= 0); 4247 end Is_True; 4248 4249 ----------------- 4250 -- Is_Variable -- 4251 ----------------- 4252 4253 function Is_Variable (N : Node_Id) return Boolean is 4254 4255 Orig_Node : constant Node_Id := Original_Node (N); 4256 -- We do the test on the original node, since this is basically a 4257 -- test of syntactic categories, so it must not be disturbed by 4258 -- whatever rewriting might have occurred. For example, an aggregate, 4259 -- which is certainly NOT a variable, could be turned into a variable 4260 -- by expansion. 4261 4262 function In_Protected_Function (E : Entity_Id) return Boolean; 4263 -- Within a protected function, the private components of the 4264 -- enclosing protected type are constants. A function nested within 4265 -- a (protected) procedure is not itself protected. 4266 4267 function Is_Variable_Prefix (P : Node_Id) return Boolean; 4268 -- Prefixes can involve implicit dereferences, in which case we 4269 -- must test for the case of a reference of a constant access 4270 -- type, which can never be a variable. 4271 4272 --------------------------- 4273 -- In_Protected_Function -- 4274 --------------------------- 4275 4276 function In_Protected_Function (E : Entity_Id) return Boolean is 4277 Prot : constant Entity_Id := Scope (E); 4278 S : Entity_Id; 4279 4280 begin 4281 if not Is_Protected_Type (Prot) then 4282 return False; 4283 else 4284 S := Current_Scope; 4285 4286 while Present (S) and then S /= Prot loop 4287 4288 if Ekind (S) = E_Function 4289 and then Scope (S) = Prot 4290 then 4291 return True; 4292 end if; 4293 4294 S := Scope (S); 4295 end loop; 4296 4297 return False; 4298 end if; 4299 end In_Protected_Function; 4300 4301 ------------------------ 4302 -- Is_Variable_Prefix -- 4303 ------------------------ 4304 4305 function Is_Variable_Prefix (P : Node_Id) return Boolean is 4306 begin 4307 if Is_Access_Type (Etype (P)) then 4308 return not Is_Access_Constant (Root_Type (Etype (P))); 4309 else 4310 return Is_Variable (P); 4311 end if; 4312 end Is_Variable_Prefix; 4313 4314 -- Start of processing for Is_Variable 4315 4316 begin 4317 -- Definitely OK if Assignment_OK is set. Since this is something that 4318 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 4319 4320 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 4321 return True; 4322 4323 -- Normally we go to the original node, but there is one exception 4324 -- where we use the rewritten node, namely when it is an explicit 4325 -- dereference. The generated code may rewrite a prefix which is an 4326 -- access type with an explicit dereference. The dereference is a 4327 -- variable, even though the original node may not be (since it could 4328 -- be a constant of the access type). 4329 4330 elsif Nkind (N) = N_Explicit_Dereference 4331 and then Nkind (Orig_Node) /= N_Explicit_Dereference 4332 and then Is_Access_Type (Etype (Orig_Node)) 4333 then 4334 return Is_Variable_Prefix (Original_Node (Prefix (N))); 4335 4336 -- All remaining checks use the original node 4337 4338 elsif Is_Entity_Name (Orig_Node) then 4339 declare 4340 E : constant Entity_Id := Entity (Orig_Node); 4341 K : constant Entity_Kind := Ekind (E); 4342 4343 begin 4344 return (K = E_Variable 4345 and then Nkind (Parent (E)) /= N_Exception_Handler) 4346 or else (K = E_Component 4347 and then not In_Protected_Function (E)) 4348 or else K = E_Out_Parameter 4349 or else K = E_In_Out_Parameter 4350 or else K = E_Generic_In_Out_Parameter 4351 4352 -- Current instance of type: 4353 4354 or else (Is_Type (E) and then In_Open_Scopes (E)) 4355 or else (Is_Incomplete_Or_Private_Type (E) 4356 and then In_Open_Scopes (Full_View (E))); 4357 end; 4358 4359 else 4360 case Nkind (Orig_Node) is 4361 when N_Indexed_Component | N_Slice => 4362 return Is_Variable_Prefix (Prefix (Orig_Node)); 4363 4364 when N_Selected_Component => 4365 return Is_Variable_Prefix (Prefix (Orig_Node)) 4366 and then Is_Variable (Selector_Name (Orig_Node)); 4367 4368 -- For an explicit dereference, the type of the prefix cannot 4369 -- be an access to constant or an access to subprogram. 4370 4371 when N_Explicit_Dereference => 4372 declare 4373 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 4374 4375 begin 4376 return Is_Access_Type (Typ) 4377 and then not Is_Access_Constant (Root_Type (Typ)) 4378 and then Ekind (Typ) /= E_Access_Subprogram_Type; 4379 end; 4380 4381 -- The type conversion is the case where we do not deal with the 4382 -- context dependent special case of an actual parameter. Thus 4383 -- the type conversion is only considered a variable for the 4384 -- purposes of this routine if the target type is tagged. However, 4385 -- a type conversion is considered to be a variable if it does not 4386 -- come from source (this deals for example with the conversions 4387 -- of expressions to their actual subtypes). 4388 4389 when N_Type_Conversion => 4390 return Is_Variable (Expression (Orig_Node)) 4391 and then 4392 (not Comes_From_Source (Orig_Node) 4393 or else 4394 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 4395 and then 4396 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 4397 4398 -- GNAT allows an unchecked type conversion as a variable. This 4399 -- only affects the generation of internal expanded code, since 4400 -- calls to instantiations of Unchecked_Conversion are never 4401 -- considered variables (since they are function calls). 4402 -- This is also true for expression actions. 4403 4404 when N_Unchecked_Type_Conversion => 4405 return Is_Variable (Expression (Orig_Node)); 4406 4407 when others => 4408 return False; 4409 end case; 4410 end if; 4411 end Is_Variable; 4412 4413 ------------------------ 4414 -- Is_Volatile_Object -- 4415 ------------------------ 4416 4417 function Is_Volatile_Object (N : Node_Id) return Boolean is 4418 4419 function Object_Has_Volatile_Components (N : Node_Id) return Boolean; 4420 -- Determines if given object has volatile components 4421 4422 function Is_Volatile_Prefix (N : Node_Id) return Boolean; 4423 -- If prefix is an implicit dereference, examine designated type. 4424 4425 ------------------------ 4426 -- Is_Volatile_Prefix -- 4427 ------------------------ 4428 4429 function Is_Volatile_Prefix (N : Node_Id) return Boolean is 4430 Typ : constant Entity_Id := Etype (N); 4431 4432 begin 4433 if Is_Access_Type (Typ) then 4434 declare 4435 Dtyp : constant Entity_Id := Designated_Type (Typ); 4436 4437 begin 4438 return Is_Volatile (Dtyp) 4439 or else Has_Volatile_Components (Dtyp); 4440 end; 4441 4442 else 4443 return Object_Has_Volatile_Components (N); 4444 end if; 4445 end Is_Volatile_Prefix; 4446 4447 ------------------------------------ 4448 -- Object_Has_Volatile_Components -- 4449 ------------------------------------ 4450 4451 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is 4452 Typ : constant Entity_Id := Etype (N); 4453 4454 begin 4455 if Is_Volatile (Typ) 4456 or else Has_Volatile_Components (Typ) 4457 then 4458 return True; 4459 4460 elsif Is_Entity_Name (N) 4461 and then (Has_Volatile_Components (Entity (N)) 4462 or else Is_Volatile (Entity (N))) 4463 then 4464 return True; 4465 4466 elsif Nkind (N) = N_Indexed_Component 4467 or else Nkind (N) = N_Selected_Component 4468 then 4469 return Is_Volatile_Prefix (Prefix (N)); 4470 4471 else 4472 return False; 4473 end if; 4474 end Object_Has_Volatile_Components; 4475 4476 -- Start of processing for Is_Volatile_Object 4477 4478 begin 4479 if Is_Volatile (Etype (N)) 4480 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N))) 4481 then 4482 return True; 4483 4484 elsif Nkind (N) = N_Indexed_Component 4485 or else Nkind (N) = N_Selected_Component 4486 then 4487 return Is_Volatile_Prefix (Prefix (N)); 4488 4489 else 4490 return False; 4491 end if; 4492 end Is_Volatile_Object; 4493 4494 ------------------------- 4495 -- Kill_Current_Values -- 4496 ------------------------- 4497 4498 procedure Kill_Current_Values is 4499 S : Entity_Id; 4500 4501 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 4502 -- Clear current value for entity E and all entities chained to E 4503 4504 ------------------------------------------- 4505 -- Kill_Current_Values_For_Entity_Chain -- 4506 ------------------------------------------- 4507 4508 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 4509 Ent : Entity_Id; 4510 4511 begin 4512 Ent := E; 4513 while Present (Ent) loop 4514 if Is_Object (Ent) then 4515 Set_Current_Value (Ent, Empty); 4516 4517 if not Can_Never_Be_Null (Ent) then 4518 Set_Is_Known_Non_Null (Ent, False); 4519 end if; 4520 end if; 4521 4522 Next_Entity (Ent); 4523 end loop; 4524 end Kill_Current_Values_For_Entity_Chain; 4525 4526 -- Start of processing for Kill_Current_Values 4527 4528 begin 4529 -- Kill all saved checks, a special case of killing saved values 4530 4531 Kill_All_Checks; 4532 4533 -- Loop through relevant scopes, which includes the current scope and 4534 -- any parent scopes if the current scope is a block or a package. 4535 4536 S := Current_Scope; 4537 Scope_Loop : loop 4538 4539 -- Clear current values of all entities in current scope 4540 4541 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 4542 4543 -- If scope is a package, also clear current values of all 4544 -- private entities in the scope. 4545 4546 if Ekind (S) = E_Package 4547 or else 4548 Ekind (S) = E_Generic_Package 4549 or else 4550 Is_Concurrent_Type (S) 4551 then 4552 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 4553 end if; 4554 4555 -- If this is a block or nested package, deal with parent 4556 4557 if Ekind (S) = E_Block 4558 or else (Ekind (S) = E_Package 4559 and then not Is_Library_Level_Entity (S)) 4560 then 4561 S := Scope (S); 4562 else 4563 exit Scope_Loop; 4564 end if; 4565 end loop Scope_Loop; 4566 end Kill_Current_Values; 4567 4568 -------------------------- 4569 -- Kill_Size_Check_Code -- 4570 -------------------------- 4571 4572 procedure Kill_Size_Check_Code (E : Entity_Id) is 4573 begin 4574 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 4575 and then Present (Size_Check_Code (E)) 4576 then 4577 Remove (Size_Check_Code (E)); 4578 Set_Size_Check_Code (E, Empty); 4579 end if; 4580 end Kill_Size_Check_Code; 4581 4582 ------------------------- 4583 -- New_External_Entity -- 4584 ------------------------- 4585 4586 function New_External_Entity 4587 (Kind : Entity_Kind; 4588 Scope_Id : Entity_Id; 4589 Sloc_Value : Source_Ptr; 4590 Related_Id : Entity_Id; 4591 Suffix : Character; 4592 Suffix_Index : Nat := 0; 4593 Prefix : Character := ' ') return Entity_Id 4594 is 4595 N : constant Entity_Id := 4596 Make_Defining_Identifier (Sloc_Value, 4597 New_External_Name 4598 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 4599 4600 begin 4601 Set_Ekind (N, Kind); 4602 Set_Is_Internal (N, True); 4603 Append_Entity (N, Scope_Id); 4604 Set_Public_Status (N); 4605 4606 if Kind in Type_Kind then 4607 Init_Size_Align (N); 4608 end if; 4609 4610 return N; 4611 end New_External_Entity; 4612 4613 ------------------------- 4614 -- New_Internal_Entity -- 4615 ------------------------- 4616 4617 function New_Internal_Entity 4618 (Kind : Entity_Kind; 4619 Scope_Id : Entity_Id; 4620 Sloc_Value : Source_Ptr; 4621 Id_Char : Character) return Entity_Id 4622 is 4623 N : constant Entity_Id := 4624 Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char)); 4625 4626 begin 4627 Set_Ekind (N, Kind); 4628 Set_Is_Internal (N, True); 4629 Append_Entity (N, Scope_Id); 4630 4631 if Kind in Type_Kind then 4632 Init_Size_Align (N); 4633 end if; 4634 4635 return N; 4636 end New_Internal_Entity; 4637 4638 ----------------- 4639 -- Next_Actual -- 4640 ----------------- 4641 4642 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 4643 N : Node_Id; 4644 4645 begin 4646 -- If we are pointing at a positional parameter, it is a member of 4647 -- a node list (the list of parameters), and the next parameter 4648 -- is the next node on the list, unless we hit a parameter 4649 -- association, in which case we shift to using the chain whose 4650 -- head is the First_Named_Actual in the parent, and then is 4651 -- threaded using the Next_Named_Actual of the Parameter_Association. 4652 -- All this fiddling is because the original node list is in the 4653 -- textual call order, and what we need is the declaration order. 4654 4655 if Is_List_Member (Actual_Id) then 4656 N := Next (Actual_Id); 4657 4658 if Nkind (N) = N_Parameter_Association then 4659 return First_Named_Actual (Parent (Actual_Id)); 4660 else 4661 return N; 4662 end if; 4663 4664 else 4665 return Next_Named_Actual (Parent (Actual_Id)); 4666 end if; 4667 end Next_Actual; 4668 4669 procedure Next_Actual (Actual_Id : in out Node_Id) is 4670 begin 4671 Actual_Id := Next_Actual (Actual_Id); 4672 end Next_Actual; 4673 4674 ----------------------- 4675 -- Normalize_Actuals -- 4676 ----------------------- 4677 4678 -- Chain actuals according to formals of subprogram. If there are 4679 -- no named associations, the chain is simply the list of Parameter 4680 -- Associations, since the order is the same as the declaration order. 4681 -- If there are named associations, then the First_Named_Actual field 4682 -- in the N_Procedure_Call_Statement node or N_Function_Call node 4683 -- points to the Parameter_Association node for the parameter that 4684 -- comes first in declaration order. The remaining named parameters 4685 -- are then chained in declaration order using Next_Named_Actual. 4686 4687 -- This routine also verifies that the number of actuals is compatible 4688 -- with the number and default values of formals, but performs no type 4689 -- checking (type checking is done by the caller). 4690 4691 -- If the matching succeeds, Success is set to True, and the caller 4692 -- proceeds with type-checking. If the match is unsuccessful, then 4693 -- Success is set to False, and the caller attempts a different 4694 -- interpretation, if there is one. 4695 4696 -- If the flag Report is on, the call is not overloaded, and a failure 4697 -- to match can be reported here, rather than in the caller. 4698 4699 procedure Normalize_Actuals 4700 (N : Node_Id; 4701 S : Entity_Id; 4702 Report : Boolean; 4703 Success : out Boolean) 4704 is 4705 Actuals : constant List_Id := Parameter_Associations (N); 4706 Actual : Node_Id := Empty; 4707 Formal : Entity_Id; 4708 Last : Node_Id := Empty; 4709 First_Named : Node_Id := Empty; 4710 Found : Boolean; 4711 4712 Formals_To_Match : Integer := 0; 4713 Actuals_To_Match : Integer := 0; 4714 4715 procedure Chain (A : Node_Id); 4716 -- Add named actual at the proper place in the list, using the 4717 -- Next_Named_Actual link. 4718 4719 function Reporting return Boolean; 4720 -- Determines if an error is to be reported. To report an error, we 4721 -- need Report to be True, and also we do not report errors caused 4722 -- by calls to init procs that occur within other init procs. Such 4723 -- errors must always be cascaded errors, since if all the types are 4724 -- declared correctly, the compiler will certainly build decent calls! 4725 4726 ----------- 4727 -- Chain -- 4728 ----------- 4729 4730 procedure Chain (A : Node_Id) is 4731 begin 4732 if No (Last) then 4733 4734 -- Call node points to first actual in list. 4735 4736 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 4737 4738 else 4739 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 4740 end if; 4741 4742 Last := A; 4743 Set_Next_Named_Actual (Last, Empty); 4744 end Chain; 4745 4746 --------------- 4747 -- Reporting -- 4748 --------------- 4749 4750 function Reporting return Boolean is 4751 begin 4752 if not Report then 4753 return False; 4754 4755 elsif not Within_Init_Proc then 4756 return True; 4757 4758 elsif Is_Init_Proc (Entity (Name (N))) then 4759 return False; 4760 4761 else 4762 return True; 4763 end if; 4764 end Reporting; 4765 4766 -- Start of processing for Normalize_Actuals 4767 4768 begin 4769 if Is_Access_Type (S) then 4770 4771 -- The name in the call is a function call that returns an access 4772 -- to subprogram. The designated type has the list of formals. 4773 4774 Formal := First_Formal (Designated_Type (S)); 4775 else 4776 Formal := First_Formal (S); 4777 end if; 4778 4779 while Present (Formal) loop 4780 Formals_To_Match := Formals_To_Match + 1; 4781 Next_Formal (Formal); 4782 end loop; 4783 4784 -- Find if there is a named association, and verify that no positional 4785 -- associations appear after named ones. 4786 4787 if Present (Actuals) then 4788 Actual := First (Actuals); 4789 end if; 4790 4791 while Present (Actual) 4792 and then Nkind (Actual) /= N_Parameter_Association 4793 loop 4794 Actuals_To_Match := Actuals_To_Match + 1; 4795 Next (Actual); 4796 end loop; 4797 4798 if No (Actual) and Actuals_To_Match = Formals_To_Match then 4799 4800 -- Most common case: positional notation, no defaults 4801 4802 Success := True; 4803 return; 4804 4805 elsif Actuals_To_Match > Formals_To_Match then 4806 4807 -- Too many actuals: will not work. 4808 4809 if Reporting then 4810 if Is_Entity_Name (Name (N)) then 4811 Error_Msg_N ("too many arguments in call to&", Name (N)); 4812 else 4813 Error_Msg_N ("too many arguments in call", N); 4814 end if; 4815 end if; 4816 4817 Success := False; 4818 return; 4819 end if; 4820 4821 First_Named := Actual; 4822 4823 while Present (Actual) loop 4824 if Nkind (Actual) /= N_Parameter_Association then 4825 Error_Msg_N 4826 ("positional parameters not allowed after named ones", Actual); 4827 Success := False; 4828 return; 4829 4830 else 4831 Actuals_To_Match := Actuals_To_Match + 1; 4832 end if; 4833 4834 Next (Actual); 4835 end loop; 4836 4837 if Present (Actuals) then 4838 Actual := First (Actuals); 4839 end if; 4840 4841 Formal := First_Formal (S); 4842 4843 while Present (Formal) loop 4844 4845 -- Match the formals in order. If the corresponding actual 4846 -- is positional, nothing to do. Else scan the list of named 4847 -- actuals to find the one with the right name. 4848 4849 if Present (Actual) 4850 and then Nkind (Actual) /= N_Parameter_Association 4851 then 4852 Next (Actual); 4853 Actuals_To_Match := Actuals_To_Match - 1; 4854 Formals_To_Match := Formals_To_Match - 1; 4855 4856 else 4857 -- For named parameters, search the list of actuals to find 4858 -- one that matches the next formal name. 4859 4860 Actual := First_Named; 4861 Found := False; 4862 4863 while Present (Actual) loop 4864 if Chars (Selector_Name (Actual)) = Chars (Formal) then 4865 Found := True; 4866 Chain (Actual); 4867 Actuals_To_Match := Actuals_To_Match - 1; 4868 Formals_To_Match := Formals_To_Match - 1; 4869 exit; 4870 end if; 4871 4872 Next (Actual); 4873 end loop; 4874 4875 if not Found then 4876 if Ekind (Formal) /= E_In_Parameter 4877 or else No (Default_Value (Formal)) 4878 then 4879 if Reporting then 4880 if (Comes_From_Source (S) 4881 or else Sloc (S) = Standard_Location) 4882 and then Is_Overloadable (S) 4883 then 4884 Error_Msg_Name_1 := Chars (S); 4885 Error_Msg_Sloc := Sloc (S); 4886 Error_Msg_NE 4887 ("missing argument for parameter & " & 4888 "in call to % declared #", N, Formal); 4889 4890 elsif Is_Overloadable (S) then 4891 Error_Msg_Name_1 := Chars (S); 4892 4893 -- Point to type derivation that 4894 -- generated the operation. 4895 4896 Error_Msg_Sloc := Sloc (Parent (S)); 4897 4898 Error_Msg_NE 4899 ("missing argument for parameter & " & 4900 "in call to % (inherited) #", N, Formal); 4901 4902 else 4903 Error_Msg_NE 4904 ("missing argument for parameter &", N, Formal); 4905 end if; 4906 end if; 4907 4908 Success := False; 4909 return; 4910 4911 else 4912 Formals_To_Match := Formals_To_Match - 1; 4913 end if; 4914 end if; 4915 end if; 4916 4917 Next_Formal (Formal); 4918 end loop; 4919 4920 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 4921 Success := True; 4922 return; 4923 4924 else 4925 if Reporting then 4926 4927 -- Find some superfluous named actual that did not get 4928 -- attached to the list of associations. 4929 4930 Actual := First (Actuals); 4931 4932 while Present (Actual) loop 4933 4934 if Nkind (Actual) = N_Parameter_Association 4935 and then Actual /= Last 4936 and then No (Next_Named_Actual (Actual)) 4937 then 4938 Error_Msg_N ("unmatched actual & in call", 4939 Selector_Name (Actual)); 4940 exit; 4941 end if; 4942 4943 Next (Actual); 4944 end loop; 4945 end if; 4946 4947 Success := False; 4948 return; 4949 end if; 4950 end Normalize_Actuals; 4951 4952 -------------------------------- 4953 -- Note_Possible_Modification -- 4954 -------------------------------- 4955 4956 procedure Note_Possible_Modification (N : Node_Id) is 4957 Ent : Entity_Id; 4958 Exp : Node_Id; 4959 4960 procedure Set_Ref (E : Entity_Id; N : Node_Id); 4961 -- Internal routine to note modification on entity E by node N 4962 -- Has no effect if entity E does not represent an object. 4963 4964 ------------- 4965 -- Set_Ref -- 4966 ------------- 4967 4968 procedure Set_Ref (E : Entity_Id; N : Node_Id) is 4969 begin 4970 if Is_Object (E) then 4971 if Comes_From_Source (N) then 4972 Set_Never_Set_In_Source (E, False); 4973 end if; 4974 4975 Set_Is_True_Constant (E, False); 4976 Set_Current_Value (E, Empty); 4977 Generate_Reference (E, N, 'm'); 4978 Kill_Checks (E); 4979 4980 if not Can_Never_Be_Null (E) then 4981 Set_Is_Known_Non_Null (E, False); 4982 end if; 4983 end if; 4984 end Set_Ref; 4985 4986 -- Start of processing for Note_Possible_Modification 4987 4988 begin 4989 -- Loop to find referenced entity, if there is one 4990 4991 Exp := N; 4992 loop 4993 -- Test for node rewritten as dereference (e.g. accept parameter) 4994 4995 if Nkind (Exp) = N_Explicit_Dereference 4996 and then not Comes_From_Source (Exp) 4997 then 4998 Exp := Original_Node (Exp); 4999 end if; 5000 5001 -- Now look for entity being referenced 5002 5003 if Is_Entity_Name (Exp) then 5004 Ent := Entity (Exp); 5005 5006 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) 5007 and then Present (Renamed_Object (Ent)) 5008 then 5009 Set_Never_Set_In_Source (Ent, False); 5010 Set_Is_True_Constant (Ent, False); 5011 Set_Current_Value (Ent, Empty); 5012 5013 if not Can_Never_Be_Null (Ent) then 5014 Set_Is_Known_Non_Null (Ent, False); 5015 end if; 5016 5017 Exp := Renamed_Object (Ent); 5018 5019 else 5020 Set_Ref (Ent, Exp); 5021 Kill_Checks (Ent); 5022 return; 5023 end if; 5024 5025 elsif Nkind (Exp) = N_Type_Conversion 5026 or else Nkind (Exp) = N_Unchecked_Type_Conversion 5027 then 5028 Exp := Expression (Exp); 5029 5030 elsif Nkind (Exp) = N_Slice 5031 or else Nkind (Exp) = N_Indexed_Component 5032 or else Nkind (Exp) = N_Selected_Component 5033 then 5034 Exp := Prefix (Exp); 5035 5036 else 5037 return; 5038 end if; 5039 end loop; 5040 end Note_Possible_Modification; 5041 5042 ------------------------- 5043 -- Object_Access_Level -- 5044 ------------------------- 5045 5046 function Object_Access_Level (Obj : Node_Id) return Uint is 5047 E : Entity_Id; 5048 5049 -- Returns the static accessibility level of the view denoted 5050 -- by Obj. Note that the value returned is the result of a 5051 -- call to Scope_Depth. Only scope depths associated with 5052 -- dynamic scopes can actually be returned. Since only 5053 -- relative levels matter for accessibility checking, the fact 5054 -- that the distance between successive levels of accessibility 5055 -- is not always one is immaterial (invariant: if level(E2) is 5056 -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). 5057 5058 begin 5059 if Is_Entity_Name (Obj) then 5060 E := Entity (Obj); 5061 5062 -- If E is a type then it denotes a current instance. 5063 -- For this case we add one to the normal accessibility 5064 -- level of the type to ensure that current instances 5065 -- are treated as always being deeper than than the level 5066 -- of any visible named access type (see 3.10.2(21)). 5067 5068 if Is_Type (E) then 5069 return Type_Access_Level (E) + 1; 5070 5071 elsif Present (Renamed_Object (E)) then 5072 return Object_Access_Level (Renamed_Object (E)); 5073 5074 -- Similarly, if E is a component of the current instance of a 5075 -- protected type, any instance of it is assumed to be at a deeper 5076 -- level than the type. For a protected object (whose type is an 5077 -- anonymous protected type) its components are at the same level 5078 -- as the type itself. 5079 5080 elsif not Is_Overloadable (E) 5081 and then Ekind (Scope (E)) = E_Protected_Type 5082 and then Comes_From_Source (Scope (E)) 5083 then 5084 return Type_Access_Level (Scope (E)) + 1; 5085 5086 else 5087 return Scope_Depth (Enclosing_Dynamic_Scope (E)); 5088 end if; 5089 5090 elsif Nkind (Obj) = N_Selected_Component then 5091 if Is_Access_Type (Etype (Prefix (Obj))) then 5092 return Type_Access_Level (Etype (Prefix (Obj))); 5093 else 5094 return Object_Access_Level (Prefix (Obj)); 5095 end if; 5096 5097 elsif Nkind (Obj) = N_Indexed_Component then 5098 if Is_Access_Type (Etype (Prefix (Obj))) then 5099 return Type_Access_Level (Etype (Prefix (Obj))); 5100 else 5101 return Object_Access_Level (Prefix (Obj)); 5102 end if; 5103 5104 elsif Nkind (Obj) = N_Explicit_Dereference then 5105 5106 -- If the prefix is a selected access discriminant then 5107 -- we make a recursive call on the prefix, which will 5108 -- in turn check the level of the prefix object of 5109 -- the selected discriminant. 5110 5111 if Nkind (Prefix (Obj)) = N_Selected_Component 5112 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type 5113 and then 5114 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant 5115 then 5116 return Object_Access_Level (Prefix (Obj)); 5117 else 5118 return Type_Access_Level (Etype (Prefix (Obj))); 5119 end if; 5120 5121 elsif Nkind (Obj) = N_Type_Conversion 5122 or else Nkind (Obj) = N_Unchecked_Type_Conversion 5123 then 5124 return Object_Access_Level (Expression (Obj)); 5125 5126 -- Function results are objects, so we get either the access level 5127 -- of the function or, in the case of an indirect call, the level of 5128 -- of the access-to-subprogram type. 5129 5130 elsif Nkind (Obj) = N_Function_Call then 5131 if Is_Entity_Name (Name (Obj)) then 5132 return Subprogram_Access_Level (Entity (Name (Obj))); 5133 else 5134 return Type_Access_Level (Etype (Prefix (Name (Obj)))); 5135 end if; 5136 5137 -- For convenience we handle qualified expressions, even though 5138 -- they aren't technically object names. 5139 5140 elsif Nkind (Obj) = N_Qualified_Expression then 5141 return Object_Access_Level (Expression (Obj)); 5142 5143 -- Otherwise return the scope level of Standard. 5144 -- (If there are cases that fall through 5145 -- to this point they will be treated as 5146 -- having global accessibility for now. ???) 5147 5148 else 5149 return Scope_Depth (Standard_Standard); 5150 end if; 5151 end Object_Access_Level; 5152 5153 ----------------------- 5154 -- Private_Component -- 5155 ----------------------- 5156 5157 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 5158 Ancestor : constant Entity_Id := Base_Type (Type_Id); 5159 5160 function Trace_Components 5161 (T : Entity_Id; 5162 Check : Boolean) return Entity_Id; 5163 -- Recursive function that does the work, and checks against circular 5164 -- definition for each subcomponent type. 5165 5166 ---------------------- 5167 -- Trace_Components -- 5168 ---------------------- 5169 5170 function Trace_Components 5171 (T : Entity_Id; 5172 Check : Boolean) return Entity_Id 5173 is 5174 Btype : constant Entity_Id := Base_Type (T); 5175 Component : Entity_Id; 5176 P : Entity_Id; 5177 Candidate : Entity_Id := Empty; 5178 5179 begin 5180 if Check and then Btype = Ancestor then 5181 Error_Msg_N ("circular type definition", Type_Id); 5182 return Any_Type; 5183 end if; 5184 5185 if Is_Private_Type (Btype) 5186 and then not Is_Generic_Type (Btype) 5187 then 5188 return Btype; 5189 5190 elsif Is_Array_Type (Btype) then 5191 return Trace_Components (Component_Type (Btype), True); 5192 5193 elsif Is_Record_Type (Btype) then 5194 Component := First_Entity (Btype); 5195 while Present (Component) loop 5196 5197 -- skip anonymous types generated by constrained components. 5198 5199 if not Is_Type (Component) then 5200 P := Trace_Components (Etype (Component), True); 5201 5202 if Present (P) then 5203 if P = Any_Type then 5204 return P; 5205 else 5206 Candidate := P; 5207 end if; 5208 end if; 5209 end if; 5210 5211 Next_Entity (Component); 5212 end loop; 5213 5214 return Candidate; 5215 5216 else 5217 return Empty; 5218 end if; 5219 end Trace_Components; 5220 5221 -- Start of processing for Private_Component 5222 5223 begin 5224 return Trace_Components (Type_Id, False); 5225 end Private_Component; 5226 5227 ----------------------- 5228 -- Process_End_Label -- 5229 ----------------------- 5230 5231 procedure Process_End_Label 5232 (N : Node_Id; 5233 Typ : Character; 5234 Ent : Entity_Id) 5235 is 5236 Loc : Source_Ptr; 5237 Nam : Node_Id; 5238 5239 Label_Ref : Boolean; 5240 -- Set True if reference to end label itself is required 5241 5242 Endl : Node_Id; 5243 -- Gets set to the operator symbol or identifier that references 5244 -- the entity Ent. For the child unit case, this is the identifier 5245 -- from the designator. For other cases, this is simply Endl. 5246 5247 procedure Generate_Parent_Ref (N : Node_Id); 5248 -- N is an identifier node that appears as a parent unit reference 5249 -- in the case where Ent is a child unit. This procedure generates 5250 -- an appropriate cross-reference entry. 5251 5252 ------------------------- 5253 -- Generate_Parent_Ref -- 5254 ------------------------- 5255 5256 procedure Generate_Parent_Ref (N : Node_Id) is 5257 Parent_Ent : Entity_Id; 5258 5259 begin 5260 -- Search up scope stack. The reason we do this is that normal 5261 -- visibility analysis would not work for two reasons. First in 5262 -- some subunit cases, the entry for the parent unit may not be 5263 -- visible, and in any case there can be a local entity that 5264 -- hides the scope entity. 5265 5266 Parent_Ent := Current_Scope; 5267 while Present (Parent_Ent) loop 5268 if Chars (Parent_Ent) = Chars (N) then 5269 5270 -- Generate the reference. We do NOT consider this as a 5271 -- reference for unreferenced symbol purposes, but we do 5272 -- force a cross-reference even if the end line does not 5273 -- come from source (the caller already generated the 5274 -- appropriate Typ for this situation). 5275 5276 Generate_Reference 5277 (Parent_Ent, N, 'r', Set_Ref => False, Force => True); 5278 Style.Check_Identifier (N, Parent_Ent); 5279 return; 5280 end if; 5281 5282 Parent_Ent := Scope (Parent_Ent); 5283 end loop; 5284 5285 -- Fall through means entity was not found -- that's odd, but 5286 -- the appropriate thing is simply to ignore and not generate 5287 -- any cross-reference for this entry. 5288 5289 return; 5290 end Generate_Parent_Ref; 5291 5292 -- Start of processing for Process_End_Label 5293 5294 begin 5295 -- If no node, ignore. This happens in some error situations, 5296 -- and also for some internally generated structures where no 5297 -- end label references are required in any case. 5298 5299 if No (N) then 5300 return; 5301 end if; 5302 5303 -- Nothing to do if no End_Label, happens for internally generated 5304 -- constructs where we don't want an end label reference anyway. 5305 -- Also nothing to do if Endl is a string literal, which means 5306 -- there was some prior error (bad operator symbol) 5307 5308 Endl := End_Label (N); 5309 5310 if No (Endl) or else Nkind (Endl) = N_String_Literal then 5311 return; 5312 end if; 5313 5314 -- Reference node is not in extended main source unit 5315 5316 if not In_Extended_Main_Source_Unit (N) then 5317 5318 -- Generally we do not collect references except for the 5319 -- extended main source unit. The one exception is the 'e' 5320 -- entry for a package spec, where it is useful for a client 5321 -- to have the ending information to define scopes. 5322 5323 if Typ /= 'e' then 5324 return; 5325 5326 else 5327 Label_Ref := False; 5328 5329 -- For this case, we can ignore any parent references, 5330 -- but we need the package name itself for the 'e' entry. 5331 5332 if Nkind (Endl) = N_Designator then 5333 Endl := Identifier (Endl); 5334 end if; 5335 end if; 5336 5337 -- Reference is in extended main source unit 5338 5339 else 5340 Label_Ref := True; 5341 5342 -- For designator, generate references for the parent entries 5343 5344 if Nkind (Endl) = N_Designator then 5345 5346 -- Generate references for the prefix if the END line comes 5347 -- from source (otherwise we do not need these references) 5348 5349 if Comes_From_Source (Endl) then 5350 Nam := Name (Endl); 5351 while Nkind (Nam) = N_Selected_Component loop 5352 Generate_Parent_Ref (Selector_Name (Nam)); 5353 Nam := Prefix (Nam); 5354 end loop; 5355 5356 Generate_Parent_Ref (Nam); 5357 end if; 5358 5359 Endl := Identifier (Endl); 5360 end if; 5361 end if; 5362 5363 -- If the end label is not for the given entity, then either we have 5364 -- some previous error, or this is a generic instantiation for which 5365 -- we do not need to make a cross-reference in this case anyway. In 5366 -- either case we simply ignore the call. 5367 5368 if Chars (Ent) /= Chars (Endl) then 5369 return; 5370 end if; 5371 5372 -- If label was really there, then generate a normal reference 5373 -- and then adjust the location in the end label to point past 5374 -- the name (which should almost always be the semicolon). 5375 5376 Loc := Sloc (Endl); 5377 5378 if Comes_From_Source (Endl) then 5379 5380 -- If a label reference is required, then do the style check 5381 -- and generate an l-type cross-reference entry for the label 5382 5383 if Label_Ref then 5384 if Style_Check then 5385 Style.Check_Identifier (Endl, Ent); 5386 end if; 5387 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 5388 end if; 5389 5390 -- Set the location to point past the label (normally this will 5391 -- mean the semicolon immediately following the label). This is 5392 -- done for the sake of the 'e' or 't' entry generated below. 5393 5394 Get_Decoded_Name_String (Chars (Endl)); 5395 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 5396 end if; 5397 5398 -- Now generate the e/t reference 5399 5400 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 5401 5402 -- Restore Sloc, in case modified above, since we have an identifier 5403 -- and the normal Sloc should be left set in the tree. 5404 5405 Set_Sloc (Endl, Loc); 5406 end Process_End_Label; 5407 5408 ------------------ 5409 -- Real_Convert -- 5410 ------------------ 5411 5412 -- We do the conversion to get the value of the real string by using 5413 -- the scanner, see Sinput for details on use of the internal source 5414 -- buffer for scanning internal strings. 5415 5416 function Real_Convert (S : String) return Node_Id is 5417 Save_Src : constant Source_Buffer_Ptr := Source; 5418 Negative : Boolean; 5419 5420 begin 5421 Source := Internal_Source_Ptr; 5422 Scan_Ptr := 1; 5423 5424 for J in S'Range loop 5425 Source (Source_Ptr (J)) := S (J); 5426 end loop; 5427 5428 Source (S'Length + 1) := EOF; 5429 5430 if Source (Scan_Ptr) = '-' then 5431 Negative := True; 5432 Scan_Ptr := Scan_Ptr + 1; 5433 else 5434 Negative := False; 5435 end if; 5436 5437 Scan; 5438 5439 if Negative then 5440 Set_Realval (Token_Node, UR_Negate (Realval (Token_Node))); 5441 end if; 5442 5443 Source := Save_Src; 5444 return Token_Node; 5445 end Real_Convert; 5446 5447 --------------------- 5448 -- Rep_To_Pos_Flag -- 5449 --------------------- 5450 5451 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 5452 begin 5453 if Range_Checks_Suppressed (E) then 5454 return New_Occurrence_Of (Standard_False, Loc); 5455 else 5456 return New_Occurrence_Of (Standard_True, Loc); 5457 end if; 5458 end Rep_To_Pos_Flag; 5459 5460 -------------------- 5461 -- Require_Entity -- 5462 -------------------- 5463 5464 procedure Require_Entity (N : Node_Id) is 5465 begin 5466 if Is_Entity_Name (N) and then No (Entity (N)) then 5467 if Total_Errors_Detected /= 0 then 5468 Set_Entity (N, Any_Id); 5469 else 5470 raise Program_Error; 5471 end if; 5472 end if; 5473 end Require_Entity; 5474 5475 ------------------------------ 5476 -- Requires_Transient_Scope -- 5477 ------------------------------ 5478 5479 -- A transient scope is required when variable-sized temporaries are 5480 -- allocated in the primary or secondary stack, or when finalization 5481 -- actions must be generated before the next instruction 5482 5483 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 5484 Typ : constant Entity_Id := Underlying_Type (Id); 5485 5486 begin 5487 -- This is a private type which is not completed yet. This can only 5488 -- happen in a default expression (of a formal parameter or of a 5489 -- record component). Do not expand transient scope in this case 5490 5491 if No (Typ) then 5492 return False; 5493 5494 elsif Typ = Standard_Void_Type then 5495 return False; 5496 5497 -- The back-end has trouble allocating variable-size temporaries so 5498 -- we generate them in the front-end and need a transient scope to 5499 -- reclaim them properly 5500 5501 elsif not Size_Known_At_Compile_Time (Typ) then 5502 return True; 5503 5504 -- Unconstrained discriminated records always require a variable 5505 -- length temporary, since the length may depend on the variant. 5506 5507 elsif Is_Record_Type (Typ) 5508 and then Has_Discriminants (Typ) 5509 and then not Is_Constrained (Typ) 5510 then 5511 return True; 5512 5513 -- Functions returning tagged types may dispatch on result so their 5514 -- returned value is allocated on the secondary stack. Controlled 5515 -- type temporaries need finalization. 5516 5517 elsif Is_Tagged_Type (Typ) 5518 or else Has_Controlled_Component (Typ) 5519 then 5520 return True; 5521 5522 -- Unconstrained array types are returned on the secondary stack 5523 5524 elsif Is_Array_Type (Typ) then 5525 return not Is_Constrained (Typ); 5526 end if; 5527 5528 return False; 5529 end Requires_Transient_Scope; 5530 5531 -------------------------- 5532 -- Reset_Analyzed_Flags -- 5533 -------------------------- 5534 5535 procedure Reset_Analyzed_Flags (N : Node_Id) is 5536 5537 function Clear_Analyzed 5538 (N : Node_Id) return Traverse_Result; 5539 -- Function used to reset Analyzed flags in tree. Note that we do 5540 -- not reset Analyzed flags in entities, since there is no need to 5541 -- renalalyze entities, and indeed, it is wrong to do so, since it 5542 -- can result in generating auxiliary stuff more than once. 5543 5544 -------------------- 5545 -- Clear_Analyzed -- 5546 -------------------- 5547 5548 function Clear_Analyzed 5549 (N : Node_Id) return Traverse_Result 5550 is 5551 begin 5552 if not Has_Extension (N) then 5553 Set_Analyzed (N, False); 5554 end if; 5555 5556 return OK; 5557 end Clear_Analyzed; 5558 5559 function Reset_Analyzed is 5560 new Traverse_Func (Clear_Analyzed); 5561 5562 Discard : Traverse_Result; 5563 pragma Warnings (Off, Discard); 5564 5565 -- Start of processing for Reset_Analyzed_Flags 5566 5567 begin 5568 Discard := Reset_Analyzed (N); 5569 end Reset_Analyzed_Flags; 5570 5571 --------------------------- 5572 -- Safe_To_Capture_Value -- 5573 --------------------------- 5574 5575 function Safe_To_Capture_Value 5576 (N : Node_Id; 5577 Ent : Entity_Id) return Boolean 5578 is 5579 begin 5580 -- The only entities for which we track constant values are variables, 5581 -- out parameters and in out parameters, so check if we have this case. 5582 5583 if Ekind (Ent) /= E_Variable 5584 and then 5585 Ekind (Ent) /= E_Out_Parameter 5586 and then 5587 Ekind (Ent) /= E_In_Out_Parameter 5588 then 5589 return False; 5590 end if; 5591 5592 -- Skip volatile and aliased variables, since funny things might 5593 -- be going on in these cases which we cannot necessarily track. 5594 5595 if Treat_As_Volatile (Ent) or else Is_Aliased (Ent) then 5596 return False; 5597 end if; 5598 5599 -- OK, all above conditions are met. We also require that the scope 5600 -- of the reference be the same as the scope of the entity, not 5601 -- counting packages and blocks. 5602 5603 declare 5604 E_Scope : constant Entity_Id := Scope (Ent); 5605 R_Scope : Entity_Id; 5606 5607 begin 5608 R_Scope := Current_Scope; 5609 while R_Scope /= Standard_Standard loop 5610 exit when R_Scope = E_Scope; 5611 5612 if Ekind (R_Scope) /= E_Package 5613 and then 5614 Ekind (R_Scope) /= E_Block 5615 then 5616 return False; 5617 else 5618 R_Scope := Scope (R_Scope); 5619 end if; 5620 end loop; 5621 end; 5622 5623 -- We also require that the reference does not appear in a context 5624 -- where it is not sure to be executed (i.e. a conditional context 5625 -- or an exception handler). 5626 5627 declare 5628 P : Node_Id; 5629 5630 begin 5631 P := Parent (N); 5632 while Present (P) loop 5633 if Nkind (P) = N_If_Statement 5634 or else 5635 Nkind (P) = N_Case_Statement 5636 or else 5637 Nkind (P) = N_Exception_Handler 5638 or else 5639 Nkind (P) = N_Selective_Accept 5640 or else 5641 Nkind (P) = N_Conditional_Entry_Call 5642 or else 5643 Nkind (P) = N_Timed_Entry_Call 5644 or else 5645 Nkind (P) = N_Asynchronous_Select 5646 then 5647 return False; 5648 else 5649 P := Parent (P); 5650 end if; 5651 end loop; 5652 end; 5653 5654 -- OK, looks safe to set value 5655 5656 return True; 5657 end Safe_To_Capture_Value; 5658 5659 --------------- 5660 -- Same_Name -- 5661 --------------- 5662 5663 function Same_Name (N1, N2 : Node_Id) return Boolean is 5664 K1 : constant Node_Kind := Nkind (N1); 5665 K2 : constant Node_Kind := Nkind (N2); 5666 5667 begin 5668 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 5669 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 5670 then 5671 return Chars (N1) = Chars (N2); 5672 5673 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 5674 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 5675 then 5676 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 5677 and then Same_Name (Prefix (N1), Prefix (N2)); 5678 5679 else 5680 return False; 5681 end if; 5682 end Same_Name; 5683 5684 --------------- 5685 -- Same_Type -- 5686 --------------- 5687 5688 function Same_Type (T1, T2 : Entity_Id) return Boolean is 5689 begin 5690 if T1 = T2 then 5691 return True; 5692 5693 elsif not Is_Constrained (T1) 5694 and then not Is_Constrained (T2) 5695 and then Base_Type (T1) = Base_Type (T2) 5696 then 5697 return True; 5698 5699 -- For now don't bother with case of identical constraints, to be 5700 -- fiddled with later on perhaps (this is only used for optimization 5701 -- purposes, so it is not critical to do a best possible job) 5702 5703 else 5704 return False; 5705 end if; 5706 end Same_Type; 5707 5708 ------------------------ 5709 -- Scope_Is_Transient -- 5710 ------------------------ 5711 5712 function Scope_Is_Transient return Boolean is 5713 begin 5714 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 5715 end Scope_Is_Transient; 5716 5717 ------------------ 5718 -- Scope_Within -- 5719 ------------------ 5720 5721 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is 5722 Scop : Entity_Id; 5723 5724 begin 5725 Scop := Scope1; 5726 while Scop /= Standard_Standard loop 5727 Scop := Scope (Scop); 5728 5729 if Scop = Scope2 then 5730 return True; 5731 end if; 5732 end loop; 5733 5734 return False; 5735 end Scope_Within; 5736 5737 -------------------------- 5738 -- Scope_Within_Or_Same -- 5739 -------------------------- 5740 5741 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is 5742 Scop : Entity_Id; 5743 5744 begin 5745 Scop := Scope1; 5746 while Scop /= Standard_Standard loop 5747 if Scop = Scope2 then 5748 return True; 5749 else 5750 Scop := Scope (Scop); 5751 end if; 5752 end loop; 5753 5754 return False; 5755 end Scope_Within_Or_Same; 5756 5757 ------------------------ 5758 -- Set_Current_Entity -- 5759 ------------------------ 5760 5761 -- The given entity is to be set as the currently visible definition 5762 -- of its associated name (i.e. the Node_Id associated with its name). 5763 -- All we have to do is to get the name from the identifier, and 5764 -- then set the associated Node_Id to point to the given entity. 5765 5766 procedure Set_Current_Entity (E : Entity_Id) is 5767 begin 5768 Set_Name_Entity_Id (Chars (E), E); 5769 end Set_Current_Entity; 5770 5771 --------------------------------- 5772 -- Set_Entity_With_Style_Check -- 5773 --------------------------------- 5774 5775 procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is 5776 Val_Actual : Entity_Id; 5777 Nod : Node_Id; 5778 5779 begin 5780 Set_Entity (N, Val); 5781 5782 if Style_Check 5783 and then not Suppress_Style_Checks (Val) 5784 and then not In_Instance 5785 then 5786 if Nkind (N) = N_Identifier then 5787 Nod := N; 5788 5789 elsif Nkind (N) = N_Expanded_Name then 5790 Nod := Selector_Name (N); 5791 5792 else 5793 return; 5794 end if; 5795 5796 Val_Actual := Val; 5797 5798 -- A special situation arises for derived operations, where we want 5799 -- to do the check against the parent (since the Sloc of the derived 5800 -- operation points to the derived type declaration itself). 5801 5802 while not Comes_From_Source (Val_Actual) 5803 and then Nkind (Val_Actual) in N_Entity 5804 and then (Ekind (Val_Actual) = E_Enumeration_Literal 5805 or else Is_Subprogram (Val_Actual) 5806 or else Is_Generic_Subprogram (Val_Actual)) 5807 and then Present (Alias (Val_Actual)) 5808 loop 5809 Val_Actual := Alias (Val_Actual); 5810 end loop; 5811 5812 -- Renaming declarations for generic actuals do not come from source, 5813 -- and have a different name from that of the entity they rename, so 5814 -- there is no style check to perform here. 5815 5816 if Chars (Nod) = Chars (Val_Actual) then 5817 Style.Check_Identifier (Nod, Val_Actual); 5818 end if; 5819 end if; 5820 5821 Set_Entity (N, Val); 5822 end Set_Entity_With_Style_Check; 5823 5824 ------------------------ 5825 -- Set_Name_Entity_Id -- 5826 ------------------------ 5827 5828 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 5829 begin 5830 Set_Name_Table_Info (Id, Int (Val)); 5831 end Set_Name_Entity_Id; 5832 5833 --------------------- 5834 -- Set_Next_Actual -- 5835 --------------------- 5836 5837 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 5838 begin 5839 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 5840 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 5841 end if; 5842 end Set_Next_Actual; 5843 5844 ----------------------- 5845 -- Set_Public_Status -- 5846 ----------------------- 5847 5848 procedure Set_Public_Status (Id : Entity_Id) is 5849 S : constant Entity_Id := Current_Scope; 5850 5851 begin 5852 if S = Standard_Standard 5853 or else (Is_Public (S) 5854 and then (Ekind (S) = E_Package 5855 or else Is_Record_Type (S) 5856 or else Ekind (S) = E_Void)) 5857 then 5858 Set_Is_Public (Id); 5859 5860 -- The bounds of an entry family declaration can generate object 5861 -- declarations that are visible to the back-end, e.g. in the 5862 -- the declaration of a composite type that contains tasks. 5863 5864 elsif Is_Public (S) 5865 and then Is_Concurrent_Type (S) 5866 and then not Has_Completion (S) 5867 and then Nkind (Parent (Id)) = N_Object_Declaration 5868 then 5869 Set_Is_Public (Id); 5870 end if; 5871 end Set_Public_Status; 5872 5873 ---------------------------- 5874 -- Set_Scope_Is_Transient -- 5875 ---------------------------- 5876 5877 procedure Set_Scope_Is_Transient (V : Boolean := True) is 5878 begin 5879 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 5880 end Set_Scope_Is_Transient; 5881 5882 ------------------- 5883 -- Set_Size_Info -- 5884 ------------------- 5885 5886 procedure Set_Size_Info (T1, T2 : Entity_Id) is 5887 begin 5888 -- We copy Esize, but not RM_Size, since in general RM_Size is 5889 -- subtype specific and does not get inherited by all subtypes. 5890 5891 Set_Esize (T1, Esize (T2)); 5892 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 5893 5894 if Is_Discrete_Or_Fixed_Point_Type (T1) 5895 and then 5896 Is_Discrete_Or_Fixed_Point_Type (T2) 5897 then 5898 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 5899 end if; 5900 Set_Alignment (T1, Alignment (T2)); 5901 end Set_Size_Info; 5902 5903 -------------------- 5904 -- Static_Integer -- 5905 -------------------- 5906 5907 function Static_Integer (N : Node_Id) return Uint is 5908 begin 5909 Analyze_And_Resolve (N, Any_Integer); 5910 5911 if N = Error 5912 or else Error_Posted (N) 5913 or else Etype (N) = Any_Type 5914 then 5915 return No_Uint; 5916 end if; 5917 5918 if Is_Static_Expression (N) then 5919 if not Raises_Constraint_Error (N) then 5920 return Expr_Value (N); 5921 else 5922 return No_Uint; 5923 end if; 5924 5925 elsif Etype (N) = Any_Type then 5926 return No_Uint; 5927 5928 else 5929 Flag_Non_Static_Expr 5930 ("static integer expression required here", N); 5931 return No_Uint; 5932 end if; 5933 end Static_Integer; 5934 5935 -------------------------- 5936 -- Statically_Different -- 5937 -------------------------- 5938 5939 function Statically_Different (E1, E2 : Node_Id) return Boolean is 5940 R1 : constant Node_Id := Get_Referenced_Object (E1); 5941 R2 : constant Node_Id := Get_Referenced_Object (E2); 5942 5943 begin 5944 return Is_Entity_Name (R1) 5945 and then Is_Entity_Name (R2) 5946 and then Entity (R1) /= Entity (R2) 5947 and then not Is_Formal (Entity (R1)) 5948 and then not Is_Formal (Entity (R2)); 5949 end Statically_Different; 5950 5951 ----------------------------- 5952 -- Subprogram_Access_Level -- 5953 ----------------------------- 5954 5955 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 5956 begin 5957 if Present (Alias (Subp)) then 5958 return Subprogram_Access_Level (Alias (Subp)); 5959 else 5960 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 5961 end if; 5962 end Subprogram_Access_Level; 5963 5964 ----------------- 5965 -- Trace_Scope -- 5966 ----------------- 5967 5968 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 5969 begin 5970 if Debug_Flag_W then 5971 for J in 0 .. Scope_Stack.Last loop 5972 Write_Str (" "); 5973 end loop; 5974 5975 Write_Str (Msg); 5976 Write_Name (Chars (E)); 5977 Write_Str (" line "); 5978 Write_Int (Int (Get_Logical_Line_Number (Sloc (N)))); 5979 Write_Eol; 5980 end if; 5981 end Trace_Scope; 5982 5983 ----------------------- 5984 -- Transfer_Entities -- 5985 ----------------------- 5986 5987 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 5988 Ent : Entity_Id := First_Entity (From); 5989 5990 begin 5991 if No (Ent) then 5992 return; 5993 end if; 5994 5995 if (Last_Entity (To)) = Empty then 5996 Set_First_Entity (To, Ent); 5997 else 5998 Set_Next_Entity (Last_Entity (To), Ent); 5999 end if; 6000 6001 Set_Last_Entity (To, Last_Entity (From)); 6002 6003 while Present (Ent) loop 6004 Set_Scope (Ent, To); 6005 6006 if not Is_Public (Ent) then 6007 Set_Public_Status (Ent); 6008 6009 if Is_Public (Ent) 6010 and then Ekind (Ent) = E_Record_Subtype 6011 6012 then 6013 -- The components of the propagated Itype must be public 6014 -- as well. 6015 6016 declare 6017 Comp : Entity_Id; 6018 6019 begin 6020 Comp := First_Entity (Ent); 6021 6022 while Present (Comp) loop 6023 Set_Is_Public (Comp); 6024 Next_Entity (Comp); 6025 end loop; 6026 end; 6027 end if; 6028 end if; 6029 6030 Next_Entity (Ent); 6031 end loop; 6032 6033 Set_First_Entity (From, Empty); 6034 Set_Last_Entity (From, Empty); 6035 end Transfer_Entities; 6036 6037 ----------------------- 6038 -- Type_Access_Level -- 6039 ----------------------- 6040 6041 function Type_Access_Level (Typ : Entity_Id) return Uint is 6042 Btyp : Entity_Id; 6043 6044 begin 6045 -- If the type is an anonymous access type we treat it as being 6046 -- declared at the library level to ensure that names such as 6047 -- X.all'access don't fail static accessibility checks. 6048 6049 Btyp := Base_Type (Typ); 6050 if Ekind (Btyp) in Access_Kind then 6051 if Ekind (Btyp) = E_Anonymous_Access_Type then 6052 return Scope_Depth (Standard_Standard); 6053 end if; 6054 6055 Btyp := Root_Type (Btyp); 6056 end if; 6057 6058 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 6059 end Type_Access_Level; 6060 6061 -------------------------- 6062 -- Unit_Declaration_Node -- 6063 -------------------------- 6064 6065 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is 6066 N : Node_Id := Parent (Unit_Id); 6067 6068 begin 6069 -- Predefined operators do not have a full function declaration. 6070 6071 if Ekind (Unit_Id) = E_Operator then 6072 return N; 6073 end if; 6074 6075 while Nkind (N) /= N_Abstract_Subprogram_Declaration 6076 and then Nkind (N) /= N_Formal_Package_Declaration 6077 and then Nkind (N) /= N_Formal_Subprogram_Declaration 6078 and then Nkind (N) /= N_Function_Instantiation 6079 and then Nkind (N) /= N_Generic_Package_Declaration 6080 and then Nkind (N) /= N_Generic_Subprogram_Declaration 6081 and then Nkind (N) /= N_Package_Declaration 6082 and then Nkind (N) /= N_Package_Body 6083 and then Nkind (N) /= N_Package_Instantiation 6084 and then Nkind (N) /= N_Package_Renaming_Declaration 6085 and then Nkind (N) /= N_Procedure_Instantiation 6086 and then Nkind (N) /= N_Protected_Body 6087 and then Nkind (N) /= N_Subprogram_Declaration 6088 and then Nkind (N) /= N_Subprogram_Body 6089 and then Nkind (N) /= N_Subprogram_Body_Stub 6090 and then Nkind (N) /= N_Subprogram_Renaming_Declaration 6091 and then Nkind (N) /= N_Task_Body 6092 and then Nkind (N) /= N_Task_Type_Declaration 6093 and then Nkind (N) not in N_Generic_Renaming_Declaration 6094 loop 6095 N := Parent (N); 6096 pragma Assert (Present (N)); 6097 end loop; 6098 6099 return N; 6100 end Unit_Declaration_Node; 6101 6102 ------------------------------ 6103 -- Universal_Interpretation -- 6104 ------------------------------ 6105 6106 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 6107 Index : Interp_Index; 6108 It : Interp; 6109 6110 begin 6111 -- The argument may be a formal parameter of an operator or subprogram 6112 -- with multiple interpretations, or else an expression for an actual. 6113 6114 if Nkind (Opnd) = N_Defining_Identifier 6115 or else not Is_Overloaded (Opnd) 6116 then 6117 if Etype (Opnd) = Universal_Integer 6118 or else Etype (Opnd) = Universal_Real 6119 then 6120 return Etype (Opnd); 6121 else 6122 return Empty; 6123 end if; 6124 6125 else 6126 Get_First_Interp (Opnd, Index, It); 6127 6128 while Present (It.Typ) loop 6129 6130 if It.Typ = Universal_Integer 6131 or else It.Typ = Universal_Real 6132 then 6133 return It.Typ; 6134 end if; 6135 6136 Get_Next_Interp (Index, It); 6137 end loop; 6138 6139 return Empty; 6140 end if; 6141 end Universal_Interpretation; 6142 6143 ---------------------- 6144 -- Within_Init_Proc -- 6145 ---------------------- 6146 6147 function Within_Init_Proc return Boolean is 6148 S : Entity_Id; 6149 6150 begin 6151 S := Current_Scope; 6152 while not Is_Overloadable (S) loop 6153 if S = Standard_Standard then 6154 return False; 6155 else 6156 S := Scope (S); 6157 end if; 6158 end loop; 6159 6160 return Is_Init_Proc (S); 6161 end Within_Init_Proc; 6162 6163 ---------------- 6164 -- Wrong_Type -- 6165 ---------------- 6166 6167 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 6168 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 6169 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 6170 6171 function Has_One_Matching_Field return Boolean; 6172 -- Determines whether Expec_Type is a record type with a single 6173 -- component or discriminant whose type matches the found type or 6174 -- is a one dimensional array whose component type matches the 6175 -- found type. 6176 6177 function Has_One_Matching_Field return Boolean is 6178 E : Entity_Id; 6179 6180 begin 6181 if Is_Array_Type (Expec_Type) 6182 and then Number_Dimensions (Expec_Type) = 1 6183 and then 6184 Covers (Etype (Component_Type (Expec_Type)), Found_Type) 6185 then 6186 return True; 6187 6188 elsif not Is_Record_Type (Expec_Type) then 6189 return False; 6190 6191 else 6192 E := First_Entity (Expec_Type); 6193 6194 loop 6195 if No (E) then 6196 return False; 6197 6198 elsif (Ekind (E) /= E_Discriminant 6199 and then Ekind (E) /= E_Component) 6200 or else (Chars (E) = Name_uTag 6201 or else Chars (E) = Name_uParent) 6202 then 6203 Next_Entity (E); 6204 6205 else 6206 exit; 6207 end if; 6208 end loop; 6209 6210 if not Covers (Etype (E), Found_Type) then 6211 return False; 6212 6213 elsif Present (Next_Entity (E)) then 6214 return False; 6215 6216 else 6217 return True; 6218 end if; 6219 end if; 6220 end Has_One_Matching_Field; 6221 6222 -- Start of processing for Wrong_Type 6223 6224 begin 6225 -- Don't output message if either type is Any_Type, or if a message 6226 -- has already been posted for this node. We need to do the latter 6227 -- check explicitly (it is ordinarily done in Errout), because we 6228 -- are using ! to force the output of the error messages. 6229 6230 if Expec_Type = Any_Type 6231 or else Found_Type = Any_Type 6232 or else Error_Posted (Expr) 6233 then 6234 return; 6235 6236 -- In an instance, there is an ongoing problem with completion of 6237 -- type derived from private types. Their structure is what Gigi 6238 -- expects, but the Etype is the parent type rather than the 6239 -- derived private type itself. Do not flag error in this case. The 6240 -- private completion is an entity without a parent, like an Itype. 6241 -- Similarly, full and partial views may be incorrect in the instance. 6242 -- There is no simple way to insure that it is consistent ??? 6243 6244 elsif In_Instance then 6245 6246 if Etype (Etype (Expr)) = Etype (Expected_Type) 6247 and then 6248 (Has_Private_Declaration (Expected_Type) 6249 or else Has_Private_Declaration (Etype (Expr))) 6250 and then No (Parent (Expected_Type)) 6251 then 6252 return; 6253 end if; 6254 end if; 6255 6256 -- An interesting special check. If the expression is parenthesized 6257 -- and its type corresponds to the type of the sole component of the 6258 -- expected record type, or to the component type of the expected one 6259 -- dimensional array type, then assume we have a bad aggregate attempt. 6260 6261 if Nkind (Expr) in N_Subexpr 6262 and then Paren_Count (Expr) /= 0 6263 and then Has_One_Matching_Field 6264 then 6265 Error_Msg_N ("positional aggregate cannot have one component", Expr); 6266 6267 -- Another special check, if we are looking for a pool-specific access 6268 -- type and we found an E_Access_Attribute_Type, then we have the case 6269 -- of an Access attribute being used in a context which needs a pool- 6270 -- specific type, which is never allowed. The one extra check we make 6271 -- is that the expected designated type covers the Found_Type. 6272 6273 elsif Is_Access_Type (Expec_Type) 6274 and then Ekind (Found_Type) = E_Access_Attribute_Type 6275 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 6276 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 6277 and then Covers 6278 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 6279 then 6280 Error_Msg_N ("result must be general access type!", Expr); 6281 Error_Msg_NE ("add ALL to }!", Expr, Expec_Type); 6282 6283 -- If the expected type is an anonymous access type, as for access 6284 -- parameters and discriminants, the error is on the designated types. 6285 6286 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 6287 if Comes_From_Source (Expec_Type) then 6288 Error_Msg_NE ("expected}!", Expr, Expec_Type); 6289 else 6290 Error_Msg_NE 6291 ("expected an access type with designated}", 6292 Expr, Designated_Type (Expec_Type)); 6293 end if; 6294 6295 if Is_Access_Type (Found_Type) 6296 and then not Comes_From_Source (Found_Type) 6297 then 6298 Error_Msg_NE 6299 ("found an access type with designated}!", 6300 Expr, Designated_Type (Found_Type)); 6301 else 6302 if From_With_Type (Found_Type) then 6303 Error_Msg_NE ("found incomplete}!", Expr, Found_Type); 6304 Error_Msg_NE 6305 ("\possibly missing with_clause on&", Expr, 6306 Scope (Found_Type)); 6307 else 6308 Error_Msg_NE ("found}!", Expr, Found_Type); 6309 end if; 6310 end if; 6311 6312 -- Normal case of one type found, some other type expected 6313 6314 else 6315 -- If the names of the two types are the same, see if some 6316 -- number of levels of qualification will help. Don't try 6317 -- more than three levels, and if we get to standard, it's 6318 -- no use (and probably represents an error in the compiler) 6319 -- Also do not bother with internal scope names. 6320 6321 declare 6322 Expec_Scope : Entity_Id; 6323 Found_Scope : Entity_Id; 6324 6325 begin 6326 Expec_Scope := Expec_Type; 6327 Found_Scope := Found_Type; 6328 6329 for Levels in Int range 0 .. 3 loop 6330 if Chars (Expec_Scope) /= Chars (Found_Scope) then 6331 Error_Msg_Qual_Level := Levels; 6332 exit; 6333 end if; 6334 6335 Expec_Scope := Scope (Expec_Scope); 6336 Found_Scope := Scope (Found_Scope); 6337 6338 exit when Expec_Scope = Standard_Standard 6339 or else 6340 Found_Scope = Standard_Standard 6341 or else 6342 not Comes_From_Source (Expec_Scope) 6343 or else 6344 not Comes_From_Source (Found_Scope); 6345 end loop; 6346 end; 6347 6348 Error_Msg_NE ("expected}!", Expr, Expec_Type); 6349 6350 if Is_Entity_Name (Expr) 6351 and then Is_Package (Entity (Expr)) 6352 then 6353 Error_Msg_N ("found package name!", Expr); 6354 6355 elsif Is_Entity_Name (Expr) 6356 and then 6357 (Ekind (Entity (Expr)) = E_Procedure 6358 or else 6359 Ekind (Entity (Expr)) = E_Generic_Procedure) 6360 then 6361 Error_Msg_N ("found procedure name instead of function!", Expr); 6362 6363 -- catch common error: a prefix or infix operator which is not 6364 -- directly visible because the type isn't. 6365 6366 elsif Nkind (Expr) in N_Op 6367 and then Is_Overloaded (Expr) 6368 and then not Is_Immediately_Visible (Expec_Type) 6369 and then not Is_Potentially_Use_Visible (Expec_Type) 6370 and then not In_Use (Expec_Type) 6371 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 6372 then 6373 Error_Msg_N ( 6374 "operator of the type is not directly visible!", Expr); 6375 6376 elsif Ekind (Found_Type) = E_Void 6377 and then Present (Parent (Found_Type)) 6378 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 6379 then 6380 Error_Msg_NE ("found premature usage of}!", Expr, Found_Type); 6381 6382 else 6383 Error_Msg_NE ("found}!", Expr, Found_Type); 6384 end if; 6385 6386 Error_Msg_Qual_Level := 0; 6387 end if; 6388 end Wrong_Type; 6389 6390end Sem_Util; 6391