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