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