1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ A T T R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; 27 28with Atree; use Atree; 29with Casing; use Casing; 30with Checks; use Checks; 31with Debug; use Debug; 32with Einfo; use Einfo; 33with Elists; use Elists; 34with Errout; use Errout; 35with Eval_Fat; 36with Exp_Dist; use Exp_Dist; 37with Exp_Util; use Exp_Util; 38with Expander; use Expander; 39with Freeze; use Freeze; 40with Gnatvsn; use Gnatvsn; 41with Itypes; use Itypes; 42with Lib; use Lib; 43with Lib.Xref; use Lib.Xref; 44with Nlists; use Nlists; 45with Nmake; use Nmake; 46with Opt; use Opt; 47with Restrict; use Restrict; 48with Rident; use Rident; 49with Rtsfind; use Rtsfind; 50with Sdefault; use Sdefault; 51with Sem; use Sem; 52with Sem_Aux; use Sem_Aux; 53with Sem_Cat; use Sem_Cat; 54with Sem_Ch6; use Sem_Ch6; 55with Sem_Ch8; use Sem_Ch8; 56with Sem_Ch10; use Sem_Ch10; 57with Sem_Dim; use Sem_Dim; 58with Sem_Dist; use Sem_Dist; 59with Sem_Elab; use Sem_Elab; 60with Sem_Elim; use Sem_Elim; 61with Sem_Eval; use Sem_Eval; 62with Sem_Res; use Sem_Res; 63with Sem_Type; use Sem_Type; 64with Sem_Util; use Sem_Util; 65with Stand; use Stand; 66with Sinfo; use Sinfo; 67with Sinput; use Sinput; 68with Stringt; use Stringt; 69with Style; 70with Stylesw; use Stylesw; 71with Targparm; use Targparm; 72with Ttypes; use Ttypes; 73with Tbuild; use Tbuild; 74with Uintp; use Uintp; 75with Urealp; use Urealp; 76 77package body Sem_Attr is 78 79 True_Value : constant Uint := Uint_1; 80 False_Value : constant Uint := Uint_0; 81 -- Synonyms to be used when these constants are used as Boolean values 82 83 Bad_Attribute : exception; 84 -- Exception raised if an error is detected during attribute processing, 85 -- used so that we can abandon the processing so we don't run into 86 -- trouble with cascaded errors. 87 88 -- The following array is the list of attributes defined in the Ada 83 RM 89 -- that are not included in Ada 95, but still get recognized in GNAT. 90 91 Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( 92 Attribute_Address | 93 Attribute_Aft | 94 Attribute_Alignment | 95 Attribute_Base | 96 Attribute_Callable | 97 Attribute_Constrained | 98 Attribute_Count | 99 Attribute_Delta | 100 Attribute_Digits | 101 Attribute_Emax | 102 Attribute_Epsilon | 103 Attribute_First | 104 Attribute_First_Bit | 105 Attribute_Fore | 106 Attribute_Image | 107 Attribute_Large | 108 Attribute_Last | 109 Attribute_Last_Bit | 110 Attribute_Leading_Part | 111 Attribute_Length | 112 Attribute_Machine_Emax | 113 Attribute_Machine_Emin | 114 Attribute_Machine_Mantissa | 115 Attribute_Machine_Overflows | 116 Attribute_Machine_Radix | 117 Attribute_Machine_Rounds | 118 Attribute_Mantissa | 119 Attribute_Pos | 120 Attribute_Position | 121 Attribute_Pred | 122 Attribute_Range | 123 Attribute_Safe_Emax | 124 Attribute_Safe_Large | 125 Attribute_Safe_Small | 126 Attribute_Size | 127 Attribute_Small | 128 Attribute_Storage_Size | 129 Attribute_Succ | 130 Attribute_Terminated | 131 Attribute_Val | 132 Attribute_Value | 133 Attribute_Width => True, 134 others => False); 135 136 -- The following array is the list of attributes defined in the Ada 2005 137 -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode, 138 -- but in Ada 95 they are considered to be implementation defined. 139 140 Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( 141 Attribute_Machine_Rounding | 142 Attribute_Mod | 143 Attribute_Priority | 144 Attribute_Stream_Size | 145 Attribute_Wide_Wide_Width => True, 146 others => False); 147 148 -- The following array contains all attributes that imply a modification 149 -- of their prefixes or result in an access value. Such prefixes can be 150 -- considered as lvalues. 151 152 Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array := 153 Attribute_Class_Array'( 154 Attribute_Access | 155 Attribute_Address | 156 Attribute_Input | 157 Attribute_Read | 158 Attribute_Unchecked_Access | 159 Attribute_Unrestricted_Access => True, 160 others => False); 161 162 ----------------------- 163 -- Local_Subprograms -- 164 ----------------------- 165 166 procedure Eval_Attribute (N : Node_Id); 167 -- Performs compile time evaluation of attributes where possible, leaving 168 -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately 169 -- set, and replacing the node with a literal node if the value can be 170 -- computed at compile time. All static attribute references are folded, 171 -- as well as a number of cases of non-static attributes that can always 172 -- be computed at compile time (e.g. floating-point model attributes that 173 -- are applied to non-static subtypes). Of course in such cases, the 174 -- Is_Static_Expression flag will not be set on the resulting literal. 175 -- Note that the only required action of this procedure is to catch the 176 -- static expression cases as described in the RM. Folding of other cases 177 -- is done where convenient, but some additional non-static folding is in 178 -- N_Expand_Attribute_Reference in cases where this is more convenient. 179 180 function Is_Anonymous_Tagged_Base 181 (Anon : Entity_Id; 182 Typ : Entity_Id) 183 return Boolean; 184 -- For derived tagged types that constrain parent discriminants we build 185 -- an anonymous unconstrained base type. We need to recognize the relation 186 -- between the two when analyzing an access attribute for a constrained 187 -- component, before the full declaration for Typ has been analyzed, and 188 -- where therefore the prefix of the attribute does not match the enclosing 189 -- scope. 190 191 ----------------------- 192 -- Analyze_Attribute -- 193 ----------------------- 194 195 procedure Analyze_Attribute (N : Node_Id) is 196 Loc : constant Source_Ptr := Sloc (N); 197 Aname : constant Name_Id := Attribute_Name (N); 198 P : constant Node_Id := Prefix (N); 199 Exprs : constant List_Id := Expressions (N); 200 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); 201 E1 : Node_Id; 202 E2 : Node_Id; 203 204 P_Type : Entity_Id; 205 -- Type of prefix after analysis 206 207 P_Base_Type : Entity_Id; 208 -- Base type of prefix after analysis 209 210 ----------------------- 211 -- Local Subprograms -- 212 ----------------------- 213 214 procedure Analyze_Access_Attribute; 215 -- Used for Access, Unchecked_Access, Unrestricted_Access attributes. 216 -- Internally, Id distinguishes which of the three cases is involved. 217 218 procedure Bad_Attribute_For_Predicate; 219 -- Output error message for use of a predicate (First, Last, Range) not 220 -- allowed with a type that has predicates. If the type is a generic 221 -- actual, then the message is a warning, and we generate code to raise 222 -- program error with an appropriate reason. No error message is given 223 -- for internally generated uses of the attributes. This legality rule 224 -- only applies to scalar types. 225 226 procedure Check_Ada_2012_Attribute; 227 -- Check that we are in Ada 2012 mode for an Ada 2012 attribute, and 228 -- issue appropriate messages if not (and return to caller even in 229 -- the error case). 230 231 procedure Check_Array_Or_Scalar_Type; 232 -- Common procedure used by First, Last, Range attribute to check 233 -- that the prefix is a constrained array or scalar type, or a name 234 -- of an array object, and that an argument appears only if appropriate 235 -- (i.e. only in the array case). 236 237 procedure Check_Array_Type; 238 -- Common semantic checks for all array attributes. Checks that the 239 -- prefix is a constrained array type or the name of an array object. 240 -- The error message for non-arrays is specialized appropriately. 241 242 procedure Check_Asm_Attribute; 243 -- Common semantic checks for Asm_Input and Asm_Output attributes 244 245 procedure Check_Component; 246 -- Common processing for Bit_Position, First_Bit, Last_Bit, and 247 -- Position. Checks prefix is an appropriate selected component. 248 249 procedure Check_Decimal_Fixed_Point_Type; 250 -- Check that prefix of attribute N is a decimal fixed-point type 251 252 procedure Check_Dereference; 253 -- If the prefix of attribute is an object of an access type, then 254 -- introduce an explicit dereference, and adjust P_Type accordingly. 255 256 procedure Check_Discrete_Type; 257 -- Verify that prefix of attribute N is a discrete type 258 259 procedure Check_E0; 260 -- Check that no attribute arguments are present 261 262 procedure Check_Either_E0_Or_E1; 263 -- Check that there are zero or one attribute arguments present 264 265 procedure Check_E1; 266 -- Check that exactly one attribute argument is present 267 268 procedure Check_E2; 269 -- Check that two attribute arguments are present 270 271 procedure Check_Enum_Image; 272 -- If the prefix type is an enumeration type, set all its literals 273 -- as referenced, since the image function could possibly end up 274 -- referencing any of the literals indirectly. Same for Enum_Val. 275 -- Set the flag only if the reference is in the main code unit. Same 276 -- restriction when resolving 'Value; otherwise an improperly set 277 -- reference when analyzing an inlined body will lose a proper warning 278 -- on a useless with_clause. 279 280 procedure Check_First_Last_Valid; 281 -- Perform all checks for First_Valid and Last_Valid attributes 282 283 procedure Check_Fixed_Point_Type; 284 -- Verify that prefix of attribute N is a fixed type 285 286 procedure Check_Fixed_Point_Type_0; 287 -- Verify that prefix of attribute N is a fixed type and that 288 -- no attribute expressions are present 289 290 procedure Check_Floating_Point_Type; 291 -- Verify that prefix of attribute N is a float type 292 293 procedure Check_Floating_Point_Type_0; 294 -- Verify that prefix of attribute N is a float type and that 295 -- no attribute expressions are present 296 297 procedure Check_Floating_Point_Type_1; 298 -- Verify that prefix of attribute N is a float type and that 299 -- exactly one attribute expression is present 300 301 procedure Check_Floating_Point_Type_2; 302 -- Verify that prefix of attribute N is a float type and that 303 -- two attribute expressions are present 304 305 procedure Legal_Formal_Attribute; 306 -- Common processing for attributes Definite and Has_Discriminants. 307 -- Checks that prefix is generic indefinite formal type. 308 309 procedure Check_SPARK_Restriction_On_Attribute; 310 -- Issue an error in formal mode because attribute N is allowed 311 312 procedure Check_Integer_Type; 313 -- Verify that prefix of attribute N is an integer type 314 315 procedure Check_Modular_Integer_Type; 316 -- Verify that prefix of attribute N is a modular integer type 317 318 procedure Check_Not_CPP_Type; 319 -- Check that P (the prefix of the attribute) is not an CPP type 320 -- for which no Ada predefined primitive is available. 321 322 procedure Check_Not_Incomplete_Type; 323 -- Check that P (the prefix of the attribute) is not an incomplete 324 -- type or a private type for which no full view has been given. 325 326 procedure Check_Object_Reference (P : Node_Id); 327 -- Check that P is an object reference 328 329 procedure Check_Program_Unit; 330 -- Verify that prefix of attribute N is a program unit 331 332 procedure Check_Real_Type; 333 -- Verify that prefix of attribute N is fixed or float type 334 335 procedure Check_Scalar_Type; 336 -- Verify that prefix of attribute N is a scalar type 337 338 procedure Check_Standard_Prefix; 339 -- Verify that prefix of attribute N is package Standard 340 341 procedure Check_Stream_Attribute (Nam : TSS_Name_Type); 342 -- Validity checking for stream attribute. Nam is the TSS name of the 343 -- corresponding possible defined attribute function (e.g. for the 344 -- Read attribute, Nam will be TSS_Stream_Read). 345 346 procedure Check_PolyORB_Attribute; 347 -- Validity checking for PolyORB/DSA attribute 348 349 procedure Check_Task_Prefix; 350 -- Verify that prefix of attribute N is a task or task type 351 352 procedure Check_Type; 353 -- Verify that the prefix of attribute N is a type 354 355 procedure Check_Unit_Name (Nod : Node_Id); 356 -- Check that Nod is of the form of a library unit name, i.e that 357 -- it is an identifier, or a selected component whose prefix is 358 -- itself of the form of a library unit name. Note that this is 359 -- quite different from Check_Program_Unit, since it only checks 360 -- the syntactic form of the name, not the semantic identity. This 361 -- is because it is used with attributes (Elab_Body, Elab_Spec, 362 -- UET_Address and Elaborated) which can refer to non-visible unit. 363 364 procedure Error_Attr (Msg : String; Error_Node : Node_Id); 365 pragma No_Return (Error_Attr); 366 procedure Error_Attr; 367 pragma No_Return (Error_Attr); 368 -- Posts error using Error_Msg_N at given node, sets type of attribute 369 -- node to Any_Type, and then raises Bad_Attribute to avoid any further 370 -- semantic processing. The message typically contains a % insertion 371 -- character which is replaced by the attribute name. The call with 372 -- no arguments is used when the caller has already generated the 373 -- required error messages. 374 375 procedure Error_Attr_P (Msg : String); 376 pragma No_Return (Error_Attr); 377 -- Like Error_Attr, but error is posted at the start of the prefix 378 379 procedure S14_Attribute; 380 -- Called for all attributes defined for formal verification to check 381 -- that the S14_Extensions flag is set. 382 383 procedure Standard_Attribute (Val : Int); 384 -- Used to process attributes whose prefix is package Standard which 385 -- yield values of type Universal_Integer. The attribute reference 386 -- node is rewritten with an integer literal of the given value. 387 388 procedure Unexpected_Argument (En : Node_Id); 389 -- Signal unexpected attribute argument (En is the argument) 390 391 procedure Validate_Non_Static_Attribute_Function_Call; 392 -- Called when processing an attribute that is a function call to a 393 -- non-static function, i.e. an attribute function that either takes 394 -- non-scalar arguments or returns a non-scalar result. Verifies that 395 -- such a call does not appear in a preelaborable context. 396 397 ------------------------------ 398 -- Analyze_Access_Attribute -- 399 ------------------------------ 400 401 procedure Analyze_Access_Attribute is 402 Acc_Type : Entity_Id; 403 404 Scop : Entity_Id; 405 Typ : Entity_Id; 406 407 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id; 408 -- Build an access-to-object type whose designated type is DT, 409 -- and whose Ekind is appropriate to the attribute type. The 410 -- type that is constructed is returned as the result. 411 412 procedure Build_Access_Subprogram_Type (P : Node_Id); 413 -- Build an access to subprogram whose designated type is the type of 414 -- the prefix. If prefix is overloaded, so is the node itself. The 415 -- result is stored in Acc_Type. 416 417 function OK_Self_Reference return Boolean; 418 -- An access reference whose prefix is a type can legally appear 419 -- within an aggregate, where it is obtained by expansion of 420 -- a defaulted aggregate. The enclosing aggregate that contains 421 -- the self-referenced is flagged so that the self-reference can 422 -- be expanded into a reference to the target object (see exp_aggr). 423 424 ------------------------------ 425 -- Build_Access_Object_Type -- 426 ------------------------------ 427 428 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is 429 Typ : constant Entity_Id := 430 New_Internal_Entity 431 (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); 432 begin 433 Set_Etype (Typ, Typ); 434 Set_Is_Itype (Typ); 435 Set_Associated_Node_For_Itype (Typ, N); 436 Set_Directly_Designated_Type (Typ, DT); 437 return Typ; 438 end Build_Access_Object_Type; 439 440 ---------------------------------- 441 -- Build_Access_Subprogram_Type -- 442 ---------------------------------- 443 444 procedure Build_Access_Subprogram_Type (P : Node_Id) is 445 Index : Interp_Index; 446 It : Interp; 447 448 procedure Check_Local_Access (E : Entity_Id); 449 -- Deal with possible access to local subprogram. If we have such 450 -- an access, we set a flag to kill all tracked values on any call 451 -- because this access value may be passed around, and any called 452 -- code might use it to access a local procedure which clobbers a 453 -- tracked value. If the scope is a loop or block, indicate that 454 -- value tracking is disabled for the enclosing subprogram. 455 456 function Get_Kind (E : Entity_Id) return Entity_Kind; 457 -- Distinguish between access to regular/protected subprograms 458 459 ------------------------ 460 -- Check_Local_Access -- 461 ------------------------ 462 463 procedure Check_Local_Access (E : Entity_Id) is 464 begin 465 if not Is_Library_Level_Entity (E) then 466 Set_Suppress_Value_Tracking_On_Call (Current_Scope); 467 Set_Suppress_Value_Tracking_On_Call 468 (Nearest_Dynamic_Scope (Current_Scope)); 469 end if; 470 end Check_Local_Access; 471 472 -------------- 473 -- Get_Kind -- 474 -------------- 475 476 function Get_Kind (E : Entity_Id) return Entity_Kind is 477 begin 478 if Convention (E) = Convention_Protected then 479 return E_Access_Protected_Subprogram_Type; 480 else 481 return E_Access_Subprogram_Type; 482 end if; 483 end Get_Kind; 484 485 -- Start of processing for Build_Access_Subprogram_Type 486 487 begin 488 -- In the case of an access to subprogram, use the name of the 489 -- subprogram itself as the designated type. Type-checking in 490 -- this case compares the signatures of the designated types. 491 492 -- Note: This fragment of the tree is temporarily malformed 493 -- because the correct tree requires an E_Subprogram_Type entity 494 -- as the designated type. In most cases this designated type is 495 -- later overridden by the semantics with the type imposed by the 496 -- context during the resolution phase. In the specific case of 497 -- the expression Address!(Prim'Unrestricted_Access), used to 498 -- initialize slots of dispatch tables, this work will be done by 499 -- the expander (see Exp_Aggr). 500 501 -- The reason to temporarily add this kind of node to the tree 502 -- instead of a proper E_Subprogram_Type itype, is the following: 503 -- in case of errors found in the source file we report better 504 -- error messages. For example, instead of generating the 505 -- following error: 506 507 -- "expected access to subprogram with profile 508 -- defined at line X" 509 510 -- we currently generate: 511 512 -- "expected access to function Z defined at line X" 513 514 Set_Etype (N, Any_Type); 515 516 if not Is_Overloaded (P) then 517 Check_Local_Access (Entity (P)); 518 519 if not Is_Intrinsic_Subprogram (Entity (P)) then 520 Acc_Type := Create_Itype (Get_Kind (Entity (P)), N); 521 Set_Is_Public (Acc_Type, False); 522 Set_Etype (Acc_Type, Acc_Type); 523 Set_Convention (Acc_Type, Convention (Entity (P))); 524 Set_Directly_Designated_Type (Acc_Type, Entity (P)); 525 Set_Etype (N, Acc_Type); 526 Freeze_Before (N, Acc_Type); 527 end if; 528 529 else 530 Get_First_Interp (P, Index, It); 531 while Present (It.Nam) loop 532 Check_Local_Access (It.Nam); 533 534 if not Is_Intrinsic_Subprogram (It.Nam) then 535 Acc_Type := Create_Itype (Get_Kind (It.Nam), N); 536 Set_Is_Public (Acc_Type, False); 537 Set_Etype (Acc_Type, Acc_Type); 538 Set_Convention (Acc_Type, Convention (It.Nam)); 539 Set_Directly_Designated_Type (Acc_Type, It.Nam); 540 Add_One_Interp (N, Acc_Type, Acc_Type); 541 Freeze_Before (N, Acc_Type); 542 end if; 543 544 Get_Next_Interp (Index, It); 545 end loop; 546 end if; 547 548 -- Cannot be applied to intrinsic. Looking at the tests above, 549 -- the only way Etype (N) can still be set to Any_Type is if 550 -- Is_Intrinsic_Subprogram was True for some referenced entity. 551 552 if Etype (N) = Any_Type then 553 Error_Attr_P ("prefix of % attribute cannot be intrinsic"); 554 end if; 555 end Build_Access_Subprogram_Type; 556 557 ---------------------- 558 -- OK_Self_Reference -- 559 ---------------------- 560 561 function OK_Self_Reference return Boolean is 562 Par : Node_Id; 563 564 begin 565 Par := Parent (N); 566 while Present (Par) 567 and then 568 (Nkind (Par) = N_Component_Association 569 or else Nkind (Par) in N_Subexpr) 570 loop 571 if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then 572 if Etype (Par) = Typ then 573 Set_Has_Self_Reference (Par); 574 return True; 575 end if; 576 end if; 577 578 Par := Parent (Par); 579 end loop; 580 581 -- No enclosing aggregate, or not a self-reference 582 583 return False; 584 end OK_Self_Reference; 585 586 -- Start of processing for Analyze_Access_Attribute 587 588 begin 589 Check_SPARK_Restriction_On_Attribute; 590 Check_E0; 591 592 if Nkind (P) = N_Character_Literal then 593 Error_Attr_P 594 ("prefix of % attribute cannot be enumeration literal"); 595 end if; 596 597 -- Case of access to subprogram 598 599 if Is_Entity_Name (P) 600 and then Is_Overloadable (Entity (P)) 601 then 602 if Has_Pragma_Inline_Always (Entity (P)) then 603 Error_Attr_P 604 ("prefix of % attribute cannot be Inline_Always subprogram"); 605 end if; 606 607 if Aname = Name_Unchecked_Access then 608 Error_Attr ("attribute% cannot be applied to a subprogram", P); 609 end if; 610 611 -- Issue an error if the prefix denotes an eliminated subprogram 612 613 Check_For_Eliminated_Subprogram (P, Entity (P)); 614 615 -- Check for obsolescent subprogram reference 616 617 Check_Obsolescent_2005_Entity (Entity (P), P); 618 619 -- Build the appropriate subprogram type 620 621 Build_Access_Subprogram_Type (P); 622 623 -- For P'Access or P'Unrestricted_Access, where P is a nested 624 -- subprogram, we might be passing P to another subprogram (but we 625 -- don't check that here), which might call P. P could modify 626 -- local variables, so we need to kill current values. It is 627 -- important not to do this for library-level subprograms, because 628 -- Kill_Current_Values is very inefficient in the case of library 629 -- level packages with lots of tagged types. 630 631 if Is_Library_Level_Entity (Entity (Prefix (N))) then 632 null; 633 634 -- Do not kill values on nodes initializing dispatch tables 635 -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access) 636 -- is currently generated by the expander only for this 637 -- purpose. Done to keep the quality of warnings currently 638 -- generated by the compiler (otherwise any declaration of 639 -- a tagged type cleans constant indications from its scope). 640 641 elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion 642 and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr) 643 or else 644 Etype (Parent (N)) = RTE (RE_Size_Ptr)) 645 and then Is_Dispatching_Operation 646 (Directly_Designated_Type (Etype (N))) 647 then 648 null; 649 650 else 651 Kill_Current_Values; 652 end if; 653 654 -- Treat as call for elaboration purposes and we are all done. 655 -- Suppress this treatment under debug flag. 656 657 if not Debug_Flag_Dot_UU then 658 Check_Elab_Call (N); 659 end if; 660 661 return; 662 663 -- Component is an operation of a protected type 664 665 elsif Nkind (P) = N_Selected_Component 666 and then Is_Overloadable (Entity (Selector_Name (P))) 667 then 668 if Ekind (Entity (Selector_Name (P))) = E_Entry then 669 Error_Attr_P ("prefix of % attribute must be subprogram"); 670 end if; 671 672 Build_Access_Subprogram_Type (Selector_Name (P)); 673 return; 674 end if; 675 676 -- Deal with incorrect reference to a type, but note that some 677 -- accesses are allowed: references to the current type instance, 678 -- or in Ada 2005 self-referential pointer in a default-initialized 679 -- aggregate. 680 681 if Is_Entity_Name (P) then 682 Typ := Entity (P); 683 684 -- The reference may appear in an aggregate that has been expanded 685 -- into a loop. Locate scope of type definition, if any. 686 687 Scop := Current_Scope; 688 while Ekind (Scop) = E_Loop loop 689 Scop := Scope (Scop); 690 end loop; 691 692 if Is_Type (Typ) then 693 694 -- OK if we are within the scope of a limited type 695 -- let's mark the component as having per object constraint 696 697 if Is_Anonymous_Tagged_Base (Scop, Typ) then 698 Typ := Scop; 699 Set_Entity (P, Typ); 700 Set_Etype (P, Typ); 701 end if; 702 703 if Typ = Scop then 704 declare 705 Q : Node_Id := Parent (N); 706 707 begin 708 while Present (Q) 709 and then Nkind (Q) /= N_Component_Declaration 710 loop 711 Q := Parent (Q); 712 end loop; 713 714 if Present (Q) then 715 Set_Has_Per_Object_Constraint 716 (Defining_Identifier (Q), True); 717 end if; 718 end; 719 720 if Nkind (P) = N_Expanded_Name then 721 Error_Msg_F 722 ("current instance prefix must be a direct name", P); 723 end if; 724 725 -- If a current instance attribute appears in a component 726 -- constraint it must appear alone; other contexts (spec- 727 -- expressions, within a task body) are not subject to this 728 -- restriction. 729 730 if not In_Spec_Expression 731 and then not Has_Completion (Scop) 732 and then not 733 Nkind_In (Parent (N), N_Discriminant_Association, 734 N_Index_Or_Discriminant_Constraint) 735 then 736 Error_Msg_N 737 ("current instance attribute must appear alone", N); 738 end if; 739 740 if Is_CPP_Class (Root_Type (Typ)) then 741 Error_Msg_N 742 ("??current instance unsupported for derivations of " 743 & "'C'P'P types", N); 744 end if; 745 746 -- OK if we are in initialization procedure for the type 747 -- in question, in which case the reference to the type 748 -- is rewritten as a reference to the current object. 749 750 elsif Ekind (Scop) = E_Procedure 751 and then Is_Init_Proc (Scop) 752 and then Etype (First_Formal (Scop)) = Typ 753 then 754 Rewrite (N, 755 Make_Attribute_Reference (Loc, 756 Prefix => Make_Identifier (Loc, Name_uInit), 757 Attribute_Name => Name_Unrestricted_Access)); 758 Analyze (N); 759 return; 760 761 -- OK if a task type, this test needs sharpening up ??? 762 763 elsif Is_Task_Type (Typ) then 764 null; 765 766 -- OK if self-reference in an aggregate in Ada 2005, and 767 -- the reference comes from a copied default expression. 768 769 -- Note that we check legality of self-reference even if the 770 -- expression comes from source, e.g. when a single component 771 -- association in an aggregate has a box association. 772 773 elsif Ada_Version >= Ada_2005 774 and then OK_Self_Reference 775 then 776 null; 777 778 -- OK if reference to current instance of a protected object 779 780 elsif Is_Protected_Self_Reference (P) then 781 null; 782 783 -- Otherwise we have an error case 784 785 else 786 Error_Attr ("% attribute cannot be applied to type", P); 787 return; 788 end if; 789 end if; 790 end if; 791 792 -- If we fall through, we have a normal access to object case. 793 -- Unrestricted_Access is legal wherever an allocator would be 794 -- legal, so its Etype is set to E_Allocator. The expected type 795 -- of the other attributes is a general access type, and therefore 796 -- we label them with E_Access_Attribute_Type. 797 798 if not Is_Overloaded (P) then 799 Acc_Type := Build_Access_Object_Type (P_Type); 800 Set_Etype (N, Acc_Type); 801 else 802 declare 803 Index : Interp_Index; 804 It : Interp; 805 begin 806 Set_Etype (N, Any_Type); 807 Get_First_Interp (P, Index, It); 808 while Present (It.Typ) loop 809 Acc_Type := Build_Access_Object_Type (It.Typ); 810 Add_One_Interp (N, Acc_Type, Acc_Type); 811 Get_Next_Interp (Index, It); 812 end loop; 813 end; 814 end if; 815 816 -- Special cases when we can find a prefix that is an entity name 817 818 declare 819 PP : Node_Id; 820 Ent : Entity_Id; 821 822 begin 823 PP := P; 824 loop 825 if Is_Entity_Name (PP) then 826 Ent := Entity (PP); 827 828 -- If we have an access to an object, and the attribute 829 -- comes from source, then set the object as potentially 830 -- source modified. We do this because the resulting access 831 -- pointer can be used to modify the variable, and we might 832 -- not detect this, leading to some junk warnings. 833 834 Set_Never_Set_In_Source (Ent, False); 835 836 -- Mark entity as address taken, and kill current values 837 838 Set_Address_Taken (Ent); 839 Kill_Current_Values (Ent); 840 exit; 841 842 elsif Nkind_In (PP, N_Selected_Component, 843 N_Indexed_Component) 844 then 845 PP := Prefix (PP); 846 847 else 848 exit; 849 end if; 850 end loop; 851 end; 852 853 -- Check for aliased view unless unrestricted case. We allow a 854 -- nonaliased prefix when within an instance because the prefix may 855 -- have been a tagged formal object, which is defined to be aliased 856 -- even when the actual might not be (other instance cases will have 857 -- been caught in the generic). Similarly, within an inlined body we 858 -- know that the attribute is legal in the original subprogram, and 859 -- therefore legal in the expansion. 860 861 if Aname /= Name_Unrestricted_Access 862 and then not Is_Aliased_View (P) 863 and then not In_Instance 864 and then not In_Inlined_Body 865 then 866 Error_Attr_P ("prefix of % attribute must be aliased"); 867 Check_No_Implicit_Aliasing (P); 868 end if; 869 end Analyze_Access_Attribute; 870 871 --------------------------------- 872 -- Bad_Attribute_For_Predicate -- 873 --------------------------------- 874 875 procedure Bad_Attribute_For_Predicate is 876 begin 877 if Is_Scalar_Type (P_Type) 878 and then Comes_From_Source (N) 879 then 880 Error_Msg_Name_1 := Aname; 881 Bad_Predicated_Subtype_Use 882 ("type& has predicates, attribute % not allowed", N, P_Type); 883 end if; 884 end Bad_Attribute_For_Predicate; 885 886 ------------------------------ 887 -- Check_Ada_2012_Attribute -- 888 ------------------------------ 889 890 procedure Check_Ada_2012_Attribute is 891 begin 892 if Ada_Version < Ada_2012 then 893 Error_Msg_Name_1 := Aname; 894 Error_Msg_N 895 ("attribute % is an Ada 2012 feature", N); 896 Error_Msg_N 897 ("\unit must be compiled with -gnat2012 switch", N); 898 end if; 899 end Check_Ada_2012_Attribute; 900 901 -------------------------------- 902 -- Check_Array_Or_Scalar_Type -- 903 -------------------------------- 904 905 procedure Check_Array_Or_Scalar_Type is 906 Index : Entity_Id; 907 908 D : Int; 909 -- Dimension number for array attributes 910 911 begin 912 -- Case of string literal or string literal subtype. These cases 913 -- cannot arise from legal Ada code, but the expander is allowed 914 -- to generate them. They require special handling because string 915 -- literal subtypes do not have standard bounds (the whole idea 916 -- of these subtypes is to avoid having to generate the bounds) 917 918 if Ekind (P_Type) = E_String_Literal_Subtype then 919 Set_Etype (N, Etype (First_Index (P_Base_Type))); 920 return; 921 922 -- Scalar types 923 924 elsif Is_Scalar_Type (P_Type) then 925 Check_Type; 926 927 if Present (E1) then 928 Error_Attr ("invalid argument in % attribute", E1); 929 else 930 Set_Etype (N, P_Base_Type); 931 return; 932 end if; 933 934 -- The following is a special test to allow 'First to apply to 935 -- private scalar types if the attribute comes from generated 936 -- code. This occurs in the case of Normalize_Scalars code. 937 938 elsif Is_Private_Type (P_Type) 939 and then Present (Full_View (P_Type)) 940 and then Is_Scalar_Type (Full_View (P_Type)) 941 and then not Comes_From_Source (N) 942 then 943 Set_Etype (N, Implementation_Base_Type (P_Type)); 944 945 -- Array types other than string literal subtypes handled above 946 947 else 948 Check_Array_Type; 949 950 -- We know prefix is an array type, or the name of an array 951 -- object, and that the expression, if present, is static 952 -- and within the range of the dimensions of the type. 953 954 pragma Assert (Is_Array_Type (P_Type)); 955 Index := First_Index (P_Base_Type); 956 957 if No (E1) then 958 959 -- First dimension assumed 960 961 Set_Etype (N, Base_Type (Etype (Index))); 962 963 else 964 D := UI_To_Int (Intval (E1)); 965 966 for J in 1 .. D - 1 loop 967 Next_Index (Index); 968 end loop; 969 970 Set_Etype (N, Base_Type (Etype (Index))); 971 Set_Etype (E1, Standard_Integer); 972 end if; 973 end if; 974 end Check_Array_Or_Scalar_Type; 975 976 ---------------------- 977 -- Check_Array_Type -- 978 ---------------------- 979 980 procedure Check_Array_Type is 981 D : Int; 982 -- Dimension number for array attributes 983 984 begin 985 -- If the type is a string literal type, then this must be generated 986 -- internally, and no further check is required on its legality. 987 988 if Ekind (P_Type) = E_String_Literal_Subtype then 989 return; 990 991 -- If the type is a composite, it is an illegal aggregate, no point 992 -- in going on. 993 994 elsif P_Type = Any_Composite then 995 raise Bad_Attribute; 996 end if; 997 998 -- Normal case of array type or subtype 999 1000 Check_Either_E0_Or_E1; 1001 Check_Dereference; 1002 1003 if Is_Array_Type (P_Type) then 1004 if not Is_Constrained (P_Type) 1005 and then Is_Entity_Name (P) 1006 and then Is_Type (Entity (P)) 1007 then 1008 -- Note: we do not call Error_Attr here, since we prefer to 1009 -- continue, using the relevant index type of the array, 1010 -- even though it is unconstrained. This gives better error 1011 -- recovery behavior. 1012 1013 Error_Msg_Name_1 := Aname; 1014 Error_Msg_F 1015 ("prefix for % attribute must be constrained array", P); 1016 end if; 1017 1018 -- The attribute reference freezes the type, and thus the 1019 -- component type, even if the attribute may not depend on the 1020 -- component. Diagnose arrays with incomplete components now. 1021 -- If the prefix is an access to array, this does not freeze 1022 -- the designated type. 1023 1024 if Nkind (P) /= N_Explicit_Dereference then 1025 Check_Fully_Declared (Component_Type (P_Type), P); 1026 end if; 1027 1028 D := Number_Dimensions (P_Type); 1029 1030 else 1031 if Is_Private_Type (P_Type) then 1032 Error_Attr_P ("prefix for % attribute may not be private type"); 1033 1034 elsif Is_Access_Type (P_Type) 1035 and then Is_Array_Type (Designated_Type (P_Type)) 1036 and then Is_Entity_Name (P) 1037 and then Is_Type (Entity (P)) 1038 then 1039 Error_Attr_P ("prefix of % attribute cannot be access type"); 1040 1041 elsif Attr_Id = Attribute_First 1042 or else 1043 Attr_Id = Attribute_Last 1044 then 1045 Error_Attr ("invalid prefix for % attribute", P); 1046 1047 else 1048 Error_Attr_P ("prefix for % attribute must be array"); 1049 end if; 1050 end if; 1051 1052 if Present (E1) then 1053 Resolve (E1, Any_Integer); 1054 Set_Etype (E1, Standard_Integer); 1055 1056 if not Is_Static_Expression (E1) 1057 or else Raises_Constraint_Error (E1) 1058 then 1059 Flag_Non_Static_Expr 1060 ("expression for dimension must be static!", E1); 1061 Error_Attr; 1062 1063 elsif UI_To_Int (Expr_Value (E1)) > D 1064 or else UI_To_Int (Expr_Value (E1)) < 1 1065 then 1066 Error_Attr ("invalid dimension number for array type", E1); 1067 end if; 1068 end if; 1069 1070 if (Style_Check and Style_Check_Array_Attribute_Index) 1071 and then Comes_From_Source (N) 1072 then 1073 Style.Check_Array_Attribute_Index (N, E1, D); 1074 end if; 1075 end Check_Array_Type; 1076 1077 ------------------------- 1078 -- Check_Asm_Attribute -- 1079 ------------------------- 1080 1081 procedure Check_Asm_Attribute is 1082 begin 1083 Check_Type; 1084 Check_E2; 1085 1086 -- Check first argument is static string expression 1087 1088 Analyze_And_Resolve (E1, Standard_String); 1089 1090 if Etype (E1) = Any_Type then 1091 return; 1092 1093 elsif not Is_OK_Static_Expression (E1) then 1094 Flag_Non_Static_Expr 1095 ("constraint argument must be static string expression!", E1); 1096 Error_Attr; 1097 end if; 1098 1099 -- Check second argument is right type 1100 1101 Analyze_And_Resolve (E2, Entity (P)); 1102 1103 -- Note: that is all we need to do, we don't need to check 1104 -- that it appears in a correct context. The Ada type system 1105 -- will do that for us. 1106 1107 end Check_Asm_Attribute; 1108 1109 --------------------- 1110 -- Check_Component -- 1111 --------------------- 1112 1113 procedure Check_Component is 1114 begin 1115 Check_E0; 1116 1117 if Nkind (P) /= N_Selected_Component 1118 or else 1119 (Ekind (Entity (Selector_Name (P))) /= E_Component 1120 and then 1121 Ekind (Entity (Selector_Name (P))) /= E_Discriminant) 1122 then 1123 Error_Attr_P ("prefix for % attribute must be selected component"); 1124 end if; 1125 end Check_Component; 1126 1127 ------------------------------------ 1128 -- Check_Decimal_Fixed_Point_Type -- 1129 ------------------------------------ 1130 1131 procedure Check_Decimal_Fixed_Point_Type is 1132 begin 1133 Check_Type; 1134 1135 if not Is_Decimal_Fixed_Point_Type (P_Type) then 1136 Error_Attr_P ("prefix of % attribute must be decimal type"); 1137 end if; 1138 end Check_Decimal_Fixed_Point_Type; 1139 1140 ----------------------- 1141 -- Check_Dereference -- 1142 ----------------------- 1143 1144 procedure Check_Dereference is 1145 begin 1146 1147 -- Case of a subtype mark 1148 1149 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then 1150 return; 1151 end if; 1152 1153 -- Case of an expression 1154 1155 Resolve (P); 1156 1157 if Is_Access_Type (P_Type) then 1158 1159 -- If there is an implicit dereference, then we must freeze the 1160 -- designated type of the access type, since the type of the 1161 -- referenced array is this type (see AI95-00106). 1162 1163 -- As done elsewhere, freezing must not happen when pre-analyzing 1164 -- a pre- or postcondition or a default value for an object or for 1165 -- a formal parameter. 1166 1167 if not In_Spec_Expression then 1168 Freeze_Before (N, Designated_Type (P_Type)); 1169 end if; 1170 1171 Rewrite (P, 1172 Make_Explicit_Dereference (Sloc (P), 1173 Prefix => Relocate_Node (P))); 1174 1175 Analyze_And_Resolve (P); 1176 P_Type := Etype (P); 1177 1178 if P_Type = Any_Type then 1179 raise Bad_Attribute; 1180 end if; 1181 1182 P_Base_Type := Base_Type (P_Type); 1183 end if; 1184 end Check_Dereference; 1185 1186 ------------------------- 1187 -- Check_Discrete_Type -- 1188 ------------------------- 1189 1190 procedure Check_Discrete_Type is 1191 begin 1192 Check_Type; 1193 1194 if not Is_Discrete_Type (P_Type) then 1195 Error_Attr_P ("prefix of % attribute must be discrete type"); 1196 end if; 1197 end Check_Discrete_Type; 1198 1199 -------------- 1200 -- Check_E0 -- 1201 -------------- 1202 1203 procedure Check_E0 is 1204 begin 1205 if Present (E1) then 1206 Unexpected_Argument (E1); 1207 end if; 1208 end Check_E0; 1209 1210 -------------- 1211 -- Check_E1 -- 1212 -------------- 1213 1214 procedure Check_E1 is 1215 begin 1216 Check_Either_E0_Or_E1; 1217 1218 if No (E1) then 1219 1220 -- Special-case attributes that are functions and that appear as 1221 -- the prefix of another attribute. Error is posted on parent. 1222 1223 if Nkind (Parent (N)) = N_Attribute_Reference 1224 and then (Attribute_Name (Parent (N)) = Name_Address 1225 or else 1226 Attribute_Name (Parent (N)) = Name_Code_Address 1227 or else 1228 Attribute_Name (Parent (N)) = Name_Access) 1229 then 1230 Error_Msg_Name_1 := Attribute_Name (Parent (N)); 1231 Error_Msg_N ("illegal prefix for % attribute", Parent (N)); 1232 Set_Etype (Parent (N), Any_Type); 1233 Set_Entity (Parent (N), Any_Type); 1234 raise Bad_Attribute; 1235 1236 else 1237 Error_Attr ("missing argument for % attribute", N); 1238 end if; 1239 end if; 1240 end Check_E1; 1241 1242 -------------- 1243 -- Check_E2 -- 1244 -------------- 1245 1246 procedure Check_E2 is 1247 begin 1248 if No (E1) then 1249 Error_Attr ("missing arguments for % attribute (2 required)", N); 1250 elsif No (E2) then 1251 Error_Attr ("missing argument for % attribute (2 required)", N); 1252 end if; 1253 end Check_E2; 1254 1255 --------------------------- 1256 -- Check_Either_E0_Or_E1 -- 1257 --------------------------- 1258 1259 procedure Check_Either_E0_Or_E1 is 1260 begin 1261 if Present (E2) then 1262 Unexpected_Argument (E2); 1263 end if; 1264 end Check_Either_E0_Or_E1; 1265 1266 ---------------------- 1267 -- Check_Enum_Image -- 1268 ---------------------- 1269 1270 procedure Check_Enum_Image is 1271 Lit : Entity_Id; 1272 1273 begin 1274 -- When an enumeration type appears in an attribute reference, all 1275 -- literals of the type are marked as referenced. This must only be 1276 -- done if the attribute reference appears in the current source. 1277 -- Otherwise the information on references may differ between a 1278 -- normal compilation and one that performs inlining. 1279 1280 if Is_Enumeration_Type (P_Base_Type) 1281 and then In_Extended_Main_Code_Unit (N) 1282 then 1283 Lit := First_Literal (P_Base_Type); 1284 while Present (Lit) loop 1285 Set_Referenced (Lit); 1286 Next_Literal (Lit); 1287 end loop; 1288 end if; 1289 end Check_Enum_Image; 1290 1291 ---------------------------- 1292 -- Check_First_Last_Valid -- 1293 ---------------------------- 1294 1295 procedure Check_First_Last_Valid is 1296 begin 1297 Check_Ada_2012_Attribute; 1298 Check_Discrete_Type; 1299 1300 -- Freeze the subtype now, so that the following test for predicates 1301 -- works (we set the predicates stuff up at freeze time) 1302 1303 Insert_Actions (N, Freeze_Entity (P_Type, P)); 1304 1305 -- Now test for dynamic predicate 1306 1307 if Has_Predicates (P_Type) 1308 and then No (Static_Predicate (P_Type)) 1309 then 1310 Error_Attr_P 1311 ("prefix of % attribute may not have dynamic predicate"); 1312 end if; 1313 1314 -- Check non-static subtype 1315 1316 if not Is_Static_Subtype (P_Type) then 1317 Error_Attr_P ("prefix of % attribute must be a static subtype"); 1318 end if; 1319 1320 -- Test case for no values 1321 1322 if Expr_Value (Type_Low_Bound (P_Type)) > 1323 Expr_Value (Type_High_Bound (P_Type)) 1324 or else (Has_Predicates (P_Type) 1325 and then Is_Empty_List (Static_Predicate (P_Type))) 1326 then 1327 Error_Attr_P 1328 ("prefix of % attribute must be subtype with " 1329 & "at least one value"); 1330 end if; 1331 end Check_First_Last_Valid; 1332 1333 ---------------------------- 1334 -- Check_Fixed_Point_Type -- 1335 ---------------------------- 1336 1337 procedure Check_Fixed_Point_Type is 1338 begin 1339 Check_Type; 1340 1341 if not Is_Fixed_Point_Type (P_Type) then 1342 Error_Attr_P ("prefix of % attribute must be fixed point type"); 1343 end if; 1344 end Check_Fixed_Point_Type; 1345 1346 ------------------------------ 1347 -- Check_Fixed_Point_Type_0 -- 1348 ------------------------------ 1349 1350 procedure Check_Fixed_Point_Type_0 is 1351 begin 1352 Check_Fixed_Point_Type; 1353 Check_E0; 1354 end Check_Fixed_Point_Type_0; 1355 1356 ------------------------------- 1357 -- Check_Floating_Point_Type -- 1358 ------------------------------- 1359 1360 procedure Check_Floating_Point_Type is 1361 begin 1362 Check_Type; 1363 1364 if not Is_Floating_Point_Type (P_Type) then 1365 Error_Attr_P ("prefix of % attribute must be float type"); 1366 end if; 1367 end Check_Floating_Point_Type; 1368 1369 --------------------------------- 1370 -- Check_Floating_Point_Type_0 -- 1371 --------------------------------- 1372 1373 procedure Check_Floating_Point_Type_0 is 1374 begin 1375 Check_Floating_Point_Type; 1376 Check_E0; 1377 end Check_Floating_Point_Type_0; 1378 1379 --------------------------------- 1380 -- Check_Floating_Point_Type_1 -- 1381 --------------------------------- 1382 1383 procedure Check_Floating_Point_Type_1 is 1384 begin 1385 Check_Floating_Point_Type; 1386 Check_E1; 1387 end Check_Floating_Point_Type_1; 1388 1389 --------------------------------- 1390 -- Check_Floating_Point_Type_2 -- 1391 --------------------------------- 1392 1393 procedure Check_Floating_Point_Type_2 is 1394 begin 1395 Check_Floating_Point_Type; 1396 Check_E2; 1397 end Check_Floating_Point_Type_2; 1398 1399 ------------------------ 1400 -- Check_Integer_Type -- 1401 ------------------------ 1402 1403 procedure Check_Integer_Type is 1404 begin 1405 Check_Type; 1406 1407 if not Is_Integer_Type (P_Type) then 1408 Error_Attr_P ("prefix of % attribute must be integer type"); 1409 end if; 1410 end Check_Integer_Type; 1411 1412 -------------------------------- 1413 -- Check_Modular_Integer_Type -- 1414 -------------------------------- 1415 1416 procedure Check_Modular_Integer_Type is 1417 begin 1418 Check_Type; 1419 1420 if not Is_Modular_Integer_Type (P_Type) then 1421 Error_Attr_P 1422 ("prefix of % attribute must be modular integer type"); 1423 end if; 1424 end Check_Modular_Integer_Type; 1425 1426 ------------------------ 1427 -- Check_Not_CPP_Type -- 1428 ------------------------ 1429 1430 procedure Check_Not_CPP_Type is 1431 begin 1432 if Is_Tagged_Type (Etype (P)) 1433 and then Convention (Etype (P)) = Convention_CPP 1434 and then Is_CPP_Class (Root_Type (Etype (P))) 1435 then 1436 Error_Attr_P 1437 ("invalid use of % attribute with 'C'P'P tagged type"); 1438 end if; 1439 end Check_Not_CPP_Type; 1440 1441 ------------------------------- 1442 -- Check_Not_Incomplete_Type -- 1443 ------------------------------- 1444 1445 procedure Check_Not_Incomplete_Type is 1446 E : Entity_Id; 1447 Typ : Entity_Id; 1448 1449 begin 1450 -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit 1451 -- dereference we have to check wrong uses of incomplete types 1452 -- (other wrong uses are checked at their freezing point). 1453 1454 -- Example 1: Limited-with 1455 1456 -- limited with Pkg; 1457 -- package P is 1458 -- type Acc is access Pkg.T; 1459 -- X : Acc; 1460 -- S : Integer := X.all'Size; -- ERROR 1461 -- end P; 1462 1463 -- Example 2: Tagged incomplete 1464 1465 -- type T is tagged; 1466 -- type Acc is access all T; 1467 -- X : Acc; 1468 -- S : constant Integer := X.all'Size; -- ERROR 1469 -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR 1470 1471 if Ada_Version >= Ada_2005 1472 and then Nkind (P) = N_Explicit_Dereference 1473 then 1474 E := P; 1475 while Nkind (E) = N_Explicit_Dereference loop 1476 E := Prefix (E); 1477 end loop; 1478 1479 Typ := Etype (E); 1480 1481 if From_With_Type (Typ) then 1482 Error_Attr_P 1483 ("prefix of % attribute cannot be an incomplete type"); 1484 1485 else 1486 if Is_Access_Type (Typ) then 1487 Typ := Directly_Designated_Type (Typ); 1488 end if; 1489 1490 if Is_Class_Wide_Type (Typ) then 1491 Typ := Root_Type (Typ); 1492 end if; 1493 1494 -- A legal use of a shadow entity occurs only when the unit 1495 -- where the non-limited view resides is imported via a regular 1496 -- with clause in the current body. Such references to shadow 1497 -- entities may occur in subprogram formals. 1498 1499 if Is_Incomplete_Type (Typ) 1500 and then From_With_Type (Typ) 1501 and then Present (Non_Limited_View (Typ)) 1502 and then Is_Legal_Shadow_Entity_In_Body (Typ) 1503 then 1504 Typ := Non_Limited_View (Typ); 1505 end if; 1506 1507 if Ekind (Typ) = E_Incomplete_Type 1508 and then No (Full_View (Typ)) 1509 then 1510 Error_Attr_P 1511 ("prefix of % attribute cannot be an incomplete type"); 1512 end if; 1513 end if; 1514 end if; 1515 1516 if not Is_Entity_Name (P) 1517 or else not Is_Type (Entity (P)) 1518 or else In_Spec_Expression 1519 then 1520 return; 1521 else 1522 Check_Fully_Declared (P_Type, P); 1523 end if; 1524 end Check_Not_Incomplete_Type; 1525 1526 ---------------------------- 1527 -- Check_Object_Reference -- 1528 ---------------------------- 1529 1530 procedure Check_Object_Reference (P : Node_Id) is 1531 Rtyp : Entity_Id; 1532 1533 begin 1534 -- If we need an object, and we have a prefix that is the name of 1535 -- a function entity, convert it into a function call. 1536 1537 if Is_Entity_Name (P) 1538 and then Ekind (Entity (P)) = E_Function 1539 then 1540 Rtyp := Etype (Entity (P)); 1541 1542 Rewrite (P, 1543 Make_Function_Call (Sloc (P), 1544 Name => Relocate_Node (P))); 1545 1546 Analyze_And_Resolve (P, Rtyp); 1547 1548 -- Otherwise we must have an object reference 1549 1550 elsif not Is_Object_Reference (P) then 1551 Error_Attr_P ("prefix of % attribute must be object"); 1552 end if; 1553 end Check_Object_Reference; 1554 1555 ---------------------------- 1556 -- Check_PolyORB_Attribute -- 1557 ---------------------------- 1558 1559 procedure Check_PolyORB_Attribute is 1560 begin 1561 Validate_Non_Static_Attribute_Function_Call; 1562 1563 Check_Type; 1564 Check_Not_CPP_Type; 1565 1566 if Get_PCS_Name /= Name_PolyORB_DSA then 1567 Error_Attr 1568 ("attribute% requires the 'Poly'O'R'B 'P'C'S", N); 1569 end if; 1570 end Check_PolyORB_Attribute; 1571 1572 ------------------------ 1573 -- Check_Program_Unit -- 1574 ------------------------ 1575 1576 procedure Check_Program_Unit is 1577 begin 1578 if Is_Entity_Name (P) then 1579 declare 1580 K : constant Entity_Kind := Ekind (Entity (P)); 1581 T : constant Entity_Id := Etype (Entity (P)); 1582 1583 begin 1584 if K in Subprogram_Kind 1585 or else K in Task_Kind 1586 or else K in Protected_Kind 1587 or else K = E_Package 1588 or else K in Generic_Unit_Kind 1589 or else (K = E_Variable 1590 and then 1591 (Is_Task_Type (T) 1592 or else 1593 Is_Protected_Type (T))) 1594 then 1595 return; 1596 end if; 1597 end; 1598 end if; 1599 1600 Error_Attr_P ("prefix of % attribute must be program unit"); 1601 end Check_Program_Unit; 1602 1603 --------------------- 1604 -- Check_Real_Type -- 1605 --------------------- 1606 1607 procedure Check_Real_Type is 1608 begin 1609 Check_Type; 1610 1611 if not Is_Real_Type (P_Type) then 1612 Error_Attr_P ("prefix of % attribute must be real type"); 1613 end if; 1614 end Check_Real_Type; 1615 1616 ----------------------- 1617 -- Check_Scalar_Type -- 1618 ----------------------- 1619 1620 procedure Check_Scalar_Type is 1621 begin 1622 Check_Type; 1623 1624 if not Is_Scalar_Type (P_Type) then 1625 Error_Attr_P ("prefix of % attribute must be scalar type"); 1626 end if; 1627 end Check_Scalar_Type; 1628 1629 ------------------------------------------ 1630 -- Check_SPARK_Restriction_On_Attribute -- 1631 ------------------------------------------ 1632 1633 procedure Check_SPARK_Restriction_On_Attribute is 1634 begin 1635 Error_Msg_Name_1 := Aname; 1636 Check_SPARK_Restriction ("attribute % is not allowed", P); 1637 end Check_SPARK_Restriction_On_Attribute; 1638 1639 --------------------------- 1640 -- Check_Standard_Prefix -- 1641 --------------------------- 1642 1643 procedure Check_Standard_Prefix is 1644 begin 1645 Check_E0; 1646 1647 if Nkind (P) /= N_Identifier 1648 or else Chars (P) /= Name_Standard 1649 then 1650 Error_Attr ("only allowed prefix for % attribute is Standard", P); 1651 end if; 1652 end Check_Standard_Prefix; 1653 1654 ---------------------------- 1655 -- Check_Stream_Attribute -- 1656 ---------------------------- 1657 1658 procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is 1659 Etyp : Entity_Id; 1660 Btyp : Entity_Id; 1661 1662 In_Shared_Var_Procs : Boolean; 1663 -- True when compiling the body of System.Shared_Storage. 1664 -- Shared_Var_Procs. For this runtime package (always compiled in 1665 -- GNAT mode), we allow stream attributes references for limited 1666 -- types for the case where shared passive objects are implemented 1667 -- using stream attributes, which is the default in GNAT's persistent 1668 -- storage implementation. 1669 1670 begin 1671 Validate_Non_Static_Attribute_Function_Call; 1672 1673 -- With the exception of 'Input, Stream attributes are procedures, 1674 -- and can only appear at the position of procedure calls. We check 1675 -- for this here, before they are rewritten, to give a more precise 1676 -- diagnostic. 1677 1678 if Nam = TSS_Stream_Input then 1679 null; 1680 1681 elsif Is_List_Member (N) 1682 and then not Nkind_In (Parent (N), N_Procedure_Call_Statement, 1683 N_Aggregate) 1684 then 1685 null; 1686 1687 else 1688 Error_Attr 1689 ("invalid context for attribute%, which is a procedure", N); 1690 end if; 1691 1692 Check_Type; 1693 Btyp := Implementation_Base_Type (P_Type); 1694 1695 -- Stream attributes not allowed on limited types unless the 1696 -- attribute reference was generated by the expander (in which 1697 -- case the underlying type will be used, as described in Sinfo), 1698 -- or the attribute was specified explicitly for the type itself 1699 -- or one of its ancestors (taking visibility rules into account if 1700 -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp 1701 -- (with no visibility restriction). 1702 1703 declare 1704 Gen_Body : constant Node_Id := Enclosing_Generic_Body (N); 1705 begin 1706 if Present (Gen_Body) then 1707 In_Shared_Var_Procs := 1708 Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs); 1709 else 1710 In_Shared_Var_Procs := False; 1711 end if; 1712 end; 1713 1714 if (Comes_From_Source (N) 1715 and then not (In_Shared_Var_Procs or In_Instance)) 1716 and then not Stream_Attribute_Available (P_Type, Nam) 1717 and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) 1718 then 1719 Error_Msg_Name_1 := Aname; 1720 1721 if Is_Limited_Type (P_Type) then 1722 Error_Msg_NE 1723 ("limited type& has no% attribute", P, P_Type); 1724 Explain_Limited_Type (P_Type, P); 1725 else 1726 Error_Msg_NE 1727 ("attribute% for type& is not available", P, P_Type); 1728 end if; 1729 end if; 1730 1731 -- Check restriction violations 1732 1733 -- First check the No_Streams restriction, which prohibits the use 1734 -- of explicit stream attributes in the source program. We do not 1735 -- prevent the occurrence of stream attributes in generated code, 1736 -- for instance those generated implicitly for dispatching purposes. 1737 1738 if Comes_From_Source (N) then 1739 Check_Restriction (No_Streams, P); 1740 end if; 1741 1742 -- AI05-0057: if restriction No_Default_Stream_Attributes is active, 1743 -- it is illegal to use a predefined elementary type stream attribute 1744 -- either by itself, or more importantly as part of the attribute 1745 -- subprogram for a composite type. 1746 1747 if Restriction_Active (No_Default_Stream_Attributes) then 1748 declare 1749 T : Entity_Id; 1750 1751 begin 1752 if Nam = TSS_Stream_Input 1753 or else 1754 Nam = TSS_Stream_Read 1755 then 1756 T := 1757 Type_Without_Stream_Operation (P_Type, TSS_Stream_Read); 1758 else 1759 T := 1760 Type_Without_Stream_Operation (P_Type, TSS_Stream_Write); 1761 end if; 1762 1763 if Present (T) then 1764 Check_Restriction (No_Default_Stream_Attributes, N); 1765 1766 Error_Msg_NE 1767 ("missing user-defined Stream Read or Write for type&", 1768 N, T); 1769 if not Is_Elementary_Type (P_Type) then 1770 Error_Msg_NE 1771 ("\which is a component of type&", N, P_Type); 1772 end if; 1773 end if; 1774 end; 1775 end if; 1776 1777 -- Check special case of Exception_Id and Exception_Occurrence which 1778 -- are not allowed for restriction No_Exception_Registration. 1779 1780 if Restriction_Check_Required (No_Exception_Registration) 1781 and then (Is_RTE (P_Type, RE_Exception_Id) 1782 or else 1783 Is_RTE (P_Type, RE_Exception_Occurrence)) 1784 then 1785 Check_Restriction (No_Exception_Registration, P); 1786 end if; 1787 1788 -- Here we must check that the first argument is an access type 1789 -- that is compatible with Ada.Streams.Root_Stream_Type'Class. 1790 1791 Analyze_And_Resolve (E1); 1792 Etyp := Etype (E1); 1793 1794 -- Note: the double call to Root_Type here is needed because the 1795 -- root type of a class-wide type is the corresponding type (e.g. 1796 -- X for X'Class, and we really want to go to the root.) 1797 1798 if not Is_Access_Type (Etyp) 1799 or else Root_Type (Root_Type (Designated_Type (Etyp))) /= 1800 RTE (RE_Root_Stream_Type) 1801 then 1802 Error_Attr 1803 ("expected access to Ada.Streams.Root_Stream_Type''Class", E1); 1804 end if; 1805 1806 -- Check that the second argument is of the right type if there is 1807 -- one (the Input attribute has only one argument so this is skipped) 1808 1809 if Present (E2) then 1810 Analyze (E2); 1811 1812 if Nam = TSS_Stream_Read 1813 and then not Is_OK_Variable_For_Out_Formal (E2) 1814 then 1815 Error_Attr 1816 ("second argument of % attribute must be a variable", E2); 1817 end if; 1818 1819 Resolve (E2, P_Type); 1820 end if; 1821 1822 Check_Not_CPP_Type; 1823 end Check_Stream_Attribute; 1824 1825 ----------------------- 1826 -- Check_Task_Prefix -- 1827 ----------------------- 1828 1829 procedure Check_Task_Prefix is 1830 begin 1831 Analyze (P); 1832 1833 -- Ada 2005 (AI-345): Attribute 'Terminated can be applied to 1834 -- task interface class-wide types. 1835 1836 if Is_Task_Type (Etype (P)) 1837 or else (Is_Access_Type (Etype (P)) 1838 and then Is_Task_Type (Designated_Type (Etype (P)))) 1839 or else (Ada_Version >= Ada_2005 1840 and then Ekind (Etype (P)) = E_Class_Wide_Type 1841 and then Is_Interface (Etype (P)) 1842 and then Is_Task_Interface (Etype (P))) 1843 then 1844 Resolve (P); 1845 1846 else 1847 if Ada_Version >= Ada_2005 then 1848 Error_Attr_P 1849 ("prefix of % attribute must be a task or a task " & 1850 "interface class-wide object"); 1851 1852 else 1853 Error_Attr_P ("prefix of % attribute must be a task"); 1854 end if; 1855 end if; 1856 end Check_Task_Prefix; 1857 1858 ---------------- 1859 -- Check_Type -- 1860 ---------------- 1861 1862 -- The possibilities are an entity name denoting a type, or an 1863 -- attribute reference that denotes a type (Base or Class). If 1864 -- the type is incomplete, replace it with its full view. 1865 1866 procedure Check_Type is 1867 begin 1868 if not Is_Entity_Name (P) 1869 or else not Is_Type (Entity (P)) 1870 then 1871 Error_Attr_P ("prefix of % attribute must be a type"); 1872 1873 elsif Is_Protected_Self_Reference (P) then 1874 Error_Attr_P 1875 ("prefix of % attribute denotes current instance " 1876 & "(RM 9.4(21/2))"); 1877 1878 elsif Ekind (Entity (P)) = E_Incomplete_Type 1879 and then Present (Full_View (Entity (P))) 1880 then 1881 P_Type := Full_View (Entity (P)); 1882 Set_Entity (P, P_Type); 1883 end if; 1884 end Check_Type; 1885 1886 --------------------- 1887 -- Check_Unit_Name -- 1888 --------------------- 1889 1890 procedure Check_Unit_Name (Nod : Node_Id) is 1891 begin 1892 if Nkind (Nod) = N_Identifier then 1893 return; 1894 1895 elsif Nkind_In (Nod, N_Selected_Component, N_Expanded_Name) then 1896 Check_Unit_Name (Prefix (Nod)); 1897 1898 if Nkind (Selector_Name (Nod)) = N_Identifier then 1899 return; 1900 end if; 1901 end if; 1902 1903 Error_Attr ("argument for % attribute must be unit name", P); 1904 end Check_Unit_Name; 1905 1906 ---------------- 1907 -- Error_Attr -- 1908 ---------------- 1909 1910 procedure Error_Attr is 1911 begin 1912 Set_Etype (N, Any_Type); 1913 Set_Entity (N, Any_Type); 1914 raise Bad_Attribute; 1915 end Error_Attr; 1916 1917 procedure Error_Attr (Msg : String; Error_Node : Node_Id) is 1918 begin 1919 Error_Msg_Name_1 := Aname; 1920 Error_Msg_N (Msg, Error_Node); 1921 Error_Attr; 1922 end Error_Attr; 1923 1924 ------------------ 1925 -- Error_Attr_P -- 1926 ------------------ 1927 1928 procedure Error_Attr_P (Msg : String) is 1929 begin 1930 Error_Msg_Name_1 := Aname; 1931 Error_Msg_F (Msg, P); 1932 Error_Attr; 1933 end Error_Attr_P; 1934 1935 ---------------------------- 1936 -- Legal_Formal_Attribute -- 1937 ---------------------------- 1938 1939 procedure Legal_Formal_Attribute is 1940 begin 1941 Check_E0; 1942 1943 if not Is_Entity_Name (P) 1944 or else not Is_Type (Entity (P)) 1945 then 1946 Error_Attr_P ("prefix of % attribute must be generic type"); 1947 1948 elsif Is_Generic_Actual_Type (Entity (P)) 1949 or else In_Instance 1950 or else In_Inlined_Body 1951 then 1952 null; 1953 1954 elsif Is_Generic_Type (Entity (P)) then 1955 if not Is_Indefinite_Subtype (Entity (P)) then 1956 Error_Attr_P 1957 ("prefix of % attribute must be indefinite generic type"); 1958 end if; 1959 1960 else 1961 Error_Attr_P 1962 ("prefix of % attribute must be indefinite generic type"); 1963 end if; 1964 1965 Set_Etype (N, Standard_Boolean); 1966 end Legal_Formal_Attribute; 1967 1968 ------------------- 1969 -- S14_Attribute -- 1970 ------------------- 1971 1972 procedure S14_Attribute is 1973 begin 1974 if not Formal_Extensions then 1975 Error_Attr 1976 ("attribute % requires the use of debug switch -gnatd.V", N); 1977 end if; 1978 end S14_Attribute; 1979 1980 ------------------------ 1981 -- Standard_Attribute -- 1982 ------------------------ 1983 1984 procedure Standard_Attribute (Val : Int) is 1985 begin 1986 Check_Standard_Prefix; 1987 Rewrite (N, Make_Integer_Literal (Loc, Val)); 1988 Analyze (N); 1989 end Standard_Attribute; 1990 1991 ------------------------- 1992 -- Unexpected Argument -- 1993 ------------------------- 1994 1995 procedure Unexpected_Argument (En : Node_Id) is 1996 begin 1997 Error_Attr ("unexpected argument for % attribute", En); 1998 end Unexpected_Argument; 1999 2000 ------------------------------------------------- 2001 -- Validate_Non_Static_Attribute_Function_Call -- 2002 ------------------------------------------------- 2003 2004 -- This function should be moved to Sem_Dist ??? 2005 2006 procedure Validate_Non_Static_Attribute_Function_Call is 2007 begin 2008 if In_Preelaborated_Unit 2009 and then not In_Subprogram_Or_Concurrent_Unit 2010 then 2011 Flag_Non_Static_Expr 2012 ("non-static function call in preelaborated unit!", N); 2013 end if; 2014 end Validate_Non_Static_Attribute_Function_Call; 2015 2016 -- Start of processing for Analyze_Attribute 2017 2018 begin 2019 -- Immediate return if unrecognized attribute (already diagnosed 2020 -- by parser, so there is nothing more that we need to do) 2021 2022 if not Is_Attribute_Name (Aname) then 2023 raise Bad_Attribute; 2024 end if; 2025 2026 -- Deal with Ada 83 issues 2027 2028 if Comes_From_Source (N) then 2029 if not Attribute_83 (Attr_Id) then 2030 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 2031 Error_Msg_Name_1 := Aname; 2032 Error_Msg_N ("(Ada 83) attribute% is not standard??", N); 2033 end if; 2034 2035 if Attribute_Impl_Def (Attr_Id) then 2036 Check_Restriction (No_Implementation_Attributes, N); 2037 end if; 2038 end if; 2039 end if; 2040 2041 -- Deal with Ada 2005 attributes that are 2042 2043 if Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005 then 2044 Check_Restriction (No_Implementation_Attributes, N); 2045 end if; 2046 2047 -- Remote access to subprogram type access attribute reference needs 2048 -- unanalyzed copy for tree transformation. The analyzed copy is used 2049 -- for its semantic information (whether prefix is a remote subprogram 2050 -- name), the unanalyzed copy is used to construct new subtree rooted 2051 -- with N_Aggregate which represents a fat pointer aggregate. 2052 2053 if Aname = Name_Access then 2054 Discard_Node (Copy_Separate_Tree (N)); 2055 end if; 2056 2057 -- Analyze prefix and exit if error in analysis. If the prefix is an 2058 -- incomplete type, use full view if available. Note that there are 2059 -- some attributes for which we do not analyze the prefix, since the 2060 -- prefix is not a normal name, or else needs special handling. 2061 2062 if Aname /= Name_Elab_Body 2063 and then 2064 Aname /= Name_Elab_Spec 2065 and then 2066 Aname /= Name_Elab_Subp_Body 2067 and then 2068 Aname /= Name_UET_Address 2069 and then 2070 Aname /= Name_Enabled 2071 and then 2072 Aname /= Name_Old 2073 then 2074 Analyze (P); 2075 P_Type := Etype (P); 2076 2077 if Is_Entity_Name (P) 2078 and then Present (Entity (P)) 2079 and then Is_Type (Entity (P)) 2080 then 2081 if Ekind (Entity (P)) = E_Incomplete_Type then 2082 P_Type := Get_Full_View (P_Type); 2083 Set_Entity (P, P_Type); 2084 Set_Etype (P, P_Type); 2085 2086 elsif Entity (P) = Current_Scope 2087 and then Is_Record_Type (Entity (P)) 2088 then 2089 -- Use of current instance within the type. Verify that if the 2090 -- attribute appears within a constraint, it yields an access 2091 -- type, other uses are illegal. 2092 2093 declare 2094 Par : Node_Id; 2095 2096 begin 2097 Par := Parent (N); 2098 while Present (Par) 2099 and then Nkind (Parent (Par)) /= N_Component_Definition 2100 loop 2101 Par := Parent (Par); 2102 end loop; 2103 2104 if Present (Par) 2105 and then Nkind (Par) = N_Subtype_Indication 2106 then 2107 if Attr_Id /= Attribute_Access 2108 and then Attr_Id /= Attribute_Unchecked_Access 2109 and then Attr_Id /= Attribute_Unrestricted_Access 2110 then 2111 Error_Msg_N 2112 ("in a constraint the current instance can only" 2113 & " be used with an access attribute", N); 2114 end if; 2115 end if; 2116 end; 2117 end if; 2118 end if; 2119 2120 if P_Type = Any_Type then 2121 raise Bad_Attribute; 2122 end if; 2123 2124 P_Base_Type := Base_Type (P_Type); 2125 end if; 2126 2127 -- Analyze expressions that may be present, exiting if an error occurs 2128 2129 if No (Exprs) then 2130 E1 := Empty; 2131 E2 := Empty; 2132 2133 -- Do not analyze the expressions of attribute Loop_Entry. Depending on 2134 -- the number of arguments and/or the nature of the first argument, the 2135 -- whole attribute reference may be rewritten into an indexed component. 2136 -- In the case of two or more arguments, the expressions are analyzed 2137 -- when the indexed component is analyzed, otherwise the sole argument 2138 -- is preanalyzed to determine whether it is a loop name. 2139 2140 elsif Aname = Name_Loop_Entry then 2141 E1 := First (Exprs); 2142 2143 if Present (E1) then 2144 E2 := Next (E1); 2145 end if; 2146 2147 else 2148 E1 := First (Exprs); 2149 Analyze (E1); 2150 2151 -- Check for missing/bad expression (result of previous error) 2152 2153 if No (E1) or else Etype (E1) = Any_Type then 2154 raise Bad_Attribute; 2155 end if; 2156 2157 E2 := Next (E1); 2158 2159 if Present (E2) then 2160 Analyze (E2); 2161 2162 if Etype (E2) = Any_Type then 2163 raise Bad_Attribute; 2164 end if; 2165 2166 if Present (Next (E2)) then 2167 Unexpected_Argument (Next (E2)); 2168 end if; 2169 end if; 2170 end if; 2171 2172 -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current 2173 -- output compiling in Ada 95 mode for the case of ambiguous prefixes. 2174 2175 if Ada_Version < Ada_2005 2176 and then Is_Overloaded (P) 2177 and then Aname /= Name_Access 2178 and then Aname /= Name_Address 2179 and then Aname /= Name_Code_Address 2180 and then Aname /= Name_Count 2181 and then Aname /= Name_Result 2182 and then Aname /= Name_Unchecked_Access 2183 then 2184 Error_Attr ("ambiguous prefix for % attribute", P); 2185 2186 elsif Ada_Version >= Ada_2005 2187 and then Is_Overloaded (P) 2188 and then Aname /= Name_Access 2189 and then Aname /= Name_Address 2190 and then Aname /= Name_Code_Address 2191 and then Aname /= Name_Result 2192 and then Aname /= Name_Unchecked_Access 2193 then 2194 -- Ada 2005 (AI-345): Since protected and task types have primitive 2195 -- entry wrappers, the attributes Count, Caller and AST_Entry require 2196 -- a context check 2197 2198 if Ada_Version >= Ada_2005 2199 and then (Aname = Name_Count 2200 or else Aname = Name_Caller 2201 or else Aname = Name_AST_Entry) 2202 then 2203 declare 2204 Count : Natural := 0; 2205 I : Interp_Index; 2206 It : Interp; 2207 2208 begin 2209 Get_First_Interp (P, I, It); 2210 while Present (It.Nam) loop 2211 if Comes_From_Source (It.Nam) then 2212 Count := Count + 1; 2213 else 2214 Remove_Interp (I); 2215 end if; 2216 2217 Get_Next_Interp (I, It); 2218 end loop; 2219 2220 if Count > 1 then 2221 Error_Attr ("ambiguous prefix for % attribute", P); 2222 else 2223 Set_Is_Overloaded (P, False); 2224 end if; 2225 end; 2226 2227 else 2228 Error_Attr ("ambiguous prefix for % attribute", P); 2229 end if; 2230 end if; 2231 2232 -- In SPARK, attributes of private types are only allowed if the full 2233 -- type declaration is visible. 2234 2235 if Is_Entity_Name (P) 2236 and then Present (Entity (P)) -- needed in some cases 2237 and then Is_Type (Entity (P)) 2238 and then Is_Private_Type (P_Type) 2239 and then not In_Open_Scopes (Scope (P_Type)) 2240 and then not In_Spec_Expression 2241 then 2242 Check_SPARK_Restriction ("invisible attribute of type", N); 2243 end if; 2244 2245 -- Remaining processing depends on attribute 2246 2247 case Attr_Id is 2248 2249 -- Attributes related to Ada 2012 iterators. Attribute specifications 2250 -- exist for these, but they cannot be queried. 2251 2252 when Attribute_Constant_Indexing | 2253 Attribute_Default_Iterator | 2254 Attribute_Implicit_Dereference | 2255 Attribute_Iterator_Element | 2256 Attribute_Variable_Indexing => 2257 Error_Msg_N ("illegal attribute", N); 2258 2259 -- Internal attributes used to deal with Ada 2012 delayed aspects. These 2260 -- were already rejected by the parser. Thus they shouldn't appear here. 2261 2262 when Internal_Attribute_Id => 2263 raise Program_Error; 2264 2265 ------------------ 2266 -- Abort_Signal -- 2267 ------------------ 2268 2269 when Attribute_Abort_Signal => 2270 Check_Standard_Prefix; 2271 Rewrite (N, New_Reference_To (Stand.Abort_Signal, Loc)); 2272 Analyze (N); 2273 2274 ------------ 2275 -- Access -- 2276 ------------ 2277 2278 when Attribute_Access => 2279 Analyze_Access_Attribute; 2280 2281 ------------- 2282 -- Address -- 2283 ------------- 2284 2285 when Attribute_Address => 2286 Check_E0; 2287 2288 -- Check for some junk cases, where we have to allow the address 2289 -- attribute but it does not make much sense, so at least for now 2290 -- just replace with Null_Address. 2291 2292 -- We also do this if the prefix is a reference to the AST_Entry 2293 -- attribute. If expansion is active, the attribute will be 2294 -- replaced by a function call, and address will work fine and 2295 -- get the proper value, but if expansion is not active, then 2296 -- the check here allows proper semantic analysis of the reference. 2297 2298 -- An Address attribute created by expansion is legal even when it 2299 -- applies to other entity-denoting expressions. 2300 2301 if Is_Protected_Self_Reference (P) then 2302 2303 -- Address attribute on a protected object self reference is legal 2304 2305 null; 2306 2307 elsif Is_Entity_Name (P) then 2308 declare 2309 Ent : constant Entity_Id := Entity (P); 2310 2311 begin 2312 if Is_Subprogram (Ent) then 2313 Set_Address_Taken (Ent); 2314 Kill_Current_Values (Ent); 2315 2316 -- An Address attribute is accepted when generated by the 2317 -- compiler for dispatching operation, and an error is 2318 -- issued once the subprogram is frozen (to avoid confusing 2319 -- errors about implicit uses of Address in the dispatch 2320 -- table initialization). 2321 2322 if Has_Pragma_Inline_Always (Entity (P)) 2323 and then Comes_From_Source (P) 2324 then 2325 Error_Attr_P 2326 ("prefix of % attribute cannot be Inline_Always" & 2327 " subprogram"); 2328 2329 -- It is illegal to apply 'Address to an intrinsic 2330 -- subprogram. This is now formalized in AI05-0095. 2331 -- In an instance, an attempt to obtain 'Address of an 2332 -- intrinsic subprogram (e.g the renaming of a predefined 2333 -- operator that is an actual) raises Program_Error. 2334 2335 elsif Convention (Ent) = Convention_Intrinsic then 2336 if In_Instance then 2337 Rewrite (N, 2338 Make_Raise_Program_Error (Loc, 2339 Reason => PE_Address_Of_Intrinsic)); 2340 2341 else 2342 Error_Msg_N 2343 ("cannot take Address of intrinsic subprogram", N); 2344 end if; 2345 2346 -- Issue an error if prefix denotes an eliminated subprogram 2347 2348 else 2349 Check_For_Eliminated_Subprogram (P, Ent); 2350 end if; 2351 2352 elsif Is_Object (Ent) 2353 or else Ekind (Ent) = E_Label 2354 then 2355 Set_Address_Taken (Ent); 2356 2357 -- Deal with No_Implicit_Aliasing restriction 2358 2359 if Restriction_Check_Required (No_Implicit_Aliasing) then 2360 if not Is_Aliased_View (P) then 2361 Check_Restriction (No_Implicit_Aliasing, P); 2362 else 2363 Check_No_Implicit_Aliasing (P); 2364 end if; 2365 end if; 2366 2367 -- If we have an address of an object, and the attribute 2368 -- comes from source, then set the object as potentially 2369 -- source modified. We do this because the resulting address 2370 -- can potentially be used to modify the variable and we 2371 -- might not detect this, leading to some junk warnings. 2372 2373 Set_Never_Set_In_Source (Ent, False); 2374 2375 elsif (Is_Concurrent_Type (Etype (Ent)) 2376 and then Etype (Ent) = Base_Type (Ent)) 2377 or else Ekind (Ent) = E_Package 2378 or else Is_Generic_Unit (Ent) 2379 then 2380 Rewrite (N, 2381 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 2382 2383 else 2384 Error_Attr ("invalid prefix for % attribute", P); 2385 end if; 2386 end; 2387 2388 elsif Nkind (P) = N_Attribute_Reference 2389 and then Attribute_Name (P) = Name_AST_Entry 2390 then 2391 Rewrite (N, 2392 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 2393 2394 elsif Is_Object_Reference (P) then 2395 null; 2396 2397 elsif Nkind (P) = N_Selected_Component 2398 and then Is_Subprogram (Entity (Selector_Name (P))) 2399 then 2400 null; 2401 2402 -- What exactly are we allowing here ??? and is this properly 2403 -- documented in the sinfo documentation for this node ??? 2404 2405 elsif not Comes_From_Source (N) then 2406 null; 2407 2408 else 2409 Error_Attr ("invalid prefix for % attribute", P); 2410 end if; 2411 2412 Set_Etype (N, RTE (RE_Address)); 2413 2414 ------------------ 2415 -- Address_Size -- 2416 ------------------ 2417 2418 when Attribute_Address_Size => 2419 Standard_Attribute (System_Address_Size); 2420 2421 -------------- 2422 -- Adjacent -- 2423 -------------- 2424 2425 when Attribute_Adjacent => 2426 Check_Floating_Point_Type_2; 2427 Set_Etype (N, P_Base_Type); 2428 Resolve (E1, P_Base_Type); 2429 Resolve (E2, P_Base_Type); 2430 2431 --------- 2432 -- Aft -- 2433 --------- 2434 2435 when Attribute_Aft => 2436 Check_Fixed_Point_Type_0; 2437 Set_Etype (N, Universal_Integer); 2438 2439 --------------- 2440 -- Alignment -- 2441 --------------- 2442 2443 when Attribute_Alignment => 2444 2445 -- Don't we need more checking here, cf Size ??? 2446 2447 Check_E0; 2448 Check_Not_Incomplete_Type; 2449 Check_Not_CPP_Type; 2450 Set_Etype (N, Universal_Integer); 2451 2452 --------------- 2453 -- Asm_Input -- 2454 --------------- 2455 2456 when Attribute_Asm_Input => 2457 Check_Asm_Attribute; 2458 2459 -- The back-end may need to take the address of E2 2460 2461 if Is_Entity_Name (E2) then 2462 Set_Address_Taken (Entity (E2)); 2463 end if; 2464 2465 Set_Etype (N, RTE (RE_Asm_Input_Operand)); 2466 2467 ---------------- 2468 -- Asm_Output -- 2469 ---------------- 2470 2471 when Attribute_Asm_Output => 2472 Check_Asm_Attribute; 2473 2474 if Etype (E2) = Any_Type then 2475 return; 2476 2477 elsif Aname = Name_Asm_Output then 2478 if not Is_Variable (E2) then 2479 Error_Attr 2480 ("second argument for Asm_Output is not variable", E2); 2481 end if; 2482 end if; 2483 2484 Note_Possible_Modification (E2, Sure => True); 2485 2486 -- The back-end may need to take the address of E2 2487 2488 if Is_Entity_Name (E2) then 2489 Set_Address_Taken (Entity (E2)); 2490 end if; 2491 2492 Set_Etype (N, RTE (RE_Asm_Output_Operand)); 2493 2494 --------------- 2495 -- AST_Entry -- 2496 --------------- 2497 2498 when Attribute_AST_Entry => AST_Entry : declare 2499 Ent : Entity_Id; 2500 Pref : Node_Id; 2501 Ptyp : Entity_Id; 2502 2503 Indexed : Boolean; 2504 -- Indicates if entry family index is present. Note the coding 2505 -- here handles the entry family case, but in fact it cannot be 2506 -- executed currently, because pragma AST_Entry does not permit 2507 -- the specification of an entry family. 2508 2509 procedure Bad_AST_Entry; 2510 -- Signal a bad AST_Entry pragma 2511 2512 function OK_Entry (E : Entity_Id) return Boolean; 2513 -- Checks that E is of an appropriate entity kind for an entry 2514 -- (i.e. E_Entry if Index is False, or E_Entry_Family if Index 2515 -- is set True for the entry family case). In the True case, 2516 -- makes sure that Is_AST_Entry is set on the entry. 2517 2518 ------------------- 2519 -- Bad_AST_Entry -- 2520 ------------------- 2521 2522 procedure Bad_AST_Entry is 2523 begin 2524 Error_Attr_P ("prefix for % attribute must be task entry"); 2525 end Bad_AST_Entry; 2526 2527 -------------- 2528 -- OK_Entry -- 2529 -------------- 2530 2531 function OK_Entry (E : Entity_Id) return Boolean is 2532 Result : Boolean; 2533 2534 begin 2535 if Indexed then 2536 Result := (Ekind (E) = E_Entry_Family); 2537 else 2538 Result := (Ekind (E) = E_Entry); 2539 end if; 2540 2541 if Result then 2542 if not Is_AST_Entry (E) then 2543 Error_Msg_Name_2 := Aname; 2544 Error_Attr ("% attribute requires previous % pragma", P); 2545 end if; 2546 end if; 2547 2548 return Result; 2549 end OK_Entry; 2550 2551 -- Start of processing for AST_Entry 2552 2553 begin 2554 Check_VMS (N); 2555 Check_E0; 2556 2557 -- Deal with entry family case 2558 2559 if Nkind (P) = N_Indexed_Component then 2560 Pref := Prefix (P); 2561 Indexed := True; 2562 else 2563 Pref := P; 2564 Indexed := False; 2565 end if; 2566 2567 Ptyp := Etype (Pref); 2568 2569 if Ptyp = Any_Type or else Error_Posted (Pref) then 2570 return; 2571 end if; 2572 2573 -- If the prefix is a selected component whose prefix is of an 2574 -- access type, then introduce an explicit dereference. 2575 -- ??? Could we reuse Check_Dereference here? 2576 2577 if Nkind (Pref) = N_Selected_Component 2578 and then Is_Access_Type (Ptyp) 2579 then 2580 Rewrite (Pref, 2581 Make_Explicit_Dereference (Sloc (Pref), 2582 Relocate_Node (Pref))); 2583 Analyze_And_Resolve (Pref, Designated_Type (Ptyp)); 2584 end if; 2585 2586 -- Prefix can be of the form a.b, where a is a task object 2587 -- and b is one of the entries of the corresponding task type. 2588 2589 if Nkind (Pref) = N_Selected_Component 2590 and then OK_Entry (Entity (Selector_Name (Pref))) 2591 and then Is_Object_Reference (Prefix (Pref)) 2592 and then Is_Task_Type (Etype (Prefix (Pref))) 2593 then 2594 null; 2595 2596 -- Otherwise the prefix must be an entry of a containing task, 2597 -- or of a variable of the enclosing task type. 2598 2599 else 2600 if Nkind_In (Pref, N_Identifier, N_Expanded_Name) then 2601 Ent := Entity (Pref); 2602 2603 if not OK_Entry (Ent) 2604 or else not In_Open_Scopes (Scope (Ent)) 2605 then 2606 Bad_AST_Entry; 2607 end if; 2608 2609 else 2610 Bad_AST_Entry; 2611 end if; 2612 end if; 2613 2614 Set_Etype (N, RTE (RE_AST_Handler)); 2615 end AST_Entry; 2616 2617 ----------------------------- 2618 -- Atomic_Always_Lock_Free -- 2619 ----------------------------- 2620 2621 when Attribute_Atomic_Always_Lock_Free => 2622 Check_E0; 2623 Check_Type; 2624 Set_Etype (N, Standard_Boolean); 2625 2626 ---------- 2627 -- Base -- 2628 ---------- 2629 2630 -- Note: when the base attribute appears in the context of a subtype 2631 -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by 2632 -- the following circuit. 2633 2634 when Attribute_Base => Base : declare 2635 Typ : Entity_Id; 2636 2637 begin 2638 Check_E0; 2639 Find_Type (P); 2640 Typ := Entity (P); 2641 2642 if Ada_Version >= Ada_95 2643 and then not Is_Scalar_Type (Typ) 2644 and then not Is_Generic_Type (Typ) 2645 then 2646 Error_Attr_P ("prefix of Base attribute must be scalar type"); 2647 2648 elsif Sloc (Typ) = Standard_Location 2649 and then Base_Type (Typ) = Typ 2650 and then Warn_On_Redundant_Constructs 2651 then 2652 Error_Msg_NE -- CODEFIX 2653 ("?r?redundant attribute, & is its own base type", N, Typ); 2654 end if; 2655 2656 if Nkind (Parent (N)) /= N_Attribute_Reference then 2657 Error_Msg_Name_1 := Aname; 2658 Check_SPARK_Restriction 2659 ("attribute% is only allowed as prefix of another attribute", P); 2660 end if; 2661 2662 Set_Etype (N, Base_Type (Entity (P))); 2663 Set_Entity (N, Base_Type (Entity (P))); 2664 Rewrite (N, New_Reference_To (Entity (N), Loc)); 2665 Analyze (N); 2666 end Base; 2667 2668 --------- 2669 -- Bit -- 2670 --------- 2671 2672 when Attribute_Bit => Bit : 2673 begin 2674 Check_E0; 2675 2676 if not Is_Object_Reference (P) then 2677 Error_Attr_P ("prefix for % attribute must be object"); 2678 2679 -- What about the access object cases ??? 2680 2681 else 2682 null; 2683 end if; 2684 2685 Set_Etype (N, Universal_Integer); 2686 end Bit; 2687 2688 --------------- 2689 -- Bit_Order -- 2690 --------------- 2691 2692 when Attribute_Bit_Order => Bit_Order : 2693 begin 2694 Check_E0; 2695 Check_Type; 2696 2697 if not Is_Record_Type (P_Type) then 2698 Error_Attr_P ("prefix of % attribute must be record type"); 2699 end if; 2700 2701 if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then 2702 Rewrite (N, 2703 New_Occurrence_Of (RTE (RE_High_Order_First), Loc)); 2704 else 2705 Rewrite (N, 2706 New_Occurrence_Of (RTE (RE_Low_Order_First), Loc)); 2707 end if; 2708 2709 Set_Etype (N, RTE (RE_Bit_Order)); 2710 Resolve (N); 2711 2712 -- Reset incorrect indication of staticness 2713 2714 Set_Is_Static_Expression (N, False); 2715 end Bit_Order; 2716 2717 ------------------ 2718 -- Bit_Position -- 2719 ------------------ 2720 2721 -- Note: in generated code, we can have a Bit_Position attribute 2722 -- applied to a (naked) record component (i.e. the prefix is an 2723 -- identifier that references an E_Component or E_Discriminant 2724 -- entity directly, and this is interpreted as expected by Gigi. 2725 -- The following code will not tolerate such usage, but when the 2726 -- expander creates this special case, it marks it as analyzed 2727 -- immediately and sets an appropriate type. 2728 2729 when Attribute_Bit_Position => 2730 if Comes_From_Source (N) then 2731 Check_Component; 2732 end if; 2733 2734 Set_Etype (N, Universal_Integer); 2735 2736 ------------------ 2737 -- Body_Version -- 2738 ------------------ 2739 2740 when Attribute_Body_Version => 2741 Check_E0; 2742 Check_Program_Unit; 2743 Set_Etype (N, RTE (RE_Version_String)); 2744 2745 -------------- 2746 -- Callable -- 2747 -------------- 2748 2749 when Attribute_Callable => 2750 Check_E0; 2751 Set_Etype (N, Standard_Boolean); 2752 Check_Task_Prefix; 2753 2754 ------------ 2755 -- Caller -- 2756 ------------ 2757 2758 when Attribute_Caller => Caller : declare 2759 Ent : Entity_Id; 2760 S : Entity_Id; 2761 2762 begin 2763 Check_E0; 2764 2765 if Nkind_In (P, N_Identifier, N_Expanded_Name) then 2766 Ent := Entity (P); 2767 2768 if not Is_Entry (Ent) then 2769 Error_Attr ("invalid entry name", N); 2770 end if; 2771 2772 else 2773 Error_Attr ("invalid entry name", N); 2774 return; 2775 end if; 2776 2777 for J in reverse 0 .. Scope_Stack.Last loop 2778 S := Scope_Stack.Table (J).Entity; 2779 2780 if S = Scope (Ent) then 2781 Error_Attr ("Caller must appear in matching accept or body", N); 2782 elsif S = Ent then 2783 exit; 2784 end if; 2785 end loop; 2786 2787 Set_Etype (N, RTE (RO_AT_Task_Id)); 2788 end Caller; 2789 2790 ------------- 2791 -- Ceiling -- 2792 ------------- 2793 2794 when Attribute_Ceiling => 2795 Check_Floating_Point_Type_1; 2796 Set_Etype (N, P_Base_Type); 2797 Resolve (E1, P_Base_Type); 2798 2799 ----------- 2800 -- Class -- 2801 ----------- 2802 2803 when Attribute_Class => 2804 Check_Restriction (No_Dispatch, N); 2805 Check_E0; 2806 Find_Type (N); 2807 2808 -- Applying Class to untagged incomplete type is obsolescent in Ada 2809 -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since 2810 -- this flag gets set by Find_Type in this situation. 2811 2812 if Restriction_Check_Required (No_Obsolescent_Features) 2813 and then Ada_Version >= Ada_2005 2814 and then Ekind (P_Type) = E_Incomplete_Type 2815 then 2816 declare 2817 DN : constant Node_Id := Declaration_Node (P_Type); 2818 begin 2819 if Nkind (DN) = N_Incomplete_Type_Declaration 2820 and then not Tagged_Present (DN) 2821 then 2822 Check_Restriction (No_Obsolescent_Features, P); 2823 end if; 2824 end; 2825 end if; 2826 2827 ------------------ 2828 -- Code_Address -- 2829 ------------------ 2830 2831 when Attribute_Code_Address => 2832 Check_E0; 2833 2834 if Nkind (P) = N_Attribute_Reference 2835 and then (Attribute_Name (P) = Name_Elab_Body 2836 or else 2837 Attribute_Name (P) = Name_Elab_Spec) 2838 then 2839 null; 2840 2841 elsif not Is_Entity_Name (P) 2842 or else (Ekind (Entity (P)) /= E_Function 2843 and then 2844 Ekind (Entity (P)) /= E_Procedure) 2845 then 2846 Error_Attr ("invalid prefix for % attribute", P); 2847 Set_Address_Taken (Entity (P)); 2848 2849 -- Issue an error if the prefix denotes an eliminated subprogram 2850 2851 else 2852 Check_For_Eliminated_Subprogram (P, Entity (P)); 2853 end if; 2854 2855 Set_Etype (N, RTE (RE_Address)); 2856 2857 ---------------------- 2858 -- Compiler_Version -- 2859 ---------------------- 2860 2861 when Attribute_Compiler_Version => 2862 Check_E0; 2863 Check_Standard_Prefix; 2864 Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String)); 2865 Analyze_And_Resolve (N, Standard_String); 2866 2867 -------------------- 2868 -- Component_Size -- 2869 -------------------- 2870 2871 when Attribute_Component_Size => 2872 Check_E0; 2873 Set_Etype (N, Universal_Integer); 2874 2875 -- Note: unlike other array attributes, unconstrained arrays are OK 2876 2877 if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then 2878 null; 2879 else 2880 Check_Array_Type; 2881 end if; 2882 2883 ------------- 2884 -- Compose -- 2885 ------------- 2886 2887 when Attribute_Compose => 2888 Check_Floating_Point_Type_2; 2889 Set_Etype (N, P_Base_Type); 2890 Resolve (E1, P_Base_Type); 2891 Resolve (E2, Any_Integer); 2892 2893 ----------------- 2894 -- Constrained -- 2895 ----------------- 2896 2897 when Attribute_Constrained => 2898 Check_E0; 2899 Set_Etype (N, Standard_Boolean); 2900 2901 -- Case from RM J.4(2) of constrained applied to private type 2902 2903 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then 2904 Check_Restriction (No_Obsolescent_Features, P); 2905 2906 if Warn_On_Obsolescent_Feature then 2907 Error_Msg_N 2908 ("constrained for private type is an " & 2909 "obsolescent feature (RM J.4)?j?", N); 2910 end if; 2911 2912 -- If we are within an instance, the attribute must be legal 2913 -- because it was valid in the generic unit. Ditto if this is 2914 -- an inlining of a function declared in an instance. 2915 2916 if In_Instance 2917 or else In_Inlined_Body 2918 then 2919 return; 2920 2921 -- For sure OK if we have a real private type itself, but must 2922 -- be completed, cannot apply Constrained to incomplete type. 2923 2924 elsif Is_Private_Type (Entity (P)) then 2925 2926 -- Note: this is one of the Annex J features that does not 2927 -- generate a warning from -gnatwj, since in fact it seems 2928 -- very useful, and is used in the GNAT runtime. 2929 2930 Check_Not_Incomplete_Type; 2931 return; 2932 end if; 2933 2934 -- Normal (non-obsolescent case) of application to object of 2935 -- a discriminated type. 2936 2937 else 2938 Check_Object_Reference (P); 2939 2940 -- If N does not come from source, then we allow the 2941 -- the attribute prefix to be of a private type whose 2942 -- full type has discriminants. This occurs in cases 2943 -- involving expanded calls to stream attributes. 2944 2945 if not Comes_From_Source (N) then 2946 P_Type := Underlying_Type (P_Type); 2947 end if; 2948 2949 -- Must have discriminants or be an access type designating 2950 -- a type with discriminants. If it is a classwide type is ??? 2951 -- has unknown discriminants. 2952 2953 if Has_Discriminants (P_Type) 2954 or else Has_Unknown_Discriminants (P_Type) 2955 or else 2956 (Is_Access_Type (P_Type) 2957 and then Has_Discriminants (Designated_Type (P_Type))) 2958 then 2959 return; 2960 2961 -- Also allow an object of a generic type if extensions allowed 2962 -- and allow this for any type at all. 2963 2964 elsif (Is_Generic_Type (P_Type) 2965 or else Is_Generic_Actual_Type (P_Type)) 2966 and then Extensions_Allowed 2967 then 2968 return; 2969 end if; 2970 end if; 2971 2972 -- Fall through if bad prefix 2973 2974 Error_Attr_P 2975 ("prefix of % attribute must be object of discriminated type"); 2976 2977 --------------- 2978 -- Copy_Sign -- 2979 --------------- 2980 2981 when Attribute_Copy_Sign => 2982 Check_Floating_Point_Type_2; 2983 Set_Etype (N, P_Base_Type); 2984 Resolve (E1, P_Base_Type); 2985 Resolve (E2, P_Base_Type); 2986 2987 ----------- 2988 -- Count -- 2989 ----------- 2990 2991 when Attribute_Count => Count : 2992 declare 2993 Ent : Entity_Id; 2994 S : Entity_Id; 2995 Tsk : Entity_Id; 2996 2997 begin 2998 Check_E0; 2999 3000 if Nkind_In (P, N_Identifier, N_Expanded_Name) then 3001 Ent := Entity (P); 3002 3003 if Ekind (Ent) /= E_Entry then 3004 Error_Attr ("invalid entry name", N); 3005 end if; 3006 3007 elsif Nkind (P) = N_Indexed_Component then 3008 if not Is_Entity_Name (Prefix (P)) 3009 or else No (Entity (Prefix (P))) 3010 or else Ekind (Entity (Prefix (P))) /= E_Entry_Family 3011 then 3012 if Nkind (Prefix (P)) = N_Selected_Component 3013 and then Present (Entity (Selector_Name (Prefix (P)))) 3014 and then Ekind (Entity (Selector_Name (Prefix (P)))) = 3015 E_Entry_Family 3016 then 3017 Error_Attr 3018 ("attribute % must apply to entry of current task", P); 3019 3020 else 3021 Error_Attr ("invalid entry family name", P); 3022 end if; 3023 return; 3024 3025 else 3026 Ent := Entity (Prefix (P)); 3027 end if; 3028 3029 elsif Nkind (P) = N_Selected_Component 3030 and then Present (Entity (Selector_Name (P))) 3031 and then Ekind (Entity (Selector_Name (P))) = E_Entry 3032 then 3033 Error_Attr 3034 ("attribute % must apply to entry of current task", P); 3035 3036 else 3037 Error_Attr ("invalid entry name", N); 3038 return; 3039 end if; 3040 3041 for J in reverse 0 .. Scope_Stack.Last loop 3042 S := Scope_Stack.Table (J).Entity; 3043 3044 if S = Scope (Ent) then 3045 if Nkind (P) = N_Expanded_Name then 3046 Tsk := Entity (Prefix (P)); 3047 3048 -- The prefix denotes either the task type, or else a 3049 -- single task whose task type is being analyzed. 3050 3051 if (Is_Type (Tsk) 3052 and then Tsk = S) 3053 3054 or else (not Is_Type (Tsk) 3055 and then Etype (Tsk) = S 3056 and then not (Comes_From_Source (S))) 3057 then 3058 null; 3059 else 3060 Error_Attr 3061 ("Attribute % must apply to entry of current task", N); 3062 end if; 3063 end if; 3064 3065 exit; 3066 3067 elsif Ekind (Scope (Ent)) in Task_Kind 3068 and then 3069 not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family) 3070 then 3071 Error_Attr ("Attribute % cannot appear in inner unit", N); 3072 3073 elsif Ekind (Scope (Ent)) = E_Protected_Type 3074 and then not Has_Completion (Scope (Ent)) 3075 then 3076 Error_Attr ("attribute % can only be used inside body", N); 3077 end if; 3078 end loop; 3079 3080 if Is_Overloaded (P) then 3081 declare 3082 Index : Interp_Index; 3083 It : Interp; 3084 3085 begin 3086 Get_First_Interp (P, Index, It); 3087 3088 while Present (It.Nam) loop 3089 if It.Nam = Ent then 3090 null; 3091 3092 -- Ada 2005 (AI-345): Do not consider primitive entry 3093 -- wrappers generated for task or protected types. 3094 3095 elsif Ada_Version >= Ada_2005 3096 and then not Comes_From_Source (It.Nam) 3097 then 3098 null; 3099 3100 else 3101 Error_Attr ("ambiguous entry name", N); 3102 end if; 3103 3104 Get_Next_Interp (Index, It); 3105 end loop; 3106 end; 3107 end if; 3108 3109 Set_Etype (N, Universal_Integer); 3110 end Count; 3111 3112 ----------------------- 3113 -- Default_Bit_Order -- 3114 ----------------------- 3115 3116 when Attribute_Default_Bit_Order => Default_Bit_Order : 3117 begin 3118 Check_Standard_Prefix; 3119 3120 if Bytes_Big_Endian then 3121 Rewrite (N, 3122 Make_Integer_Literal (Loc, False_Value)); 3123 else 3124 Rewrite (N, 3125 Make_Integer_Literal (Loc, True_Value)); 3126 end if; 3127 3128 Set_Etype (N, Universal_Integer); 3129 Set_Is_Static_Expression (N); 3130 end Default_Bit_Order; 3131 3132 -------------- 3133 -- Definite -- 3134 -------------- 3135 3136 when Attribute_Definite => 3137 Legal_Formal_Attribute; 3138 3139 ----------- 3140 -- Delta -- 3141 ----------- 3142 3143 when Attribute_Delta => 3144 Check_Fixed_Point_Type_0; 3145 Set_Etype (N, Universal_Real); 3146 3147 ------------ 3148 -- Denorm -- 3149 ------------ 3150 3151 when Attribute_Denorm => 3152 Check_Floating_Point_Type_0; 3153 Set_Etype (N, Standard_Boolean); 3154 3155 --------------------- 3156 -- Descriptor_Size -- 3157 --------------------- 3158 3159 when Attribute_Descriptor_Size => 3160 Check_E0; 3161 3162 if not Is_Entity_Name (P) 3163 or else not Is_Type (Entity (P)) 3164 then 3165 Error_Attr_P ("prefix of attribute % must denote a type"); 3166 end if; 3167 3168 Set_Etype (N, Universal_Integer); 3169 3170 ------------ 3171 -- Digits -- 3172 ------------ 3173 3174 when Attribute_Digits => 3175 Check_E0; 3176 Check_Type; 3177 3178 if not Is_Floating_Point_Type (P_Type) 3179 and then not Is_Decimal_Fixed_Point_Type (P_Type) 3180 then 3181 Error_Attr_P 3182 ("prefix of % attribute must be float or decimal type"); 3183 end if; 3184 3185 Set_Etype (N, Universal_Integer); 3186 3187 --------------- 3188 -- Elab_Body -- 3189 --------------- 3190 3191 -- Also handles processing for Elab_Spec and Elab_Subp_Body 3192 3193 when Attribute_Elab_Body | 3194 Attribute_Elab_Spec | 3195 Attribute_Elab_Subp_Body => 3196 3197 Check_E0; 3198 Check_Unit_Name (P); 3199 Set_Etype (N, Standard_Void_Type); 3200 3201 -- We have to manually call the expander in this case to get 3202 -- the necessary expansion (normally attributes that return 3203 -- entities are not expanded). 3204 3205 Expand (N); 3206 3207 --------------- 3208 -- Elab_Spec -- 3209 --------------- 3210 3211 -- Shares processing with Elab_Body 3212 3213 ---------------- 3214 -- Elaborated -- 3215 ---------------- 3216 3217 when Attribute_Elaborated => 3218 Check_E0; 3219 Check_Unit_Name (P); 3220 Set_Etype (N, Standard_Boolean); 3221 3222 ---------- 3223 -- Emax -- 3224 ---------- 3225 3226 when Attribute_Emax => 3227 Check_Floating_Point_Type_0; 3228 Set_Etype (N, Universal_Integer); 3229 3230 ------------- 3231 -- Enabled -- 3232 ------------- 3233 3234 when Attribute_Enabled => 3235 Check_Either_E0_Or_E1; 3236 3237 if Present (E1) then 3238 if not Is_Entity_Name (E1) or else No (Entity (E1)) then 3239 Error_Msg_N ("entity name expected for Enabled attribute", E1); 3240 E1 := Empty; 3241 end if; 3242 end if; 3243 3244 if Nkind (P) /= N_Identifier then 3245 Error_Msg_N ("identifier expected (check name)", P); 3246 elsif Get_Check_Id (Chars (P)) = No_Check_Id then 3247 Error_Msg_N ("& is not a recognized check name", P); 3248 end if; 3249 3250 Set_Etype (N, Standard_Boolean); 3251 3252 -------------- 3253 -- Enum_Rep -- 3254 -------------- 3255 3256 when Attribute_Enum_Rep => Enum_Rep : declare 3257 begin 3258 if Present (E1) then 3259 Check_E1; 3260 Check_Discrete_Type; 3261 Resolve (E1, P_Base_Type); 3262 3263 else 3264 if not Is_Entity_Name (P) 3265 or else (not Is_Object (Entity (P)) 3266 and then 3267 Ekind (Entity (P)) /= E_Enumeration_Literal) 3268 then 3269 Error_Attr_P 3270 ("prefix of % attribute must be " & 3271 "discrete type/object or enum literal"); 3272 end if; 3273 end if; 3274 3275 Set_Etype (N, Universal_Integer); 3276 end Enum_Rep; 3277 3278 -------------- 3279 -- Enum_Val -- 3280 -------------- 3281 3282 when Attribute_Enum_Val => Enum_Val : begin 3283 Check_E1; 3284 Check_Type; 3285 3286 if not Is_Enumeration_Type (P_Type) then 3287 Error_Attr_P ("prefix of % attribute must be enumeration type"); 3288 end if; 3289 3290 -- If the enumeration type has a standard representation, the effect 3291 -- is the same as 'Val, so rewrite the attribute as a 'Val. 3292 3293 if not Has_Non_Standard_Rep (P_Base_Type) then 3294 Rewrite (N, 3295 Make_Attribute_Reference (Loc, 3296 Prefix => Relocate_Node (Prefix (N)), 3297 Attribute_Name => Name_Val, 3298 Expressions => New_List (Relocate_Node (E1)))); 3299 Analyze_And_Resolve (N, P_Base_Type); 3300 3301 -- Non-standard representation case (enumeration with holes) 3302 3303 else 3304 Check_Enum_Image; 3305 Resolve (E1, Any_Integer); 3306 Set_Etype (N, P_Base_Type); 3307 end if; 3308 end Enum_Val; 3309 3310 ------------- 3311 -- Epsilon -- 3312 ------------- 3313 3314 when Attribute_Epsilon => 3315 Check_Floating_Point_Type_0; 3316 Set_Etype (N, Universal_Real); 3317 3318 -------------- 3319 -- Exponent -- 3320 -------------- 3321 3322 when Attribute_Exponent => 3323 Check_Floating_Point_Type_1; 3324 Set_Etype (N, Universal_Integer); 3325 Resolve (E1, P_Base_Type); 3326 3327 ------------------ 3328 -- External_Tag -- 3329 ------------------ 3330 3331 when Attribute_External_Tag => 3332 Check_E0; 3333 Check_Type; 3334 3335 Set_Etype (N, Standard_String); 3336 3337 if not Is_Tagged_Type (P_Type) then 3338 Error_Attr_P ("prefix of % attribute must be tagged"); 3339 end if; 3340 3341 --------------- 3342 -- Fast_Math -- 3343 --------------- 3344 3345 when Attribute_Fast_Math => 3346 Check_Standard_Prefix; 3347 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc)); 3348 3349 ----------- 3350 -- First -- 3351 ----------- 3352 3353 when Attribute_First => 3354 Check_Array_Or_Scalar_Type; 3355 Bad_Attribute_For_Predicate; 3356 3357 --------------- 3358 -- First_Bit -- 3359 --------------- 3360 3361 when Attribute_First_Bit => 3362 Check_Component; 3363 Set_Etype (N, Universal_Integer); 3364 3365 ----------------- 3366 -- First_Valid -- 3367 ----------------- 3368 3369 when Attribute_First_Valid => 3370 Check_First_Last_Valid; 3371 Set_Etype (N, P_Type); 3372 3373 ----------------- 3374 -- Fixed_Value -- 3375 ----------------- 3376 3377 when Attribute_Fixed_Value => 3378 Check_E1; 3379 Check_Fixed_Point_Type; 3380 Resolve (E1, Any_Integer); 3381 Set_Etype (N, P_Base_Type); 3382 3383 ----------- 3384 -- Floor -- 3385 ----------- 3386 3387 when Attribute_Floor => 3388 Check_Floating_Point_Type_1; 3389 Set_Etype (N, P_Base_Type); 3390 Resolve (E1, P_Base_Type); 3391 3392 ---------- 3393 -- Fore -- 3394 ---------- 3395 3396 when Attribute_Fore => 3397 Check_Fixed_Point_Type_0; 3398 Set_Etype (N, Universal_Integer); 3399 3400 -------------- 3401 -- Fraction -- 3402 -------------- 3403 3404 when Attribute_Fraction => 3405 Check_Floating_Point_Type_1; 3406 Set_Etype (N, P_Base_Type); 3407 Resolve (E1, P_Base_Type); 3408 3409 -------------- 3410 -- From_Any -- 3411 -------------- 3412 3413 when Attribute_From_Any => 3414 Check_E1; 3415 Check_PolyORB_Attribute; 3416 Set_Etype (N, P_Base_Type); 3417 3418 ----------------------- 3419 -- Has_Access_Values -- 3420 ----------------------- 3421 3422 when Attribute_Has_Access_Values => 3423 Check_Type; 3424 Check_E0; 3425 Set_Etype (N, Standard_Boolean); 3426 3427 ----------------------- 3428 -- Has_Tagged_Values -- 3429 ----------------------- 3430 3431 when Attribute_Has_Tagged_Values => 3432 Check_Type; 3433 Check_E0; 3434 Set_Etype (N, Standard_Boolean); 3435 3436 ----------------------- 3437 -- Has_Discriminants -- 3438 ----------------------- 3439 3440 when Attribute_Has_Discriminants => 3441 Legal_Formal_Attribute; 3442 3443 -------------- 3444 -- Identity -- 3445 -------------- 3446 3447 when Attribute_Identity => 3448 Check_E0; 3449 Analyze (P); 3450 3451 if Etype (P) = Standard_Exception_Type then 3452 Set_Etype (N, RTE (RE_Exception_Id)); 3453 3454 -- Ada 2005 (AI-345): Attribute 'Identity may be applied to 3455 -- task interface class-wide types. 3456 3457 elsif Is_Task_Type (Etype (P)) 3458 or else (Is_Access_Type (Etype (P)) 3459 and then Is_Task_Type (Designated_Type (Etype (P)))) 3460 or else (Ada_Version >= Ada_2005 3461 and then Ekind (Etype (P)) = E_Class_Wide_Type 3462 and then Is_Interface (Etype (P)) 3463 and then Is_Task_Interface (Etype (P))) 3464 then 3465 Resolve (P); 3466 Set_Etype (N, RTE (RO_AT_Task_Id)); 3467 3468 else 3469 if Ada_Version >= Ada_2005 then 3470 Error_Attr_P 3471 ("prefix of % attribute must be an exception, a " & 3472 "task or a task interface class-wide object"); 3473 else 3474 Error_Attr_P 3475 ("prefix of % attribute must be a task or an exception"); 3476 end if; 3477 end if; 3478 3479 ----------- 3480 -- Image -- 3481 ----------- 3482 3483 when Attribute_Image => Image : 3484 begin 3485 Check_SPARK_Restriction_On_Attribute; 3486 Check_Scalar_Type; 3487 Set_Etype (N, Standard_String); 3488 3489 if Is_Real_Type (P_Type) then 3490 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 3491 Error_Msg_Name_1 := Aname; 3492 Error_Msg_N 3493 ("(Ada 83) % attribute not allowed for real types", N); 3494 end if; 3495 end if; 3496 3497 if Is_Enumeration_Type (P_Type) then 3498 Check_Restriction (No_Enumeration_Maps, N); 3499 end if; 3500 3501 Check_E1; 3502 Resolve (E1, P_Base_Type); 3503 Check_Enum_Image; 3504 Validate_Non_Static_Attribute_Function_Call; 3505 end Image; 3506 3507 --------- 3508 -- Img -- 3509 --------- 3510 3511 when Attribute_Img => Img : 3512 begin 3513 Check_E0; 3514 Set_Etype (N, Standard_String); 3515 3516 if not Is_Scalar_Type (P_Type) 3517 or else (Is_Entity_Name (P) and then Is_Type (Entity (P))) 3518 then 3519 Error_Attr_P 3520 ("prefix of % attribute must be scalar object name"); 3521 end if; 3522 3523 Check_Enum_Image; 3524 end Img; 3525 3526 ----------- 3527 -- Input -- 3528 ----------- 3529 3530 when Attribute_Input => 3531 Check_E1; 3532 Check_Stream_Attribute (TSS_Stream_Input); 3533 Set_Etype (N, P_Base_Type); 3534 3535 ------------------- 3536 -- Integer_Value -- 3537 ------------------- 3538 3539 when Attribute_Integer_Value => 3540 Check_E1; 3541 Check_Integer_Type; 3542 Resolve (E1, Any_Fixed); 3543 3544 -- Signal an error if argument type is not a specific fixed-point 3545 -- subtype. An error has been signalled already if the argument 3546 -- was not of a fixed-point type. 3547 3548 if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then 3549 Error_Attr ("argument of % must be of a fixed-point type", E1); 3550 end if; 3551 3552 Set_Etype (N, P_Base_Type); 3553 3554 ------------------- 3555 -- Invalid_Value -- 3556 ------------------- 3557 3558 when Attribute_Invalid_Value => 3559 Check_E0; 3560 Check_Scalar_Type; 3561 Set_Etype (N, P_Base_Type); 3562 Invalid_Value_Used := True; 3563 3564 ----------- 3565 -- Large -- 3566 ----------- 3567 3568 when Attribute_Large => 3569 Check_E0; 3570 Check_Real_Type; 3571 Set_Etype (N, Universal_Real); 3572 3573 ---------- 3574 -- Last -- 3575 ---------- 3576 3577 when Attribute_Last => 3578 Check_Array_Or_Scalar_Type; 3579 Bad_Attribute_For_Predicate; 3580 3581 -------------- 3582 -- Last_Bit -- 3583 -------------- 3584 3585 when Attribute_Last_Bit => 3586 Check_Component; 3587 Set_Etype (N, Universal_Integer); 3588 3589 ---------------- 3590 -- Last_Valid -- 3591 ---------------- 3592 3593 when Attribute_Last_Valid => 3594 Check_First_Last_Valid; 3595 Set_Etype (N, P_Type); 3596 3597 ------------------ 3598 -- Leading_Part -- 3599 ------------------ 3600 3601 when Attribute_Leading_Part => 3602 Check_Floating_Point_Type_2; 3603 Set_Etype (N, P_Base_Type); 3604 Resolve (E1, P_Base_Type); 3605 Resolve (E2, Any_Integer); 3606 3607 ------------ 3608 -- Length -- 3609 ------------ 3610 3611 when Attribute_Length => 3612 Check_Array_Type; 3613 Set_Etype (N, Universal_Integer); 3614 3615 --------------- 3616 -- Lock_Free -- 3617 --------------- 3618 3619 when Attribute_Lock_Free => 3620 Check_E0; 3621 Set_Etype (N, Standard_Boolean); 3622 3623 if not Is_Protected_Type (P_Type) then 3624 Error_Attr_P 3625 ("prefix of % attribute must be a protected object"); 3626 end if; 3627 3628 ---------------- 3629 -- Loop_Entry -- 3630 ---------------- 3631 3632 when Attribute_Loop_Entry => Loop_Entry : declare 3633 procedure Check_References_In_Prefix (Loop_Id : Entity_Id); 3634 -- Inspect the prefix for any uses of entities declared within the 3635 -- related loop. Loop_Id denotes the loop identifier. 3636 3637 procedure Convert_To_Indexed_Component; 3638 -- Transform the attribute reference into an indexed component where 3639 -- the prefix is Prefix'Loop_Entry and the expressions are associated 3640 -- with the indexed component. 3641 3642 -------------------------------- 3643 -- Check_References_In_Prefix -- 3644 -------------------------------- 3645 3646 procedure Check_References_In_Prefix (Loop_Id : Entity_Id) is 3647 Loop_Decl : constant Node_Id := Label_Construct (Parent (Loop_Id)); 3648 3649 function Check_Reference (Nod : Node_Id) return Traverse_Result; 3650 -- Determine whether a reference mentions an entity declared 3651 -- within the related loop. 3652 3653 function Declared_Within (Nod : Node_Id) return Boolean; 3654 -- Determine whether Nod appears in the subtree of Loop_Decl 3655 3656 --------------------- 3657 -- Check_Reference -- 3658 --------------------- 3659 3660 function Check_Reference (Nod : Node_Id) return Traverse_Result is 3661 begin 3662 if Nkind (Nod) = N_Identifier 3663 and then Present (Entity (Nod)) 3664 and then Declared_Within (Declaration_Node (Entity (Nod))) 3665 then 3666 Error_Attr 3667 ("prefix of attribute % cannot reference local entities", 3668 Nod); 3669 return Abandon; 3670 else 3671 return OK; 3672 end if; 3673 end Check_Reference; 3674 3675 procedure Check_References is new Traverse_Proc (Check_Reference); 3676 3677 --------------------- 3678 -- Declared_Within -- 3679 --------------------- 3680 3681 function Declared_Within (Nod : Node_Id) return Boolean is 3682 Stmt : Node_Id; 3683 3684 begin 3685 Stmt := Nod; 3686 while Present (Stmt) loop 3687 if Stmt = Loop_Decl then 3688 return True; 3689 3690 -- Prevent the search from going too far 3691 3692 elsif Nkind_In (Stmt, N_Entry_Body, 3693 N_Package_Body, 3694 N_Package_Declaration, 3695 N_Protected_Body, 3696 N_Subprogram_Body, 3697 N_Task_Body) 3698 then 3699 exit; 3700 end if; 3701 3702 Stmt := Parent (Stmt); 3703 end loop; 3704 3705 return False; 3706 end Declared_Within; 3707 3708 -- Start of processing for Check_Prefix_For_Local_References 3709 3710 begin 3711 Check_References (P); 3712 end Check_References_In_Prefix; 3713 3714 ---------------------------------- 3715 -- Convert_To_Indexed_Component -- 3716 ---------------------------------- 3717 3718 procedure Convert_To_Indexed_Component is 3719 New_Loop_Entry : constant Node_Id := Relocate_Node (N); 3720 3721 begin 3722 -- The new Loop_Entry loses its arguments. They will be converted 3723 -- into the expressions of the indexed component. 3724 3725 Set_Expressions (New_Loop_Entry, No_List); 3726 3727 Rewrite (N, 3728 Make_Indexed_Component (Loc, 3729 Prefix => New_Loop_Entry, 3730 Expressions => Exprs)); 3731 end Convert_To_Indexed_Component; 3732 3733 -- Local variables 3734 3735 Enclosing_Loop : Node_Id; 3736 In_Loop_Assertion : Boolean := False; 3737 Loop_Id : Entity_Id := Empty; 3738 Scop : Entity_Id; 3739 Stmt : Node_Id; 3740 3741 -- Start of processing for Loop_Entry 3742 3743 begin 3744 S14_Attribute; 3745 3746 -- The attribute reference appears as 3747 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN) 3748 3749 -- In this case, the loop name is omitted and the arguments are part 3750 -- of an indexed component. Transform the whole attribute reference 3751 -- to reflect this scenario. 3752 3753 if Present (E2) then 3754 Convert_To_Indexed_Component; 3755 Analyze (N); 3756 return; 3757 3758 -- The attribute reference appears as 3759 -- Prefix'Loop_Entry (Loop_Name) 3760 -- or 3761 -- Prefix'Loop_Entry (Expr1) 3762 3763 -- Depending on what Expr1 resolves to, either rewrite the reference 3764 -- into an indexed component or continue with the analysis. 3765 3766 elsif Present (E1) then 3767 3768 -- Do not expand the argument as it may have side effects. Simply 3769 -- preanalyze to determine whether it is a loop or something else. 3770 3771 Preanalyze_And_Resolve (E1); 3772 3773 if Is_Entity_Name (E1) 3774 and then Present (Entity (E1)) 3775 and then Ekind (Entity (E1)) = E_Loop 3776 then 3777 Loop_Id := Entity (E1); 3778 3779 -- The argument is not a loop name 3780 3781 else 3782 Convert_To_Indexed_Component; 3783 Analyze (N); 3784 return; 3785 end if; 3786 end if; 3787 3788 -- The prefix must denote an object 3789 3790 if not Is_Object_Reference (P) then 3791 Error_Attr_P ("prefix of attribute % must denote an object"); 3792 end if; 3793 3794 -- The prefix cannot be of a limited type because the expansion of 3795 -- Loop_Entry must create a constant initialized by the evaluated 3796 -- prefix. 3797 3798 if Is_Immutably_Limited_Type (Etype (P)) then 3799 Error_Attr_P ("prefix of attribute % cannot be limited"); 3800 end if; 3801 3802 -- Climb the parent chain to verify the location of the attribute and 3803 -- find the enclosing loop. 3804 3805 Stmt := N; 3806 while Present (Stmt) loop 3807 3808 -- Locate the enclosing Loop_Invariant / Loop_Variant pragma (if 3809 -- any). Note that when these two are expanded, we must look for 3810 -- an Assertion pragma. 3811 3812 if Nkind (Original_Node (Stmt)) = N_Pragma 3813 and then 3814 (Pragma_Name (Original_Node (Stmt)) = Name_Assert 3815 or else 3816 Pragma_Name (Original_Node (Stmt)) = Name_Loop_Invariant 3817 or else 3818 Pragma_Name (Original_Node (Stmt)) = Name_Loop_Variant) 3819 then 3820 In_Loop_Assertion := True; 3821 3822 -- Locate the enclosing loop (if any). Note that Ada 2012 array 3823 -- iteration may be expanded into several nested loops, we are 3824 -- interested in the outermost one which has the loop identifier. 3825 3826 elsif Nkind (Stmt) = N_Loop_Statement 3827 and then Present (Identifier (Stmt)) 3828 then 3829 Enclosing_Loop := Stmt; 3830 3831 -- The original attribute reference may lack a loop name. Use 3832 -- the name of the enclosing loop because it is the related 3833 -- loop. 3834 3835 if No (Loop_Id) then 3836 Loop_Id := Entity (Identifier (Enclosing_Loop)); 3837 end if; 3838 3839 exit; 3840 3841 -- Prevent the search from going too far 3842 3843 elsif Nkind_In (Stmt, N_Entry_Body, 3844 N_Package_Body, 3845 N_Package_Declaration, 3846 N_Protected_Body, 3847 N_Subprogram_Body, 3848 N_Task_Body) 3849 then 3850 exit; 3851 end if; 3852 3853 Stmt := Parent (Stmt); 3854 end loop; 3855 3856 -- Loop_Entry must appear within a Loop_Assertion pragma 3857 3858 if not In_Loop_Assertion then 3859 Error_Attr 3860 ("attribute % must appear within pragma Loop_Variant or " & 3861 "Loop_Invariant", N); 3862 end if; 3863 3864 -- A Loop_Entry that applies to a given loop statement shall not 3865 -- appear within a body of accept statement, if this construct is 3866 -- itself enclosed by the given loop statement. 3867 3868 for J in reverse 0 .. Scope_Stack.Last loop 3869 Scop := Scope_Stack.Table (J).Entity; 3870 3871 if Ekind (Scop) = E_Loop and then Scop = Loop_Id then 3872 exit; 3873 3874 elsif Ekind_In (Scop, E_Block, E_Loop, E_Return_Statement) then 3875 null; 3876 3877 else 3878 Error_Attr 3879 ("attribute % cannot appear in body or accept statement", N); 3880 exit; 3881 end if; 3882 end loop; 3883 3884 -- The prefix cannot mention entities declared within the related 3885 -- loop because they will not be visible once the prefix is moved 3886 -- outside the loop. 3887 3888 Check_References_In_Prefix (Loop_Id); 3889 3890 -- The prefix must denote a static entity if the pragma does not 3891 -- apply to the innermost enclosing loop statement. 3892 3893 if Present (Enclosing_Loop) 3894 and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id 3895 and then not Is_Entity_Name (P) 3896 then 3897 Error_Attr_P ("prefix of attribute % must denote an entity"); 3898 end if; 3899 3900 Set_Etype (N, Etype (P)); 3901 3902 -- Associate the attribute with its related loop 3903 3904 if No (Loop_Entry_Attributes (Loop_Id)) then 3905 Set_Loop_Entry_Attributes (Loop_Id, New_Elmt_List); 3906 end if; 3907 3908 -- A Loop_Entry may be [pre]analyzed several times, depending on the 3909 -- context. Ensure that it appears only once in the attributes list 3910 -- of the related loop. 3911 3912 Append_Unique_Elmt (N, Loop_Entry_Attributes (Loop_Id)); 3913 end Loop_Entry; 3914 3915 ------------- 3916 -- Machine -- 3917 ------------- 3918 3919 when Attribute_Machine => 3920 Check_Floating_Point_Type_1; 3921 Set_Etype (N, P_Base_Type); 3922 Resolve (E1, P_Base_Type); 3923 3924 ------------------ 3925 -- Machine_Emax -- 3926 ------------------ 3927 3928 when Attribute_Machine_Emax => 3929 Check_Floating_Point_Type_0; 3930 Set_Etype (N, Universal_Integer); 3931 3932 ------------------ 3933 -- Machine_Emin -- 3934 ------------------ 3935 3936 when Attribute_Machine_Emin => 3937 Check_Floating_Point_Type_0; 3938 Set_Etype (N, Universal_Integer); 3939 3940 ---------------------- 3941 -- Machine_Mantissa -- 3942 ---------------------- 3943 3944 when Attribute_Machine_Mantissa => 3945 Check_Floating_Point_Type_0; 3946 Set_Etype (N, Universal_Integer); 3947 3948 ----------------------- 3949 -- Machine_Overflows -- 3950 ----------------------- 3951 3952 when Attribute_Machine_Overflows => 3953 Check_Real_Type; 3954 Check_E0; 3955 Set_Etype (N, Standard_Boolean); 3956 3957 ------------------- 3958 -- Machine_Radix -- 3959 ------------------- 3960 3961 when Attribute_Machine_Radix => 3962 Check_Real_Type; 3963 Check_E0; 3964 Set_Etype (N, Universal_Integer); 3965 3966 ---------------------- 3967 -- Machine_Rounding -- 3968 ---------------------- 3969 3970 when Attribute_Machine_Rounding => 3971 Check_Floating_Point_Type_1; 3972 Set_Etype (N, P_Base_Type); 3973 Resolve (E1, P_Base_Type); 3974 3975 -------------------- 3976 -- Machine_Rounds -- 3977 -------------------- 3978 3979 when Attribute_Machine_Rounds => 3980 Check_Real_Type; 3981 Check_E0; 3982 Set_Etype (N, Standard_Boolean); 3983 3984 ------------------ 3985 -- Machine_Size -- 3986 ------------------ 3987 3988 when Attribute_Machine_Size => 3989 Check_E0; 3990 Check_Type; 3991 Check_Not_Incomplete_Type; 3992 Set_Etype (N, Universal_Integer); 3993 3994 -------------- 3995 -- Mantissa -- 3996 -------------- 3997 3998 when Attribute_Mantissa => 3999 Check_E0; 4000 Check_Real_Type; 4001 Set_Etype (N, Universal_Integer); 4002 4003 --------- 4004 -- Max -- 4005 --------- 4006 4007 when Attribute_Max => 4008 Check_E2; 4009 Check_Scalar_Type; 4010 Resolve (E1, P_Base_Type); 4011 Resolve (E2, P_Base_Type); 4012 Set_Etype (N, P_Base_Type); 4013 4014 ---------------------------------- 4015 -- Max_Alignment_For_Allocation -- 4016 -- Max_Size_In_Storage_Elements -- 4017 ---------------------------------- 4018 4019 when Attribute_Max_Alignment_For_Allocation | 4020 Attribute_Max_Size_In_Storage_Elements => 4021 Check_E0; 4022 Check_Type; 4023 Check_Not_Incomplete_Type; 4024 Set_Etype (N, Universal_Integer); 4025 4026 ----------------------- 4027 -- Maximum_Alignment -- 4028 ----------------------- 4029 4030 when Attribute_Maximum_Alignment => 4031 Standard_Attribute (Ttypes.Maximum_Alignment); 4032 4033 -------------------- 4034 -- Mechanism_Code -- 4035 -------------------- 4036 4037 when Attribute_Mechanism_Code => 4038 if not Is_Entity_Name (P) 4039 or else not Is_Subprogram (Entity (P)) 4040 then 4041 Error_Attr_P ("prefix of % attribute must be subprogram"); 4042 end if; 4043 4044 Check_Either_E0_Or_E1; 4045 4046 if Present (E1) then 4047 Resolve (E1, Any_Integer); 4048 Set_Etype (E1, Standard_Integer); 4049 4050 if not Is_Static_Expression (E1) then 4051 Flag_Non_Static_Expr 4052 ("expression for parameter number must be static!", E1); 4053 Error_Attr; 4054 4055 elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P)) 4056 or else UI_To_Int (Intval (E1)) < 0 4057 then 4058 Error_Attr ("invalid parameter number for % attribute", E1); 4059 end if; 4060 end if; 4061 4062 Set_Etype (N, Universal_Integer); 4063 4064 --------- 4065 -- Min -- 4066 --------- 4067 4068 when Attribute_Min => 4069 Check_E2; 4070 Check_Scalar_Type; 4071 Resolve (E1, P_Base_Type); 4072 Resolve (E2, P_Base_Type); 4073 Set_Etype (N, P_Base_Type); 4074 4075 --------- 4076 -- Mod -- 4077 --------- 4078 4079 when Attribute_Mod => 4080 4081 -- Note: this attribute is only allowed in Ada 2005 mode, but 4082 -- we do not need to test that here, since Mod is only recognized 4083 -- as an attribute name in Ada 2005 mode during the parse. 4084 4085 Check_E1; 4086 Check_Modular_Integer_Type; 4087 Resolve (E1, Any_Integer); 4088 Set_Etype (N, P_Base_Type); 4089 4090 ----------- 4091 -- Model -- 4092 ----------- 4093 4094 when Attribute_Model => 4095 Check_Floating_Point_Type_1; 4096 Set_Etype (N, P_Base_Type); 4097 Resolve (E1, P_Base_Type); 4098 4099 ---------------- 4100 -- Model_Emin -- 4101 ---------------- 4102 4103 when Attribute_Model_Emin => 4104 Check_Floating_Point_Type_0; 4105 Set_Etype (N, Universal_Integer); 4106 4107 ------------------- 4108 -- Model_Epsilon -- 4109 ------------------- 4110 4111 when Attribute_Model_Epsilon => 4112 Check_Floating_Point_Type_0; 4113 Set_Etype (N, Universal_Real); 4114 4115 -------------------- 4116 -- Model_Mantissa -- 4117 -------------------- 4118 4119 when Attribute_Model_Mantissa => 4120 Check_Floating_Point_Type_0; 4121 Set_Etype (N, Universal_Integer); 4122 4123 ----------------- 4124 -- Model_Small -- 4125 ----------------- 4126 4127 when Attribute_Model_Small => 4128 Check_Floating_Point_Type_0; 4129 Set_Etype (N, Universal_Real); 4130 4131 ------------- 4132 -- Modulus -- 4133 ------------- 4134 4135 when Attribute_Modulus => 4136 Check_E0; 4137 Check_Modular_Integer_Type; 4138 Set_Etype (N, Universal_Integer); 4139 4140 -------------------- 4141 -- Null_Parameter -- 4142 -------------------- 4143 4144 when Attribute_Null_Parameter => Null_Parameter : declare 4145 Parnt : constant Node_Id := Parent (N); 4146 GParnt : constant Node_Id := Parent (Parnt); 4147 4148 procedure Bad_Null_Parameter (Msg : String); 4149 -- Used if bad Null parameter attribute node is found. Issues 4150 -- given error message, and also sets the type to Any_Type to 4151 -- avoid blowups later on from dealing with a junk node. 4152 4153 procedure Must_Be_Imported (Proc_Ent : Entity_Id); 4154 -- Called to check that Proc_Ent is imported subprogram 4155 4156 ------------------------ 4157 -- Bad_Null_Parameter -- 4158 ------------------------ 4159 4160 procedure Bad_Null_Parameter (Msg : String) is 4161 begin 4162 Error_Msg_N (Msg, N); 4163 Set_Etype (N, Any_Type); 4164 end Bad_Null_Parameter; 4165 4166 ---------------------- 4167 -- Must_Be_Imported -- 4168 ---------------------- 4169 4170 procedure Must_Be_Imported (Proc_Ent : Entity_Id) is 4171 Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent); 4172 4173 begin 4174 -- Ignore check if procedure not frozen yet (we will get 4175 -- another chance when the default parameter is reanalyzed) 4176 4177 if not Is_Frozen (Pent) then 4178 return; 4179 4180 elsif not Is_Imported (Pent) then 4181 Bad_Null_Parameter 4182 ("Null_Parameter can only be used with imported subprogram"); 4183 4184 else 4185 return; 4186 end if; 4187 end Must_Be_Imported; 4188 4189 -- Start of processing for Null_Parameter 4190 4191 begin 4192 Check_Type; 4193 Check_E0; 4194 Set_Etype (N, P_Type); 4195 4196 -- Case of attribute used as default expression 4197 4198 if Nkind (Parnt) = N_Parameter_Specification then 4199 Must_Be_Imported (Defining_Entity (GParnt)); 4200 4201 -- Case of attribute used as actual for subprogram (positional) 4202 4203 elsif Nkind (Parnt) in N_Subprogram_Call 4204 and then Is_Entity_Name (Name (Parnt)) 4205 then 4206 Must_Be_Imported (Entity (Name (Parnt))); 4207 4208 -- Case of attribute used as actual for subprogram (named) 4209 4210 elsif Nkind (Parnt) = N_Parameter_Association 4211 and then Nkind (GParnt) in N_Subprogram_Call 4212 and then Is_Entity_Name (Name (GParnt)) 4213 then 4214 Must_Be_Imported (Entity (Name (GParnt))); 4215 4216 -- Not an allowed case 4217 4218 else 4219 Bad_Null_Parameter 4220 ("Null_Parameter must be actual or default parameter"); 4221 end if; 4222 end Null_Parameter; 4223 4224 ----------------- 4225 -- Object_Size -- 4226 ----------------- 4227 4228 when Attribute_Object_Size => 4229 Check_E0; 4230 Check_Type; 4231 Check_Not_Incomplete_Type; 4232 Set_Etype (N, Universal_Integer); 4233 4234 --------- 4235 -- Old -- 4236 --------- 4237 4238 when Attribute_Old => Old : declare 4239 CS : Entity_Id; 4240 -- The enclosing scope, excluding loops for quantified expressions. 4241 -- During analysis, it is the postcondition subprogram. During 4242 -- pre-analysis, it is the scope of the subprogram declaration. 4243 4244 Prag : Node_Id; 4245 -- During pre-analysis, Prag is the enclosing pragma node if any 4246 4247 begin 4248 -- Find enclosing scopes, excluding loops 4249 4250 CS := Current_Scope; 4251 while Ekind (CS) = E_Loop loop 4252 CS := Scope (CS); 4253 end loop; 4254 4255 -- If we are in Spec_Expression mode, this should be the prescan of 4256 -- the postcondition (or contract case, or test case) pragma. 4257 4258 if In_Spec_Expression then 4259 4260 -- Check in postcondition or Ensures clause 4261 4262 Prag := N; 4263 while not Nkind_In (Prag, N_Pragma, 4264 N_Function_Specification, 4265 N_Procedure_Specification, 4266 N_Subprogram_Body) 4267 loop 4268 Prag := Parent (Prag); 4269 end loop; 4270 4271 if Nkind (Prag) /= N_Pragma then 4272 Error_Attr ("% attribute can only appear in postcondition", P); 4273 4274 elsif Get_Pragma_Id (Prag) = Pragma_Contract_Case 4275 or else 4276 Get_Pragma_Id (Prag) = Pragma_Test_Case 4277 then 4278 declare 4279 Arg_Ens : constant Node_Id := 4280 Get_Ensures_From_CTC_Pragma (Prag); 4281 Arg : Node_Id; 4282 4283 begin 4284 Arg := N; 4285 while Arg /= Prag and Arg /= Arg_Ens loop 4286 Arg := Parent (Arg); 4287 end loop; 4288 4289 if Arg /= Arg_Ens then 4290 if Get_Pragma_Id (Prag) = Pragma_Contract_Case then 4291 Error_Attr 4292 ("% attribute misplaced inside contract case", P); 4293 else 4294 Error_Attr 4295 ("% attribute misplaced inside test case", P); 4296 end if; 4297 end if; 4298 end; 4299 4300 elsif Get_Pragma_Id (Prag) /= Pragma_Postcondition then 4301 Error_Attr ("% attribute can only appear in postcondition", P); 4302 end if; 4303 4304 -- Body case, where we must be inside a generated _Postcondition 4305 -- procedure, or else the attribute use is definitely misplaced. The 4306 -- postcondition itself may have generated transient scopes, and is 4307 -- not necessarily the current one. 4308 4309 else 4310 while Present (CS) and then CS /= Standard_Standard loop 4311 if Chars (CS) = Name_uPostconditions then 4312 exit; 4313 else 4314 CS := Scope (CS); 4315 end if; 4316 end loop; 4317 4318 if Chars (CS) /= Name_uPostconditions then 4319 Error_Attr ("% attribute can only appear in postcondition", P); 4320 end if; 4321 end if; 4322 4323 -- Either the attribute reference is generated for a Requires 4324 -- clause, in which case no expressions follow, or it is a 4325 -- primary. In that case, if expressions follow, the attribute 4326 -- reference is an indexable object, so rewrite the node 4327 -- accordingly. 4328 4329 if Present (E1) then 4330 Rewrite (N, 4331 Make_Indexed_Component (Loc, 4332 Prefix => 4333 Make_Attribute_Reference (Loc, 4334 Prefix => Relocate_Node (Prefix (N)), 4335 Attribute_Name => Name_Old), 4336 Expressions => Expressions (N))); 4337 4338 Analyze (N); 4339 return; 4340 end if; 4341 4342 Check_E0; 4343 4344 -- Prefix has not been analyzed yet, and its full analysis will 4345 -- take place during expansion (see below). 4346 4347 Preanalyze_And_Resolve (P); 4348 P_Type := Etype (P); 4349 Set_Etype (N, P_Type); 4350 4351 if Is_Limited_Type (P_Type) then 4352 Error_Attr ("attribute % cannot apply to limited objects", P); 4353 end if; 4354 4355 if Is_Entity_Name (P) 4356 and then Is_Constant_Object (Entity (P)) 4357 then 4358 Error_Msg_N 4359 ("??attribute Old applied to constant has no effect", P); 4360 end if; 4361 4362 -- The attribute appears within a pre/postcondition, but refers to 4363 -- an entity in the enclosing subprogram. If it is a component of 4364 -- a formal its expansion might generate actual subtypes that may 4365 -- be referenced in an inner context, and which must be elaborated 4366 -- within the subprogram itself. If the prefix includes a function 4367 -- call it may involve finalization actions that should only be 4368 -- inserted when the attribute has been rewritten as a declarations. 4369 -- As a result, if the prefix is not a simple name we create 4370 -- a declaration for it now, and insert it at the start of the 4371 -- enclosing subprogram. This is properly an expansion activity 4372 -- but it has to be performed now to prevent out-of-order issues. 4373 4374 -- This expansion is both harmful and not needed in Alfa mode, since 4375 -- the formal verification backend relies on the types of nodes 4376 -- (hence is not robust w.r.t. a change to base type here), and does 4377 -- not suffer from the out-of-order issue described above. Thus, this 4378 -- expansion is skipped in Alfa mode. 4379 4380 if not Is_Entity_Name (P) and then not Alfa_Mode then 4381 P_Type := Base_Type (P_Type); 4382 Set_Etype (N, P_Type); 4383 Set_Etype (P, P_Type); 4384 Analyze_Dimension (N); 4385 Expand (N); 4386 end if; 4387 end Old; 4388 4389 ---------------------- 4390 -- Overlaps_Storage -- 4391 ---------------------- 4392 4393 when Attribute_Overlaps_Storage => 4394 Check_E1; 4395 4396 -- Both arguments must be objects of any type 4397 4398 Analyze_And_Resolve (P); 4399 Analyze_And_Resolve (E1); 4400 Check_Object_Reference (P); 4401 Check_Object_Reference (E1); 4402 Set_Etype (N, Standard_Boolean); 4403 4404 ------------ 4405 -- Output -- 4406 ------------ 4407 4408 when Attribute_Output => 4409 Check_E2; 4410 Check_Stream_Attribute (TSS_Stream_Output); 4411 Set_Etype (N, Standard_Void_Type); 4412 Resolve (N, Standard_Void_Type); 4413 4414 ------------------ 4415 -- Partition_ID -- 4416 ------------------ 4417 4418 when Attribute_Partition_ID => Partition_Id : 4419 begin 4420 Check_E0; 4421 4422 if P_Type /= Any_Type then 4423 if not Is_Library_Level_Entity (Entity (P)) then 4424 Error_Attr_P 4425 ("prefix of % attribute must be library-level entity"); 4426 4427 -- The defining entity of prefix should not be declared inside a 4428 -- Pure unit. RM E.1(8). Is_Pure was set during declaration. 4429 4430 elsif Is_Entity_Name (P) 4431 and then Is_Pure (Entity (P)) 4432 then 4433 Error_Attr_P ("prefix of% attribute must not be declared pure"); 4434 end if; 4435 end if; 4436 4437 Set_Etype (N, Universal_Integer); 4438 end Partition_Id; 4439 4440 ------------------------- 4441 -- Passed_By_Reference -- 4442 ------------------------- 4443 4444 when Attribute_Passed_By_Reference => 4445 Check_E0; 4446 Check_Type; 4447 Set_Etype (N, Standard_Boolean); 4448 4449 ------------------ 4450 -- Pool_Address -- 4451 ------------------ 4452 4453 when Attribute_Pool_Address => 4454 Check_E0; 4455 Set_Etype (N, RTE (RE_Address)); 4456 4457 --------- 4458 -- Pos -- 4459 --------- 4460 4461 when Attribute_Pos => 4462 Check_Discrete_Type; 4463 Check_E1; 4464 4465 if Is_Boolean_Type (P_Type) then 4466 Error_Msg_Name_1 := Aname; 4467 Error_Msg_Name_2 := Chars (P_Type); 4468 Check_SPARK_Restriction 4469 ("attribute% is not allowed for type%", P); 4470 end if; 4471 4472 Resolve (E1, P_Base_Type); 4473 Set_Etype (N, Universal_Integer); 4474 4475 -------------- 4476 -- Position -- 4477 -------------- 4478 4479 when Attribute_Position => 4480 Check_Component; 4481 Set_Etype (N, Universal_Integer); 4482 4483 ---------- 4484 -- Pred -- 4485 ---------- 4486 4487 when Attribute_Pred => 4488 Check_Scalar_Type; 4489 Check_E1; 4490 4491 if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then 4492 Error_Msg_Name_1 := Aname; 4493 Error_Msg_Name_2 := Chars (P_Type); 4494 Check_SPARK_Restriction 4495 ("attribute% is not allowed for type%", P); 4496 end if; 4497 4498 Resolve (E1, P_Base_Type); 4499 Set_Etype (N, P_Base_Type); 4500 4501 -- Nothing to do for real type case 4502 4503 if Is_Real_Type (P_Type) then 4504 null; 4505 4506 -- If not modular type, test for overflow check required 4507 4508 else 4509 if not Is_Modular_Integer_Type (P_Type) 4510 and then not Range_Checks_Suppressed (P_Base_Type) 4511 then 4512 Enable_Range_Check (E1); 4513 end if; 4514 end if; 4515 4516 -------------- 4517 -- Priority -- 4518 -------------- 4519 4520 -- Ada 2005 (AI-327): Dynamic ceiling priorities 4521 4522 when Attribute_Priority => 4523 if Ada_Version < Ada_2005 then 4524 Error_Attr ("% attribute is allowed only in Ada 2005 mode", P); 4525 end if; 4526 4527 Check_E0; 4528 4529 -- The prefix must be a protected object (AARM D.5.2 (2/2)) 4530 4531 Analyze (P); 4532 4533 if Is_Protected_Type (Etype (P)) 4534 or else (Is_Access_Type (Etype (P)) 4535 and then Is_Protected_Type (Designated_Type (Etype (P)))) 4536 then 4537 Resolve (P, Etype (P)); 4538 else 4539 Error_Attr_P ("prefix of % attribute must be a protected object"); 4540 end if; 4541 4542 Set_Etype (N, Standard_Integer); 4543 4544 -- Must be called from within a protected procedure or entry of the 4545 -- protected object. 4546 4547 declare 4548 S : Entity_Id; 4549 4550 begin 4551 S := Current_Scope; 4552 while S /= Etype (P) 4553 and then S /= Standard_Standard 4554 loop 4555 S := Scope (S); 4556 end loop; 4557 4558 if S = Standard_Standard then 4559 Error_Attr ("the attribute % is only allowed inside protected " 4560 & "operations", P); 4561 end if; 4562 end; 4563 4564 Validate_Non_Static_Attribute_Function_Call; 4565 4566 ----------- 4567 -- Range -- 4568 ----------- 4569 4570 when Attribute_Range => 4571 Check_Array_Or_Scalar_Type; 4572 Bad_Attribute_For_Predicate; 4573 4574 if Ada_Version = Ada_83 4575 and then Is_Scalar_Type (P_Type) 4576 and then Comes_From_Source (N) 4577 then 4578 Error_Attr 4579 ("(Ada 83) % attribute not allowed for scalar type", P); 4580 end if; 4581 4582 ------------ 4583 -- Result -- 4584 ------------ 4585 4586 when Attribute_Result => Result : declare 4587 CS : Entity_Id; 4588 -- The enclosing scope, excluding loops for quantified expressions 4589 4590 PS : Entity_Id; 4591 -- During analysis, CS is the postcondition subprogram and PS the 4592 -- source subprogram to which the postcondition applies. During 4593 -- pre-analysis, CS is the scope of the subprogram declaration. 4594 4595 Prag : Node_Id; 4596 -- During pre-analysis, Prag is the enclosing pragma node if any 4597 4598 begin 4599 -- Find the proper enclosing scope 4600 4601 CS := Current_Scope; 4602 while Present (CS) loop 4603 4604 -- Skip generated loops 4605 4606 if Ekind (CS) = E_Loop then 4607 CS := Scope (CS); 4608 4609 -- Skip the special _Parent scope generated to capture references 4610 -- to formals during the process of subprogram inlining. 4611 4612 elsif Ekind (CS) = E_Function 4613 and then Chars (CS) = Name_uParent 4614 then 4615 CS := Scope (CS); 4616 else 4617 exit; 4618 end if; 4619 end loop; 4620 4621 PS := Scope (CS); 4622 4623 -- If the enclosing subprogram is always inlined, the enclosing 4624 -- postcondition will not be propagated to the expanded call. 4625 4626 if not In_Spec_Expression 4627 and then Has_Pragma_Inline_Always (PS) 4628 and then Warn_On_Redundant_Constructs 4629 then 4630 Error_Msg_N 4631 ("postconditions on inlined functions not enforced?r?", N); 4632 end if; 4633 4634 -- If we are in the scope of a function and in Spec_Expression mode, 4635 -- this is likely the prescan of the postcondition (or contract case, 4636 -- or test case) pragma, and we just set the proper type. If there is 4637 -- an error it will be caught when the real Analyze call is done. 4638 4639 if Ekind (CS) = E_Function 4640 and then In_Spec_Expression 4641 then 4642 -- Check OK prefix 4643 4644 if Chars (CS) /= Chars (P) then 4645 Error_Msg_Name_1 := Name_Result; 4646 4647 Error_Msg_NE 4648 ("incorrect prefix for % attribute, expected &", P, CS); 4649 Error_Attr; 4650 end if; 4651 4652 -- Check in postcondition or Ensures clause of function 4653 4654 Prag := N; 4655 while not Nkind_In (Prag, N_Pragma, 4656 N_Function_Specification, 4657 N_Subprogram_Body) 4658 loop 4659 Prag := Parent (Prag); 4660 end loop; 4661 4662 if Nkind (Prag) /= N_Pragma then 4663 Error_Attr 4664 ("% attribute can only appear in postcondition of function", 4665 P); 4666 4667 elsif Get_Pragma_Id (Prag) = Pragma_Contract_Case 4668 or else 4669 Get_Pragma_Id (Prag) = Pragma_Test_Case 4670 then 4671 declare 4672 Arg_Ens : constant Node_Id := 4673 Get_Ensures_From_CTC_Pragma (Prag); 4674 Arg : Node_Id; 4675 4676 begin 4677 Arg := N; 4678 while Arg /= Prag and Arg /= Arg_Ens loop 4679 Arg := Parent (Arg); 4680 end loop; 4681 4682 if Arg /= Arg_Ens then 4683 if Get_Pragma_Id (Prag) = Pragma_Contract_Case then 4684 Error_Attr 4685 ("% attribute misplaced inside contract case", P); 4686 else 4687 Error_Attr 4688 ("% attribute misplaced inside test case", P); 4689 end if; 4690 end if; 4691 end; 4692 4693 elsif Get_Pragma_Id (Prag) /= Pragma_Postcondition then 4694 Error_Attr 4695 ("% attribute can only appear in postcondition of function", 4696 P); 4697 end if; 4698 4699 -- The attribute reference is a primary. If expressions follow, 4700 -- the attribute reference is really an indexable object, so 4701 -- rewrite and analyze as an indexed component. 4702 4703 if Present (E1) then 4704 Rewrite (N, 4705 Make_Indexed_Component (Loc, 4706 Prefix => 4707 Make_Attribute_Reference (Loc, 4708 Prefix => Relocate_Node (Prefix (N)), 4709 Attribute_Name => Name_Result), 4710 Expressions => Expressions (N))); 4711 Analyze (N); 4712 return; 4713 end if; 4714 4715 Set_Etype (N, Etype (CS)); 4716 4717 -- If several functions with that name are visible, 4718 -- the intended one is the current scope. 4719 4720 if Is_Overloaded (P) then 4721 Set_Entity (P, CS); 4722 Set_Is_Overloaded (P, False); 4723 end if; 4724 4725 -- Body case, where we must be inside a generated _Postcondition 4726 -- procedure, and the prefix must be on the scope stack, or else the 4727 -- attribute use is definitely misplaced. The postcondition itself 4728 -- may have generated transient scopes, and is not necessarily the 4729 -- current one. 4730 4731 else 4732 while Present (CS) and then CS /= Standard_Standard loop 4733 if Chars (CS) = Name_uPostconditions then 4734 exit; 4735 else 4736 CS := Scope (CS); 4737 end if; 4738 end loop; 4739 4740 PS := Scope (CS); 4741 4742 if Chars (CS) = Name_uPostconditions 4743 and then Ekind (PS) = E_Function 4744 then 4745 -- Check OK prefix 4746 4747 if Nkind_In (P, N_Identifier, N_Operator_Symbol) 4748 and then Chars (P) = Chars (PS) 4749 then 4750 null; 4751 4752 -- Within an instance, the prefix designates the local renaming 4753 -- of the original generic. 4754 4755 elsif Is_Entity_Name (P) 4756 and then Ekind (Entity (P)) = E_Function 4757 and then Present (Alias (Entity (P))) 4758 and then Chars (Alias (Entity (P))) = Chars (PS) 4759 then 4760 null; 4761 4762 else 4763 Error_Msg_NE 4764 ("incorrect prefix for % attribute, expected &", P, PS); 4765 Error_Attr; 4766 end if; 4767 4768 Rewrite (N, Make_Identifier (Sloc (N), Name_uResult)); 4769 Analyze_And_Resolve (N, Etype (PS)); 4770 4771 else 4772 Error_Attr 4773 ("% attribute can only appear in postcondition of function", 4774 P); 4775 end if; 4776 end if; 4777 end Result; 4778 4779 ------------------ 4780 -- Range_Length -- 4781 ------------------ 4782 4783 when Attribute_Range_Length => 4784 Check_E0; 4785 Check_Discrete_Type; 4786 Set_Etype (N, Universal_Integer); 4787 4788 ---------- 4789 -- Read -- 4790 ---------- 4791 4792 when Attribute_Read => 4793 Check_E2; 4794 Check_Stream_Attribute (TSS_Stream_Read); 4795 Set_Etype (N, Standard_Void_Type); 4796 Resolve (N, Standard_Void_Type); 4797 Note_Possible_Modification (E2, Sure => True); 4798 4799 --------- 4800 -- Ref -- 4801 --------- 4802 4803 when Attribute_Ref => 4804 Check_E1; 4805 Analyze (P); 4806 4807 if Nkind (P) /= N_Expanded_Name 4808 or else not Is_RTE (P_Type, RE_Address) 4809 then 4810 Error_Attr_P ("prefix of % attribute must be System.Address"); 4811 end if; 4812 4813 Analyze_And_Resolve (E1, Any_Integer); 4814 Set_Etype (N, RTE (RE_Address)); 4815 4816 --------------- 4817 -- Remainder -- 4818 --------------- 4819 4820 when Attribute_Remainder => 4821 Check_Floating_Point_Type_2; 4822 Set_Etype (N, P_Base_Type); 4823 Resolve (E1, P_Base_Type); 4824 Resolve (E2, P_Base_Type); 4825 4826 ----------- 4827 -- Round -- 4828 ----------- 4829 4830 when Attribute_Round => 4831 Check_E1; 4832 Check_Decimal_Fixed_Point_Type; 4833 Set_Etype (N, P_Base_Type); 4834 4835 -- Because the context is universal_real (3.5.10(12)) it is a 4836 -- legal context for a universal fixed expression. This is the 4837 -- only attribute whose functional description involves U_R. 4838 4839 if Etype (E1) = Universal_Fixed then 4840 declare 4841 Conv : constant Node_Id := Make_Type_Conversion (Loc, 4842 Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc), 4843 Expression => Relocate_Node (E1)); 4844 4845 begin 4846 Rewrite (E1, Conv); 4847 Analyze (E1); 4848 end; 4849 end if; 4850 4851 Resolve (E1, Any_Real); 4852 4853 -------------- 4854 -- Rounding -- 4855 -------------- 4856 4857 when Attribute_Rounding => 4858 Check_Floating_Point_Type_1; 4859 Set_Etype (N, P_Base_Type); 4860 Resolve (E1, P_Base_Type); 4861 4862 --------------- 4863 -- Safe_Emax -- 4864 --------------- 4865 4866 when Attribute_Safe_Emax => 4867 Check_Floating_Point_Type_0; 4868 Set_Etype (N, Universal_Integer); 4869 4870 ---------------- 4871 -- Safe_First -- 4872 ---------------- 4873 4874 when Attribute_Safe_First => 4875 Check_Floating_Point_Type_0; 4876 Set_Etype (N, Universal_Real); 4877 4878 ---------------- 4879 -- Safe_Large -- 4880 ---------------- 4881 4882 when Attribute_Safe_Large => 4883 Check_E0; 4884 Check_Real_Type; 4885 Set_Etype (N, Universal_Real); 4886 4887 --------------- 4888 -- Safe_Last -- 4889 --------------- 4890 4891 when Attribute_Safe_Last => 4892 Check_Floating_Point_Type_0; 4893 Set_Etype (N, Universal_Real); 4894 4895 ---------------- 4896 -- Safe_Small -- 4897 ---------------- 4898 4899 when Attribute_Safe_Small => 4900 Check_E0; 4901 Check_Real_Type; 4902 Set_Etype (N, Universal_Real); 4903 4904 ------------------ 4905 -- Same_Storage -- 4906 ------------------ 4907 4908 when Attribute_Same_Storage => 4909 Check_Ada_2012_Attribute; 4910 Check_E1; 4911 4912 -- The arguments must be objects of any type 4913 4914 Analyze_And_Resolve (P); 4915 Analyze_And_Resolve (E1); 4916 Check_Object_Reference (P); 4917 Check_Object_Reference (E1); 4918 Set_Etype (N, Standard_Boolean); 4919 4920 -------------------------- 4921 -- Scalar_Storage_Order -- 4922 -------------------------- 4923 4924 when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : 4925 begin 4926 Check_E0; 4927 Check_Type; 4928 4929 if not Is_Record_Type (P_Type) or else Is_Array_Type (P_Type) then 4930 Error_Attr_P 4931 ("prefix of % attribute must be record or array type"); 4932 end if; 4933 4934 if Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then 4935 Rewrite (N, 4936 New_Occurrence_Of (RTE (RE_High_Order_First), Loc)); 4937 else 4938 Rewrite (N, 4939 New_Occurrence_Of (RTE (RE_Low_Order_First), Loc)); 4940 end if; 4941 4942 Set_Etype (N, RTE (RE_Bit_Order)); 4943 Resolve (N); 4944 4945 -- Reset incorrect indication of staticness 4946 4947 Set_Is_Static_Expression (N, False); 4948 end Scalar_Storage_Order; 4949 4950 ----------- 4951 -- Scale -- 4952 ----------- 4953 4954 when Attribute_Scale => 4955 Check_E0; 4956 Check_Decimal_Fixed_Point_Type; 4957 Set_Etype (N, Universal_Integer); 4958 4959 ------------- 4960 -- Scaling -- 4961 ------------- 4962 4963 when Attribute_Scaling => 4964 Check_Floating_Point_Type_2; 4965 Set_Etype (N, P_Base_Type); 4966 Resolve (E1, P_Base_Type); 4967 4968 ------------------ 4969 -- Signed_Zeros -- 4970 ------------------ 4971 4972 when Attribute_Signed_Zeros => 4973 Check_Floating_Point_Type_0; 4974 Set_Etype (N, Standard_Boolean); 4975 4976 ---------- 4977 -- Size -- 4978 ---------- 4979 4980 when Attribute_Size | Attribute_VADS_Size => Size : 4981 begin 4982 Check_E0; 4983 4984 -- If prefix is parameterless function call, rewrite and resolve 4985 -- as such. 4986 4987 if Is_Entity_Name (P) 4988 and then Ekind (Entity (P)) = E_Function 4989 then 4990 Resolve (P); 4991 4992 -- Similar processing for a protected function call 4993 4994 elsif Nkind (P) = N_Selected_Component 4995 and then Ekind (Entity (Selector_Name (P))) = E_Function 4996 then 4997 Resolve (P); 4998 end if; 4999 5000 if Is_Object_Reference (P) then 5001 Check_Object_Reference (P); 5002 5003 elsif Is_Entity_Name (P) 5004 and then (Is_Type (Entity (P)) 5005 or else Ekind (Entity (P)) = E_Enumeration_Literal) 5006 then 5007 null; 5008 5009 elsif Nkind (P) = N_Type_Conversion 5010 and then not Comes_From_Source (P) 5011 then 5012 null; 5013 5014 else 5015 Error_Attr_P ("invalid prefix for % attribute"); 5016 end if; 5017 5018 Check_Not_Incomplete_Type; 5019 Check_Not_CPP_Type; 5020 Set_Etype (N, Universal_Integer); 5021 end Size; 5022 5023 ----------- 5024 -- Small -- 5025 ----------- 5026 5027 when Attribute_Small => 5028 Check_E0; 5029 Check_Real_Type; 5030 Set_Etype (N, Universal_Real); 5031 5032 ------------------ 5033 -- Storage_Pool -- 5034 ------------------ 5035 5036 when Attribute_Storage_Pool | 5037 Attribute_Simple_Storage_Pool => Storage_Pool : 5038 begin 5039 Check_E0; 5040 5041 if Is_Access_Type (P_Type) then 5042 if Ekind (P_Type) = E_Access_Subprogram_Type then 5043 Error_Attr_P 5044 ("cannot use % attribute for access-to-subprogram type"); 5045 end if; 5046 5047 -- Set appropriate entity 5048 5049 if Present (Associated_Storage_Pool (Root_Type (P_Type))) then 5050 Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type))); 5051 else 5052 Set_Entity (N, RTE (RE_Global_Pool_Object)); 5053 end if; 5054 5055 if Attr_Id = Attribute_Storage_Pool then 5056 if Present (Get_Rep_Pragma (Etype (Entity (N)), 5057 Name_Simple_Storage_Pool_Type)) 5058 then 5059 Error_Msg_Name_1 := Aname; 5060 Error_Msg_N ("cannot use % attribute for type with simple " 5061 & "storage pool??", N); 5062 Error_Msg_N 5063 ("\Program_Error will be raised at run time??", N); 5064 5065 Rewrite 5066 (N, Make_Raise_Program_Error 5067 (Sloc (N), Reason => PE_Explicit_Raise)); 5068 end if; 5069 5070 Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 5071 5072 -- In the Simple_Storage_Pool case, verify that the pool entity is 5073 -- actually of a simple storage pool type, and set the attribute's 5074 -- type to the pool object's type. 5075 5076 else 5077 if not Present (Get_Rep_Pragma (Etype (Entity (N)), 5078 Name_Simple_Storage_Pool_Type)) 5079 then 5080 Error_Attr_P 5081 ("cannot use % attribute for type without simple " & 5082 "storage pool"); 5083 end if; 5084 5085 Set_Etype (N, Etype (Entity (N))); 5086 end if; 5087 5088 -- Validate_Remote_Access_To_Class_Wide_Type for attribute 5089 -- Storage_Pool since this attribute is not defined for such 5090 -- types (RM E.2.3(22)). 5091 5092 Validate_Remote_Access_To_Class_Wide_Type (N); 5093 5094 else 5095 Error_Attr_P ("prefix of % attribute must be access type"); 5096 end if; 5097 end Storage_Pool; 5098 5099 ------------------ 5100 -- Storage_Size -- 5101 ------------------ 5102 5103 when Attribute_Storage_Size => Storage_Size : 5104 begin 5105 Check_E0; 5106 5107 if Is_Task_Type (P_Type) then 5108 Set_Etype (N, Universal_Integer); 5109 5110 -- Use with tasks is an obsolescent feature 5111 5112 Check_Restriction (No_Obsolescent_Features, P); 5113 5114 elsif Is_Access_Type (P_Type) then 5115 if Ekind (P_Type) = E_Access_Subprogram_Type then 5116 Error_Attr_P 5117 ("cannot use % attribute for access-to-subprogram type"); 5118 end if; 5119 5120 if Is_Entity_Name (P) 5121 and then Is_Type (Entity (P)) 5122 then 5123 Check_Type; 5124 Set_Etype (N, Universal_Integer); 5125 5126 -- Validate_Remote_Access_To_Class_Wide_Type for attribute 5127 -- Storage_Size since this attribute is not defined for 5128 -- such types (RM E.2.3(22)). 5129 5130 Validate_Remote_Access_To_Class_Wide_Type (N); 5131 5132 -- The prefix is allowed to be an implicit dereference of an 5133 -- access value designating a task. 5134 5135 else 5136 Check_Task_Prefix; 5137 Set_Etype (N, Universal_Integer); 5138 end if; 5139 5140 else 5141 Error_Attr_P ("prefix of % attribute must be access or task type"); 5142 end if; 5143 end Storage_Size; 5144 5145 ------------------ 5146 -- Storage_Unit -- 5147 ------------------ 5148 5149 when Attribute_Storage_Unit => 5150 Standard_Attribute (Ttypes.System_Storage_Unit); 5151 5152 ----------------- 5153 -- Stream_Size -- 5154 ----------------- 5155 5156 when Attribute_Stream_Size => 5157 Check_E0; 5158 Check_Type; 5159 5160 if Is_Entity_Name (P) 5161 and then Is_Elementary_Type (Entity (P)) 5162 then 5163 Set_Etype (N, Universal_Integer); 5164 else 5165 Error_Attr_P ("invalid prefix for % attribute"); 5166 end if; 5167 5168 --------------- 5169 -- Stub_Type -- 5170 --------------- 5171 5172 when Attribute_Stub_Type => 5173 Check_Type; 5174 Check_E0; 5175 5176 if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then 5177 5178 -- For a real RACW [sub]type, use corresponding stub type 5179 5180 if not Is_Generic_Type (P_Type) then 5181 Rewrite (N, 5182 New_Occurrence_Of 5183 (Corresponding_Stub_Type (Base_Type (P_Type)), Loc)); 5184 5185 -- For a generic type (that has been marked as an RACW using the 5186 -- Remote_Access_Type aspect or pragma), use a generic RACW stub 5187 -- type. Note that if the actual is not a remote access type, the 5188 -- instantiation will fail. 5189 5190 else 5191 -- Note: we go to the underlying type here because the view 5192 -- returned by RTE (RE_RACW_Stub_Type) might be incomplete. 5193 5194 Rewrite (N, 5195 New_Occurrence_Of 5196 (Underlying_Type (RTE (RE_RACW_Stub_Type)), Loc)); 5197 end if; 5198 5199 else 5200 Error_Attr_P 5201 ("prefix of% attribute must be remote access to classwide"); 5202 end if; 5203 5204 ---------- 5205 -- Succ -- 5206 ---------- 5207 5208 when Attribute_Succ => 5209 Check_Scalar_Type; 5210 Check_E1; 5211 5212 if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then 5213 Error_Msg_Name_1 := Aname; 5214 Error_Msg_Name_2 := Chars (P_Type); 5215 Check_SPARK_Restriction 5216 ("attribute% is not allowed for type%", P); 5217 end if; 5218 5219 Resolve (E1, P_Base_Type); 5220 Set_Etype (N, P_Base_Type); 5221 5222 -- Nothing to do for real type case 5223 5224 if Is_Real_Type (P_Type) then 5225 null; 5226 5227 -- If not modular type, test for overflow check required 5228 5229 else 5230 if not Is_Modular_Integer_Type (P_Type) 5231 and then not Range_Checks_Suppressed (P_Base_Type) 5232 then 5233 Enable_Range_Check (E1); 5234 end if; 5235 end if; 5236 5237 -------------------------------- 5238 -- System_Allocator_Alignment -- 5239 -------------------------------- 5240 5241 when Attribute_System_Allocator_Alignment => 5242 Standard_Attribute (Ttypes.System_Allocator_Alignment); 5243 5244 --------- 5245 -- Tag -- 5246 --------- 5247 5248 when Attribute_Tag => Tag : 5249 begin 5250 Check_E0; 5251 Check_Dereference; 5252 5253 if not Is_Tagged_Type (P_Type) then 5254 Error_Attr_P ("prefix of % attribute must be tagged"); 5255 5256 -- Next test does not apply to generated code why not, and what does 5257 -- the illegal reference mean??? 5258 5259 elsif Is_Object_Reference (P) 5260 and then not Is_Class_Wide_Type (P_Type) 5261 and then Comes_From_Source (N) 5262 then 5263 Error_Attr_P 5264 ("% attribute can only be applied to objects " & 5265 "of class - wide type"); 5266 end if; 5267 5268 -- The prefix cannot be an incomplete type. However, references to 5269 -- 'Tag can be generated when expanding interface conversions, and 5270 -- this is legal. 5271 5272 if Comes_From_Source (N) then 5273 Check_Not_Incomplete_Type; 5274 end if; 5275 5276 -- Set appropriate type 5277 5278 Set_Etype (N, RTE (RE_Tag)); 5279 end Tag; 5280 5281 ----------------- 5282 -- Target_Name -- 5283 ----------------- 5284 5285 when Attribute_Target_Name => Target_Name : declare 5286 TN : constant String := Sdefault.Target_Name.all; 5287 TL : Natural; 5288 5289 begin 5290 Check_Standard_Prefix; 5291 5292 TL := TN'Last; 5293 5294 if TN (TL) = '/' or else TN (TL) = '\' then 5295 TL := TL - 1; 5296 end if; 5297 5298 Rewrite (N, 5299 Make_String_Literal (Loc, 5300 Strval => TN (TN'First .. TL))); 5301 Analyze_And_Resolve (N, Standard_String); 5302 end Target_Name; 5303 5304 ---------------- 5305 -- Terminated -- 5306 ---------------- 5307 5308 when Attribute_Terminated => 5309 Check_E0; 5310 Set_Etype (N, Standard_Boolean); 5311 Check_Task_Prefix; 5312 5313 ---------------- 5314 -- To_Address -- 5315 ---------------- 5316 5317 when Attribute_To_Address => 5318 Check_E1; 5319 Analyze (P); 5320 5321 if Nkind (P) /= N_Identifier 5322 or else Chars (P) /= Name_System 5323 then 5324 Error_Attr_P ("prefix of % attribute must be System"); 5325 end if; 5326 5327 Generate_Reference (RTE (RE_Address), P); 5328 Analyze_And_Resolve (E1, Any_Integer); 5329 Set_Etype (N, RTE (RE_Address)); 5330 5331 ------------ 5332 -- To_Any -- 5333 ------------ 5334 5335 when Attribute_To_Any => 5336 Check_E1; 5337 Check_PolyORB_Attribute; 5338 Set_Etype (N, RTE (RE_Any)); 5339 5340 ---------------- 5341 -- Truncation -- 5342 ---------------- 5343 5344 when Attribute_Truncation => 5345 Check_Floating_Point_Type_1; 5346 Resolve (E1, P_Base_Type); 5347 Set_Etype (N, P_Base_Type); 5348 5349 ---------------- 5350 -- Type_Class -- 5351 ---------------- 5352 5353 when Attribute_Type_Class => 5354 Check_E0; 5355 Check_Type; 5356 Check_Not_Incomplete_Type; 5357 Set_Etype (N, RTE (RE_Type_Class)); 5358 5359 -------------- 5360 -- TypeCode -- 5361 -------------- 5362 5363 when Attribute_TypeCode => 5364 Check_E0; 5365 Check_PolyORB_Attribute; 5366 Set_Etype (N, RTE (RE_TypeCode)); 5367 5368 -------------- 5369 -- Type_Key -- 5370 -------------- 5371 5372 when Attribute_Type_Key => 5373 Check_E0; 5374 Check_Type; 5375 5376 -- This processing belongs in Eval_Attribute ??? 5377 5378 declare 5379 function Type_Key return String_Id; 5380 -- A very preliminary implementation. For now, a signature 5381 -- consists of only the type name. This is clearly incomplete 5382 -- (e.g., adding a new field to a record type should change the 5383 -- type's Type_Key attribute). 5384 5385 -------------- 5386 -- Type_Key -- 5387 -------------- 5388 5389 function Type_Key return String_Id is 5390 Full_Name : constant String_Id := 5391 Fully_Qualified_Name_String (Entity (P)); 5392 5393 begin 5394 -- Copy all characters in Full_Name but the trailing NUL 5395 5396 Start_String; 5397 for J in 1 .. String_Length (Full_Name) - 1 loop 5398 Store_String_Char (Get_String_Char (Full_Name, Int (J))); 5399 end loop; 5400 5401 Store_String_Chars ("'Type_Key"); 5402 return End_String; 5403 end Type_Key; 5404 5405 begin 5406 Rewrite (N, Make_String_Literal (Loc, Type_Key)); 5407 end; 5408 5409 Analyze_And_Resolve (N, Standard_String); 5410 5411 ----------------- 5412 -- UET_Address -- 5413 ----------------- 5414 5415 when Attribute_UET_Address => 5416 Check_E0; 5417 Check_Unit_Name (P); 5418 Set_Etype (N, RTE (RE_Address)); 5419 5420 ----------------------- 5421 -- Unbiased_Rounding -- 5422 ----------------------- 5423 5424 when Attribute_Unbiased_Rounding => 5425 Check_Floating_Point_Type_1; 5426 Set_Etype (N, P_Base_Type); 5427 Resolve (E1, P_Base_Type); 5428 5429 ---------------------- 5430 -- Unchecked_Access -- 5431 ---------------------- 5432 5433 when Attribute_Unchecked_Access => 5434 if Comes_From_Source (N) then 5435 Check_Restriction (No_Unchecked_Access, N); 5436 end if; 5437 5438 Analyze_Access_Attribute; 5439 5440 ------------------------- 5441 -- Unconstrained_Array -- 5442 ------------------------- 5443 5444 when Attribute_Unconstrained_Array => 5445 Check_E0; 5446 Check_Type; 5447 Check_Not_Incomplete_Type; 5448 Set_Etype (N, Standard_Boolean); 5449 5450 ------------------------------ 5451 -- Universal_Literal_String -- 5452 ------------------------------ 5453 5454 -- This is a GNAT specific attribute whose prefix must be a named 5455 -- number where the expression is either a single numeric literal, 5456 -- or a numeric literal immediately preceded by a minus sign. The 5457 -- result is equivalent to a string literal containing the text of 5458 -- the literal as it appeared in the source program with a possible 5459 -- leading minus sign. 5460 5461 when Attribute_Universal_Literal_String => Universal_Literal_String : 5462 begin 5463 Check_E0; 5464 5465 if not Is_Entity_Name (P) 5466 or else Ekind (Entity (P)) not in Named_Kind 5467 then 5468 Error_Attr_P ("prefix for % attribute must be named number"); 5469 5470 else 5471 declare 5472 Expr : Node_Id; 5473 Negative : Boolean; 5474 S : Source_Ptr; 5475 Src : Source_Buffer_Ptr; 5476 5477 begin 5478 Expr := Original_Node (Expression (Parent (Entity (P)))); 5479 5480 if Nkind (Expr) = N_Op_Minus then 5481 Negative := True; 5482 Expr := Original_Node (Right_Opnd (Expr)); 5483 else 5484 Negative := False; 5485 end if; 5486 5487 if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then 5488 Error_Attr 5489 ("named number for % attribute must be simple literal", N); 5490 end if; 5491 5492 -- Build string literal corresponding to source literal text 5493 5494 Start_String; 5495 5496 if Negative then 5497 Store_String_Char (Get_Char_Code ('-')); 5498 end if; 5499 5500 S := Sloc (Expr); 5501 Src := Source_Text (Get_Source_File_Index (S)); 5502 5503 while Src (S) /= ';' and then Src (S) /= ' ' loop 5504 Store_String_Char (Get_Char_Code (Src (S))); 5505 S := S + 1; 5506 end loop; 5507 5508 -- Now we rewrite the attribute with the string literal 5509 5510 Rewrite (N, 5511 Make_String_Literal (Loc, End_String)); 5512 Analyze (N); 5513 end; 5514 end if; 5515 end Universal_Literal_String; 5516 5517 ------------------------- 5518 -- Unrestricted_Access -- 5519 ------------------------- 5520 5521 -- This is a GNAT specific attribute which is like Access except that 5522 -- all scope checks and checks for aliased views are omitted. 5523 5524 when Attribute_Unrestricted_Access => 5525 5526 -- If from source, deal with relevant restrictions 5527 5528 if Comes_From_Source (N) then 5529 Check_Restriction (No_Unchecked_Access, N); 5530 5531 if Nkind (P) in N_Has_Entity 5532 and then Present (Entity (P)) 5533 and then Is_Object (Entity (P)) 5534 then 5535 Check_Restriction (No_Implicit_Aliasing, N); 5536 end if; 5537 end if; 5538 5539 if Is_Entity_Name (P) then 5540 Set_Address_Taken (Entity (P)); 5541 end if; 5542 5543 Analyze_Access_Attribute; 5544 5545 ------------ 5546 -- Update -- 5547 ------------ 5548 5549 when Attribute_Update => Update : declare 5550 Comps : Elist_Id := No_Elist; 5551 5552 procedure Check_Component_Reference 5553 (Comp : Entity_Id; 5554 Typ : Entity_Id); 5555 -- Comp is a record component (possibly a discriminant) and Typ is a 5556 -- record type. Determine whether Comp is a legal component of Typ. 5557 -- Emit an error if Comp mentions a discriminant or is not a unique 5558 -- component reference in the update aggregate. 5559 5560 ------------------------------- 5561 -- Check_Component_Reference -- 5562 ------------------------------- 5563 5564 procedure Check_Component_Reference 5565 (Comp : Entity_Id; 5566 Typ : Entity_Id) 5567 is 5568 Comp_Name : constant Name_Id := Chars (Comp); 5569 5570 function Is_Duplicate_Component return Boolean; 5571 -- Determine whether component Comp already appears in list Comps 5572 5573 ---------------------------- 5574 -- Is_Duplicate_Component -- 5575 ---------------------------- 5576 5577 function Is_Duplicate_Component return Boolean is 5578 Comp_Elmt : Elmt_Id; 5579 5580 begin 5581 if Present (Comps) then 5582 Comp_Elmt := First_Elmt (Comps); 5583 while Present (Comp_Elmt) loop 5584 if Chars (Node (Comp_Elmt)) = Comp_Name then 5585 return True; 5586 end if; 5587 5588 Next_Elmt (Comp_Elmt); 5589 end loop; 5590 end if; 5591 5592 return False; 5593 end Is_Duplicate_Component; 5594 5595 -- Local variables 5596 5597 Comp_Or_Discr : Entity_Id; 5598 5599 -- Start of processing for Check_Component_Reference 5600 5601 begin 5602 -- Find the discriminant or component whose name corresponds to 5603 -- Comp. A simple character comparison is sufficient because all 5604 -- visible names within a record type are unique. 5605 5606 Comp_Or_Discr := First_Entity (Typ); 5607 while Present (Comp_Or_Discr) loop 5608 if Chars (Comp_Or_Discr) = Comp_Name then 5609 exit; 5610 end if; 5611 5612 Comp_Or_Discr := Next_Entity (Comp_Or_Discr); 5613 end loop; 5614 5615 -- Diagnose possible erroneous references 5616 5617 if Present (Comp_Or_Discr) then 5618 if Ekind (Comp_Or_Discr) = E_Discriminant then 5619 Error_Attr 5620 ("attribute % may not modify record discriminants", Comp); 5621 5622 else pragma Assert (Ekind (Comp_Or_Discr) = E_Component); 5623 if Is_Duplicate_Component then 5624 Error_Msg_NE ("component & already updated", Comp, Comp); 5625 5626 -- Mark this component as processed 5627 5628 else 5629 if No (Comps) then 5630 Comps := New_Elmt_List; 5631 end if; 5632 5633 Append_Elmt (Comp, Comps); 5634 end if; 5635 end if; 5636 5637 -- The update aggregate mentions an entity that does not belong to 5638 -- the record type. 5639 5640 else 5641 Error_Msg_NE 5642 ("& is not a component of aggregate subtype", Comp, Comp); 5643 end if; 5644 end Check_Component_Reference; 5645 5646 -- Local variables 5647 5648 Assoc : Node_Id; 5649 Comp : Node_Id; 5650 5651 -- Start of processing for Update 5652 5653 begin 5654 S14_Attribute; 5655 Check_E1; 5656 5657 if not Is_Object_Reference (P) then 5658 Error_Attr_P ("prefix of attribute % must denote an object"); 5659 5660 elsif not Is_Array_Type (P_Type) 5661 and then not Is_Record_Type (P_Type) 5662 then 5663 Error_Attr_P ("prefix of attribute % must be a record or array"); 5664 5665 elsif Is_Immutably_Limited_Type (P_Type) then 5666 Error_Attr ("prefix of attribute % cannot be limited", N); 5667 5668 elsif Nkind (E1) /= N_Aggregate then 5669 Error_Attr ("attribute % requires component association list", N); 5670 end if; 5671 5672 -- Inspect the update aggregate, looking at all the associations and 5673 -- choices. Perform the following checks: 5674 5675 -- 1) Legality of "others" in all cases 5676 -- 2) Component legality for records 5677 5678 -- The remaining checks are performed on the expanded attribute 5679 5680 Assoc := First (Component_Associations (E1)); 5681 while Present (Assoc) loop 5682 Comp := First (Choices (Assoc)); 5683 while Present (Comp) loop 5684 if Nkind (Comp) = N_Others_Choice then 5685 Error_Attr 5686 ("others choice not allowed in attribute %", Comp); 5687 5688 elsif Is_Record_Type (P_Type) then 5689 Check_Component_Reference (Comp, P_Type); 5690 end if; 5691 5692 Next (Comp); 5693 end loop; 5694 5695 Next (Assoc); 5696 end loop; 5697 5698 -- The type of attribute Update is that of the prefix 5699 5700 Set_Etype (N, P_Type); 5701 end Update; 5702 5703 --------- 5704 -- Val -- 5705 --------- 5706 5707 when Attribute_Val => Val : declare 5708 begin 5709 Check_E1; 5710 Check_Discrete_Type; 5711 5712 if Is_Boolean_Type (P_Type) then 5713 Error_Msg_Name_1 := Aname; 5714 Error_Msg_Name_2 := Chars (P_Type); 5715 Check_SPARK_Restriction 5716 ("attribute% is not allowed for type%", P); 5717 end if; 5718 5719 Resolve (E1, Any_Integer); 5720 Set_Etype (N, P_Base_Type); 5721 5722 -- Note, we need a range check in general, but we wait for the 5723 -- Resolve call to do this, since we want to let Eval_Attribute 5724 -- have a chance to find an static illegality first! 5725 end Val; 5726 5727 ----------- 5728 -- Valid -- 5729 ----------- 5730 5731 when Attribute_Valid => 5732 Check_E0; 5733 5734 -- Ignore check for object if we have a 'Valid reference generated 5735 -- by the expanded code, since in some cases valid checks can occur 5736 -- on items that are names, but are not objects (e.g. attributes). 5737 5738 if Comes_From_Source (N) then 5739 Check_Object_Reference (P); 5740 end if; 5741 5742 if not Is_Scalar_Type (P_Type) then 5743 Error_Attr_P ("object for % attribute must be of scalar type"); 5744 end if; 5745 5746 -- If the attribute appears within the subtype's own predicate 5747 -- function, then issue a warning that this will cause infinite 5748 -- recursion. 5749 5750 declare 5751 Pred_Func : constant Entity_Id := Predicate_Function (P_Type); 5752 5753 begin 5754 if Present (Pred_Func) and then Current_Scope = Pred_Func then 5755 Error_Msg_N 5756 ("attribute Valid requires a predicate check??", N); 5757 Error_Msg_N ("\and will result in infinite recursion??", N); 5758 end if; 5759 end; 5760 5761 Set_Etype (N, Standard_Boolean); 5762 5763 ------------------- 5764 -- Valid_Scalars -- 5765 ------------------- 5766 5767 when Attribute_Valid_Scalars => 5768 Check_E0; 5769 Check_Object_Reference (P); 5770 5771 if No_Scalar_Parts (P_Type) then 5772 Error_Attr_P ("??attribute % always True, no scalars to check"); 5773 end if; 5774 5775 Set_Etype (N, Standard_Boolean); 5776 5777 ----------- 5778 -- Value -- 5779 ----------- 5780 5781 when Attribute_Value => Value : 5782 begin 5783 Check_SPARK_Restriction_On_Attribute; 5784 Check_E1; 5785 Check_Scalar_Type; 5786 5787 -- Case of enumeration type 5788 5789 -- When an enumeration type appears in an attribute reference, all 5790 -- literals of the type are marked as referenced. This must only be 5791 -- done if the attribute reference appears in the current source. 5792 -- Otherwise the information on references may differ between a 5793 -- normal compilation and one that performs inlining. 5794 5795 if Is_Enumeration_Type (P_Type) 5796 and then In_Extended_Main_Code_Unit (N) 5797 then 5798 Check_Restriction (No_Enumeration_Maps, N); 5799 5800 -- Mark all enumeration literals as referenced, since the use of 5801 -- the Value attribute can implicitly reference any of the 5802 -- literals of the enumeration base type. 5803 5804 declare 5805 Ent : Entity_Id := First_Literal (P_Base_Type); 5806 begin 5807 while Present (Ent) loop 5808 Set_Referenced (Ent); 5809 Next_Literal (Ent); 5810 end loop; 5811 end; 5812 end if; 5813 5814 -- Set Etype before resolving expression because expansion of 5815 -- expression may require enclosing type. Note that the type 5816 -- returned by 'Value is the base type of the prefix type. 5817 5818 Set_Etype (N, P_Base_Type); 5819 Validate_Non_Static_Attribute_Function_Call; 5820 end Value; 5821 5822 ---------------- 5823 -- Value_Size -- 5824 ---------------- 5825 5826 when Attribute_Value_Size => 5827 Check_E0; 5828 Check_Type; 5829 Check_Not_Incomplete_Type; 5830 Set_Etype (N, Universal_Integer); 5831 5832 ------------- 5833 -- Version -- 5834 ------------- 5835 5836 when Attribute_Version => 5837 Check_E0; 5838 Check_Program_Unit; 5839 Set_Etype (N, RTE (RE_Version_String)); 5840 5841 ------------------ 5842 -- Wchar_T_Size -- 5843 ------------------ 5844 5845 when Attribute_Wchar_T_Size => 5846 Standard_Attribute (Interfaces_Wchar_T_Size); 5847 5848 ---------------- 5849 -- Wide_Image -- 5850 ---------------- 5851 5852 when Attribute_Wide_Image => Wide_Image : 5853 begin 5854 Check_SPARK_Restriction_On_Attribute; 5855 Check_Scalar_Type; 5856 Set_Etype (N, Standard_Wide_String); 5857 Check_E1; 5858 Resolve (E1, P_Base_Type); 5859 Validate_Non_Static_Attribute_Function_Call; 5860 end Wide_Image; 5861 5862 --------------------- 5863 -- Wide_Wide_Image -- 5864 --------------------- 5865 5866 when Attribute_Wide_Wide_Image => Wide_Wide_Image : 5867 begin 5868 Check_Scalar_Type; 5869 Set_Etype (N, Standard_Wide_Wide_String); 5870 Check_E1; 5871 Resolve (E1, P_Base_Type); 5872 Validate_Non_Static_Attribute_Function_Call; 5873 end Wide_Wide_Image; 5874 5875 ---------------- 5876 -- Wide_Value -- 5877 ---------------- 5878 5879 when Attribute_Wide_Value => Wide_Value : 5880 begin 5881 Check_SPARK_Restriction_On_Attribute; 5882 Check_E1; 5883 Check_Scalar_Type; 5884 5885 -- Set Etype before resolving expression because expansion 5886 -- of expression may require enclosing type. 5887 5888 Set_Etype (N, P_Type); 5889 Validate_Non_Static_Attribute_Function_Call; 5890 end Wide_Value; 5891 5892 --------------------- 5893 -- Wide_Wide_Value -- 5894 --------------------- 5895 5896 when Attribute_Wide_Wide_Value => Wide_Wide_Value : 5897 begin 5898 Check_E1; 5899 Check_Scalar_Type; 5900 5901 -- Set Etype before resolving expression because expansion 5902 -- of expression may require enclosing type. 5903 5904 Set_Etype (N, P_Type); 5905 Validate_Non_Static_Attribute_Function_Call; 5906 end Wide_Wide_Value; 5907 5908 --------------------- 5909 -- Wide_Wide_Width -- 5910 --------------------- 5911 5912 when Attribute_Wide_Wide_Width => 5913 Check_E0; 5914 Check_Scalar_Type; 5915 Set_Etype (N, Universal_Integer); 5916 5917 ---------------- 5918 -- Wide_Width -- 5919 ---------------- 5920 5921 when Attribute_Wide_Width => 5922 Check_SPARK_Restriction_On_Attribute; 5923 Check_E0; 5924 Check_Scalar_Type; 5925 Set_Etype (N, Universal_Integer); 5926 5927 ----------- 5928 -- Width -- 5929 ----------- 5930 5931 when Attribute_Width => 5932 Check_SPARK_Restriction_On_Attribute; 5933 Check_E0; 5934 Check_Scalar_Type; 5935 Set_Etype (N, Universal_Integer); 5936 5937 --------------- 5938 -- Word_Size -- 5939 --------------- 5940 5941 when Attribute_Word_Size => 5942 Standard_Attribute (System_Word_Size); 5943 5944 ----------- 5945 -- Write -- 5946 ----------- 5947 5948 when Attribute_Write => 5949 Check_E2; 5950 Check_Stream_Attribute (TSS_Stream_Write); 5951 Set_Etype (N, Standard_Void_Type); 5952 Resolve (N, Standard_Void_Type); 5953 5954 end case; 5955 5956 -- All errors raise Bad_Attribute, so that we get out before any further 5957 -- damage occurs when an error is detected (for example, if we check for 5958 -- one attribute expression, and the check succeeds, we want to be able 5959 -- to proceed securely assuming that an expression is in fact present. 5960 5961 -- Note: we set the attribute analyzed in this case to prevent any 5962 -- attempt at reanalysis which could generate spurious error msgs. 5963 5964 exception 5965 when Bad_Attribute => 5966 Set_Analyzed (N); 5967 Set_Etype (N, Any_Type); 5968 return; 5969 end Analyze_Attribute; 5970 5971 -------------------- 5972 -- Eval_Attribute -- 5973 -------------------- 5974 5975 procedure Eval_Attribute (N : Node_Id) is 5976 Loc : constant Source_Ptr := Sloc (N); 5977 Aname : constant Name_Id := Attribute_Name (N); 5978 Id : constant Attribute_Id := Get_Attribute_Id (Aname); 5979 P : constant Node_Id := Prefix (N); 5980 5981 C_Type : constant Entity_Id := Etype (N); 5982 -- The type imposed by the context 5983 5984 E1 : Node_Id; 5985 -- First expression, or Empty if none 5986 5987 E2 : Node_Id; 5988 -- Second expression, or Empty if none 5989 5990 P_Entity : Entity_Id; 5991 -- Entity denoted by prefix 5992 5993 P_Type : Entity_Id; 5994 -- The type of the prefix 5995 5996 P_Base_Type : Entity_Id; 5997 -- The base type of the prefix type 5998 5999 P_Root_Type : Entity_Id; 6000 -- The root type of the prefix type 6001 6002 Static : Boolean; 6003 -- True if the result is Static. This is set by the general processing 6004 -- to true if the prefix is static, and all expressions are static. It 6005 -- can be reset as processing continues for particular attributes 6006 6007 Lo_Bound, Hi_Bound : Node_Id; 6008 -- Expressions for low and high bounds of type or array index referenced 6009 -- by First, Last, or Length attribute for array, set by Set_Bounds. 6010 6011 CE_Node : Node_Id; 6012 -- Constraint error node used if we have an attribute reference has 6013 -- an argument that raises a constraint error. In this case we replace 6014 -- the attribute with a raise constraint_error node. This is important 6015 -- processing, since otherwise gigi might see an attribute which it is 6016 -- unprepared to deal with. 6017 6018 procedure Check_Concurrent_Discriminant (Bound : Node_Id); 6019 -- If Bound is a reference to a discriminant of a task or protected type 6020 -- occurring within the object's body, rewrite attribute reference into 6021 -- a reference to the corresponding discriminal. Use for the expansion 6022 -- of checks against bounds of entry family index subtypes. 6023 6024 procedure Check_Expressions; 6025 -- In case where the attribute is not foldable, the expressions, if 6026 -- any, of the attribute, are in a non-static context. This procedure 6027 -- performs the required additional checks. 6028 6029 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean; 6030 -- Determines if the given type has compile time known bounds. Note 6031 -- that we enter the case statement even in cases where the prefix 6032 -- type does NOT have known bounds, so it is important to guard any 6033 -- attempt to evaluate both bounds with a call to this function. 6034 6035 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint); 6036 -- This procedure is called when the attribute N has a non-static 6037 -- but compile time known value given by Val. It includes the 6038 -- necessary checks for out of range values. 6039 6040 function Fore_Value return Nat; 6041 -- Computes the Fore value for the current attribute prefix, which is 6042 -- known to be a static fixed-point type. Used by Fore and Width. 6043 6044 function Is_VAX_Float (Typ : Entity_Id) return Boolean; 6045 -- Determine whether Typ denotes a VAX floating point type 6046 6047 function Mantissa return Uint; 6048 -- Returns the Mantissa value for the prefix type 6049 6050 procedure Set_Bounds; 6051 -- Used for First, Last and Length attributes applied to an array or 6052 -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low 6053 -- and high bound expressions for the index referenced by the attribute 6054 -- designator (i.e. the first index if no expression is present, and the 6055 -- N'th index if the value N is present as an expression). Also used for 6056 -- First and Last of scalar types and for First_Valid and Last_Valid. 6057 -- Static is reset to False if the type or index type is not statically 6058 -- constrained. 6059 6060 function Statically_Denotes_Entity (N : Node_Id) return Boolean; 6061 -- Verify that the prefix of a potentially static array attribute 6062 -- satisfies the conditions of 4.9 (14). 6063 6064 ----------------------------------- 6065 -- Check_Concurrent_Discriminant -- 6066 ----------------------------------- 6067 6068 procedure Check_Concurrent_Discriminant (Bound : Node_Id) is 6069 Tsk : Entity_Id; 6070 -- The concurrent (task or protected) type 6071 6072 begin 6073 if Nkind (Bound) = N_Identifier 6074 and then Ekind (Entity (Bound)) = E_Discriminant 6075 and then Is_Concurrent_Record_Type (Scope (Entity (Bound))) 6076 then 6077 Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound))); 6078 6079 if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then 6080 6081 -- Find discriminant of original concurrent type, and use 6082 -- its current discriminal, which is the renaming within 6083 -- the task/protected body. 6084 6085 Rewrite (N, 6086 New_Occurrence_Of 6087 (Find_Body_Discriminal (Entity (Bound)), Loc)); 6088 end if; 6089 end if; 6090 end Check_Concurrent_Discriminant; 6091 6092 ----------------------- 6093 -- Check_Expressions -- 6094 ----------------------- 6095 6096 procedure Check_Expressions is 6097 E : Node_Id; 6098 begin 6099 E := E1; 6100 while Present (E) loop 6101 Check_Non_Static_Context (E); 6102 Next (E); 6103 end loop; 6104 end Check_Expressions; 6105 6106 ---------------------------------- 6107 -- Compile_Time_Known_Attribute -- 6108 ---------------------------------- 6109 6110 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is 6111 T : constant Entity_Id := Etype (N); 6112 6113 begin 6114 Fold_Uint (N, Val, False); 6115 6116 -- Check that result is in bounds of the type if it is static 6117 6118 if Is_In_Range (N, T, Assume_Valid => False) then 6119 null; 6120 6121 elsif Is_Out_Of_Range (N, T) then 6122 Apply_Compile_Time_Constraint_Error 6123 (N, "value not in range of}??", CE_Range_Check_Failed); 6124 6125 elsif not Range_Checks_Suppressed (T) then 6126 Enable_Range_Check (N); 6127 6128 else 6129 Set_Do_Range_Check (N, False); 6130 end if; 6131 end Compile_Time_Known_Attribute; 6132 6133 ------------------------------- 6134 -- Compile_Time_Known_Bounds -- 6135 ------------------------------- 6136 6137 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is 6138 begin 6139 return 6140 Compile_Time_Known_Value (Type_Low_Bound (Typ)) 6141 and then 6142 Compile_Time_Known_Value (Type_High_Bound (Typ)); 6143 end Compile_Time_Known_Bounds; 6144 6145 ---------------- 6146 -- Fore_Value -- 6147 ---------------- 6148 6149 -- Note that the Fore calculation is based on the actual values 6150 -- of the bounds, and does not take into account possible rounding. 6151 6152 function Fore_Value return Nat is 6153 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); 6154 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); 6155 Small : constant Ureal := Small_Value (P_Type); 6156 Lo_Real : constant Ureal := Lo * Small; 6157 Hi_Real : constant Ureal := Hi * Small; 6158 T : Ureal; 6159 R : Nat; 6160 6161 begin 6162 -- Bounds are given in terms of small units, so first compute 6163 -- proper values as reals. 6164 6165 T := UR_Max (abs Lo_Real, abs Hi_Real); 6166 R := 2; 6167 6168 -- Loop to compute proper value if more than one digit required 6169 6170 while T >= Ureal_10 loop 6171 R := R + 1; 6172 T := T / Ureal_10; 6173 end loop; 6174 6175 return R; 6176 end Fore_Value; 6177 6178 ------------------ 6179 -- Is_VAX_Float -- 6180 ------------------ 6181 6182 function Is_VAX_Float (Typ : Entity_Id) return Boolean is 6183 begin 6184 return 6185 Is_Floating_Point_Type (Typ) 6186 and then 6187 (Float_Format = 'V' or else Float_Rep (Typ) = VAX_Native); 6188 end Is_VAX_Float; 6189 6190 -------------- 6191 -- Mantissa -- 6192 -------------- 6193 6194 -- Table of mantissa values accessed by function Computed using 6195 -- the relation: 6196 6197 -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1) 6198 6199 -- where D is T'Digits (RM83 3.5.7) 6200 6201 Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := ( 6202 1 => 5, 6203 2 => 8, 6204 3 => 11, 6205 4 => 15, 6206 5 => 18, 6207 6 => 21, 6208 7 => 25, 6209 8 => 28, 6210 9 => 31, 6211 10 => 35, 6212 11 => 38, 6213 12 => 41, 6214 13 => 45, 6215 14 => 48, 6216 15 => 51, 6217 16 => 55, 6218 17 => 58, 6219 18 => 61, 6220 19 => 65, 6221 20 => 68, 6222 21 => 71, 6223 22 => 75, 6224 23 => 78, 6225 24 => 81, 6226 25 => 85, 6227 26 => 88, 6228 27 => 91, 6229 28 => 95, 6230 29 => 98, 6231 30 => 101, 6232 31 => 104, 6233 32 => 108, 6234 33 => 111, 6235 34 => 114, 6236 35 => 118, 6237 36 => 121, 6238 37 => 124, 6239 38 => 128, 6240 39 => 131, 6241 40 => 134); 6242 6243 function Mantissa return Uint is 6244 begin 6245 return 6246 UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type)))); 6247 end Mantissa; 6248 6249 ---------------- 6250 -- Set_Bounds -- 6251 ---------------- 6252 6253 procedure Set_Bounds is 6254 Ndim : Nat; 6255 Indx : Node_Id; 6256 Ityp : Entity_Id; 6257 6258 begin 6259 -- For a string literal subtype, we have to construct the bounds. 6260 -- Valid Ada code never applies attributes to string literals, but 6261 -- it is convenient to allow the expander to generate attribute 6262 -- references of this type (e.g. First and Last applied to a string 6263 -- literal). 6264 6265 -- Note that the whole point of the E_String_Literal_Subtype is to 6266 -- avoid this construction of bounds, but the cases in which we 6267 -- have to materialize them are rare enough that we don't worry! 6268 6269 -- The low bound is simply the low bound of the base type. The 6270 -- high bound is computed from the length of the string and this 6271 -- low bound. 6272 6273 if Ekind (P_Type) = E_String_Literal_Subtype then 6274 Ityp := Etype (First_Index (Base_Type (P_Type))); 6275 Lo_Bound := Type_Low_Bound (Ityp); 6276 6277 Hi_Bound := 6278 Make_Integer_Literal (Sloc (P), 6279 Intval => 6280 Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1); 6281 6282 Set_Parent (Hi_Bound, P); 6283 Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound)); 6284 return; 6285 6286 -- For non-array case, just get bounds of scalar type 6287 6288 elsif Is_Scalar_Type (P_Type) then 6289 Ityp := P_Type; 6290 6291 -- For a fixed-point type, we must freeze to get the attributes 6292 -- of the fixed-point type set now so we can reference them. 6293 6294 if Is_Fixed_Point_Type (P_Type) 6295 and then not Is_Frozen (Base_Type (P_Type)) 6296 and then Compile_Time_Known_Value (Type_Low_Bound (P_Type)) 6297 and then Compile_Time_Known_Value (Type_High_Bound (P_Type)) 6298 then 6299 Freeze_Fixed_Point_Type (Base_Type (P_Type)); 6300 end if; 6301 6302 -- For array case, get type of proper index 6303 6304 else 6305 if No (E1) then 6306 Ndim := 1; 6307 else 6308 Ndim := UI_To_Int (Expr_Value (E1)); 6309 end if; 6310 6311 Indx := First_Index (P_Type); 6312 for J in 1 .. Ndim - 1 loop 6313 Next_Index (Indx); 6314 end loop; 6315 6316 -- If no index type, get out (some other error occurred, and 6317 -- we don't have enough information to complete the job!) 6318 6319 if No (Indx) then 6320 Lo_Bound := Error; 6321 Hi_Bound := Error; 6322 return; 6323 end if; 6324 6325 Ityp := Etype (Indx); 6326 end if; 6327 6328 -- A discrete range in an index constraint is allowed to be a 6329 -- subtype indication. This is syntactically a pain, but should 6330 -- not propagate to the entity for the corresponding index subtype. 6331 -- After checking that the subtype indication is legal, the range 6332 -- of the subtype indication should be transfered to the entity. 6333 -- The attributes for the bounds should remain the simple retrievals 6334 -- that they are now. 6335 6336 Lo_Bound := Type_Low_Bound (Ityp); 6337 Hi_Bound := Type_High_Bound (Ityp); 6338 6339 if not Is_Static_Subtype (Ityp) then 6340 Static := False; 6341 end if; 6342 end Set_Bounds; 6343 6344 ------------------------------- 6345 -- Statically_Denotes_Entity -- 6346 ------------------------------- 6347 6348 function Statically_Denotes_Entity (N : Node_Id) return Boolean is 6349 E : Entity_Id; 6350 6351 begin 6352 if not Is_Entity_Name (N) then 6353 return False; 6354 else 6355 E := Entity (N); 6356 end if; 6357 6358 return 6359 Nkind (Parent (E)) /= N_Object_Renaming_Declaration 6360 or else Statically_Denotes_Entity (Renamed_Object (E)); 6361 end Statically_Denotes_Entity; 6362 6363 -- Start of processing for Eval_Attribute 6364 6365 begin 6366 -- Acquire first two expressions (at the moment, no attributes take more 6367 -- than two expressions in any case). 6368 6369 if Present (Expressions (N)) then 6370 E1 := First (Expressions (N)); 6371 E2 := Next (E1); 6372 else 6373 E1 := Empty; 6374 E2 := Empty; 6375 end if; 6376 6377 -- Special processing for Enabled attribute. This attribute has a very 6378 -- special prefix, and the easiest way to avoid lots of special checks 6379 -- to protect this special prefix from causing trouble is to deal with 6380 -- this attribute immediately and be done with it. 6381 6382 if Id = Attribute_Enabled then 6383 6384 -- We skip evaluation if the expander is not active. This is not just 6385 -- an optimization. It is of key importance that we not rewrite the 6386 -- attribute in a generic template, since we want to pick up the 6387 -- setting of the check in the instance, and testing expander active 6388 -- is as easy way of doing this as any. 6389 6390 if Expander_Active then 6391 declare 6392 C : constant Check_Id := Get_Check_Id (Chars (P)); 6393 R : Boolean; 6394 6395 begin 6396 if No (E1) then 6397 if C in Predefined_Check_Id then 6398 R := Scope_Suppress.Suppress (C); 6399 else 6400 R := Is_Check_Suppressed (Empty, C); 6401 end if; 6402 6403 else 6404 R := Is_Check_Suppressed (Entity (E1), C); 6405 end if; 6406 6407 Rewrite (N, New_Occurrence_Of (Boolean_Literals (not R), Loc)); 6408 end; 6409 end if; 6410 6411 return; 6412 end if; 6413 6414 -- Special processing for cases where the prefix is an object. For 6415 -- this purpose, a string literal counts as an object (attributes 6416 -- of string literals can only appear in generated code). 6417 6418 if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then 6419 6420 -- For Component_Size, the prefix is an array object, and we apply 6421 -- the attribute to the type of the object. This is allowed for 6422 -- both unconstrained and constrained arrays, since the bounds 6423 -- have no influence on the value of this attribute. 6424 6425 if Id = Attribute_Component_Size then 6426 P_Entity := Etype (P); 6427 6428 -- For First and Last, the prefix is an array object, and we apply 6429 -- the attribute to the type of the array, but we need a constrained 6430 -- type for this, so we use the actual subtype if available. 6431 6432 elsif Id = Attribute_First 6433 or else 6434 Id = Attribute_Last 6435 or else 6436 Id = Attribute_Length 6437 then 6438 declare 6439 AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P); 6440 6441 begin 6442 if Present (AS) and then Is_Constrained (AS) then 6443 P_Entity := AS; 6444 6445 -- If we have an unconstrained type we cannot fold 6446 6447 else 6448 Check_Expressions; 6449 return; 6450 end if; 6451 end; 6452 6453 -- For Size, give size of object if available, otherwise we 6454 -- cannot fold Size. 6455 6456 elsif Id = Attribute_Size then 6457 if Is_Entity_Name (P) 6458 and then Known_Esize (Entity (P)) 6459 then 6460 Compile_Time_Known_Attribute (N, Esize (Entity (P))); 6461 return; 6462 6463 else 6464 Check_Expressions; 6465 return; 6466 end if; 6467 6468 -- For Alignment, give size of object if available, otherwise we 6469 -- cannot fold Alignment. 6470 6471 elsif Id = Attribute_Alignment then 6472 if Is_Entity_Name (P) 6473 and then Known_Alignment (Entity (P)) 6474 then 6475 Fold_Uint (N, Alignment (Entity (P)), False); 6476 return; 6477 6478 else 6479 Check_Expressions; 6480 return; 6481 end if; 6482 6483 -- For Lock_Free, we apply the attribute to the type of the object. 6484 -- This is allowed since we have already verified that the type is a 6485 -- protected type. 6486 6487 elsif Id = Attribute_Lock_Free then 6488 P_Entity := Etype (P); 6489 6490 -- No other attributes for objects are folded 6491 6492 else 6493 Check_Expressions; 6494 return; 6495 end if; 6496 6497 -- Cases where P is not an object. Cannot do anything if P is 6498 -- not the name of an entity. 6499 6500 elsif not Is_Entity_Name (P) then 6501 Check_Expressions; 6502 return; 6503 6504 -- Otherwise get prefix entity 6505 6506 else 6507 P_Entity := Entity (P); 6508 end if; 6509 6510 -- At this stage P_Entity is the entity to which the attribute 6511 -- is to be applied. This is usually simply the entity of the 6512 -- prefix, except in some cases of attributes for objects, where 6513 -- as described above, we apply the attribute to the object type. 6514 6515 -- First foldable possibility is a scalar or array type (RM 4.9(7)) 6516 -- that is not generic (generic types are eliminated by RM 4.9(25)). 6517 -- Note we allow non-static non-generic types at this stage as further 6518 -- described below. 6519 6520 if Is_Type (P_Entity) 6521 and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity)) 6522 and then (not Is_Generic_Type (P_Entity)) 6523 then 6524 P_Type := P_Entity; 6525 6526 -- Second foldable possibility is an array object (RM 4.9(8)) 6527 6528 elsif (Ekind (P_Entity) = E_Variable 6529 or else 6530 Ekind (P_Entity) = E_Constant) 6531 and then Is_Array_Type (Etype (P_Entity)) 6532 and then (not Is_Generic_Type (Etype (P_Entity))) 6533 then 6534 P_Type := Etype (P_Entity); 6535 6536 -- If the entity is an array constant with an unconstrained nominal 6537 -- subtype then get the type from the initial value. If the value has 6538 -- been expanded into assignments, there is no expression and the 6539 -- attribute reference remains dynamic. 6540 6541 -- We could do better here and retrieve the type ??? 6542 6543 if Ekind (P_Entity) = E_Constant 6544 and then not Is_Constrained (P_Type) 6545 then 6546 if No (Constant_Value (P_Entity)) then 6547 return; 6548 else 6549 P_Type := Etype (Constant_Value (P_Entity)); 6550 end if; 6551 end if; 6552 6553 -- Definite must be folded if the prefix is not a generic type, 6554 -- that is to say if we are within an instantiation. Same processing 6555 -- applies to the GNAT attributes Atomic_Always_Lock_Free, 6556 -- Has_Discriminants, Lock_Free, Type_Class, Has_Tagged_Value, and 6557 -- Unconstrained_Array. 6558 6559 elsif (Id = Attribute_Atomic_Always_Lock_Free 6560 or else 6561 Id = Attribute_Definite 6562 or else 6563 Id = Attribute_Has_Access_Values 6564 or else 6565 Id = Attribute_Has_Discriminants 6566 or else 6567 Id = Attribute_Has_Tagged_Values 6568 or else 6569 Id = Attribute_Lock_Free 6570 or else 6571 Id = Attribute_Type_Class 6572 or else 6573 Id = Attribute_Unconstrained_Array 6574 or else 6575 Id = Attribute_Max_Alignment_For_Allocation) 6576 and then not Is_Generic_Type (P_Entity) 6577 then 6578 P_Type := P_Entity; 6579 6580 -- We can fold 'Size applied to a type if the size is known (as happens 6581 -- for a size from an attribute definition clause). At this stage, this 6582 -- can happen only for types (e.g. record types) for which the size is 6583 -- always non-static. We exclude generic types from consideration (since 6584 -- they have bogus sizes set within templates). 6585 6586 elsif Id = Attribute_Size 6587 and then Is_Type (P_Entity) 6588 and then (not Is_Generic_Type (P_Entity)) 6589 and then Known_Static_RM_Size (P_Entity) 6590 then 6591 Compile_Time_Known_Attribute (N, RM_Size (P_Entity)); 6592 return; 6593 6594 -- We can fold 'Alignment applied to a type if the alignment is known 6595 -- (as happens for an alignment from an attribute definition clause). 6596 -- At this stage, this can happen only for types (e.g. record 6597 -- types) for which the size is always non-static. We exclude 6598 -- generic types from consideration (since they have bogus 6599 -- sizes set within templates). 6600 6601 elsif Id = Attribute_Alignment 6602 and then Is_Type (P_Entity) 6603 and then (not Is_Generic_Type (P_Entity)) 6604 and then Known_Alignment (P_Entity) 6605 then 6606 Compile_Time_Known_Attribute (N, Alignment (P_Entity)); 6607 return; 6608 6609 -- If this is an access attribute that is known to fail accessibility 6610 -- check, rewrite accordingly. 6611 6612 elsif Attribute_Name (N) = Name_Access 6613 and then Raises_Constraint_Error (N) 6614 then 6615 Rewrite (N, 6616 Make_Raise_Program_Error (Loc, 6617 Reason => PE_Accessibility_Check_Failed)); 6618 Set_Etype (N, C_Type); 6619 return; 6620 6621 -- No other cases are foldable (they certainly aren't static, and at 6622 -- the moment we don't try to fold any cases other than the ones above). 6623 6624 else 6625 Check_Expressions; 6626 return; 6627 end if; 6628 6629 -- If either attribute or the prefix is Any_Type, then propagate 6630 -- Any_Type to the result and don't do anything else at all. 6631 6632 if P_Type = Any_Type 6633 or else (Present (E1) and then Etype (E1) = Any_Type) 6634 or else (Present (E2) and then Etype (E2) = Any_Type) 6635 then 6636 Set_Etype (N, Any_Type); 6637 return; 6638 end if; 6639 6640 -- Scalar subtype case. We have not yet enforced the static requirement 6641 -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases 6642 -- of non-static attribute references (e.g. S'Digits for a non-static 6643 -- floating-point type, which we can compute at compile time). 6644 6645 -- Note: this folding of non-static attributes is not simply a case of 6646 -- optimization. For many of the attributes affected, Gigi cannot handle 6647 -- the attribute and depends on the front end having folded them away. 6648 6649 -- Note: although we don't require staticness at this stage, we do set 6650 -- the Static variable to record the staticness, for easy reference by 6651 -- those attributes where it matters (e.g. Succ and Pred), and also to 6652 -- be used to ensure that non-static folded things are not marked as 6653 -- being static (a check that is done right at the end). 6654 6655 P_Root_Type := Root_Type (P_Type); 6656 P_Base_Type := Base_Type (P_Type); 6657 6658 -- If the root type or base type is generic, then we cannot fold. This 6659 -- test is needed because subtypes of generic types are not always 6660 -- marked as being generic themselves (which seems odd???) 6661 6662 if Is_Generic_Type (P_Root_Type) 6663 or else Is_Generic_Type (P_Base_Type) 6664 then 6665 return; 6666 end if; 6667 6668 if Is_Scalar_Type (P_Type) then 6669 Static := Is_OK_Static_Subtype (P_Type); 6670 6671 -- Array case. We enforce the constrained requirement of (RM 4.9(7-8)) 6672 -- since we can't do anything with unconstrained arrays. In addition, 6673 -- only the First, Last and Length attributes are possibly static. 6674 6675 -- Atomic_Always_Lock_Free, Definite, Has_Access_Values, 6676 -- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and 6677 -- Unconstrained_Array are again exceptions, because they apply as well 6678 -- to unconstrained types. 6679 6680 -- In addition Component_Size is an exception since it is possibly 6681 -- foldable, even though it is never static, and it does apply to 6682 -- unconstrained arrays. Furthermore, it is essential to fold this 6683 -- in the packed case, since otherwise the value will be incorrect. 6684 6685 elsif Id = Attribute_Atomic_Always_Lock_Free 6686 or else 6687 Id = Attribute_Definite 6688 or else 6689 Id = Attribute_Has_Access_Values 6690 or else 6691 Id = Attribute_Has_Discriminants 6692 or else 6693 Id = Attribute_Has_Tagged_Values 6694 or else 6695 Id = Attribute_Lock_Free 6696 or else 6697 Id = Attribute_Type_Class 6698 or else 6699 Id = Attribute_Unconstrained_Array 6700 or else 6701 Id = Attribute_Component_Size 6702 then 6703 Static := False; 6704 6705 elsif Id /= Attribute_Max_Alignment_For_Allocation then 6706 if not Is_Constrained (P_Type) 6707 or else (Id /= Attribute_First and then 6708 Id /= Attribute_Last and then 6709 Id /= Attribute_Length) 6710 then 6711 Check_Expressions; 6712 return; 6713 end if; 6714 6715 -- The rules in (RM 4.9(7,8)) require a static array, but as in the 6716 -- scalar case, we hold off on enforcing staticness, since there are 6717 -- cases which we can fold at compile time even though they are not 6718 -- static (e.g. 'Length applied to a static index, even though other 6719 -- non-static indexes make the array type non-static). This is only 6720 -- an optimization, but it falls out essentially free, so why not. 6721 -- Again we compute the variable Static for easy reference later 6722 -- (note that no array attributes are static in Ada 83). 6723 6724 -- We also need to set Static properly for subsequent legality checks 6725 -- which might otherwise accept non-static constants in contexts 6726 -- where they are not legal. 6727 6728 Static := Ada_Version >= Ada_95 6729 and then Statically_Denotes_Entity (P); 6730 6731 declare 6732 N : Node_Id; 6733 6734 begin 6735 N := First_Index (P_Type); 6736 6737 -- The expression is static if the array type is constrained 6738 -- by given bounds, and not by an initial expression. Constant 6739 -- strings are static in any case. 6740 6741 if Root_Type (P_Type) /= Standard_String then 6742 Static := 6743 Static and then not Is_Constr_Subt_For_U_Nominal (P_Type); 6744 end if; 6745 6746 while Present (N) loop 6747 Static := Static and then Is_Static_Subtype (Etype (N)); 6748 6749 -- If however the index type is generic, or derived from 6750 -- one, attributes cannot be folded. 6751 6752 if Is_Generic_Type (Root_Type (Etype (N))) 6753 and then Id /= Attribute_Component_Size 6754 then 6755 return; 6756 end if; 6757 6758 Next_Index (N); 6759 end loop; 6760 end; 6761 end if; 6762 6763 -- Check any expressions that are present. Note that these expressions, 6764 -- depending on the particular attribute type, are either part of the 6765 -- attribute designator, or they are arguments in a case where the 6766 -- attribute reference returns a function. In the latter case, the 6767 -- rule in (RM 4.9(22)) applies and in particular requires the type 6768 -- of the expressions to be scalar in order for the attribute to be 6769 -- considered to be static. 6770 6771 declare 6772 E : Node_Id; 6773 6774 begin 6775 E := E1; 6776 while Present (E) loop 6777 6778 -- If expression is not static, then the attribute reference 6779 -- result certainly cannot be static. 6780 6781 if not Is_Static_Expression (E) then 6782 Static := False; 6783 end if; 6784 6785 -- If the result is not known at compile time, or is not of 6786 -- a scalar type, then the result is definitely not static, 6787 -- so we can quit now. 6788 6789 if not Compile_Time_Known_Value (E) 6790 or else not Is_Scalar_Type (Etype (E)) 6791 then 6792 -- An odd special case, if this is a Pos attribute, this 6793 -- is where we need to apply a range check since it does 6794 -- not get done anywhere else. 6795 6796 if Id = Attribute_Pos then 6797 if Is_Integer_Type (Etype (E)) then 6798 Apply_Range_Check (E, Etype (N)); 6799 end if; 6800 end if; 6801 6802 Check_Expressions; 6803 return; 6804 6805 -- If the expression raises a constraint error, then so does 6806 -- the attribute reference. We keep going in this case because 6807 -- we are still interested in whether the attribute reference 6808 -- is static even if it is not static. 6809 6810 elsif Raises_Constraint_Error (E) then 6811 Set_Raises_Constraint_Error (N); 6812 end if; 6813 6814 Next (E); 6815 end loop; 6816 6817 if Raises_Constraint_Error (Prefix (N)) then 6818 return; 6819 end if; 6820 end; 6821 6822 -- Deal with the case of a static attribute reference that raises 6823 -- constraint error. The Raises_Constraint_Error flag will already 6824 -- have been set, and the Static flag shows whether the attribute 6825 -- reference is static. In any case we certainly can't fold such an 6826 -- attribute reference. 6827 6828 -- Note that the rewriting of the attribute node with the constraint 6829 -- error node is essential in this case, because otherwise Gigi might 6830 -- blow up on one of the attributes it never expects to see. 6831 6832 -- The constraint_error node must have the type imposed by the context, 6833 -- to avoid spurious errors in the enclosing expression. 6834 6835 if Raises_Constraint_Error (N) then 6836 CE_Node := 6837 Make_Raise_Constraint_Error (Sloc (N), 6838 Reason => CE_Range_Check_Failed); 6839 Set_Etype (CE_Node, Etype (N)); 6840 Set_Raises_Constraint_Error (CE_Node); 6841 Check_Expressions; 6842 Rewrite (N, Relocate_Node (CE_Node)); 6843 Set_Is_Static_Expression (N, Static); 6844 return; 6845 end if; 6846 6847 -- At this point we have a potentially foldable attribute reference. 6848 -- If Static is set, then the attribute reference definitely obeys 6849 -- the requirements in (RM 4.9(7,8,22)), and it definitely can be 6850 -- folded. If Static is not set, then the attribute may or may not 6851 -- be foldable, and the individual attribute processing routines 6852 -- test Static as required in cases where it makes a difference. 6853 6854 -- In the case where Static is not set, we do know that all the 6855 -- expressions present are at least known at compile time (we assumed 6856 -- above that if this was not the case, then there was no hope of static 6857 -- evaluation). However, we did not require that the bounds of the 6858 -- prefix type be compile time known, let alone static). That's because 6859 -- there are many attributes that can be computed at compile time on 6860 -- non-static subtypes, even though such references are not static 6861 -- expressions. 6862 6863 -- For VAX float, the root type is an IEEE type. So make sure to use the 6864 -- base type instead of the root-type for floating point attributes. 6865 6866 case Id is 6867 6868 -- Attributes related to Ada 2012 iterators (placeholder ???) 6869 6870 when Attribute_Constant_Indexing | 6871 Attribute_Default_Iterator | 6872 Attribute_Implicit_Dereference | 6873 Attribute_Iterator_Element | 6874 Attribute_Variable_Indexing => null; 6875 6876 -- Internal attributes used to deal with Ada 2012 delayed aspects. 6877 -- These were already rejected by the parser. Thus they shouldn't 6878 -- appear here. 6879 6880 when Internal_Attribute_Id => 6881 raise Program_Error; 6882 6883 -------------- 6884 -- Adjacent -- 6885 -------------- 6886 6887 when Attribute_Adjacent => 6888 Fold_Ureal 6889 (N, 6890 Eval_Fat.Adjacent 6891 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)), 6892 Static); 6893 6894 --------- 6895 -- Aft -- 6896 --------- 6897 6898 when Attribute_Aft => 6899 Fold_Uint (N, Aft_Value (P_Type), True); 6900 6901 --------------- 6902 -- Alignment -- 6903 --------------- 6904 6905 when Attribute_Alignment => Alignment_Block : declare 6906 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 6907 6908 begin 6909 -- Fold if alignment is set and not otherwise 6910 6911 if Known_Alignment (P_TypeA) then 6912 Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA)); 6913 end if; 6914 end Alignment_Block; 6915 6916 --------------- 6917 -- AST_Entry -- 6918 --------------- 6919 6920 -- Can only be folded in No_Ast_Handler case 6921 6922 when Attribute_AST_Entry => 6923 if not Is_AST_Entry (P_Entity) then 6924 Rewrite (N, 6925 New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc)); 6926 else 6927 null; 6928 end if; 6929 6930 ----------------------------- 6931 -- Atomic_Always_Lock_Free -- 6932 ----------------------------- 6933 6934 -- Atomic_Always_Lock_Free attribute is a Boolean, thus no need to fold 6935 -- here. 6936 6937 when Attribute_Atomic_Always_Lock_Free => Atomic_Always_Lock_Free : 6938 declare 6939 V : constant Entity_Id := 6940 Boolean_Literals 6941 (Support_Atomic_Primitives_On_Target 6942 and then Support_Atomic_Primitives (P_Type)); 6943 6944 begin 6945 Rewrite (N, New_Occurrence_Of (V, Loc)); 6946 6947 -- Analyze and resolve as boolean. Note that this attribute is a 6948 -- static attribute in GNAT. 6949 6950 Analyze_And_Resolve (N, Standard_Boolean); 6951 Static := True; 6952 end Atomic_Always_Lock_Free; 6953 6954 --------- 6955 -- Bit -- 6956 --------- 6957 6958 -- Bit can never be folded 6959 6960 when Attribute_Bit => 6961 null; 6962 6963 ------------------ 6964 -- Body_Version -- 6965 ------------------ 6966 6967 -- Body_version can never be static 6968 6969 when Attribute_Body_Version => 6970 null; 6971 6972 ------------- 6973 -- Ceiling -- 6974 ------------- 6975 6976 when Attribute_Ceiling => 6977 Fold_Ureal 6978 (N, Eval_Fat.Ceiling (P_Base_Type, Expr_Value_R (E1)), Static); 6979 6980 -------------------- 6981 -- Component_Size -- 6982 -------------------- 6983 6984 when Attribute_Component_Size => 6985 if Known_Static_Component_Size (P_Type) then 6986 Fold_Uint (N, Component_Size (P_Type), False); 6987 end if; 6988 6989 ------------- 6990 -- Compose -- 6991 ------------- 6992 6993 when Attribute_Compose => 6994 Fold_Ureal 6995 (N, 6996 Eval_Fat.Compose (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)), 6997 Static); 6998 6999 ----------------- 7000 -- Constrained -- 7001 ----------------- 7002 7003 -- Constrained is never folded for now, there may be cases that 7004 -- could be handled at compile time. To be looked at later. 7005 7006 when Attribute_Constrained => 7007 null; 7008 7009 --------------- 7010 -- Copy_Sign -- 7011 --------------- 7012 7013 when Attribute_Copy_Sign => 7014 Fold_Ureal 7015 (N, 7016 Eval_Fat.Copy_Sign 7017 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)), 7018 Static); 7019 7020 -------------- 7021 -- Definite -- 7022 -------------- 7023 7024 when Attribute_Definite => 7025 Rewrite (N, New_Occurrence_Of ( 7026 Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc)); 7027 Analyze_And_Resolve (N, Standard_Boolean); 7028 7029 ----------- 7030 -- Delta -- 7031 ----------- 7032 7033 when Attribute_Delta => 7034 Fold_Ureal (N, Delta_Value (P_Type), True); 7035 7036 ------------ 7037 -- Denorm -- 7038 ------------ 7039 7040 when Attribute_Denorm => 7041 Fold_Uint 7042 (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), True); 7043 7044 --------------------- 7045 -- Descriptor_Size -- 7046 --------------------- 7047 7048 when Attribute_Descriptor_Size => 7049 null; 7050 7051 ------------ 7052 -- Digits -- 7053 ------------ 7054 7055 when Attribute_Digits => 7056 Fold_Uint (N, Digits_Value (P_Type), True); 7057 7058 ---------- 7059 -- Emax -- 7060 ---------- 7061 7062 when Attribute_Emax => 7063 7064 -- Ada 83 attribute is defined as (RM83 3.5.8) 7065 7066 -- T'Emax = 4 * T'Mantissa 7067 7068 Fold_Uint (N, 4 * Mantissa, True); 7069 7070 -------------- 7071 -- Enum_Rep -- 7072 -------------- 7073 7074 when Attribute_Enum_Rep => 7075 7076 -- For an enumeration type with a non-standard representation use 7077 -- the Enumeration_Rep field of the proper constant. Note that this 7078 -- will not work for types Character/Wide_[Wide-]Character, since no 7079 -- real entities are created for the enumeration literals, but that 7080 -- does not matter since these two types do not have non-standard 7081 -- representations anyway. 7082 7083 if Is_Enumeration_Type (P_Type) 7084 and then Has_Non_Standard_Rep (P_Type) 7085 then 7086 Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static); 7087 7088 -- For enumeration types with standard representations and all 7089 -- other cases (i.e. all integer and modular types), Enum_Rep 7090 -- is equivalent to Pos. 7091 7092 else 7093 Fold_Uint (N, Expr_Value (E1), Static); 7094 end if; 7095 7096 -------------- 7097 -- Enum_Val -- 7098 -------------- 7099 7100 when Attribute_Enum_Val => Enum_Val : declare 7101 Lit : Node_Id; 7102 7103 begin 7104 -- We have something like Enum_Type'Enum_Val (23), so search for a 7105 -- corresponding value in the list of Enum_Rep values for the type. 7106 7107 Lit := First_Literal (P_Base_Type); 7108 loop 7109 if Enumeration_Rep (Lit) = Expr_Value (E1) then 7110 Fold_Uint (N, Enumeration_Pos (Lit), Static); 7111 exit; 7112 end if; 7113 7114 Next_Literal (Lit); 7115 7116 if No (Lit) then 7117 Apply_Compile_Time_Constraint_Error 7118 (N, "no representation value matches", 7119 CE_Range_Check_Failed, 7120 Warn => not Static); 7121 exit; 7122 end if; 7123 end loop; 7124 end Enum_Val; 7125 7126 ------------- 7127 -- Epsilon -- 7128 ------------- 7129 7130 when Attribute_Epsilon => 7131 7132 -- Ada 83 attribute is defined as (RM83 3.5.8) 7133 7134 -- T'Epsilon = 2.0**(1 - T'Mantissa) 7135 7136 Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True); 7137 7138 -------------- 7139 -- Exponent -- 7140 -------------- 7141 7142 when Attribute_Exponent => 7143 Fold_Uint (N, 7144 Eval_Fat.Exponent (P_Base_Type, Expr_Value_R (E1)), Static); 7145 7146 ----------- 7147 -- First -- 7148 ----------- 7149 7150 when Attribute_First => First_Attr : 7151 begin 7152 Set_Bounds; 7153 7154 if Compile_Time_Known_Value (Lo_Bound) then 7155 if Is_Real_Type (P_Type) then 7156 Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static); 7157 else 7158 Fold_Uint (N, Expr_Value (Lo_Bound), Static); 7159 end if; 7160 7161 -- Replace VAX Float_Type'First with a reference to the temporary 7162 -- which represents the low bound of the type. This transformation 7163 -- is needed since the back end cannot evaluate 'First on VAX. 7164 7165 elsif Is_VAX_Float (P_Type) 7166 and then Nkind (Lo_Bound) = N_Identifier 7167 then 7168 Rewrite (N, New_Reference_To (Entity (Lo_Bound), Sloc (N))); 7169 Analyze (N); 7170 7171 else 7172 Check_Concurrent_Discriminant (Lo_Bound); 7173 end if; 7174 end First_Attr; 7175 7176 ----------------- 7177 -- First_Valid -- 7178 ----------------- 7179 7180 when Attribute_First_Valid => First_Valid : 7181 begin 7182 if Has_Predicates (P_Type) 7183 and then Present (Static_Predicate (P_Type)) 7184 then 7185 declare 7186 FirstN : constant Node_Id := First (Static_Predicate (P_Type)); 7187 begin 7188 if Nkind (FirstN) = N_Range then 7189 Fold_Uint (N, Expr_Value (Low_Bound (FirstN)), Static); 7190 else 7191 Fold_Uint (N, Expr_Value (FirstN), Static); 7192 end if; 7193 end; 7194 7195 else 7196 Set_Bounds; 7197 Fold_Uint (N, Expr_Value (Lo_Bound), Static); 7198 end if; 7199 end First_Valid; 7200 7201 ----------------- 7202 -- Fixed_Value -- 7203 ----------------- 7204 7205 when Attribute_Fixed_Value => 7206 null; 7207 7208 ----------- 7209 -- Floor -- 7210 ----------- 7211 7212 when Attribute_Floor => 7213 Fold_Ureal 7214 (N, Eval_Fat.Floor (P_Base_Type, Expr_Value_R (E1)), Static); 7215 7216 ---------- 7217 -- Fore -- 7218 ---------- 7219 7220 when Attribute_Fore => 7221 if Compile_Time_Known_Bounds (P_Type) then 7222 Fold_Uint (N, UI_From_Int (Fore_Value), Static); 7223 end if; 7224 7225 -------------- 7226 -- Fraction -- 7227 -------------- 7228 7229 when Attribute_Fraction => 7230 Fold_Ureal 7231 (N, Eval_Fat.Fraction (P_Base_Type, Expr_Value_R (E1)), Static); 7232 7233 ----------------------- 7234 -- Has_Access_Values -- 7235 ----------------------- 7236 7237 when Attribute_Has_Access_Values => 7238 Rewrite (N, New_Occurrence_Of 7239 (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc)); 7240 Analyze_And_Resolve (N, Standard_Boolean); 7241 7242 ----------------------- 7243 -- Has_Discriminants -- 7244 ----------------------- 7245 7246 when Attribute_Has_Discriminants => 7247 Rewrite (N, New_Occurrence_Of ( 7248 Boolean_Literals (Has_Discriminants (P_Entity)), Loc)); 7249 Analyze_And_Resolve (N, Standard_Boolean); 7250 7251 ----------------------- 7252 -- Has_Tagged_Values -- 7253 ----------------------- 7254 7255 when Attribute_Has_Tagged_Values => 7256 Rewrite (N, New_Occurrence_Of 7257 (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc)); 7258 Analyze_And_Resolve (N, Standard_Boolean); 7259 7260 -------------- 7261 -- Identity -- 7262 -------------- 7263 7264 when Attribute_Identity => 7265 null; 7266 7267 ----------- 7268 -- Image -- 7269 ----------- 7270 7271 -- Image is a scalar attribute, but is never static, because it is 7272 -- not a static function (having a non-scalar argument (RM 4.9(22)) 7273 -- However, we can constant-fold the image of an enumeration literal 7274 -- if names are available. 7275 7276 when Attribute_Image => 7277 if Is_Entity_Name (E1) 7278 and then Ekind (Entity (E1)) = E_Enumeration_Literal 7279 and then not Discard_Names (First_Subtype (Etype (E1))) 7280 and then not Global_Discard_Names 7281 then 7282 declare 7283 Lit : constant Entity_Id := Entity (E1); 7284 Str : String_Id; 7285 begin 7286 Start_String; 7287 Get_Unqualified_Decoded_Name_String (Chars (Lit)); 7288 Set_Casing (All_Upper_Case); 7289 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 7290 Str := End_String; 7291 Rewrite (N, Make_String_Literal (Loc, Strval => Str)); 7292 Analyze_And_Resolve (N, Standard_String); 7293 Set_Is_Static_Expression (N, False); 7294 end; 7295 end if; 7296 7297 --------- 7298 -- Img -- 7299 --------- 7300 7301 -- Img is a scalar attribute, but is never static, because it is 7302 -- not a static function (having a non-scalar argument (RM 4.9(22)) 7303 7304 when Attribute_Img => 7305 null; 7306 7307 ------------------- 7308 -- Integer_Value -- 7309 ------------------- 7310 7311 -- We never try to fold Integer_Value (though perhaps we could???) 7312 7313 when Attribute_Integer_Value => 7314 null; 7315 7316 ------------------- 7317 -- Invalid_Value -- 7318 ------------------- 7319 7320 -- Invalid_Value is a scalar attribute that is never static, because 7321 -- the value is by design out of range. 7322 7323 when Attribute_Invalid_Value => 7324 null; 7325 7326 ----------- 7327 -- Large -- 7328 ----------- 7329 7330 when Attribute_Large => 7331 7332 -- For fixed-point, we use the identity: 7333 7334 -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small 7335 7336 if Is_Fixed_Point_Type (P_Type) then 7337 Rewrite (N, 7338 Make_Op_Multiply (Loc, 7339 Left_Opnd => 7340 Make_Op_Subtract (Loc, 7341 Left_Opnd => 7342 Make_Op_Expon (Loc, 7343 Left_Opnd => 7344 Make_Real_Literal (Loc, Ureal_2), 7345 Right_Opnd => 7346 Make_Attribute_Reference (Loc, 7347 Prefix => P, 7348 Attribute_Name => Name_Mantissa)), 7349 Right_Opnd => Make_Real_Literal (Loc, Ureal_1)), 7350 7351 Right_Opnd => 7352 Make_Real_Literal (Loc, Small_Value (Entity (P))))); 7353 7354 Analyze_And_Resolve (N, C_Type); 7355 7356 -- Floating-point (Ada 83 compatibility) 7357 7358 else 7359 -- Ada 83 attribute is defined as (RM83 3.5.8) 7360 7361 -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa)) 7362 7363 -- where 7364 7365 -- T'Emax = 4 * T'Mantissa 7366 7367 Fold_Ureal 7368 (N, 7369 Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)), 7370 True); 7371 end if; 7372 7373 --------------- 7374 -- Lock_Free -- 7375 --------------- 7376 7377 when Attribute_Lock_Free => Lock_Free : declare 7378 V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (P_Type)); 7379 7380 begin 7381 Rewrite (N, New_Occurrence_Of (V, Loc)); 7382 7383 -- Analyze and resolve as boolean. Note that this attribute is a 7384 -- static attribute in GNAT. 7385 7386 Analyze_And_Resolve (N, Standard_Boolean); 7387 Static := True; 7388 end Lock_Free; 7389 7390 ---------- 7391 -- Last -- 7392 ---------- 7393 7394 when Attribute_Last => Last_Attr : 7395 begin 7396 Set_Bounds; 7397 7398 if Compile_Time_Known_Value (Hi_Bound) then 7399 if Is_Real_Type (P_Type) then 7400 Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static); 7401 else 7402 Fold_Uint (N, Expr_Value (Hi_Bound), Static); 7403 end if; 7404 7405 -- Replace VAX Float_Type'Last with a reference to the temporary 7406 -- which represents the high bound of the type. This transformation 7407 -- is needed since the back end cannot evaluate 'Last on VAX. 7408 7409 elsif Is_VAX_Float (P_Type) 7410 and then Nkind (Hi_Bound) = N_Identifier 7411 then 7412 Rewrite (N, New_Reference_To (Entity (Hi_Bound), Sloc (N))); 7413 Analyze (N); 7414 7415 else 7416 Check_Concurrent_Discriminant (Hi_Bound); 7417 end if; 7418 end Last_Attr; 7419 7420 ---------------- 7421 -- Last_Valid -- 7422 ---------------- 7423 7424 when Attribute_Last_Valid => Last_Valid : 7425 begin 7426 if Has_Predicates (P_Type) 7427 and then Present (Static_Predicate (P_Type)) 7428 then 7429 declare 7430 LastN : constant Node_Id := Last (Static_Predicate (P_Type)); 7431 begin 7432 if Nkind (LastN) = N_Range then 7433 Fold_Uint (N, Expr_Value (High_Bound (LastN)), Static); 7434 else 7435 Fold_Uint (N, Expr_Value (LastN), Static); 7436 end if; 7437 end; 7438 7439 else 7440 Set_Bounds; 7441 Fold_Uint (N, Expr_Value (Hi_Bound), Static); 7442 end if; 7443 end Last_Valid; 7444 7445 ------------------ 7446 -- Leading_Part -- 7447 ------------------ 7448 7449 when Attribute_Leading_Part => 7450 Fold_Ureal 7451 (N, 7452 Eval_Fat.Leading_Part 7453 (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)), 7454 Static); 7455 7456 ------------ 7457 -- Length -- 7458 ------------ 7459 7460 when Attribute_Length => Length : declare 7461 Ind : Node_Id; 7462 7463 begin 7464 -- If any index type is a formal type, or derived from one, the 7465 -- bounds are not static. Treating them as static can produce 7466 -- spurious warnings or improper constant folding. 7467 7468 Ind := First_Index (P_Type); 7469 while Present (Ind) loop 7470 if Is_Generic_Type (Root_Type (Etype (Ind))) then 7471 return; 7472 end if; 7473 7474 Next_Index (Ind); 7475 end loop; 7476 7477 Set_Bounds; 7478 7479 -- For two compile time values, we can compute length 7480 7481 if Compile_Time_Known_Value (Lo_Bound) 7482 and then Compile_Time_Known_Value (Hi_Bound) 7483 then 7484 Fold_Uint (N, 7485 UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))), 7486 True); 7487 end if; 7488 7489 -- One more case is where Hi_Bound and Lo_Bound are compile-time 7490 -- comparable, and we can figure out the difference between them. 7491 7492 declare 7493 Diff : aliased Uint; 7494 7495 begin 7496 case 7497 Compile_Time_Compare 7498 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False) 7499 is 7500 when EQ => 7501 Fold_Uint (N, Uint_1, False); 7502 7503 when GT => 7504 Fold_Uint (N, Uint_0, False); 7505 7506 when LT => 7507 if Diff /= No_Uint then 7508 Fold_Uint (N, Diff + 1, False); 7509 end if; 7510 7511 when others => 7512 null; 7513 end case; 7514 end; 7515 end Length; 7516 7517 ---------------- 7518 -- Loop_Entry -- 7519 ---------------- 7520 7521 -- Loop_Entry acts as an alias of a constant initialized to the prefix 7522 -- of the said attribute at the point of entry into the related loop. As 7523 -- such, the attribute reference does not need to be evaluated because 7524 -- the prefix is the one that is evaluted. 7525 7526 when Attribute_Loop_Entry => 7527 null; 7528 7529 ------------- 7530 -- Machine -- 7531 ------------- 7532 7533 when Attribute_Machine => 7534 Fold_Ureal 7535 (N, 7536 Eval_Fat.Machine 7537 (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round, N), 7538 Static); 7539 7540 ------------------ 7541 -- Machine_Emax -- 7542 ------------------ 7543 7544 when Attribute_Machine_Emax => 7545 Fold_Uint (N, Machine_Emax_Value (P_Type), Static); 7546 7547 ------------------ 7548 -- Machine_Emin -- 7549 ------------------ 7550 7551 when Attribute_Machine_Emin => 7552 Fold_Uint (N, Machine_Emin_Value (P_Type), Static); 7553 7554 ---------------------- 7555 -- Machine_Mantissa -- 7556 ---------------------- 7557 7558 when Attribute_Machine_Mantissa => 7559 Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static); 7560 7561 ----------------------- 7562 -- Machine_Overflows -- 7563 ----------------------- 7564 7565 when Attribute_Machine_Overflows => 7566 7567 -- Always true for fixed-point 7568 7569 if Is_Fixed_Point_Type (P_Type) then 7570 Fold_Uint (N, True_Value, True); 7571 7572 -- Floating point case 7573 7574 else 7575 Fold_Uint (N, 7576 UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)), 7577 True); 7578 end if; 7579 7580 ------------------- 7581 -- Machine_Radix -- 7582 ------------------- 7583 7584 when Attribute_Machine_Radix => 7585 if Is_Fixed_Point_Type (P_Type) then 7586 if Is_Decimal_Fixed_Point_Type (P_Type) 7587 and then Machine_Radix_10 (P_Type) 7588 then 7589 Fold_Uint (N, Uint_10, True); 7590 else 7591 Fold_Uint (N, Uint_2, True); 7592 end if; 7593 7594 -- All floating-point type always have radix 2 7595 7596 else 7597 Fold_Uint (N, Uint_2, True); 7598 end if; 7599 7600 ---------------------- 7601 -- Machine_Rounding -- 7602 ---------------------- 7603 7604 -- Note: for the folding case, it is fine to treat Machine_Rounding 7605 -- exactly the same way as Rounding, since this is one of the allowed 7606 -- behaviors, and performance is not an issue here. It might be a bit 7607 -- better to give the same result as it would give at run time, even 7608 -- though the non-determinism is certainly permitted. 7609 7610 when Attribute_Machine_Rounding => 7611 Fold_Ureal 7612 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static); 7613 7614 -------------------- 7615 -- Machine_Rounds -- 7616 -------------------- 7617 7618 when Attribute_Machine_Rounds => 7619 7620 -- Always False for fixed-point 7621 7622 if Is_Fixed_Point_Type (P_Type) then 7623 Fold_Uint (N, False_Value, True); 7624 7625 -- Else yield proper floating-point result 7626 7627 else 7628 Fold_Uint 7629 (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True); 7630 end if; 7631 7632 ------------------ 7633 -- Machine_Size -- 7634 ------------------ 7635 7636 -- Note: Machine_Size is identical to Object_Size 7637 7638 when Attribute_Machine_Size => Machine_Size : declare 7639 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 7640 7641 begin 7642 if Known_Esize (P_TypeA) then 7643 Fold_Uint (N, Esize (P_TypeA), True); 7644 end if; 7645 end Machine_Size; 7646 7647 -------------- 7648 -- Mantissa -- 7649 -------------- 7650 7651 when Attribute_Mantissa => 7652 7653 -- Fixed-point mantissa 7654 7655 if Is_Fixed_Point_Type (P_Type) then 7656 7657 -- Compile time foldable case 7658 7659 if Compile_Time_Known_Value (Type_Low_Bound (P_Type)) 7660 and then 7661 Compile_Time_Known_Value (Type_High_Bound (P_Type)) 7662 then 7663 -- The calculation of the obsolete Ada 83 attribute Mantissa 7664 -- is annoying, because of AI00143, quoted here: 7665 7666 -- !question 84-01-10 7667 7668 -- Consider the model numbers for F: 7669 7670 -- type F is delta 1.0 range -7.0 .. 8.0; 7671 7672 -- The wording requires that F'MANTISSA be the SMALLEST 7673 -- integer number for which each bound of the specified 7674 -- range is either a model number or lies at most small 7675 -- distant from a model number. This means F'MANTISSA 7676 -- is required to be 3 since the range -7.0 .. 7.0 fits 7677 -- in 3 signed bits, and 8 is "at most" 1.0 from a model 7678 -- number, namely, 7. Is this analysis correct? Note that 7679 -- this implies the upper bound of the range is not 7680 -- represented as a model number. 7681 7682 -- !response 84-03-17 7683 7684 -- The analysis is correct. The upper and lower bounds for 7685 -- a fixed point type can lie outside the range of model 7686 -- numbers. 7687 7688 declare 7689 Siz : Uint; 7690 LBound : Ureal; 7691 UBound : Ureal; 7692 Bound : Ureal; 7693 Max_Man : Uint; 7694 7695 begin 7696 LBound := Expr_Value_R (Type_Low_Bound (P_Type)); 7697 UBound := Expr_Value_R (Type_High_Bound (P_Type)); 7698 Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound)); 7699 Max_Man := UR_Trunc (Bound / Small_Value (P_Type)); 7700 7701 -- If the Bound is exactly a model number, i.e. a multiple 7702 -- of Small, then we back it off by one to get the integer 7703 -- value that must be representable. 7704 7705 if Small_Value (P_Type) * Max_Man = Bound then 7706 Max_Man := Max_Man - 1; 7707 end if; 7708 7709 -- Now find corresponding size = Mantissa value 7710 7711 Siz := Uint_0; 7712 while 2 ** Siz < Max_Man loop 7713 Siz := Siz + 1; 7714 end loop; 7715 7716 Fold_Uint (N, Siz, True); 7717 end; 7718 7719 else 7720 -- The case of dynamic bounds cannot be evaluated at compile 7721 -- time. Instead we use a runtime routine (see Exp_Attr). 7722 7723 null; 7724 end if; 7725 7726 -- Floating-point Mantissa 7727 7728 else 7729 Fold_Uint (N, Mantissa, True); 7730 end if; 7731 7732 --------- 7733 -- Max -- 7734 --------- 7735 7736 when Attribute_Max => Max : 7737 begin 7738 if Is_Real_Type (P_Type) then 7739 Fold_Ureal 7740 (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static); 7741 else 7742 Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static); 7743 end if; 7744 end Max; 7745 7746 ---------------------------------- 7747 -- Max_Alignment_For_Allocation -- 7748 ---------------------------------- 7749 7750 -- Max_Alignment_For_Allocation is usually the Alignment. However, 7751 -- arrays are allocated with dope, so we need to take into account both 7752 -- the alignment of the array, which comes from the component alignment, 7753 -- and the alignment of the dope. Also, if the alignment is unknown, we 7754 -- use the max (it's OK to be pessimistic). 7755 7756 when Attribute_Max_Alignment_For_Allocation => 7757 declare 7758 A : Uint := UI_From_Int (Ttypes.Maximum_Alignment); 7759 begin 7760 if Known_Alignment (P_Type) and then 7761 (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A) 7762 then 7763 A := Alignment (P_Type); 7764 end if; 7765 7766 Fold_Uint (N, A, Static); 7767 end; 7768 7769 ---------------------------------- 7770 -- Max_Size_In_Storage_Elements -- 7771 ---------------------------------- 7772 7773 -- Max_Size_In_Storage_Elements is simply the Size rounded up to a 7774 -- Storage_Unit boundary. We can fold any cases for which the size 7775 -- is known by the front end. 7776 7777 when Attribute_Max_Size_In_Storage_Elements => 7778 if Known_Esize (P_Type) then 7779 Fold_Uint (N, 7780 (Esize (P_Type) + System_Storage_Unit - 1) / 7781 System_Storage_Unit, 7782 Static); 7783 end if; 7784 7785 -------------------- 7786 -- Mechanism_Code -- 7787 -------------------- 7788 7789 when Attribute_Mechanism_Code => 7790 declare 7791 Val : Int; 7792 Formal : Entity_Id; 7793 Mech : Mechanism_Type; 7794 7795 begin 7796 if No (E1) then 7797 Mech := Mechanism (P_Entity); 7798 7799 else 7800 Val := UI_To_Int (Expr_Value (E1)); 7801 7802 Formal := First_Formal (P_Entity); 7803 for J in 1 .. Val - 1 loop 7804 Next_Formal (Formal); 7805 end loop; 7806 Mech := Mechanism (Formal); 7807 end if; 7808 7809 if Mech < 0 then 7810 Fold_Uint (N, UI_From_Int (Int (-Mech)), True); 7811 end if; 7812 end; 7813 7814 --------- 7815 -- Min -- 7816 --------- 7817 7818 when Attribute_Min => Min : 7819 begin 7820 if Is_Real_Type (P_Type) then 7821 Fold_Ureal 7822 (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static); 7823 else 7824 Fold_Uint 7825 (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static); 7826 end if; 7827 end Min; 7828 7829 --------- 7830 -- Mod -- 7831 --------- 7832 7833 when Attribute_Mod => 7834 Fold_Uint 7835 (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static); 7836 7837 ----------- 7838 -- Model -- 7839 ----------- 7840 7841 when Attribute_Model => 7842 Fold_Ureal 7843 (N, Eval_Fat.Model (P_Base_Type, Expr_Value_R (E1)), Static); 7844 7845 ---------------- 7846 -- Model_Emin -- 7847 ---------------- 7848 7849 when Attribute_Model_Emin => 7850 Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static); 7851 7852 ------------------- 7853 -- Model_Epsilon -- 7854 ------------------- 7855 7856 when Attribute_Model_Epsilon => 7857 Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static); 7858 7859 -------------------- 7860 -- Model_Mantissa -- 7861 -------------------- 7862 7863 when Attribute_Model_Mantissa => 7864 Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static); 7865 7866 ----------------- 7867 -- Model_Small -- 7868 ----------------- 7869 7870 when Attribute_Model_Small => 7871 Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static); 7872 7873 ------------- 7874 -- Modulus -- 7875 ------------- 7876 7877 when Attribute_Modulus => 7878 Fold_Uint (N, Modulus (P_Type), True); 7879 7880 -------------------- 7881 -- Null_Parameter -- 7882 -------------------- 7883 7884 -- Cannot fold, we know the value sort of, but the whole point is 7885 -- that there is no way to talk about this imaginary value except 7886 -- by using the attribute, so we leave it the way it is. 7887 7888 when Attribute_Null_Parameter => 7889 null; 7890 7891 ----------------- 7892 -- Object_Size -- 7893 ----------------- 7894 7895 -- The Object_Size attribute for a type returns the Esize of the 7896 -- type and can be folded if this value is known. 7897 7898 when Attribute_Object_Size => Object_Size : declare 7899 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 7900 7901 begin 7902 if Known_Esize (P_TypeA) then 7903 Fold_Uint (N, Esize (P_TypeA), True); 7904 end if; 7905 end Object_Size; 7906 7907 ---------------------- 7908 -- Overlaps_Storage -- 7909 ---------------------- 7910 7911 when Attribute_Overlaps_Storage => 7912 null; 7913 7914 ------------------------- 7915 -- Passed_By_Reference -- 7916 ------------------------- 7917 7918 -- Scalar types are never passed by reference 7919 7920 when Attribute_Passed_By_Reference => 7921 Fold_Uint (N, False_Value, True); 7922 7923 --------- 7924 -- Pos -- 7925 --------- 7926 7927 when Attribute_Pos => 7928 Fold_Uint (N, Expr_Value (E1), True); 7929 7930 ---------- 7931 -- Pred -- 7932 ---------- 7933 7934 when Attribute_Pred => Pred : 7935 begin 7936 -- Floating-point case 7937 7938 if Is_Floating_Point_Type (P_Type) then 7939 Fold_Ureal 7940 (N, Eval_Fat.Pred (P_Base_Type, Expr_Value_R (E1)), Static); 7941 7942 -- Fixed-point case 7943 7944 elsif Is_Fixed_Point_Type (P_Type) then 7945 Fold_Ureal 7946 (N, Expr_Value_R (E1) - Small_Value (P_Type), True); 7947 7948 -- Modular integer case (wraps) 7949 7950 elsif Is_Modular_Integer_Type (P_Type) then 7951 Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static); 7952 7953 -- Other scalar cases 7954 7955 else 7956 pragma Assert (Is_Scalar_Type (P_Type)); 7957 7958 if Is_Enumeration_Type (P_Type) 7959 and then Expr_Value (E1) = 7960 Expr_Value (Type_Low_Bound (P_Base_Type)) 7961 then 7962 Apply_Compile_Time_Constraint_Error 7963 (N, "Pred of `&''First`", 7964 CE_Overflow_Check_Failed, 7965 Ent => P_Base_Type, 7966 Warn => not Static); 7967 7968 Check_Expressions; 7969 return; 7970 end if; 7971 7972 Fold_Uint (N, Expr_Value (E1) - 1, Static); 7973 end if; 7974 end Pred; 7975 7976 ----------- 7977 -- Range -- 7978 ----------- 7979 7980 -- No processing required, because by this stage, Range has been 7981 -- replaced by First .. Last, so this branch can never be taken. 7982 7983 when Attribute_Range => 7984 raise Program_Error; 7985 7986 ------------------ 7987 -- Range_Length -- 7988 ------------------ 7989 7990 when Attribute_Range_Length => 7991 Set_Bounds; 7992 7993 -- Can fold if both bounds are compile time known 7994 7995 if Compile_Time_Known_Value (Hi_Bound) 7996 and then Compile_Time_Known_Value (Lo_Bound) 7997 then 7998 Fold_Uint (N, 7999 UI_Max 8000 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1), 8001 Static); 8002 end if; 8003 8004 -- One more case is where Hi_Bound and Lo_Bound are compile-time 8005 -- comparable, and we can figure out the difference between them. 8006 8007 declare 8008 Diff : aliased Uint; 8009 8010 begin 8011 case 8012 Compile_Time_Compare 8013 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False) 8014 is 8015 when EQ => 8016 Fold_Uint (N, Uint_1, False); 8017 8018 when GT => 8019 Fold_Uint (N, Uint_0, False); 8020 8021 when LT => 8022 if Diff /= No_Uint then 8023 Fold_Uint (N, Diff + 1, False); 8024 end if; 8025 8026 when others => 8027 null; 8028 end case; 8029 end; 8030 8031 --------- 8032 -- Ref -- 8033 --------- 8034 8035 when Attribute_Ref => 8036 Fold_Uint (N, Expr_Value (E1), True); 8037 8038 --------------- 8039 -- Remainder -- 8040 --------------- 8041 8042 when Attribute_Remainder => Remainder : declare 8043 X : constant Ureal := Expr_Value_R (E1); 8044 Y : constant Ureal := Expr_Value_R (E2); 8045 8046 begin 8047 if UR_Is_Zero (Y) then 8048 Apply_Compile_Time_Constraint_Error 8049 (N, "division by zero in Remainder", 8050 CE_Overflow_Check_Failed, 8051 Warn => not Static); 8052 8053 Check_Expressions; 8054 return; 8055 end if; 8056 8057 Fold_Ureal (N, Eval_Fat.Remainder (P_Base_Type, X, Y), Static); 8058 end Remainder; 8059 8060 ----------- 8061 -- Round -- 8062 ----------- 8063 8064 when Attribute_Round => Round : 8065 declare 8066 Sr : Ureal; 8067 Si : Uint; 8068 8069 begin 8070 -- First we get the (exact result) in units of small 8071 8072 Sr := Expr_Value_R (E1) / Small_Value (C_Type); 8073 8074 -- Now round that exactly to an integer 8075 8076 Si := UR_To_Uint (Sr); 8077 8078 -- Finally the result is obtained by converting back to real 8079 8080 Fold_Ureal (N, Si * Small_Value (C_Type), Static); 8081 end Round; 8082 8083 -------------- 8084 -- Rounding -- 8085 -------------- 8086 8087 when Attribute_Rounding => 8088 Fold_Ureal 8089 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static); 8090 8091 --------------- 8092 -- Safe_Emax -- 8093 --------------- 8094 8095 when Attribute_Safe_Emax => 8096 Fold_Uint (N, Safe_Emax_Value (P_Type), Static); 8097 8098 ---------------- 8099 -- Safe_First -- 8100 ---------------- 8101 8102 when Attribute_Safe_First => 8103 Fold_Ureal (N, Safe_First_Value (P_Type), Static); 8104 8105 ---------------- 8106 -- Safe_Large -- 8107 ---------------- 8108 8109 when Attribute_Safe_Large => 8110 if Is_Fixed_Point_Type (P_Type) then 8111 Fold_Ureal 8112 (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static); 8113 else 8114 Fold_Ureal (N, Safe_Last_Value (P_Type), Static); 8115 end if; 8116 8117 --------------- 8118 -- Safe_Last -- 8119 --------------- 8120 8121 when Attribute_Safe_Last => 8122 Fold_Ureal (N, Safe_Last_Value (P_Type), Static); 8123 8124 ---------------- 8125 -- Safe_Small -- 8126 ---------------- 8127 8128 when Attribute_Safe_Small => 8129 8130 -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant 8131 -- for fixed-point, since is the same as Small, but we implement 8132 -- it for backwards compatibility. 8133 8134 if Is_Fixed_Point_Type (P_Type) then 8135 Fold_Ureal (N, Small_Value (P_Type), Static); 8136 8137 -- Ada 83 Safe_Small for floating-point cases 8138 8139 else 8140 Fold_Ureal (N, Model_Small_Value (P_Type), Static); 8141 end if; 8142 8143 ------------------ 8144 -- Same_Storage -- 8145 ------------------ 8146 8147 when Attribute_Same_Storage => 8148 null; 8149 8150 ----------- 8151 -- Scale -- 8152 ----------- 8153 8154 when Attribute_Scale => 8155 Fold_Uint (N, Scale_Value (P_Type), True); 8156 8157 ------------- 8158 -- Scaling -- 8159 ------------- 8160 8161 when Attribute_Scaling => 8162 Fold_Ureal 8163 (N, 8164 Eval_Fat.Scaling 8165 (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)), 8166 Static); 8167 8168 ------------------ 8169 -- Signed_Zeros -- 8170 ------------------ 8171 8172 when Attribute_Signed_Zeros => 8173 Fold_Uint 8174 (N, UI_From_Int (Boolean'Pos (Has_Signed_Zeros (P_Type))), Static); 8175 8176 ---------- 8177 -- Size -- 8178 ---------- 8179 8180 -- Size attribute returns the RM size. All scalar types can be folded, 8181 -- as well as any types for which the size is known by the front end, 8182 -- including any type for which a size attribute is specified. 8183 8184 when Attribute_Size | Attribute_VADS_Size => Size : declare 8185 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 8186 8187 begin 8188 if RM_Size (P_TypeA) /= Uint_0 then 8189 8190 -- VADS_Size case 8191 8192 if Id = Attribute_VADS_Size or else Use_VADS_Size then 8193 declare 8194 S : constant Node_Id := Size_Clause (P_TypeA); 8195 8196 begin 8197 -- If a size clause applies, then use the size from it. 8198 -- This is one of the rare cases where we can use the 8199 -- Size_Clause field for a subtype when Has_Size_Clause 8200 -- is False. Consider: 8201 8202 -- type x is range 1 .. 64; 8203 -- for x'size use 12; 8204 -- subtype y is x range 0 .. 3; 8205 8206 -- Here y has a size clause inherited from x, but normally 8207 -- it does not apply, and y'size is 2. However, y'VADS_Size 8208 -- is indeed 12 and not 2. 8209 8210 if Present (S) 8211 and then Is_OK_Static_Expression (Expression (S)) 8212 then 8213 Fold_Uint (N, Expr_Value (Expression (S)), True); 8214 8215 -- If no size is specified, then we simply use the object 8216 -- size in the VADS_Size case (e.g. Natural'Size is equal 8217 -- to Integer'Size, not one less). 8218 8219 else 8220 Fold_Uint (N, Esize (P_TypeA), True); 8221 end if; 8222 end; 8223 8224 -- Normal case (Size) in which case we want the RM_Size 8225 8226 else 8227 Fold_Uint (N, 8228 RM_Size (P_TypeA), 8229 Static and then Is_Discrete_Type (P_TypeA)); 8230 end if; 8231 end if; 8232 end Size; 8233 8234 ----------- 8235 -- Small -- 8236 ----------- 8237 8238 when Attribute_Small => 8239 8240 -- The floating-point case is present only for Ada 83 compatibility. 8241 -- Note that strictly this is an illegal addition, since we are 8242 -- extending an Ada 95 defined attribute, but we anticipate an 8243 -- ARG ruling that will permit this. 8244 8245 if Is_Floating_Point_Type (P_Type) then 8246 8247 -- Ada 83 attribute is defined as (RM83 3.5.8) 8248 8249 -- T'Small = 2.0**(-T'Emax - 1) 8250 8251 -- where 8252 8253 -- T'Emax = 4 * T'Mantissa 8254 8255 Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static); 8256 8257 -- Normal Ada 95 fixed-point case 8258 8259 else 8260 Fold_Ureal (N, Small_Value (P_Type), True); 8261 end if; 8262 8263 ----------------- 8264 -- Stream_Size -- 8265 ----------------- 8266 8267 when Attribute_Stream_Size => 8268 null; 8269 8270 ---------- 8271 -- Succ -- 8272 ---------- 8273 8274 when Attribute_Succ => Succ : 8275 begin 8276 -- Floating-point case 8277 8278 if Is_Floating_Point_Type (P_Type) then 8279 Fold_Ureal 8280 (N, Eval_Fat.Succ (P_Base_Type, Expr_Value_R (E1)), Static); 8281 8282 -- Fixed-point case 8283 8284 elsif Is_Fixed_Point_Type (P_Type) then 8285 Fold_Ureal (N, Expr_Value_R (E1) + Small_Value (P_Type), Static); 8286 8287 -- Modular integer case (wraps) 8288 8289 elsif Is_Modular_Integer_Type (P_Type) then 8290 Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static); 8291 8292 -- Other scalar cases 8293 8294 else 8295 pragma Assert (Is_Scalar_Type (P_Type)); 8296 8297 if Is_Enumeration_Type (P_Type) 8298 and then Expr_Value (E1) = 8299 Expr_Value (Type_High_Bound (P_Base_Type)) 8300 then 8301 Apply_Compile_Time_Constraint_Error 8302 (N, "Succ of `&''Last`", 8303 CE_Overflow_Check_Failed, 8304 Ent => P_Base_Type, 8305 Warn => not Static); 8306 8307 Check_Expressions; 8308 return; 8309 else 8310 Fold_Uint (N, Expr_Value (E1) + 1, Static); 8311 end if; 8312 end if; 8313 end Succ; 8314 8315 ---------------- 8316 -- Truncation -- 8317 ---------------- 8318 8319 when Attribute_Truncation => 8320 Fold_Ureal 8321 (N, 8322 Eval_Fat.Truncation (P_Base_Type, Expr_Value_R (E1)), 8323 Static); 8324 8325 ---------------- 8326 -- Type_Class -- 8327 ---------------- 8328 8329 when Attribute_Type_Class => Type_Class : declare 8330 Typ : constant Entity_Id := Underlying_Type (P_Base_Type); 8331 Id : RE_Id; 8332 8333 begin 8334 if Is_Descendent_Of_Address (Typ) then 8335 Id := RE_Type_Class_Address; 8336 8337 elsif Is_Enumeration_Type (Typ) then 8338 Id := RE_Type_Class_Enumeration; 8339 8340 elsif Is_Integer_Type (Typ) then 8341 Id := RE_Type_Class_Integer; 8342 8343 elsif Is_Fixed_Point_Type (Typ) then 8344 Id := RE_Type_Class_Fixed_Point; 8345 8346 elsif Is_Floating_Point_Type (Typ) then 8347 Id := RE_Type_Class_Floating_Point; 8348 8349 elsif Is_Array_Type (Typ) then 8350 Id := RE_Type_Class_Array; 8351 8352 elsif Is_Record_Type (Typ) then 8353 Id := RE_Type_Class_Record; 8354 8355 elsif Is_Access_Type (Typ) then 8356 Id := RE_Type_Class_Access; 8357 8358 elsif Is_Enumeration_Type (Typ) then 8359 Id := RE_Type_Class_Enumeration; 8360 8361 elsif Is_Task_Type (Typ) then 8362 Id := RE_Type_Class_Task; 8363 8364 -- We treat protected types like task types. It would make more 8365 -- sense to have another enumeration value, but after all the 8366 -- whole point of this feature is to be exactly DEC compatible, 8367 -- and changing the type Type_Class would not meet this requirement. 8368 8369 elsif Is_Protected_Type (Typ) then 8370 Id := RE_Type_Class_Task; 8371 8372 -- Not clear if there are any other possibilities, but if there 8373 -- are, then we will treat them as the address case. 8374 8375 else 8376 Id := RE_Type_Class_Address; 8377 end if; 8378 8379 Rewrite (N, New_Occurrence_Of (RTE (Id), Loc)); 8380 end Type_Class; 8381 8382 ----------------------- 8383 -- Unbiased_Rounding -- 8384 ----------------------- 8385 8386 when Attribute_Unbiased_Rounding => 8387 Fold_Ureal 8388 (N, 8389 Eval_Fat.Unbiased_Rounding (P_Base_Type, Expr_Value_R (E1)), 8390 Static); 8391 8392 ------------------------- 8393 -- Unconstrained_Array -- 8394 ------------------------- 8395 8396 when Attribute_Unconstrained_Array => Unconstrained_Array : declare 8397 Typ : constant Entity_Id := Underlying_Type (P_Type); 8398 8399 begin 8400 Rewrite (N, New_Occurrence_Of ( 8401 Boolean_Literals ( 8402 Is_Array_Type (P_Type) 8403 and then not Is_Constrained (Typ)), Loc)); 8404 8405 -- Analyze and resolve as boolean, note that this attribute is 8406 -- a static attribute in GNAT. 8407 8408 Analyze_And_Resolve (N, Standard_Boolean); 8409 Static := True; 8410 end Unconstrained_Array; 8411 8412 -- Attribute Update is never static 8413 8414 ------------ 8415 -- Update -- 8416 ------------ 8417 8418 when Attribute_Update => 8419 null; 8420 8421 --------------- 8422 -- VADS_Size -- 8423 --------------- 8424 8425 -- Processing is shared with Size 8426 8427 --------- 8428 -- Val -- 8429 --------- 8430 8431 when Attribute_Val => Val : 8432 begin 8433 if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type)) 8434 or else 8435 Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type)) 8436 then 8437 Apply_Compile_Time_Constraint_Error 8438 (N, "Val expression out of range", 8439 CE_Range_Check_Failed, 8440 Warn => not Static); 8441 8442 Check_Expressions; 8443 return; 8444 8445 else 8446 Fold_Uint (N, Expr_Value (E1), Static); 8447 end if; 8448 end Val; 8449 8450 ---------------- 8451 -- Value_Size -- 8452 ---------------- 8453 8454 -- The Value_Size attribute for a type returns the RM size of the 8455 -- type. This an always be folded for scalar types, and can also 8456 -- be folded for non-scalar types if the size is set. 8457 8458 when Attribute_Value_Size => Value_Size : declare 8459 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 8460 begin 8461 if RM_Size (P_TypeA) /= Uint_0 then 8462 Fold_Uint (N, RM_Size (P_TypeA), True); 8463 end if; 8464 end Value_Size; 8465 8466 ------------- 8467 -- Version -- 8468 ------------- 8469 8470 -- Version can never be static 8471 8472 when Attribute_Version => 8473 null; 8474 8475 ---------------- 8476 -- Wide_Image -- 8477 ---------------- 8478 8479 -- Wide_Image is a scalar attribute, but is never static, because it 8480 -- is not a static function (having a non-scalar argument (RM 4.9(22)) 8481 8482 when Attribute_Wide_Image => 8483 null; 8484 8485 --------------------- 8486 -- Wide_Wide_Image -- 8487 --------------------- 8488 8489 -- Wide_Wide_Image is a scalar attribute but is never static, because it 8490 -- is not a static function (having a non-scalar argument (RM 4.9(22)). 8491 8492 when Attribute_Wide_Wide_Image => 8493 null; 8494 8495 --------------------- 8496 -- Wide_Wide_Width -- 8497 --------------------- 8498 8499 -- Processing for Wide_Wide_Width is combined with Width 8500 8501 ---------------- 8502 -- Wide_Width -- 8503 ---------------- 8504 8505 -- Processing for Wide_Width is combined with Width 8506 8507 ----------- 8508 -- Width -- 8509 ----------- 8510 8511 -- This processing also handles the case of Wide_[Wide_]Width 8512 8513 when Attribute_Width | 8514 Attribute_Wide_Width | 8515 Attribute_Wide_Wide_Width => Width : 8516 begin 8517 if Compile_Time_Known_Bounds (P_Type) then 8518 8519 -- Floating-point types 8520 8521 if Is_Floating_Point_Type (P_Type) then 8522 8523 -- Width is zero for a null range (RM 3.5 (38)) 8524 8525 if Expr_Value_R (Type_High_Bound (P_Type)) < 8526 Expr_Value_R (Type_Low_Bound (P_Type)) 8527 then 8528 Fold_Uint (N, Uint_0, True); 8529 8530 else 8531 -- For floating-point, we have +N.dddE+nnn where length 8532 -- of ddd is determined by type'Digits - 1, but is one 8533 -- if Digits is one (RM 3.5 (33)). 8534 8535 -- nnn is set to 2 for Short_Float and Float (32 bit 8536 -- floats), and 3 for Long_Float and Long_Long_Float. 8537 -- For machines where Long_Long_Float is the IEEE 8538 -- extended precision type, the exponent takes 4 digits. 8539 8540 declare 8541 Len : Int := 8542 Int'Max (2, UI_To_Int (Digits_Value (P_Type))); 8543 8544 begin 8545 if Esize (P_Type) <= 32 then 8546 Len := Len + 6; 8547 elsif Esize (P_Type) = 64 then 8548 Len := Len + 7; 8549 else 8550 Len := Len + 8; 8551 end if; 8552 8553 Fold_Uint (N, UI_From_Int (Len), True); 8554 end; 8555 end if; 8556 8557 -- Fixed-point types 8558 8559 elsif Is_Fixed_Point_Type (P_Type) then 8560 8561 -- Width is zero for a null range (RM 3.5 (38)) 8562 8563 if Expr_Value (Type_High_Bound (P_Type)) < 8564 Expr_Value (Type_Low_Bound (P_Type)) 8565 then 8566 Fold_Uint (N, Uint_0, True); 8567 8568 -- The non-null case depends on the specific real type 8569 8570 else 8571 -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) 8572 8573 Fold_Uint 8574 (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type), 8575 True); 8576 end if; 8577 8578 -- Discrete types 8579 8580 else 8581 declare 8582 R : constant Entity_Id := Root_Type (P_Type); 8583 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); 8584 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); 8585 W : Nat; 8586 Wt : Nat; 8587 T : Uint; 8588 L : Node_Id; 8589 C : Character; 8590 8591 begin 8592 -- Empty ranges 8593 8594 if Lo > Hi then 8595 W := 0; 8596 8597 -- Width for types derived from Standard.Character 8598 -- and Standard.Wide_[Wide_]Character. 8599 8600 elsif Is_Standard_Character_Type (P_Type) then 8601 W := 0; 8602 8603 -- Set W larger if needed 8604 8605 for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop 8606 8607 -- All wide characters look like Hex_hhhhhhhh 8608 8609 if J > 255 then 8610 8611 -- No need to compute this more than once! 8612 8613 exit; 8614 8615 else 8616 C := Character'Val (J); 8617 8618 -- Test for all cases where Character'Image 8619 -- yields an image that is longer than three 8620 -- characters. First the cases of Reserved_xxx 8621 -- names (length = 12). 8622 8623 case C is 8624 when Reserved_128 | Reserved_129 | 8625 Reserved_132 | Reserved_153 8626 => Wt := 12; 8627 8628 when BS | HT | LF | VT | FF | CR | 8629 SO | SI | EM | FS | GS | RS | 8630 US | RI | MW | ST | PM 8631 => Wt := 2; 8632 8633 when NUL | SOH | STX | ETX | EOT | 8634 ENQ | ACK | BEL | DLE | DC1 | 8635 DC2 | DC3 | DC4 | NAK | SYN | 8636 ETB | CAN | SUB | ESC | DEL | 8637 BPH | NBH | NEL | SSA | ESA | 8638 HTS | HTJ | VTS | PLD | PLU | 8639 SS2 | SS3 | DCS | PU1 | PU2 | 8640 STS | CCH | SPA | EPA | SOS | 8641 SCI | CSI | OSC | APC 8642 => Wt := 3; 8643 8644 when Space .. Tilde | 8645 No_Break_Space .. LC_Y_Diaeresis 8646 => 8647 -- Special case of soft hyphen in Ada 2005 8648 8649 if C = Character'Val (16#AD#) 8650 and then Ada_Version >= Ada_2005 8651 then 8652 Wt := 11; 8653 else 8654 Wt := 3; 8655 end if; 8656 end case; 8657 8658 W := Int'Max (W, Wt); 8659 end if; 8660 end loop; 8661 8662 -- Width for types derived from Standard.Boolean 8663 8664 elsif R = Standard_Boolean then 8665 if Lo = 0 then 8666 W := 5; -- FALSE 8667 else 8668 W := 4; -- TRUE 8669 end if; 8670 8671 -- Width for integer types 8672 8673 elsif Is_Integer_Type (P_Type) then 8674 T := UI_Max (abs Lo, abs Hi); 8675 8676 W := 2; 8677 while T >= 10 loop 8678 W := W + 1; 8679 T := T / 10; 8680 end loop; 8681 8682 -- User declared enum type with discard names 8683 8684 elsif Discard_Names (R) then 8685 8686 -- If range is null, result is zero, that has already 8687 -- been dealt with, so what we need is the power of ten 8688 -- that accomodates the Pos of the largest value, which 8689 -- is the high bound of the range + one for the space. 8690 8691 W := 1; 8692 T := Hi; 8693 while T /= 0 loop 8694 T := T / 10; 8695 W := W + 1; 8696 end loop; 8697 8698 -- Only remaining possibility is user declared enum type 8699 -- with normal case of Discard_Names not active. 8700 8701 else 8702 pragma Assert (Is_Enumeration_Type (P_Type)); 8703 8704 W := 0; 8705 L := First_Literal (P_Type); 8706 while Present (L) loop 8707 8708 -- Only pay attention to in range characters 8709 8710 if Lo <= Enumeration_Pos (L) 8711 and then Enumeration_Pos (L) <= Hi 8712 then 8713 -- For Width case, use decoded name 8714 8715 if Id = Attribute_Width then 8716 Get_Decoded_Name_String (Chars (L)); 8717 Wt := Nat (Name_Len); 8718 8719 -- For Wide_[Wide_]Width, use encoded name, and 8720 -- then adjust for the encoding. 8721 8722 else 8723 Get_Name_String (Chars (L)); 8724 8725 -- Character literals are always of length 3 8726 8727 if Name_Buffer (1) = 'Q' then 8728 Wt := 3; 8729 8730 -- Otherwise loop to adjust for upper/wide chars 8731 8732 else 8733 Wt := Nat (Name_Len); 8734 8735 for J in 1 .. Name_Len loop 8736 if Name_Buffer (J) = 'U' then 8737 Wt := Wt - 2; 8738 elsif Name_Buffer (J) = 'W' then 8739 Wt := Wt - 4; 8740 end if; 8741 end loop; 8742 end if; 8743 end if; 8744 8745 W := Int'Max (W, Wt); 8746 end if; 8747 8748 Next_Literal (L); 8749 end loop; 8750 end if; 8751 8752 Fold_Uint (N, UI_From_Int (W), True); 8753 end; 8754 end if; 8755 end if; 8756 end Width; 8757 8758 -- The following attributes denote functions that cannot be folded 8759 8760 when Attribute_From_Any | 8761 Attribute_To_Any | 8762 Attribute_TypeCode => 8763 null; 8764 8765 -- The following attributes can never be folded, and furthermore we 8766 -- should not even have entered the case statement for any of these. 8767 -- Note that in some cases, the values have already been folded as 8768 -- a result of the processing in Analyze_Attribute. 8769 8770 when Attribute_Abort_Signal | 8771 Attribute_Access | 8772 Attribute_Address | 8773 Attribute_Address_Size | 8774 Attribute_Asm_Input | 8775 Attribute_Asm_Output | 8776 Attribute_Base | 8777 Attribute_Bit_Order | 8778 Attribute_Bit_Position | 8779 Attribute_Callable | 8780 Attribute_Caller | 8781 Attribute_Class | 8782 Attribute_Code_Address | 8783 Attribute_Compiler_Version | 8784 Attribute_Count | 8785 Attribute_Default_Bit_Order | 8786 Attribute_Elaborated | 8787 Attribute_Elab_Body | 8788 Attribute_Elab_Spec | 8789 Attribute_Elab_Subp_Body | 8790 Attribute_Enabled | 8791 Attribute_External_Tag | 8792 Attribute_Fast_Math | 8793 Attribute_First_Bit | 8794 Attribute_Input | 8795 Attribute_Last_Bit | 8796 Attribute_Maximum_Alignment | 8797 Attribute_Old | 8798 Attribute_Output | 8799 Attribute_Partition_ID | 8800 Attribute_Pool_Address | 8801 Attribute_Position | 8802 Attribute_Priority | 8803 Attribute_Read | 8804 Attribute_Result | 8805 Attribute_Scalar_Storage_Order | 8806 Attribute_Simple_Storage_Pool | 8807 Attribute_Storage_Pool | 8808 Attribute_Storage_Size | 8809 Attribute_Storage_Unit | 8810 Attribute_Stub_Type | 8811 Attribute_System_Allocator_Alignment | 8812 Attribute_Tag | 8813 Attribute_Target_Name | 8814 Attribute_Terminated | 8815 Attribute_To_Address | 8816 Attribute_Type_Key | 8817 Attribute_UET_Address | 8818 Attribute_Unchecked_Access | 8819 Attribute_Universal_Literal_String | 8820 Attribute_Unrestricted_Access | 8821 Attribute_Valid | 8822 Attribute_Valid_Scalars | 8823 Attribute_Value | 8824 Attribute_Wchar_T_Size | 8825 Attribute_Wide_Value | 8826 Attribute_Wide_Wide_Value | 8827 Attribute_Word_Size | 8828 Attribute_Write => 8829 8830 raise Program_Error; 8831 end case; 8832 8833 -- At the end of the case, one more check. If we did a static evaluation 8834 -- so that the result is now a literal, then set Is_Static_Expression 8835 -- in the constant only if the prefix type is a static subtype. For 8836 -- non-static subtypes, the folding is still OK, but not static. 8837 8838 -- An exception is the GNAT attribute Constrained_Array which is 8839 -- defined to be a static attribute in all cases. 8840 8841 if Nkind_In (N, N_Integer_Literal, 8842 N_Real_Literal, 8843 N_Character_Literal, 8844 N_String_Literal) 8845 or else (Is_Entity_Name (N) 8846 and then Ekind (Entity (N)) = E_Enumeration_Literal) 8847 then 8848 Set_Is_Static_Expression (N, Static); 8849 8850 -- If this is still an attribute reference, then it has not been folded 8851 -- and that means that its expressions are in a non-static context. 8852 8853 elsif Nkind (N) = N_Attribute_Reference then 8854 Check_Expressions; 8855 8856 -- Note: the else case not covered here are odd cases where the 8857 -- processing has transformed the attribute into something other 8858 -- than a constant. Nothing more to do in such cases. 8859 8860 else 8861 null; 8862 end if; 8863 end Eval_Attribute; 8864 8865 ------------------------------ 8866 -- Is_Anonymous_Tagged_Base -- 8867 ------------------------------ 8868 8869 function Is_Anonymous_Tagged_Base 8870 (Anon : Entity_Id; 8871 Typ : Entity_Id) 8872 return Boolean 8873 is 8874 begin 8875 return 8876 Anon = Current_Scope 8877 and then Is_Itype (Anon) 8878 and then Associated_Node_For_Itype (Anon) = Parent (Typ); 8879 end Is_Anonymous_Tagged_Base; 8880 8881 -------------------------------- 8882 -- Name_Implies_Lvalue_Prefix -- 8883 -------------------------------- 8884 8885 function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is 8886 pragma Assert (Is_Attribute_Name (Nam)); 8887 begin 8888 return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam)); 8889 end Name_Implies_Lvalue_Prefix; 8890 8891 ----------------------- 8892 -- Resolve_Attribute -- 8893 ----------------------- 8894 8895 procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is 8896 Loc : constant Source_Ptr := Sloc (N); 8897 P : constant Node_Id := Prefix (N); 8898 Aname : constant Name_Id := Attribute_Name (N); 8899 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); 8900 Btyp : constant Entity_Id := Base_Type (Typ); 8901 Des_Btyp : Entity_Id; 8902 Index : Interp_Index; 8903 It : Interp; 8904 Nom_Subt : Entity_Id; 8905 8906 procedure Accessibility_Message; 8907 -- Error, or warning within an instance, if the static accessibility 8908 -- rules of 3.10.2 are violated. 8909 8910 --------------------------- 8911 -- Accessibility_Message -- 8912 --------------------------- 8913 8914 procedure Accessibility_Message is 8915 Indic : Node_Id := Parent (Parent (N)); 8916 8917 begin 8918 -- In an instance, this is a runtime check, but one we 8919 -- know will fail, so generate an appropriate warning. 8920 8921 if In_Instance_Body then 8922 Error_Msg_F 8923 ("??non-local pointer cannot point to local object", P); 8924 Error_Msg_F 8925 ("\??Program_Error will be raised at run time", P); 8926 Rewrite (N, 8927 Make_Raise_Program_Error (Loc, 8928 Reason => PE_Accessibility_Check_Failed)); 8929 Set_Etype (N, Typ); 8930 return; 8931 8932 else 8933 Error_Msg_F ("non-local pointer cannot point to local object", P); 8934 8935 -- Check for case where we have a missing access definition 8936 8937 if Is_Record_Type (Current_Scope) 8938 and then 8939 Nkind_In (Parent (N), N_Discriminant_Association, 8940 N_Index_Or_Discriminant_Constraint) 8941 then 8942 Indic := Parent (Parent (N)); 8943 while Present (Indic) 8944 and then Nkind (Indic) /= N_Subtype_Indication 8945 loop 8946 Indic := Parent (Indic); 8947 end loop; 8948 8949 if Present (Indic) then 8950 Error_Msg_NE 8951 ("\use an access definition for" & 8952 " the access discriminant of&", 8953 N, Entity (Subtype_Mark (Indic))); 8954 end if; 8955 end if; 8956 end if; 8957 end Accessibility_Message; 8958 8959 -- Start of processing for Resolve_Attribute 8960 8961 begin 8962 -- If error during analysis, no point in continuing, except for array 8963 -- types, where we get better recovery by using unconstrained indexes 8964 -- than nothing at all (see Check_Array_Type). 8965 8966 if Error_Posted (N) 8967 and then Attr_Id /= Attribute_First 8968 and then Attr_Id /= Attribute_Last 8969 and then Attr_Id /= Attribute_Length 8970 and then Attr_Id /= Attribute_Range 8971 then 8972 return; 8973 end if; 8974 8975 -- If attribute was universal type, reset to actual type 8976 8977 if Etype (N) = Universal_Integer 8978 or else Etype (N) = Universal_Real 8979 then 8980 Set_Etype (N, Typ); 8981 end if; 8982 8983 -- Remaining processing depends on attribute 8984 8985 case Attr_Id is 8986 8987 ------------ 8988 -- Access -- 8989 ------------ 8990 8991 -- For access attributes, if the prefix denotes an entity, it is 8992 -- interpreted as a name, never as a call. It may be overloaded, 8993 -- in which case resolution uses the profile of the context type. 8994 -- Otherwise prefix must be resolved. 8995 8996 when Attribute_Access 8997 | Attribute_Unchecked_Access 8998 | Attribute_Unrestricted_Access => 8999 9000 Access_Attribute : 9001 begin 9002 if Is_Variable (P) then 9003 Note_Possible_Modification (P, Sure => False); 9004 end if; 9005 9006 -- The following comes from a query by Adam Beneschan, concerning 9007 -- improper use of universal_access in equality tests involving 9008 -- anonymous access types. Another good reason for 'Ref, but 9009 -- for now disable the test, which breaks several filed tests. 9010 9011 if Ekind (Typ) = E_Anonymous_Access_Type 9012 and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne) 9013 and then False 9014 then 9015 Error_Msg_N ("need unique type to resolve 'Access", N); 9016 Error_Msg_N ("\qualify attribute with some access type", N); 9017 end if; 9018 9019 if Is_Entity_Name (P) then 9020 if Is_Overloaded (P) then 9021 Get_First_Interp (P, Index, It); 9022 while Present (It.Nam) loop 9023 if Type_Conformant (Designated_Type (Typ), It.Nam) then 9024 Set_Entity (P, It.Nam); 9025 9026 -- The prefix is definitely NOT overloaded anymore at 9027 -- this point, so we reset the Is_Overloaded flag to 9028 -- avoid any confusion when reanalyzing the node. 9029 9030 Set_Is_Overloaded (P, False); 9031 Set_Is_Overloaded (N, False); 9032 Generate_Reference (Entity (P), P); 9033 exit; 9034 end if; 9035 9036 Get_Next_Interp (Index, It); 9037 end loop; 9038 9039 -- If Prefix is a subprogram name, it is frozen by this 9040 -- reference: 9041 9042 -- If it is a type, there is nothing to resolve. 9043 -- If it is an object, complete its resolution. 9044 9045 elsif Is_Overloadable (Entity (P)) then 9046 9047 -- Avoid insertion of freeze actions in spec expression mode 9048 9049 if not In_Spec_Expression then 9050 Freeze_Before (N, Entity (P)); 9051 end if; 9052 9053 elsif Is_Type (Entity (P)) then 9054 null; 9055 else 9056 Resolve (P); 9057 end if; 9058 9059 Error_Msg_Name_1 := Aname; 9060 9061 if not Is_Entity_Name (P) then 9062 null; 9063 9064 elsif Is_Overloadable (Entity (P)) 9065 and then Is_Abstract_Subprogram (Entity (P)) 9066 then 9067 Error_Msg_F ("prefix of % attribute cannot be abstract", P); 9068 Set_Etype (N, Any_Type); 9069 9070 elsif Convention (Entity (P)) = Convention_Intrinsic then 9071 if Ekind (Entity (P)) = E_Enumeration_Literal then 9072 Error_Msg_F 9073 ("prefix of % attribute cannot be enumeration literal", 9074 P); 9075 else 9076 Error_Msg_F 9077 ("prefix of % attribute cannot be intrinsic", P); 9078 end if; 9079 9080 Set_Etype (N, Any_Type); 9081 end if; 9082 9083 -- Assignments, return statements, components of aggregates, 9084 -- generic instantiations will require convention checks if 9085 -- the type is an access to subprogram. Given that there will 9086 -- also be accessibility checks on those, this is where the 9087 -- checks can eventually be centralized ??? 9088 9089 if Ekind_In (Btyp, E_Access_Subprogram_Type, 9090 E_Anonymous_Access_Subprogram_Type, 9091 E_Access_Protected_Subprogram_Type, 9092 E_Anonymous_Access_Protected_Subprogram_Type) 9093 then 9094 -- Deal with convention mismatch 9095 9096 if Convention (Designated_Type (Btyp)) /= 9097 Convention (Entity (P)) 9098 then 9099 Error_Msg_FE 9100 ("subprogram & has wrong convention", P, Entity (P)); 9101 Error_Msg_FE 9102 ("\does not match convention of access type &", 9103 P, Btyp); 9104 9105 if not Has_Convention_Pragma (Btyp) then 9106 Error_Msg_FE 9107 ("\probable missing pragma Convention for &", 9108 P, Btyp); 9109 end if; 9110 9111 else 9112 Check_Subtype_Conformant 9113 (New_Id => Entity (P), 9114 Old_Id => Designated_Type (Btyp), 9115 Err_Loc => P); 9116 end if; 9117 9118 if Attr_Id = Attribute_Unchecked_Access then 9119 Error_Msg_Name_1 := Aname; 9120 Error_Msg_F 9121 ("attribute% cannot be applied to a subprogram", P); 9122 9123 elsif Aname = Name_Unrestricted_Access then 9124 null; -- Nothing to check 9125 9126 -- Check the static accessibility rule of 3.10.2(32). 9127 -- This rule also applies within the private part of an 9128 -- instantiation. This rule does not apply to anonymous 9129 -- access-to-subprogram types in access parameters. 9130 9131 elsif Attr_Id = Attribute_Access 9132 and then not In_Instance_Body 9133 and then 9134 (Ekind (Btyp) = E_Access_Subprogram_Type 9135 or else Is_Local_Anonymous_Access (Btyp)) 9136 9137 and then Subprogram_Access_Level (Entity (P)) > 9138 Type_Access_Level (Btyp) 9139 then 9140 Error_Msg_F 9141 ("subprogram must not be deeper than access type", P); 9142 9143 -- Check the restriction of 3.10.2(32) that disallows the 9144 -- access attribute within a generic body when the ultimate 9145 -- ancestor of the type of the attribute is declared outside 9146 -- of the generic unit and the subprogram is declared within 9147 -- that generic unit. This includes any such attribute that 9148 -- occurs within the body of a generic unit that is a child 9149 -- of the generic unit where the subprogram is declared. 9150 9151 -- The rule also prohibits applying the attribute when the 9152 -- access type is a generic formal access type (since the 9153 -- level of the actual type is not known). This restriction 9154 -- does not apply when the attribute type is an anonymous 9155 -- access-to-subprogram type. Note that this check was 9156 -- revised by AI-229, because the originally Ada 95 rule 9157 -- was too lax. The original rule only applied when the 9158 -- subprogram was declared within the body of the generic, 9159 -- which allowed the possibility of dangling references). 9160 -- The rule was also too strict in some case, in that it 9161 -- didn't permit the access to be declared in the generic 9162 -- spec, whereas the revised rule does (as long as it's not 9163 -- a formal type). 9164 9165 -- There are a couple of subtleties of the test for applying 9166 -- the check that are worth noting. First, we only apply it 9167 -- when the levels of the subprogram and access type are the 9168 -- same (the case where the subprogram is statically deeper 9169 -- was applied above, and the case where the type is deeper 9170 -- is always safe). Second, we want the check to apply 9171 -- within nested generic bodies and generic child unit 9172 -- bodies, but not to apply to an attribute that appears in 9173 -- the generic unit's specification. This is done by testing 9174 -- that the attribute's innermost enclosing generic body is 9175 -- not the same as the innermost generic body enclosing the 9176 -- generic unit where the subprogram is declared (we don't 9177 -- want the check to apply when the access attribute is in 9178 -- the spec and there's some other generic body enclosing 9179 -- generic). Finally, there's no point applying the check 9180 -- when within an instance, because any violations will have 9181 -- been caught by the compilation of the generic unit. 9182 9183 -- Note that we relax this check in CodePeer mode for 9184 -- compatibility with legacy code, since CodePeer is an 9185 -- Ada source code analyzer, not a strict compiler. 9186 -- ??? Note that a better approach would be to have a 9187 -- separate switch to relax this rule, and enable this 9188 -- switch in CodePeer mode. 9189 9190 elsif Attr_Id = Attribute_Access 9191 and then not CodePeer_Mode 9192 and then not In_Instance 9193 and then Present (Enclosing_Generic_Unit (Entity (P))) 9194 and then Present (Enclosing_Generic_Body (N)) 9195 and then Enclosing_Generic_Body (N) /= 9196 Enclosing_Generic_Body 9197 (Enclosing_Generic_Unit (Entity (P))) 9198 and then Subprogram_Access_Level (Entity (P)) = 9199 Type_Access_Level (Btyp) 9200 and then Ekind (Btyp) /= 9201 E_Anonymous_Access_Subprogram_Type 9202 and then Ekind (Btyp) /= 9203 E_Anonymous_Access_Protected_Subprogram_Type 9204 then 9205 -- The attribute type's ultimate ancestor must be 9206 -- declared within the same generic unit as the 9207 -- subprogram is declared. The error message is 9208 -- specialized to say "ancestor" for the case where the 9209 -- access type is not its own ancestor, since saying 9210 -- simply "access type" would be very confusing. 9211 9212 if Enclosing_Generic_Unit (Entity (P)) /= 9213 Enclosing_Generic_Unit (Root_Type (Btyp)) 9214 then 9215 Error_Msg_N 9216 ("''Access attribute not allowed in generic body", 9217 N); 9218 9219 if Root_Type (Btyp) = Btyp then 9220 Error_Msg_NE 9221 ("\because " & 9222 "access type & is declared outside " & 9223 "generic unit (RM 3.10.2(32))", N, Btyp); 9224 else 9225 Error_Msg_NE 9226 ("\because ancestor of " & 9227 "access type & is declared outside " & 9228 "generic unit (RM 3.10.2(32))", N, Btyp); 9229 end if; 9230 9231 Error_Msg_NE 9232 ("\move ''Access to private part, or " & 9233 "(Ada 2005) use anonymous access type instead of &", 9234 N, Btyp); 9235 9236 -- If the ultimate ancestor of the attribute's type is 9237 -- a formal type, then the attribute is illegal because 9238 -- the actual type might be declared at a higher level. 9239 -- The error message is specialized to say "ancestor" 9240 -- for the case where the access type is not its own 9241 -- ancestor, since saying simply "access type" would be 9242 -- very confusing. 9243 9244 elsif Is_Generic_Type (Root_Type (Btyp)) then 9245 if Root_Type (Btyp) = Btyp then 9246 Error_Msg_N 9247 ("access type must not be a generic formal type", 9248 N); 9249 else 9250 Error_Msg_N 9251 ("ancestor access type must not be a generic " & 9252 "formal type", N); 9253 end if; 9254 end if; 9255 end if; 9256 end if; 9257 9258 -- If this is a renaming, an inherited operation, or a 9259 -- subprogram instance, use the original entity. This may make 9260 -- the node type-inconsistent, so this transformation can only 9261 -- be done if the node will not be reanalyzed. In particular, 9262 -- if it is within a default expression, the transformation 9263 -- must be delayed until the default subprogram is created for 9264 -- it, when the enclosing subprogram is frozen. 9265 9266 if Is_Entity_Name (P) 9267 and then Is_Overloadable (Entity (P)) 9268 and then Present (Alias (Entity (P))) 9269 and then Expander_Active 9270 then 9271 Rewrite (P, 9272 New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); 9273 end if; 9274 9275 elsif Nkind (P) = N_Selected_Component 9276 and then Is_Overloadable (Entity (Selector_Name (P))) 9277 then 9278 -- Protected operation. If operation is overloaded, must 9279 -- disambiguate. Prefix that denotes protected object itself 9280 -- is resolved with its own type. 9281 9282 if Attr_Id = Attribute_Unchecked_Access then 9283 Error_Msg_Name_1 := Aname; 9284 Error_Msg_F 9285 ("attribute% cannot be applied to protected operation", P); 9286 end if; 9287 9288 Resolve (Prefix (P)); 9289 Generate_Reference (Entity (Selector_Name (P)), P); 9290 9291 elsif Is_Overloaded (P) then 9292 9293 -- Use the designated type of the context to disambiguate 9294 -- Note that this was not strictly conformant to Ada 95, 9295 -- but was the implementation adopted by most Ada 95 compilers. 9296 -- The use of the context type to resolve an Access attribute 9297 -- reference is now mandated in AI-235 for Ada 2005. 9298 9299 declare 9300 Index : Interp_Index; 9301 It : Interp; 9302 9303 begin 9304 Get_First_Interp (P, Index, It); 9305 while Present (It.Typ) loop 9306 if Covers (Designated_Type (Typ), It.Typ) then 9307 Resolve (P, It.Typ); 9308 exit; 9309 end if; 9310 9311 Get_Next_Interp (Index, It); 9312 end loop; 9313 end; 9314 else 9315 Resolve (P); 9316 end if; 9317 9318 -- X'Access is illegal if X denotes a constant and the access type 9319 -- is access-to-variable. Same for 'Unchecked_Access. The rule 9320 -- does not apply to 'Unrestricted_Access. If the reference is a 9321 -- default-initialized aggregate component for a self-referential 9322 -- type the reference is legal. 9323 9324 if not (Ekind (Btyp) = E_Access_Subprogram_Type 9325 or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type 9326 or else (Is_Record_Type (Btyp) 9327 and then 9328 Present (Corresponding_Remote_Type (Btyp))) 9329 or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type 9330 or else Ekind (Btyp) 9331 = E_Anonymous_Access_Protected_Subprogram_Type 9332 or else Is_Access_Constant (Btyp) 9333 or else Is_Variable (P) 9334 or else Attr_Id = Attribute_Unrestricted_Access) 9335 then 9336 if Is_Entity_Name (P) 9337 and then Is_Type (Entity (P)) 9338 then 9339 -- Legality of a self-reference through an access 9340 -- attribute has been verified in Analyze_Access_Attribute. 9341 9342 null; 9343 9344 elsif Comes_From_Source (N) then 9345 Error_Msg_F ("access-to-variable designates constant", P); 9346 end if; 9347 end if; 9348 9349 Des_Btyp := Designated_Type (Btyp); 9350 9351 if Ada_Version >= Ada_2005 9352 and then Is_Incomplete_Type (Des_Btyp) 9353 then 9354 -- Ada 2005 (AI-412): If the (sub)type is a limited view of an 9355 -- imported entity, and the non-limited view is visible, make 9356 -- use of it. If it is an incomplete subtype, use the base type 9357 -- in any case. 9358 9359 if From_With_Type (Des_Btyp) 9360 and then Present (Non_Limited_View (Des_Btyp)) 9361 then 9362 Des_Btyp := Non_Limited_View (Des_Btyp); 9363 9364 elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then 9365 Des_Btyp := Etype (Des_Btyp); 9366 end if; 9367 end if; 9368 9369 if (Attr_Id = Attribute_Access 9370 or else 9371 Attr_Id = Attribute_Unchecked_Access) 9372 and then (Ekind (Btyp) = E_General_Access_Type 9373 or else Ekind (Btyp) = E_Anonymous_Access_Type) 9374 then 9375 -- Ada 2005 (AI-230): Check the accessibility of anonymous 9376 -- access types for stand-alone objects, record and array 9377 -- components, and return objects. For a component definition 9378 -- the level is the same of the enclosing composite type. 9379 9380 if Ada_Version >= Ada_2005 9381 and then (Is_Local_Anonymous_Access (Btyp) 9382 9383 -- Handle cases where Btyp is the anonymous access 9384 -- type of an Ada 2012 stand-alone object. 9385 9386 or else Nkind (Associated_Node_For_Itype (Btyp)) = 9387 N_Object_Declaration) 9388 and then 9389 Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) 9390 and then Attr_Id = Attribute_Access 9391 then 9392 -- In an instance, this is a runtime check, but one we 9393 -- know will fail, so generate an appropriate warning. 9394 9395 if In_Instance_Body then 9396 Error_Msg_F 9397 ("??non-local pointer cannot point to local object", P); 9398 Error_Msg_F 9399 ("\??Program_Error will be raised at run time", P); 9400 Rewrite (N, 9401 Make_Raise_Program_Error (Loc, 9402 Reason => PE_Accessibility_Check_Failed)); 9403 Set_Etype (N, Typ); 9404 9405 else 9406 Error_Msg_F 9407 ("non-local pointer cannot point to local object", P); 9408 end if; 9409 end if; 9410 9411 if Is_Dependent_Component_Of_Mutable_Object (P) then 9412 Error_Msg_F 9413 ("illegal attribute for discriminant-dependent component", 9414 P); 9415 end if; 9416 9417 -- Check static matching rule of 3.10.2(27). Nominal subtype 9418 -- of the prefix must statically match the designated type. 9419 9420 Nom_Subt := Etype (P); 9421 9422 if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then 9423 Nom_Subt := Base_Type (Nom_Subt); 9424 end if; 9425 9426 if Is_Tagged_Type (Designated_Type (Typ)) then 9427 9428 -- If the attribute is in the context of an access 9429 -- parameter, then the prefix is allowed to be of the 9430 -- class-wide type (by AI-127). 9431 9432 if Ekind (Typ) = E_Anonymous_Access_Type then 9433 if not Covers (Designated_Type (Typ), Nom_Subt) 9434 and then not Covers (Nom_Subt, Designated_Type (Typ)) 9435 then 9436 declare 9437 Desig : Entity_Id; 9438 9439 begin 9440 Desig := Designated_Type (Typ); 9441 9442 if Is_Class_Wide_Type (Desig) then 9443 Desig := Etype (Desig); 9444 end if; 9445 9446 if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then 9447 null; 9448 9449 else 9450 Error_Msg_FE 9451 ("type of prefix: & not compatible", 9452 P, Nom_Subt); 9453 Error_Msg_FE 9454 ("\with &, the expected designated type", 9455 P, Designated_Type (Typ)); 9456 end if; 9457 end; 9458 end if; 9459 9460 elsif not Covers (Designated_Type (Typ), Nom_Subt) 9461 or else 9462 (not Is_Class_Wide_Type (Designated_Type (Typ)) 9463 and then Is_Class_Wide_Type (Nom_Subt)) 9464 then 9465 Error_Msg_FE 9466 ("type of prefix: & is not covered", P, Nom_Subt); 9467 Error_Msg_FE 9468 ("\by &, the expected designated type" & 9469 " (RM 3.10.2 (27))", P, Designated_Type (Typ)); 9470 end if; 9471 9472 if Is_Class_Wide_Type (Designated_Type (Typ)) 9473 and then Has_Discriminants (Etype (Designated_Type (Typ))) 9474 and then Is_Constrained (Etype (Designated_Type (Typ))) 9475 and then Designated_Type (Typ) /= Nom_Subt 9476 then 9477 Apply_Discriminant_Check 9478 (N, Etype (Designated_Type (Typ))); 9479 end if; 9480 9481 -- Ada 2005 (AI-363): Require static matching when designated 9482 -- type has discriminants and a constrained partial view, since 9483 -- in general objects of such types are mutable, so we can't 9484 -- allow the access value to designate a constrained object 9485 -- (because access values must be assumed to designate mutable 9486 -- objects when designated type does not impose a constraint). 9487 9488 elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then 9489 null; 9490 9491 elsif Has_Discriminants (Designated_Type (Typ)) 9492 and then not Is_Constrained (Des_Btyp) 9493 and then 9494 (Ada_Version < Ada_2005 9495 or else 9496 not Effectively_Has_Constrained_Partial_View 9497 (Typ => Designated_Type (Base_Type (Typ)), 9498 Scop => Current_Scope)) 9499 then 9500 null; 9501 9502 else 9503 Error_Msg_F 9504 ("object subtype must statically match " 9505 & "designated subtype", P); 9506 9507 if Is_Entity_Name (P) 9508 and then Is_Array_Type (Designated_Type (Typ)) 9509 then 9510 declare 9511 D : constant Node_Id := Declaration_Node (Entity (P)); 9512 begin 9513 Error_Msg_N 9514 ("aliased object has explicit bounds??", D); 9515 Error_Msg_N 9516 ("\declare without bounds (and with explicit " 9517 & "initialization)??", D); 9518 Error_Msg_N 9519 ("\for use with unconstrained access??", D); 9520 end; 9521 end if; 9522 end if; 9523 9524 -- Check the static accessibility rule of 3.10.2(28). Note that 9525 -- this check is not performed for the case of an anonymous 9526 -- access type, since the access attribute is always legal 9527 -- in such a context. 9528 9529 if Attr_Id /= Attribute_Unchecked_Access 9530 and then 9531 Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) 9532 and then Ekind (Btyp) = E_General_Access_Type 9533 then 9534 Accessibility_Message; 9535 return; 9536 end if; 9537 end if; 9538 9539 if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, 9540 E_Anonymous_Access_Protected_Subprogram_Type) 9541 then 9542 if Is_Entity_Name (P) 9543 and then not Is_Protected_Type (Scope (Entity (P))) 9544 then 9545 Error_Msg_F ("context requires a protected subprogram", P); 9546 9547 -- Check accessibility of protected object against that of the 9548 -- access type, but only on user code, because the expander 9549 -- creates access references for handlers. If the context is an 9550 -- anonymous_access_to_protected, there are no accessibility 9551 -- checks either. Omit check entirely for Unrestricted_Access. 9552 9553 elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) 9554 and then Comes_From_Source (N) 9555 and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type 9556 and then Attr_Id /= Attribute_Unrestricted_Access 9557 then 9558 Accessibility_Message; 9559 return; 9560 9561 -- AI05-0225: If the context is not an access to protected 9562 -- function, the prefix must be a variable, given that it may 9563 -- be used subsequently in a protected call. 9564 9565 elsif Nkind (P) = N_Selected_Component 9566 and then not Is_Variable (Prefix (P)) 9567 and then Ekind (Entity (Selector_Name (P))) /= E_Function 9568 then 9569 Error_Msg_N 9570 ("target object of access to protected procedure " 9571 & "must be variable", N); 9572 9573 elsif Is_Entity_Name (P) then 9574 Check_Internal_Protected_Use (N, Entity (P)); 9575 end if; 9576 9577 elsif Ekind_In (Btyp, E_Access_Subprogram_Type, 9578 E_Anonymous_Access_Subprogram_Type) 9579 and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type 9580 then 9581 Error_Msg_F ("context requires a non-protected subprogram", P); 9582 end if; 9583 9584 -- The context cannot be a pool-specific type, but this is a 9585 -- legality rule, not a resolution rule, so it must be checked 9586 -- separately, after possibly disambiguation (see AI-245). 9587 9588 if Ekind (Btyp) = E_Access_Type 9589 and then Attr_Id /= Attribute_Unrestricted_Access 9590 then 9591 Wrong_Type (N, Typ); 9592 end if; 9593 9594 -- The context may be a constrained access type (however ill- 9595 -- advised such subtypes might be) so in order to generate a 9596 -- constraint check when needed set the type of the attribute 9597 -- reference to the base type of the context. 9598 9599 Set_Etype (N, Btyp); 9600 9601 -- Check for incorrect atomic/volatile reference (RM C.6(12)) 9602 9603 if Attr_Id /= Attribute_Unrestricted_Access then 9604 if Is_Atomic_Object (P) 9605 and then not Is_Atomic (Designated_Type (Typ)) 9606 then 9607 Error_Msg_F 9608 ("access to atomic object cannot yield access-to-" & 9609 "non-atomic type", P); 9610 9611 elsif Is_Volatile_Object (P) 9612 and then not Is_Volatile (Designated_Type (Typ)) 9613 then 9614 Error_Msg_F 9615 ("access to volatile object cannot yield access-to-" & 9616 "non-volatile type", P); 9617 end if; 9618 end if; 9619 9620 if Is_Entity_Name (P) then 9621 Set_Address_Taken (Entity (P)); 9622 end if; 9623 end Access_Attribute; 9624 9625 ------------- 9626 -- Address -- 9627 ------------- 9628 9629 -- Deal with resolving the type for Address attribute, overloading 9630 -- is not permitted here, since there is no context to resolve it. 9631 9632 when Attribute_Address | Attribute_Code_Address => 9633 Address_Attribute : begin 9634 9635 -- To be safe, assume that if the address of a variable is taken, 9636 -- it may be modified via this address, so note modification. 9637 9638 if Is_Variable (P) then 9639 Note_Possible_Modification (P, Sure => False); 9640 end if; 9641 9642 if Nkind (P) in N_Subexpr 9643 and then Is_Overloaded (P) 9644 then 9645 Get_First_Interp (P, Index, It); 9646 Get_Next_Interp (Index, It); 9647 9648 if Present (It.Nam) then 9649 Error_Msg_Name_1 := Aname; 9650 Error_Msg_F 9651 ("prefix of % attribute cannot be overloaded", P); 9652 end if; 9653 end if; 9654 9655 if not Is_Entity_Name (P) 9656 or else not Is_Overloadable (Entity (P)) 9657 then 9658 if not Is_Task_Type (Etype (P)) 9659 or else Nkind (P) = N_Explicit_Dereference 9660 then 9661 Resolve (P); 9662 end if; 9663 end if; 9664 9665 -- If this is the name of a derived subprogram, or that of a 9666 -- generic actual, the address is that of the original entity. 9667 9668 if Is_Entity_Name (P) 9669 and then Is_Overloadable (Entity (P)) 9670 and then Present (Alias (Entity (P))) 9671 then 9672 Rewrite (P, 9673 New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); 9674 end if; 9675 9676 if Is_Entity_Name (P) then 9677 Set_Address_Taken (Entity (P)); 9678 end if; 9679 9680 if Nkind (P) = N_Slice then 9681 9682 -- Arr (X .. Y)'address is identical to Arr (X)'address, 9683 -- even if the array is packed and the slice itself is not 9684 -- addressable. Transform the prefix into an indexed component. 9685 9686 -- Note that the transformation is safe only if we know that 9687 -- the slice is non-null. That is because a null slice can have 9688 -- an out of bounds index value. 9689 9690 -- Right now, gigi blows up if given 'Address on a slice as a 9691 -- result of some incorrect freeze nodes generated by the front 9692 -- end, and this covers up that bug in one case, but the bug is 9693 -- likely still there in the cases not handled by this code ??? 9694 9695 -- It's not clear what 'Address *should* return for a null 9696 -- slice with out of bounds indexes, this might be worth an ARG 9697 -- discussion ??? 9698 9699 -- One approach would be to do a length check unconditionally, 9700 -- and then do the transformation below unconditionally, but 9701 -- analyze with checks off, avoiding the problem of the out of 9702 -- bounds index. This approach would interpret the address of 9703 -- an out of bounds null slice as being the address where the 9704 -- array element would be if there was one, which is probably 9705 -- as reasonable an interpretation as any ??? 9706 9707 declare 9708 Loc : constant Source_Ptr := Sloc (P); 9709 D : constant Node_Id := Discrete_Range (P); 9710 Lo : Node_Id; 9711 9712 begin 9713 if Is_Entity_Name (D) 9714 and then 9715 Not_Null_Range 9716 (Type_Low_Bound (Entity (D)), 9717 Type_High_Bound (Entity (D))) 9718 then 9719 Lo := 9720 Make_Attribute_Reference (Loc, 9721 Prefix => (New_Occurrence_Of (Entity (D), Loc)), 9722 Attribute_Name => Name_First); 9723 9724 elsif Nkind (D) = N_Range 9725 and then Not_Null_Range (Low_Bound (D), High_Bound (D)) 9726 then 9727 Lo := Low_Bound (D); 9728 9729 else 9730 Lo := Empty; 9731 end if; 9732 9733 if Present (Lo) then 9734 Rewrite (P, 9735 Make_Indexed_Component (Loc, 9736 Prefix => Relocate_Node (Prefix (P)), 9737 Expressions => New_List (Lo))); 9738 9739 Analyze_And_Resolve (P); 9740 end if; 9741 end; 9742 end if; 9743 end Address_Attribute; 9744 9745 --------------- 9746 -- AST_Entry -- 9747 --------------- 9748 9749 -- Prefix of the AST_Entry attribute is an entry name which must 9750 -- not be resolved, since this is definitely not an entry call. 9751 9752 when Attribute_AST_Entry => 9753 null; 9754 9755 ------------------ 9756 -- Body_Version -- 9757 ------------------ 9758 9759 -- Prefix of Body_Version attribute can be a subprogram name which 9760 -- must not be resolved, since this is not a call. 9761 9762 when Attribute_Body_Version => 9763 null; 9764 9765 ------------ 9766 -- Caller -- 9767 ------------ 9768 9769 -- Prefix of Caller attribute is an entry name which must not 9770 -- be resolved, since this is definitely not an entry call. 9771 9772 when Attribute_Caller => 9773 null; 9774 9775 ------------------ 9776 -- Code_Address -- 9777 ------------------ 9778 9779 -- Shares processing with Address attribute 9780 9781 ----------- 9782 -- Count -- 9783 ----------- 9784 9785 -- If the prefix of the Count attribute is an entry name it must not 9786 -- be resolved, since this is definitely not an entry call. However, 9787 -- if it is an element of an entry family, the index itself may 9788 -- have to be resolved because it can be a general expression. 9789 9790 when Attribute_Count => 9791 if Nkind (P) = N_Indexed_Component 9792 and then Is_Entity_Name (Prefix (P)) 9793 then 9794 declare 9795 Indx : constant Node_Id := First (Expressions (P)); 9796 Fam : constant Entity_Id := Entity (Prefix (P)); 9797 begin 9798 Resolve (Indx, Entry_Index_Type (Fam)); 9799 Apply_Range_Check (Indx, Entry_Index_Type (Fam)); 9800 end; 9801 end if; 9802 9803 ---------------- 9804 -- Elaborated -- 9805 ---------------- 9806 9807 -- Prefix of the Elaborated attribute is a subprogram name which 9808 -- must not be resolved, since this is definitely not a call. Note 9809 -- that it is a library unit, so it cannot be overloaded here. 9810 9811 when Attribute_Elaborated => 9812 null; 9813 9814 ------------- 9815 -- Enabled -- 9816 ------------- 9817 9818 -- Prefix of Enabled attribute is a check name, which must be treated 9819 -- specially and not touched by Resolve. 9820 9821 when Attribute_Enabled => 9822 null; 9823 9824 ---------------- 9825 -- Loop_Entry -- 9826 ---------------- 9827 9828 -- Do not resolve the prefix of Loop_Entry, instead wait until the 9829 -- attribute has been expanded (see Expand_Loop_Entry_Attributes). 9830 -- The delay ensures that any generated checks or temporaries are 9831 -- inserted before the relocated prefix. 9832 9833 when Attribute_Loop_Entry => 9834 null; 9835 9836 -------------------- 9837 -- Mechanism_Code -- 9838 -------------------- 9839 9840 -- Prefix of the Mechanism_Code attribute is a function name 9841 -- which must not be resolved. Should we check for overloaded ??? 9842 9843 when Attribute_Mechanism_Code => 9844 null; 9845 9846 ------------------ 9847 -- Partition_ID -- 9848 ------------------ 9849 9850 -- Most processing is done in sem_dist, after determining the 9851 -- context type. Node is rewritten as a conversion to a runtime call. 9852 9853 when Attribute_Partition_ID => 9854 Process_Partition_Id (N); 9855 return; 9856 9857 ------------------ 9858 -- Pool_Address -- 9859 ------------------ 9860 9861 when Attribute_Pool_Address => 9862 Resolve (P); 9863 9864 ----------- 9865 -- Range -- 9866 ----------- 9867 9868 -- We replace the Range attribute node with a range expression whose 9869 -- bounds are the 'First and 'Last attributes applied to the same 9870 -- prefix. The reason that we do this transformation here instead of 9871 -- in the expander is that it simplifies other parts of the semantic 9872 -- analysis which assume that the Range has been replaced; thus it 9873 -- must be done even when in semantic-only mode (note that the RM 9874 -- specifically mentions this equivalence, we take care that the 9875 -- prefix is only evaluated once). 9876 9877 when Attribute_Range => Range_Attribute : 9878 declare 9879 LB : Node_Id; 9880 HB : Node_Id; 9881 Dims : List_Id; 9882 9883 begin 9884 if not Is_Entity_Name (P) 9885 or else not Is_Type (Entity (P)) 9886 then 9887 Resolve (P); 9888 end if; 9889 9890 Dims := Expressions (N); 9891 9892 HB := 9893 Make_Attribute_Reference (Loc, 9894 Prefix => 9895 Duplicate_Subexpr (P, Name_Req => True), 9896 Attribute_Name => Name_Last, 9897 Expressions => Dims); 9898 9899 LB := 9900 Make_Attribute_Reference (Loc, 9901 Prefix => P, 9902 Attribute_Name => Name_First, 9903 Expressions => (Dims)); 9904 9905 -- Do not share the dimension indicator, if present. Even 9906 -- though it is a static constant, its source location 9907 -- may be modified when printing expanded code and node 9908 -- sharing will lead to chaos in Sprint. 9909 9910 if Present (Dims) then 9911 Set_Expressions (LB, 9912 New_List (New_Copy_Tree (First (Dims)))); 9913 end if; 9914 9915 -- If the original was marked as Must_Not_Freeze (see code 9916 -- in Sem_Ch3.Make_Index), then make sure the rewriting 9917 -- does not freeze either. 9918 9919 if Must_Not_Freeze (N) then 9920 Set_Must_Not_Freeze (HB); 9921 Set_Must_Not_Freeze (LB); 9922 Set_Must_Not_Freeze (Prefix (HB)); 9923 Set_Must_Not_Freeze (Prefix (LB)); 9924 end if; 9925 9926 if Raises_Constraint_Error (Prefix (N)) then 9927 9928 -- Preserve Sloc of prefix in the new bounds, so that 9929 -- the posted warning can be removed if we are within 9930 -- unreachable code. 9931 9932 Set_Sloc (LB, Sloc (Prefix (N))); 9933 Set_Sloc (HB, Sloc (Prefix (N))); 9934 end if; 9935 9936 Rewrite (N, Make_Range (Loc, LB, HB)); 9937 Analyze_And_Resolve (N, Typ); 9938 9939 -- Ensure that the expanded range does not have side effects 9940 9941 Force_Evaluation (LB); 9942 Force_Evaluation (HB); 9943 9944 -- Normally after resolving attribute nodes, Eval_Attribute 9945 -- is called to do any possible static evaluation of the node. 9946 -- However, here since the Range attribute has just been 9947 -- transformed into a range expression it is no longer an 9948 -- attribute node and therefore the call needs to be avoided 9949 -- and is accomplished by simply returning from the procedure. 9950 9951 return; 9952 end Range_Attribute; 9953 9954 ------------ 9955 -- Result -- 9956 ------------ 9957 9958 -- We will only come here during the prescan of a spec expression 9959 -- containing a Result attribute. In that case the proper Etype has 9960 -- already been set, and nothing more needs to be done here. 9961 9962 when Attribute_Result => 9963 null; 9964 9965 ----------------- 9966 -- UET_Address -- 9967 ----------------- 9968 9969 -- Prefix must not be resolved in this case, since it is not a 9970 -- real entity reference. No action of any kind is require! 9971 9972 when Attribute_UET_Address => 9973 return; 9974 9975 ---------------------- 9976 -- Unchecked_Access -- 9977 ---------------------- 9978 9979 -- Processing is shared with Access 9980 9981 ------------------------- 9982 -- Unrestricted_Access -- 9983 ------------------------- 9984 9985 -- Processing is shared with Access 9986 9987 --------- 9988 -- Val -- 9989 --------- 9990 9991 -- Apply range check. Note that we did not do this during the 9992 -- analysis phase, since we wanted Eval_Attribute to have a 9993 -- chance at finding an illegal out of range value. 9994 9995 when Attribute_Val => 9996 9997 -- Note that we do our own Eval_Attribute call here rather than 9998 -- use the common one, because we need to do processing after 9999 -- the call, as per above comment. 10000 10001 Eval_Attribute (N); 10002 10003 -- Eval_Attribute may replace the node with a raise CE, or 10004 -- fold it to a constant. Obviously we only apply a scalar 10005 -- range check if this did not happen! 10006 10007 if Nkind (N) = N_Attribute_Reference 10008 and then Attribute_Name (N) = Name_Val 10009 then 10010 Apply_Scalar_Range_Check (First (Expressions (N)), Btyp); 10011 end if; 10012 10013 return; 10014 10015 ------------- 10016 -- Version -- 10017 ------------- 10018 10019 -- Prefix of Version attribute can be a subprogram name which 10020 -- must not be resolved, since this is not a call. 10021 10022 when Attribute_Version => 10023 null; 10024 10025 ---------------------- 10026 -- Other Attributes -- 10027 ---------------------- 10028 10029 -- For other attributes, resolve prefix unless it is a type. If 10030 -- the attribute reference itself is a type name ('Base and 'Class) 10031 -- then this is only legal within a task or protected record. 10032 10033 when others => 10034 if not Is_Entity_Name (P) 10035 or else not Is_Type (Entity (P)) 10036 then 10037 Resolve (P); 10038 end if; 10039 10040 -- If the attribute reference itself is a type name ('Base, 10041 -- 'Class) then this is only legal within a task or protected 10042 -- record. What is this all about ??? 10043 10044 if Is_Entity_Name (N) 10045 and then Is_Type (Entity (N)) 10046 then 10047 if Is_Concurrent_Type (Entity (N)) 10048 and then In_Open_Scopes (Entity (P)) 10049 then 10050 null; 10051 else 10052 Error_Msg_N 10053 ("invalid use of subtype name in expression or call", N); 10054 end if; 10055 end if; 10056 10057 -- For attributes whose argument may be a string, complete 10058 -- resolution of argument now. This avoids premature expansion 10059 -- (and the creation of transient scopes) before the attribute 10060 -- reference is resolved. 10061 10062 case Attr_Id is 10063 when Attribute_Value => 10064 Resolve (First (Expressions (N)), Standard_String); 10065 10066 when Attribute_Wide_Value => 10067 Resolve (First (Expressions (N)), Standard_Wide_String); 10068 10069 when Attribute_Wide_Wide_Value => 10070 Resolve (First (Expressions (N)), Standard_Wide_Wide_String); 10071 10072 when others => null; 10073 end case; 10074 10075 -- If the prefix of the attribute is a class-wide type then it 10076 -- will be expanded into a dispatching call to a predefined 10077 -- primitive. Therefore we must check for potential violation 10078 -- of such restriction. 10079 10080 if Is_Class_Wide_Type (Etype (P)) then 10081 Check_Restriction (No_Dispatching_Calls, N); 10082 end if; 10083 end case; 10084 10085 -- Normally the Freezing is done by Resolve but sometimes the Prefix 10086 -- is not resolved, in which case the freezing must be done now. 10087 10088 Freeze_Expression (P); 10089 10090 -- Finally perform static evaluation on the attribute reference 10091 10092 Analyze_Dimension (N); 10093 Eval_Attribute (N); 10094 end Resolve_Attribute; 10095 10096 -------------------------------- 10097 -- Stream_Attribute_Available -- 10098 -------------------------------- 10099 10100 function Stream_Attribute_Available 10101 (Typ : Entity_Id; 10102 Nam : TSS_Name_Type; 10103 Partial_View : Node_Id := Empty) return Boolean 10104 is 10105 Etyp : Entity_Id := Typ; 10106 10107 -- Start of processing for Stream_Attribute_Available 10108 10109 begin 10110 -- We need some comments in this body ??? 10111 10112 if Has_Stream_Attribute_Definition (Typ, Nam) then 10113 return True; 10114 end if; 10115 10116 if Is_Class_Wide_Type (Typ) then 10117 return not Is_Limited_Type (Typ) 10118 or else Stream_Attribute_Available (Etype (Typ), Nam); 10119 end if; 10120 10121 if Nam = TSS_Stream_Input 10122 and then Is_Abstract_Type (Typ) 10123 and then not Is_Class_Wide_Type (Typ) 10124 then 10125 return False; 10126 end if; 10127 10128 if not (Is_Limited_Type (Typ) 10129 or else (Present (Partial_View) 10130 and then Is_Limited_Type (Partial_View))) 10131 then 10132 return True; 10133 end if; 10134 10135 -- In Ada 2005, Input can invoke Read, and Output can invoke Write 10136 10137 if Nam = TSS_Stream_Input 10138 and then Ada_Version >= Ada_2005 10139 and then Stream_Attribute_Available (Etyp, TSS_Stream_Read) 10140 then 10141 return True; 10142 10143 elsif Nam = TSS_Stream_Output 10144 and then Ada_Version >= Ada_2005 10145 and then Stream_Attribute_Available (Etyp, TSS_Stream_Write) 10146 then 10147 return True; 10148 end if; 10149 10150 -- Case of Read and Write: check for attribute definition clause that 10151 -- applies to an ancestor type. 10152 10153 while Etype (Etyp) /= Etyp loop 10154 Etyp := Etype (Etyp); 10155 10156 if Has_Stream_Attribute_Definition (Etyp, Nam) then 10157 return True; 10158 end if; 10159 end loop; 10160 10161 if Ada_Version < Ada_2005 then 10162 10163 -- In Ada 95 mode, also consider a non-visible definition 10164 10165 declare 10166 Btyp : constant Entity_Id := Implementation_Base_Type (Typ); 10167 begin 10168 return Btyp /= Typ 10169 and then Stream_Attribute_Available 10170 (Btyp, Nam, Partial_View => Typ); 10171 end; 10172 end if; 10173 10174 return False; 10175 end Stream_Attribute_Available; 10176 10177end Sem_Attr; 10178