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