1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ A T T R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Exp_Atag; use Exp_Atag; 32with Exp_Ch2; use Exp_Ch2; 33with Exp_Ch3; use Exp_Ch3; 34with Exp_Ch6; use Exp_Ch6; 35with Exp_Ch9; use Exp_Ch9; 36with Exp_Dist; use Exp_Dist; 37with Exp_Imgv; use Exp_Imgv; 38with Exp_Pakd; use Exp_Pakd; 39with Exp_Strm; use Exp_Strm; 40with Exp_Tss; use Exp_Tss; 41with Exp_Util; use Exp_Util; 42with Expander; use Expander; 43with Freeze; use Freeze; 44with Gnatvsn; use Gnatvsn; 45with Itypes; use Itypes; 46with Lib; use Lib; 47with Namet; use Namet; 48with Nmake; use Nmake; 49with Nlists; use Nlists; 50with Opt; use Opt; 51with Restrict; use Restrict; 52with Rident; use Rident; 53with Rtsfind; use Rtsfind; 54with Sem; use Sem; 55with Sem_Aux; use Sem_Aux; 56with Sem_Ch6; use Sem_Ch6; 57with Sem_Ch7; use Sem_Ch7; 58with Sem_Ch8; use Sem_Ch8; 59with Sem_Eval; use Sem_Eval; 60with Sem_Res; use Sem_Res; 61with Sem_Util; use Sem_Util; 62with Sinfo; use Sinfo; 63with Snames; use Snames; 64with Stand; use Stand; 65with Stringt; use Stringt; 66with Tbuild; use Tbuild; 67with Ttypes; use Ttypes; 68with Uintp; use Uintp; 69with Uname; use Uname; 70with Validsw; use Validsw; 71 72package body Exp_Attr is 73 74 ----------------------- 75 -- Local Subprograms -- 76 ----------------------- 77 78 function Build_Array_VS_Func 79 (Attr : Node_Id; 80 Formal_Typ : Entity_Id; 81 Array_Typ : Entity_Id; 82 Comp_Typ : Entity_Id) return Entity_Id; 83 -- Validate the components of an array type by means of a function. Return 84 -- the entity of the validation function. The parameters are as follows: 85 -- 86 -- * Attr - the 'Valid_Scalars attribute for which the function is 87 -- generated. 88 -- 89 -- * Formal_Typ - the type of the generated function's only formal 90 -- parameter. 91 -- 92 -- * Array_Typ - the array type whose components are to be validated 93 -- 94 -- * Comp_Typ - the component type of the array 95 96 function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id; 97 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter 98 99 function Build_Record_VS_Func 100 (Attr : Node_Id; 101 Formal_Typ : Entity_Id; 102 Rec_Typ : Entity_Id) return Entity_Id; 103 -- Validate the components, discriminants, and variants of a record type by 104 -- means of a function. Return the entity of the validation function. The 105 -- parameters are as follows: 106 -- 107 -- * Attr - the 'Valid_Scalars attribute for which the function is 108 -- generated. 109 -- 110 -- * Formal_Typ - the type of the generated function's only formal 111 -- parameter. 112 -- 113 -- * Rec_Typ - the record type whose internals are to be validated 114 115 procedure Compile_Stream_Body_In_Scope 116 (N : Node_Id; 117 Decl : Node_Id; 118 Arr : Entity_Id; 119 Check : Boolean); 120 -- The body for a stream subprogram may be generated outside of the scope 121 -- of the type. If the type is fully private, it may depend on the full 122 -- view of other types (e.g. indexes) that are currently private as well. 123 -- We install the declarations of the package in which the type is declared 124 -- before compiling the body in what is its proper environment. The Check 125 -- parameter indicates if checks are to be suppressed for the stream body. 126 -- We suppress checks for array/record reads, since the rule is that these 127 -- are like assignments, out of range values due to uninitialized storage, 128 -- or other invalid values do NOT cause a Constraint_Error to be raised. 129 -- If we are within an instance body all visibility has been established 130 -- already and there is no need to install the package. 131 132 -- This mechanism is now extended to the component types of the array type, 133 -- when the component type is not in scope and is private, to handle 134 -- properly the case when the full view has defaulted discriminants. 135 136 -- This special processing is ultimately caused by the fact that the 137 -- compiler lacks a well-defined phase when full views are visible 138 -- everywhere. Having such a separate pass would remove much of the 139 -- special-case code that shuffles partial and full views in the middle 140 -- of semantic analysis and expansion. 141 142 procedure Expand_Access_To_Protected_Op 143 (N : Node_Id; 144 Pref : Node_Id; 145 Typ : Entity_Id); 146 -- An attribute reference to a protected subprogram is transformed into 147 -- a pair of pointers: one to the object, and one to the operations. 148 -- This expansion is performed for 'Access and for 'Unrestricted_Access. 149 150 procedure Expand_Fpt_Attribute 151 (N : Node_Id; 152 Pkg : RE_Id; 153 Nam : Name_Id; 154 Args : List_Id); 155 -- This procedure expands a call to a floating-point attribute function. 156 -- N is the attribute reference node, and Args is a list of arguments to 157 -- be passed to the function call. Pkg identifies the package containing 158 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args 159 -- have already been converted to the floating-point type for which Pkg was 160 -- instantiated. The Nam argument is the relevant attribute processing 161 -- routine to be called. This is the same as the attribute name, except in 162 -- the Unaligned_Valid case. 163 164 procedure Expand_Fpt_Attribute_R (N : Node_Id); 165 -- This procedure expands a call to a floating-point attribute function 166 -- that takes a single floating-point argument. The function to be called 167 -- is always the same as the attribute name. 168 169 procedure Expand_Fpt_Attribute_RI (N : Node_Id); 170 -- This procedure expands a call to a floating-point attribute function 171 -- that takes one floating-point argument and one integer argument. The 172 -- function to be called is always the same as the attribute name. 173 174 procedure Expand_Fpt_Attribute_RR (N : Node_Id); 175 -- This procedure expands a call to a floating-point attribute function 176 -- that takes two floating-point arguments. The function to be called 177 -- is always the same as the attribute name. 178 179 procedure Expand_Loop_Entry_Attribute (N : Node_Id); 180 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related 181 -- loop may be converted into a conditional block. See body for details. 182 183 procedure Expand_Min_Max_Attribute (N : Node_Id); 184 -- Handle the expansion of attributes 'Max and 'Min, including expanding 185 -- then out if we are in Modify_Tree_For_C mode. 186 187 procedure Expand_Pred_Succ_Attribute (N : Node_Id); 188 -- Handles expansion of Pred or Succ attributes for case of non-real 189 -- operand with overflow checking required. 190 191 procedure Expand_Update_Attribute (N : Node_Id); 192 -- Handle the expansion of attribute Update 193 194 function Get_Index_Subtype (N : Node_Id) return Entity_Id; 195 -- Used for Last, Last, and Length, when the prefix is an array type. 196 -- Obtains the corresponding index subtype. 197 198 procedure Find_Fat_Info 199 (T : Entity_Id; 200 Fat_Type : out Entity_Id; 201 Fat_Pkg : out RE_Id); 202 -- Given a floating-point type T, identifies the package containing the 203 -- attributes for this type (returned in Fat_Pkg), and the corresponding 204 -- type for which this package was instantiated from Fat_Gen. Error if T 205 -- is not a floating-point type. 206 207 function Find_Stream_Subprogram 208 (Typ : Entity_Id; 209 Nam : TSS_Name_Type) return Entity_Id; 210 -- Returns the stream-oriented subprogram attribute for Typ. For tagged 211 -- types, the corresponding primitive operation is looked up, else the 212 -- appropriate TSS from the type itself, or from its closest ancestor 213 -- defining it, is returned. In both cases, inheritance of representation 214 -- aspects is thus taken into account. 215 216 function Full_Base (T : Entity_Id) return Entity_Id; 217 -- The stream functions need to examine the underlying representation of 218 -- composite types. In some cases T may be non-private but its base type 219 -- is, in which case the function returns the corresponding full view. 220 221 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id; 222 -- Given a type, find a corresponding stream convert pragma that applies to 223 -- the implementation base type of this type (Typ). If found, return the 224 -- pragma node, otherwise return Empty if no pragma is found. 225 226 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean; 227 -- Utility for array attributes, returns true on packed constrained 228 -- arrays, and on access to same. 229 230 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean; 231 -- Returns true iff the given node refers to an attribute call that 232 -- can be expanded directly by the back end and does not need front end 233 -- expansion. Typically used for rounding and truncation attributes that 234 -- appear directly inside a conversion to integer. 235 236 ------------------------- 237 -- Build_Array_VS_Func -- 238 ------------------------- 239 240 function Build_Array_VS_Func 241 (Attr : Node_Id; 242 Formal_Typ : Entity_Id; 243 Array_Typ : Entity_Id; 244 Comp_Typ : Entity_Id) return Entity_Id 245 is 246 Loc : constant Source_Ptr := Sloc (Attr); 247 248 function Validate_Component 249 (Obj_Id : Entity_Id; 250 Indexes : List_Id) return Node_Id; 251 -- Process a single component denoted by indexes Indexes. Obj_Id denotes 252 -- the entity of the validation parameter. Return the check associated 253 -- with the component. 254 255 function Validate_Dimension 256 (Obj_Id : Entity_Id; 257 Dim : Int; 258 Indexes : List_Id) return Node_Id; 259 -- Process dimension Dim of the array type. Obj_Id denotes the entity 260 -- of the validation parameter. Indexes is a list where each dimension 261 -- deposits its loop variable, which will later identify a component. 262 -- Return the loop associated with the current dimension. 263 264 ------------------------ 265 -- Validate_Component -- 266 ------------------------ 267 268 function Validate_Component 269 (Obj_Id : Entity_Id; 270 Indexes : List_Id) return Node_Id 271 is 272 Attr_Nam : Name_Id; 273 274 begin 275 if Is_Scalar_Type (Comp_Typ) then 276 Attr_Nam := Name_Valid; 277 else 278 Attr_Nam := Name_Valid_Scalars; 279 end if; 280 281 -- Generate: 282 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then 283 -- return False; 284 -- end if; 285 286 return 287 Make_If_Statement (Loc, 288 Condition => 289 Make_Op_Not (Loc, 290 Right_Opnd => 291 Make_Attribute_Reference (Loc, 292 Prefix => 293 Make_Indexed_Component (Loc, 294 Prefix => 295 Unchecked_Convert_To (Array_Typ, 296 New_Occurrence_Of (Obj_Id, Loc)), 297 Expressions => Indexes), 298 Attribute_Name => Attr_Nam)), 299 300 Then_Statements => New_List ( 301 Make_Simple_Return_Statement (Loc, 302 Expression => New_Occurrence_Of (Standard_False, Loc)))); 303 end Validate_Component; 304 305 ------------------------ 306 -- Validate_Dimension -- 307 ------------------------ 308 309 function Validate_Dimension 310 (Obj_Id : Entity_Id; 311 Dim : Int; 312 Indexes : List_Id) return Node_Id 313 is 314 Index : Entity_Id; 315 316 begin 317 -- Validate the component once all dimensions have produced their 318 -- individual loops. 319 320 if Dim > Number_Dimensions (Array_Typ) then 321 return Validate_Component (Obj_Id, Indexes); 322 323 -- Process the current dimension 324 325 else 326 Index := 327 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)); 328 329 Append_To (Indexes, New_Occurrence_Of (Index, Loc)); 330 331 -- Generate: 332 -- for J1 in Array_Typ (Obj_Id)'Range (1) loop 333 -- for JN in Array_Typ (Obj_Id)'Range (N) loop 334 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] 335 -- then 336 -- return False; 337 -- end if; 338 -- end loop; 339 -- end loop; 340 341 return 342 Make_Implicit_Loop_Statement (Attr, 343 Identifier => Empty, 344 Iteration_Scheme => 345 Make_Iteration_Scheme (Loc, 346 Loop_Parameter_Specification => 347 Make_Loop_Parameter_Specification (Loc, 348 Defining_Identifier => Index, 349 Discrete_Subtype_Definition => 350 Make_Attribute_Reference (Loc, 351 Prefix => 352 Unchecked_Convert_To (Array_Typ, 353 New_Occurrence_Of (Obj_Id, Loc)), 354 Attribute_Name => Name_Range, 355 Expressions => New_List ( 356 Make_Integer_Literal (Loc, Dim))))), 357 Statements => New_List ( 358 Validate_Dimension (Obj_Id, Dim + 1, Indexes))); 359 end if; 360 end Validate_Dimension; 361 362 -- Local variables 363 364 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V'); 365 Indexes : constant List_Id := New_List; 366 Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'A'); 367 Stmts : List_Id; 368 369 -- Start of processing for Build_Array_VS_Func 370 371 begin 372 Stmts := New_List (Validate_Dimension (Obj_Id, 1, Indexes)); 373 374 -- Generate: 375 -- return True; 376 377 Append_To (Stmts, 378 Make_Simple_Return_Statement (Loc, 379 Expression => New_Occurrence_Of (Standard_True, Loc))); 380 381 -- Generate: 382 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is 383 -- begin 384 -- Stmts 385 -- end Func_Id; 386 387 Set_Ekind (Func_Id, E_Function); 388 Set_Is_Internal (Func_Id); 389 Set_Is_Pure (Func_Id); 390 391 if not Debug_Generated_Code then 392 Set_Debug_Info_Off (Func_Id); 393 end if; 394 395 Insert_Action (Attr, 396 Make_Subprogram_Body (Loc, 397 Specification => 398 Make_Function_Specification (Loc, 399 Defining_Unit_Name => Func_Id, 400 Parameter_Specifications => New_List ( 401 Make_Parameter_Specification (Loc, 402 Defining_Identifier => Obj_Id, 403 In_Present => True, 404 Out_Present => False, 405 Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))), 406 Result_Definition => 407 New_Occurrence_Of (Standard_Boolean, Loc)), 408 Declarations => New_List, 409 Handled_Statement_Sequence => 410 Make_Handled_Sequence_Of_Statements (Loc, 411 Statements => Stmts))); 412 413 return Func_Id; 414 end Build_Array_VS_Func; 415 416 --------------------------------- 417 -- Build_Disp_Get_Task_Id_Call -- 418 --------------------------------- 419 420 function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id is 421 Loc : constant Source_Ptr := Sloc (Actual); 422 Typ : constant Entity_Id := Etype (Actual); 423 Subp : constant Entity_Id := Find_Prim_Op (Typ, Name_uDisp_Get_Task_Id); 424 425 begin 426 -- Generate: 427 -- _Disp_Get_Task_Id (Actual) 428 429 return 430 Make_Function_Call (Loc, 431 Name => New_Occurrence_Of (Subp, Loc), 432 Parameter_Associations => New_List (Actual)); 433 end Build_Disp_Get_Task_Id_Call; 434 435 -------------------------- 436 -- Build_Record_VS_Func -- 437 -------------------------- 438 439 function Build_Record_VS_Func 440 (Attr : Node_Id; 441 Formal_Typ : Entity_Id; 442 Rec_Typ : Entity_Id) return Entity_Id 443 is 444 -- NOTE: The logic of Build_Record_VS_Func is intentionally passive. 445 -- It generates code only when there are components, discriminants, 446 -- or variant parts to validate. 447 448 -- NOTE: The routines within Build_Record_VS_Func are intentionally 449 -- unnested to avoid deep indentation of code. 450 451 Loc : constant Source_Ptr := Sloc (Attr); 452 453 procedure Validate_Component_List 454 (Obj_Id : Entity_Id; 455 Comp_List : Node_Id; 456 Stmts : in out List_Id); 457 -- Process all components and variant parts of component list Comp_List. 458 -- Obj_Id denotes the entity of the validation parameter. All new code 459 -- is added to list Stmts. 460 461 procedure Validate_Field 462 (Obj_Id : Entity_Id; 463 Field : Node_Id; 464 Cond : in out Node_Id); 465 -- Process component declaration or discriminant specification Field. 466 -- Obj_Id denotes the entity of the validation parameter. Cond denotes 467 -- an "or else" conditional expression which contains the new code (if 468 -- any). 469 470 procedure Validate_Fields 471 (Obj_Id : Entity_Id; 472 Fields : List_Id; 473 Stmts : in out List_Id); 474 -- Process component declarations or discriminant specifications in list 475 -- Fields. Obj_Id denotes the entity of the validation parameter. All 476 -- new code is added to list Stmts. 477 478 procedure Validate_Variant 479 (Obj_Id : Entity_Id; 480 Var : Node_Id; 481 Alts : in out List_Id); 482 -- Process variant Var. Obj_Id denotes the entity of the validation 483 -- parameter. Alts denotes a list of case statement alternatives which 484 -- contains the new code (if any). 485 486 procedure Validate_Variant_Part 487 (Obj_Id : Entity_Id; 488 Var_Part : Node_Id; 489 Stmts : in out List_Id); 490 -- Process variant part Var_Part. Obj_Id denotes the entity of the 491 -- validation parameter. All new code is added to list Stmts. 492 493 ----------------------------- 494 -- Validate_Component_List -- 495 ----------------------------- 496 497 procedure Validate_Component_List 498 (Obj_Id : Entity_Id; 499 Comp_List : Node_Id; 500 Stmts : in out List_Id) 501 is 502 Var_Part : constant Node_Id := Variant_Part (Comp_List); 503 504 begin 505 -- Validate all components 506 507 Validate_Fields 508 (Obj_Id => Obj_Id, 509 Fields => Component_Items (Comp_List), 510 Stmts => Stmts); 511 512 -- Validate the variant part 513 514 if Present (Var_Part) then 515 Validate_Variant_Part 516 (Obj_Id => Obj_Id, 517 Var_Part => Var_Part, 518 Stmts => Stmts); 519 end if; 520 end Validate_Component_List; 521 522 -------------------- 523 -- Validate_Field -- 524 -------------------- 525 526 procedure Validate_Field 527 (Obj_Id : Entity_Id; 528 Field : Node_Id; 529 Cond : in out Node_Id) 530 is 531 Field_Id : constant Entity_Id := Defining_Entity (Field); 532 Field_Nam : constant Name_Id := Chars (Field_Id); 533 Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id)); 534 Attr_Nam : Name_Id; 535 536 begin 537 -- Do not process internally-generated fields. Note that checking for 538 -- Comes_From_Source is not correct because this will eliminate the 539 -- components within the corresponding record of a protected type. 540 541 if Nam_In (Field_Nam, Name_uObject, 542 Name_uParent, 543 Name_uTag) 544 then 545 null; 546 547 -- Do not process fields without any scalar components 548 549 elsif not Scalar_Part_Present (Field_Typ) then 550 null; 551 552 -- Otherwise the field needs to be validated. Use Make_Identifier 553 -- rather than New_Occurrence_Of to identify the field because the 554 -- wrong entity may be picked up when private types are involved. 555 556 -- Generate: 557 -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars] 558 559 else 560 if Is_Scalar_Type (Field_Typ) then 561 Attr_Nam := Name_Valid; 562 else 563 Attr_Nam := Name_Valid_Scalars; 564 end if; 565 566 Evolve_Or_Else (Cond, 567 Make_Op_Not (Loc, 568 Right_Opnd => 569 Make_Attribute_Reference (Loc, 570 Prefix => 571 Make_Selected_Component (Loc, 572 Prefix => 573 Unchecked_Convert_To (Rec_Typ, 574 New_Occurrence_Of (Obj_Id, Loc)), 575 Selector_Name => Make_Identifier (Loc, Field_Nam)), 576 Attribute_Name => Attr_Nam))); 577 end if; 578 end Validate_Field; 579 580 --------------------- 581 -- Validate_Fields -- 582 --------------------- 583 584 procedure Validate_Fields 585 (Obj_Id : Entity_Id; 586 Fields : List_Id; 587 Stmts : in out List_Id) 588 is 589 Cond : Node_Id; 590 Field : Node_Id; 591 592 begin 593 -- Assume that none of the fields are eligible for verification 594 595 Cond := Empty; 596 597 -- Validate all fields 598 599 Field := First_Non_Pragma (Fields); 600 while Present (Field) loop 601 Validate_Field 602 (Obj_Id => Obj_Id, 603 Field => Field, 604 Cond => Cond); 605 606 Next_Non_Pragma (Field); 607 end loop; 608 609 -- Generate: 610 -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars] 611 -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars] 612 -- then 613 -- return False; 614 -- end if; 615 616 if Present (Cond) then 617 Append_New_To (Stmts, 618 Make_Implicit_If_Statement (Attr, 619 Condition => Cond, 620 Then_Statements => New_List ( 621 Make_Simple_Return_Statement (Loc, 622 Expression => New_Occurrence_Of (Standard_False, Loc))))); 623 end if; 624 end Validate_Fields; 625 626 ---------------------- 627 -- Validate_Variant -- 628 ---------------------- 629 630 procedure Validate_Variant 631 (Obj_Id : Entity_Id; 632 Var : Node_Id; 633 Alts : in out List_Id) 634 is 635 Stmts : List_Id; 636 637 begin 638 -- Assume that none of the components and variants are eligible for 639 -- verification. 640 641 Stmts := No_List; 642 643 -- Validate components 644 645 Validate_Component_List 646 (Obj_Id => Obj_Id, 647 Comp_List => Component_List (Var), 648 Stmts => Stmts); 649 650 -- Generate a null statement in case none of the components were 651 -- verified because this will otherwise eliminate an alternative 652 -- from the variant case statement and render the generated code 653 -- illegal. 654 655 if No (Stmts) then 656 Append_New_To (Stmts, Make_Null_Statement (Loc)); 657 end if; 658 659 -- Generate: 660 -- when Discrete_Choices => 661 -- Stmts 662 663 Append_New_To (Alts, 664 Make_Case_Statement_Alternative (Loc, 665 Discrete_Choices => 666 New_Copy_List_Tree (Discrete_Choices (Var)), 667 Statements => Stmts)); 668 end Validate_Variant; 669 670 --------------------------- 671 -- Validate_Variant_Part -- 672 --------------------------- 673 674 procedure Validate_Variant_Part 675 (Obj_Id : Entity_Id; 676 Var_Part : Node_Id; 677 Stmts : in out List_Id) 678 is 679 Vars : constant List_Id := Variants (Var_Part); 680 Alts : List_Id; 681 Var : Node_Id; 682 683 begin 684 -- Assume that none of the variants are eligible for verification 685 686 Alts := No_List; 687 688 -- Validate variants 689 690 Var := First_Non_Pragma (Vars); 691 while Present (Var) loop 692 Validate_Variant 693 (Obj_Id => Obj_Id, 694 Var => Var, 695 Alts => Alts); 696 697 Next_Non_Pragma (Var); 698 end loop; 699 700 -- Even though individual variants may lack eligible components, the 701 -- alternatives must still be generated. 702 703 pragma Assert (Present (Alts)); 704 705 -- Generate: 706 -- case Rec_Typ (Obj_Id).Discriminant is 707 -- when Discrete_Choices_1 => 708 -- Stmts_1 709 -- when Discrete_Choices_N => 710 -- Stmts_N 711 -- end case; 712 713 Append_New_To (Stmts, 714 Make_Case_Statement (Loc, 715 Expression => 716 Make_Selected_Component (Loc, 717 Prefix => 718 Unchecked_Convert_To (Rec_Typ, 719 New_Occurrence_Of (Obj_Id, Loc)), 720 Selector_Name => New_Copy_Tree (Name (Var_Part))), 721 Alternatives => Alts)); 722 end Validate_Variant_Part; 723 724 -- Local variables 725 726 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V'); 727 Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); 728 Comps : Node_Id; 729 Stmts : List_Id; 730 Typ : Entity_Id; 731 Typ_Decl : Node_Id; 732 Typ_Def : Node_Id; 733 Typ_Ext : Node_Id; 734 735 -- Start of processing for Build_Record_VS_Func 736 737 begin 738 Typ := Rec_Typ; 739 740 -- Use the root type when dealing with a class-wide type 741 742 if Is_Class_Wide_Type (Typ) then 743 Typ := Root_Type (Typ); 744 end if; 745 746 Typ_Decl := Declaration_Node (Typ); 747 Typ_Def := Type_Definition (Typ_Decl); 748 749 -- The components of a derived type are located in the extension part 750 751 if Nkind (Typ_Def) = N_Derived_Type_Definition then 752 Typ_Ext := Record_Extension_Part (Typ_Def); 753 754 if Present (Typ_Ext) then 755 Comps := Component_List (Typ_Ext); 756 else 757 Comps := Empty; 758 end if; 759 760 -- Otherwise the components are available in the definition 761 762 else 763 Comps := Component_List (Typ_Def); 764 end if; 765 766 -- The code generated by this routine is as follows: 767 -- 768 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is 769 -- begin 770 -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars] 771 -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars] 772 -- then 773 -- return False; 774 -- end if; 775 -- 776 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars] 777 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars] 778 -- then 779 -- return False; 780 -- end if; 781 -- 782 -- case Discriminant_1 is 783 -- when Choice_1 => 784 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars] 785 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars] 786 -- then 787 -- return False; 788 -- end if; 789 -- 790 -- case Discriminant_N is 791 -- ... 792 -- when Choice_N => 793 -- ... 794 -- end case; 795 -- 796 -- return True; 797 -- end Func_Id; 798 799 -- Assume that the record type lacks eligible components, discriminants, 800 -- and variant parts. 801 802 Stmts := No_List; 803 804 -- Validate the discriminants 805 806 if not Is_Unchecked_Union (Rec_Typ) then 807 Validate_Fields 808 (Obj_Id => Obj_Id, 809 Fields => Discriminant_Specifications (Typ_Decl), 810 Stmts => Stmts); 811 end if; 812 813 -- Validate the components and variant parts 814 815 Validate_Component_List 816 (Obj_Id => Obj_Id, 817 Comp_List => Comps, 818 Stmts => Stmts); 819 820 -- Generate: 821 -- return True; 822 823 Append_New_To (Stmts, 824 Make_Simple_Return_Statement (Loc, 825 Expression => New_Occurrence_Of (Standard_True, Loc))); 826 827 -- Generate: 828 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is 829 -- begin 830 -- Stmts 831 -- end Func_Id; 832 833 Set_Ekind (Func_Id, E_Function); 834 Set_Is_Internal (Func_Id); 835 Set_Is_Pure (Func_Id); 836 837 if not Debug_Generated_Code then 838 Set_Debug_Info_Off (Func_Id); 839 end if; 840 841 Insert_Action (Attr, 842 Make_Subprogram_Body (Loc, 843 Specification => 844 Make_Function_Specification (Loc, 845 Defining_Unit_Name => Func_Id, 846 Parameter_Specifications => New_List ( 847 Make_Parameter_Specification (Loc, 848 Defining_Identifier => Obj_Id, 849 Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))), 850 Result_Definition => 851 New_Occurrence_Of (Standard_Boolean, Loc)), 852 Declarations => New_List, 853 Handled_Statement_Sequence => 854 Make_Handled_Sequence_Of_Statements (Loc, 855 Statements => Stmts)), 856 Suppress => Discriminant_Check); 857 858 return Func_Id; 859 end Build_Record_VS_Func; 860 861 ---------------------------------- 862 -- Compile_Stream_Body_In_Scope -- 863 ---------------------------------- 864 865 procedure Compile_Stream_Body_In_Scope 866 (N : Node_Id; 867 Decl : Node_Id; 868 Arr : Entity_Id; 869 Check : Boolean) 870 is 871 C_Type : constant Entity_Id := Base_Type (Component_Type (Arr)); 872 Curr : constant Entity_Id := Current_Scope; 873 Install : Boolean := False; 874 Scop : Entity_Id := Scope (Arr); 875 876 begin 877 if Is_Hidden (Arr) 878 and then not In_Open_Scopes (Scop) 879 and then Ekind (Scop) = E_Package 880 then 881 Install := True; 882 883 else 884 -- The component type may be private, in which case we install its 885 -- full view to compile the subprogram. 886 887 -- The component type may be private, in which case we install its 888 -- full view to compile the subprogram. We do not do this if the 889 -- type has a Stream_Convert pragma, which indicates that there are 890 -- special stream-processing operations for that type (for example 891 -- Unbounded_String and its wide varieties). 892 893 Scop := Scope (C_Type); 894 895 if Is_Private_Type (C_Type) 896 and then Present (Full_View (C_Type)) 897 and then not In_Open_Scopes (Scop) 898 and then Ekind (Scop) = E_Package 899 and then No (Get_Stream_Convert_Pragma (C_Type)) 900 then 901 Install := True; 902 end if; 903 end if; 904 905 -- If we are within an instance body, then all visibility has been 906 -- established already and there is no need to install the package. 907 908 if Install and then not In_Instance_Body then 909 Push_Scope (Scop); 910 Install_Visible_Declarations (Scop); 911 Install_Private_Declarations (Scop); 912 913 -- The entities in the package are now visible, but the generated 914 -- stream entity must appear in the current scope (usually an 915 -- enclosing stream function) so that itypes all have their proper 916 -- scopes. 917 918 Push_Scope (Curr); 919 else 920 Install := False; 921 end if; 922 923 if Check then 924 Insert_Action (N, Decl); 925 else 926 Insert_Action (N, Decl, Suppress => All_Checks); 927 end if; 928 929 if Install then 930 931 -- Remove extra copy of current scope, and package itself 932 933 Pop_Scope; 934 End_Package_Scope (Scop); 935 end if; 936 end Compile_Stream_Body_In_Scope; 937 938 ----------------------------------- 939 -- Expand_Access_To_Protected_Op -- 940 ----------------------------------- 941 942 procedure Expand_Access_To_Protected_Op 943 (N : Node_Id; 944 Pref : Node_Id; 945 Typ : Entity_Id) 946 is 947 -- The value of the attribute_reference is a record containing two 948 -- fields: an access to the protected object, and an access to the 949 -- subprogram itself. The prefix is a selected component. 950 951 Loc : constant Source_Ptr := Sloc (N); 952 Agg : Node_Id; 953 Btyp : constant Entity_Id := Base_Type (Typ); 954 Sub : Entity_Id; 955 Sub_Ref : Node_Id; 956 E_T : constant Entity_Id := Equivalent_Type (Btyp); 957 Acc : constant Entity_Id := 958 Etype (Next_Component (First_Component (E_T))); 959 Obj_Ref : Node_Id; 960 Curr : Entity_Id; 961 962 -- Start of processing for Expand_Access_To_Protected_Op 963 964 begin 965 -- Within the body of the protected type, the prefix designates a local 966 -- operation, and the object is the first parameter of the corresponding 967 -- protected body of the current enclosing operation. 968 969 if Is_Entity_Name (Pref) then 970 -- All indirect calls are external calls, so must do locking and 971 -- barrier reevaluation, even if the 'Access occurs within the 972 -- protected body. Hence the call to External_Subprogram, as opposed 973 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means 974 -- that indirect calls from within the same protected body will 975 -- deadlock, as allowed by RM-9.5.1(8,15,17). 976 977 Sub := New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc); 978 979 -- Don't traverse the scopes when the attribute occurs within an init 980 -- proc, because we directly use the _init formal of the init proc in 981 -- that case. 982 983 Curr := Current_Scope; 984 if not Is_Init_Proc (Curr) then 985 pragma Assert (In_Open_Scopes (Scope (Entity (Pref)))); 986 987 while Scope (Curr) /= Scope (Entity (Pref)) loop 988 Curr := Scope (Curr); 989 end loop; 990 end if; 991 992 -- In case of protected entries the first formal of its Protected_ 993 -- Body_Subprogram is the address of the object. 994 995 if Ekind (Curr) = E_Entry then 996 Obj_Ref := 997 New_Occurrence_Of 998 (First_Formal 999 (Protected_Body_Subprogram (Curr)), Loc); 1000 1001 -- If the current scope is an init proc, then use the address of the 1002 -- _init formal as the object reference. 1003 1004 elsif Is_Init_Proc (Curr) then 1005 Obj_Ref := 1006 Make_Attribute_Reference (Loc, 1007 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc), 1008 Attribute_Name => Name_Address); 1009 1010 -- In case of protected subprograms the first formal of its 1011 -- Protected_Body_Subprogram is the object and we get its address. 1012 1013 else 1014 Obj_Ref := 1015 Make_Attribute_Reference (Loc, 1016 Prefix => 1017 New_Occurrence_Of 1018 (First_Formal 1019 (Protected_Body_Subprogram (Curr)), Loc), 1020 Attribute_Name => Name_Address); 1021 end if; 1022 1023 -- Case where the prefix is not an entity name. Find the 1024 -- version of the protected operation to be called from 1025 -- outside the protected object. 1026 1027 else 1028 Sub := 1029 New_Occurrence_Of 1030 (External_Subprogram 1031 (Entity (Selector_Name (Pref))), Loc); 1032 1033 Obj_Ref := 1034 Make_Attribute_Reference (Loc, 1035 Prefix => Relocate_Node (Prefix (Pref)), 1036 Attribute_Name => Name_Address); 1037 end if; 1038 1039 Sub_Ref := 1040 Make_Attribute_Reference (Loc, 1041 Prefix => Sub, 1042 Attribute_Name => Name_Access); 1043 1044 -- We set the type of the access reference to the already generated 1045 -- access_to_subprogram type, and declare the reference analyzed, to 1046 -- prevent further expansion when the enclosing aggregate is analyzed. 1047 1048 Set_Etype (Sub_Ref, Acc); 1049 Set_Analyzed (Sub_Ref); 1050 1051 Agg := 1052 Make_Aggregate (Loc, 1053 Expressions => New_List (Obj_Ref, Sub_Ref)); 1054 1055 -- Sub_Ref has been marked as analyzed, but we still need to make sure 1056 -- Sub is correctly frozen. 1057 1058 Freeze_Before (N, Entity (Sub)); 1059 1060 Rewrite (N, Agg); 1061 Analyze_And_Resolve (N, E_T); 1062 1063 -- For subsequent analysis, the node must retain its type. The backend 1064 -- will replace it with the equivalent type where needed. 1065 1066 Set_Etype (N, Typ); 1067 end Expand_Access_To_Protected_Op; 1068 1069 -------------------------- 1070 -- Expand_Fpt_Attribute -- 1071 -------------------------- 1072 1073 procedure Expand_Fpt_Attribute 1074 (N : Node_Id; 1075 Pkg : RE_Id; 1076 Nam : Name_Id; 1077 Args : List_Id) 1078 is 1079 Loc : constant Source_Ptr := Sloc (N); 1080 Typ : constant Entity_Id := Etype (N); 1081 Fnm : Node_Id; 1082 1083 begin 1084 -- The function name is the selected component Attr_xxx.yyy where 1085 -- Attr_xxx is the package name, and yyy is the argument Nam. 1086 1087 -- Note: it would be more usual to have separate RE entries for each 1088 -- of the entities in the Fat packages, but first they have identical 1089 -- names (so we would have to have lots of renaming declarations to 1090 -- meet the normal RE rule of separate names for all runtime entities), 1091 -- and second there would be an awful lot of them. 1092 1093 Fnm := 1094 Make_Selected_Component (Loc, 1095 Prefix => New_Occurrence_Of (RTE (Pkg), Loc), 1096 Selector_Name => Make_Identifier (Loc, Nam)); 1097 1098 -- The generated call is given the provided set of parameters, and then 1099 -- wrapped in a conversion which converts the result to the target type 1100 -- We use the base type as the target because a range check may be 1101 -- required. 1102 1103 Rewrite (N, 1104 Unchecked_Convert_To (Base_Type (Etype (N)), 1105 Make_Function_Call (Loc, 1106 Name => Fnm, 1107 Parameter_Associations => Args))); 1108 1109 Analyze_And_Resolve (N, Typ); 1110 end Expand_Fpt_Attribute; 1111 1112 ---------------------------- 1113 -- Expand_Fpt_Attribute_R -- 1114 ---------------------------- 1115 1116 -- The single argument is converted to its root type to call the 1117 -- appropriate runtime function, with the actual call being built 1118 -- by Expand_Fpt_Attribute 1119 1120 procedure Expand_Fpt_Attribute_R (N : Node_Id) is 1121 E1 : constant Node_Id := First (Expressions (N)); 1122 Ftp : Entity_Id; 1123 Pkg : RE_Id; 1124 begin 1125 Find_Fat_Info (Etype (E1), Ftp, Pkg); 1126 Expand_Fpt_Attribute 1127 (N, Pkg, Attribute_Name (N), 1128 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1)))); 1129 end Expand_Fpt_Attribute_R; 1130 1131 ----------------------------- 1132 -- Expand_Fpt_Attribute_RI -- 1133 ----------------------------- 1134 1135 -- The first argument is converted to its root type and the second 1136 -- argument is converted to standard long long integer to call the 1137 -- appropriate runtime function, with the actual call being built 1138 -- by Expand_Fpt_Attribute 1139 1140 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is 1141 E1 : constant Node_Id := First (Expressions (N)); 1142 Ftp : Entity_Id; 1143 Pkg : RE_Id; 1144 E2 : constant Node_Id := Next (E1); 1145 begin 1146 Find_Fat_Info (Etype (E1), Ftp, Pkg); 1147 Expand_Fpt_Attribute 1148 (N, Pkg, Attribute_Name (N), 1149 New_List ( 1150 Unchecked_Convert_To (Ftp, Relocate_Node (E1)), 1151 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2)))); 1152 end Expand_Fpt_Attribute_RI; 1153 1154 ----------------------------- 1155 -- Expand_Fpt_Attribute_RR -- 1156 ----------------------------- 1157 1158 -- The two arguments are converted to their root types to call the 1159 -- appropriate runtime function, with the actual call being built 1160 -- by Expand_Fpt_Attribute 1161 1162 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is 1163 E1 : constant Node_Id := First (Expressions (N)); 1164 E2 : constant Node_Id := Next (E1); 1165 Ftp : Entity_Id; 1166 Pkg : RE_Id; 1167 1168 begin 1169 Find_Fat_Info (Etype (E1), Ftp, Pkg); 1170 Expand_Fpt_Attribute 1171 (N, Pkg, Attribute_Name (N), 1172 New_List ( 1173 Unchecked_Convert_To (Ftp, Relocate_Node (E1)), 1174 Unchecked_Convert_To (Ftp, Relocate_Node (E2)))); 1175 end Expand_Fpt_Attribute_RR; 1176 1177 --------------------------------- 1178 -- Expand_Loop_Entry_Attribute -- 1179 --------------------------------- 1180 1181 procedure Expand_Loop_Entry_Attribute (N : Node_Id) is 1182 procedure Build_Conditional_Block 1183 (Loc : Source_Ptr; 1184 Cond : Node_Id; 1185 Loop_Stmt : Node_Id; 1186 If_Stmt : out Node_Id; 1187 Blk_Stmt : out Node_Id); 1188 -- Create a block Blk_Stmt with an empty declarative list and a single 1189 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with 1190 -- condition Cond. If_Stmt is Empty when there is no condition provided. 1191 1192 function Is_Array_Iteration (N : Node_Id) return Boolean; 1193 -- Determine whether loop statement N denotes an Ada 2012 iteration over 1194 -- an array object. 1195 1196 ----------------------------- 1197 -- Build_Conditional_Block -- 1198 ----------------------------- 1199 1200 procedure Build_Conditional_Block 1201 (Loc : Source_Ptr; 1202 Cond : Node_Id; 1203 Loop_Stmt : Node_Id; 1204 If_Stmt : out Node_Id; 1205 Blk_Stmt : out Node_Id) 1206 is 1207 begin 1208 -- Do not reanalyze the original loop statement because it is simply 1209 -- being relocated. 1210 1211 Set_Analyzed (Loop_Stmt); 1212 1213 Blk_Stmt := 1214 Make_Block_Statement (Loc, 1215 Declarations => New_List, 1216 Handled_Statement_Sequence => 1217 Make_Handled_Sequence_Of_Statements (Loc, 1218 Statements => New_List (Loop_Stmt))); 1219 1220 if Present (Cond) then 1221 If_Stmt := 1222 Make_If_Statement (Loc, 1223 Condition => Cond, 1224 Then_Statements => New_List (Blk_Stmt)); 1225 else 1226 If_Stmt := Empty; 1227 end if; 1228 end Build_Conditional_Block; 1229 1230 ------------------------ 1231 -- Is_Array_Iteration -- 1232 ------------------------ 1233 1234 function Is_Array_Iteration (N : Node_Id) return Boolean is 1235 Stmt : constant Node_Id := Original_Node (N); 1236 Iter : Node_Id; 1237 1238 begin 1239 if Nkind (Stmt) = N_Loop_Statement 1240 and then Present (Iteration_Scheme (Stmt)) 1241 and then Present (Iterator_Specification (Iteration_Scheme (Stmt))) 1242 then 1243 Iter := Iterator_Specification (Iteration_Scheme (Stmt)); 1244 1245 return 1246 Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter))); 1247 end if; 1248 1249 return False; 1250 end Is_Array_Iteration; 1251 1252 -- Local variables 1253 1254 Pref : constant Node_Id := Prefix (N); 1255 Base_Typ : constant Entity_Id := Base_Type (Etype (Pref)); 1256 Exprs : constant List_Id := Expressions (N); 1257 Aux_Decl : Node_Id; 1258 Blk : Node_Id := Empty; 1259 Decls : List_Id; 1260 Installed : Boolean; 1261 Loc : Source_Ptr; 1262 Loop_Id : Entity_Id; 1263 Loop_Stmt : Node_Id; 1264 Result : Node_Id := Empty; 1265 Scheme : Node_Id; 1266 Temp_Decl : Node_Id; 1267 Temp_Id : Entity_Id; 1268 1269 -- Start of processing for Expand_Loop_Entry_Attribute 1270 1271 begin 1272 -- Step 1: Find the related loop 1273 1274 -- The loop label variant of attribute 'Loop_Entry already has all the 1275 -- information in its expression. 1276 1277 if Present (Exprs) then 1278 Loop_Id := Entity (First (Exprs)); 1279 Loop_Stmt := Label_Construct (Parent (Loop_Id)); 1280 1281 -- Climb the parent chain to find the nearest enclosing loop. Skip 1282 -- all internally generated loops for quantified expressions and for 1283 -- element iterators over multidimensional arrays because the pragma 1284 -- applies to source loop. 1285 1286 else 1287 Loop_Stmt := N; 1288 while Present (Loop_Stmt) loop 1289 if Nkind (Loop_Stmt) = N_Loop_Statement 1290 and then Nkind (Original_Node (Loop_Stmt)) = N_Loop_Statement 1291 and then Comes_From_Source (Original_Node (Loop_Stmt)) 1292 then 1293 exit; 1294 end if; 1295 1296 Loop_Stmt := Parent (Loop_Stmt); 1297 end loop; 1298 1299 Loop_Id := Entity (Identifier (Loop_Stmt)); 1300 end if; 1301 1302 Loc := Sloc (Loop_Stmt); 1303 1304 -- Step 2: Transform the loop 1305 1306 -- The loop has already been transformed during the expansion of a prior 1307 -- 'Loop_Entry attribute. Retrieve the declarative list of the block. 1308 1309 if Has_Loop_Entry_Attributes (Loop_Id) then 1310 1311 -- When the related loop name appears as the argument of attribute 1312 -- Loop_Entry, the corresponding label construct is the generated 1313 -- block statement. This is because the expander reuses the label. 1314 1315 if Nkind (Loop_Stmt) = N_Block_Statement then 1316 Decls := Declarations (Loop_Stmt); 1317 1318 -- In all other cases, the loop must appear in the handled sequence 1319 -- of statements of the generated block. 1320 1321 else 1322 pragma Assert 1323 (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements 1324 and then 1325 Nkind (Parent (Parent (Loop_Stmt))) = N_Block_Statement); 1326 1327 Decls := Declarations (Parent (Parent (Loop_Stmt))); 1328 end if; 1329 1330 -- Transform the loop into a conditional block 1331 1332 else 1333 Set_Has_Loop_Entry_Attributes (Loop_Id); 1334 Scheme := Iteration_Scheme (Loop_Stmt); 1335 1336 -- Infinite loops are transformed into: 1337 1338 -- declare 1339 -- Temp1 : constant <type of Pref1> := <Pref1>; 1340 -- . . . 1341 -- TempN : constant <type of PrefN> := <PrefN>; 1342 -- begin 1343 -- loop 1344 -- <original source statements with attribute rewrites> 1345 -- end loop; 1346 -- end; 1347 1348 if No (Scheme) then 1349 Build_Conditional_Block (Loc, 1350 Cond => Empty, 1351 Loop_Stmt => Relocate_Node (Loop_Stmt), 1352 If_Stmt => Result, 1353 Blk_Stmt => Blk); 1354 1355 Result := Blk; 1356 1357 -- While loops are transformed into: 1358 1359 -- function Fnn return Boolean is 1360 -- begin 1361 -- <condition actions> 1362 -- return <condition>; 1363 -- end Fnn; 1364 1365 -- if Fnn then 1366 -- declare 1367 -- Temp1 : constant <type of Pref1> := <Pref1>; 1368 -- . . . 1369 -- TempN : constant <type of PrefN> := <PrefN>; 1370 -- begin 1371 -- loop 1372 -- <original source statements with attribute rewrites> 1373 -- exit when not Fnn; 1374 -- end loop; 1375 -- end; 1376 -- end if; 1377 1378 -- Note that loops over iterators and containers are already 1379 -- converted into while loops. 1380 1381 elsif Present (Condition (Scheme)) then 1382 declare 1383 Func_Decl : Node_Id; 1384 Func_Id : Entity_Id; 1385 Stmts : List_Id; 1386 1387 begin 1388 Func_Id := Make_Temporary (Loc, 'F'); 1389 1390 -- Wrap the condition of the while loop in a Boolean function. 1391 -- This avoids the duplication of the same code which may lead 1392 -- to gigi issues with respect to multiple declaration of the 1393 -- same entity in the presence of side effects or checks. Note 1394 -- that the condition actions must also be relocated into the 1395 -- wrapping function because they may contain itypes, e.g. in 1396 -- the case of a comparison involving slices. 1397 1398 -- Generate: 1399 -- <condition actions> 1400 -- return <condition>; 1401 1402 if Present (Condition_Actions (Scheme)) then 1403 Stmts := Condition_Actions (Scheme); 1404 else 1405 Stmts := New_List; 1406 end if; 1407 1408 Append_To (Stmts, 1409 Make_Simple_Return_Statement (Loc, 1410 Expression => 1411 New_Copy_Tree (Condition (Scheme), 1412 New_Scope => Func_Id))); 1413 1414 -- Generate: 1415 -- function Fnn return Boolean is 1416 -- begin 1417 -- <Stmts> 1418 -- end Fnn; 1419 1420 Func_Decl := 1421 Make_Subprogram_Body (Loc, 1422 Specification => 1423 Make_Function_Specification (Loc, 1424 Defining_Unit_Name => Func_Id, 1425 Result_Definition => 1426 New_Occurrence_Of (Standard_Boolean, Loc)), 1427 Declarations => Empty_List, 1428 Handled_Statement_Sequence => 1429 Make_Handled_Sequence_Of_Statements (Loc, 1430 Statements => Stmts)); 1431 1432 -- The function is inserted before the related loop. Make sure 1433 -- to analyze it in the context of the loop's enclosing scope. 1434 1435 Push_Scope (Scope (Loop_Id)); 1436 Insert_Action (Loop_Stmt, Func_Decl); 1437 Pop_Scope; 1438 1439 -- The analysis of the condition may have generated itypes 1440 -- that are now used within the function: Adjust their 1441 -- scopes accordingly so that their use appears in their 1442 -- scope of definition. 1443 1444 declare 1445 Ityp : Entity_Id; 1446 1447 begin 1448 Ityp := First_Entity (Loop_Id); 1449 1450 while Present (Ityp) loop 1451 if Is_Itype (Ityp) then 1452 Set_Scope (Ityp, Func_Id); 1453 end if; 1454 Next_Entity (Ityp); 1455 end loop; 1456 end; 1457 1458 -- Transform the original while loop into an infinite loop 1459 -- where the last statement checks the negated condition. This 1460 -- placement ensures that the condition will not be evaluated 1461 -- twice on the first iteration. 1462 1463 Set_Iteration_Scheme (Loop_Stmt, Empty); 1464 Scheme := Empty; 1465 1466 -- Generate: 1467 -- exit when not Fnn; 1468 1469 Append_To (Statements (Loop_Stmt), 1470 Make_Exit_Statement (Loc, 1471 Condition => 1472 Make_Op_Not (Loc, 1473 Right_Opnd => 1474 Make_Function_Call (Loc, 1475 Name => New_Occurrence_Of (Func_Id, Loc))))); 1476 1477 Build_Conditional_Block (Loc, 1478 Cond => 1479 Make_Function_Call (Loc, 1480 Name => New_Occurrence_Of (Func_Id, Loc)), 1481 Loop_Stmt => Relocate_Node (Loop_Stmt), 1482 If_Stmt => Result, 1483 Blk_Stmt => Blk); 1484 end; 1485 1486 -- Ada 2012 iteration over an array is transformed into: 1487 1488 -- if <Array_Nam>'Length (1) > 0 1489 -- and then <Array_Nam>'Length (N) > 0 1490 -- then 1491 -- declare 1492 -- Temp1 : constant <type of Pref1> := <Pref1>; 1493 -- . . . 1494 -- TempN : constant <type of PrefN> := <PrefN>; 1495 -- begin 1496 -- for X in ... loop -- multiple loops depending on dims 1497 -- <original source statements with attribute rewrites> 1498 -- end loop; 1499 -- end; 1500 -- end if; 1501 1502 elsif Is_Array_Iteration (Loop_Stmt) then 1503 declare 1504 Array_Nam : constant Entity_Id := 1505 Entity (Name (Iterator_Specification 1506 (Iteration_Scheme (Original_Node (Loop_Stmt))))); 1507 Num_Dims : constant Pos := 1508 Number_Dimensions (Etype (Array_Nam)); 1509 Cond : Node_Id := Empty; 1510 Check : Node_Id; 1511 1512 begin 1513 -- Generate a check which determines whether all dimensions of 1514 -- the array are non-null. 1515 1516 for Dim in 1 .. Num_Dims loop 1517 Check := 1518 Make_Op_Gt (Loc, 1519 Left_Opnd => 1520 Make_Attribute_Reference (Loc, 1521 Prefix => New_Occurrence_Of (Array_Nam, Loc), 1522 Attribute_Name => Name_Length, 1523 Expressions => New_List ( 1524 Make_Integer_Literal (Loc, Dim))), 1525 Right_Opnd => 1526 Make_Integer_Literal (Loc, 0)); 1527 1528 if No (Cond) then 1529 Cond := Check; 1530 else 1531 Cond := 1532 Make_And_Then (Loc, 1533 Left_Opnd => Cond, 1534 Right_Opnd => Check); 1535 end if; 1536 end loop; 1537 1538 Build_Conditional_Block (Loc, 1539 Cond => Cond, 1540 Loop_Stmt => Relocate_Node (Loop_Stmt), 1541 If_Stmt => Result, 1542 Blk_Stmt => Blk); 1543 end; 1544 1545 -- For loops are transformed into: 1546 1547 -- if <Low> <= <High> then 1548 -- declare 1549 -- Temp1 : constant <type of Pref1> := <Pref1>; 1550 -- . . . 1551 -- TempN : constant <type of PrefN> := <PrefN>; 1552 -- begin 1553 -- for <Def_Id> in <Low> .. <High> loop 1554 -- <original source statements with attribute rewrites> 1555 -- end loop; 1556 -- end; 1557 -- end if; 1558 1559 elsif Present (Loop_Parameter_Specification (Scheme)) then 1560 declare 1561 Loop_Spec : constant Node_Id := 1562 Loop_Parameter_Specification (Scheme); 1563 Cond : Node_Id; 1564 Subt_Def : Node_Id; 1565 1566 begin 1567 Subt_Def := Discrete_Subtype_Definition (Loop_Spec); 1568 1569 -- When the loop iterates over a subtype indication with a 1570 -- range, use the low and high bounds of the subtype itself. 1571 1572 if Nkind (Subt_Def) = N_Subtype_Indication then 1573 Subt_Def := Scalar_Range (Etype (Subt_Def)); 1574 end if; 1575 1576 pragma Assert (Nkind (Subt_Def) = N_Range); 1577 1578 -- Generate 1579 -- Low <= High 1580 1581 Cond := 1582 Make_Op_Le (Loc, 1583 Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)), 1584 Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def))); 1585 1586 Build_Conditional_Block (Loc, 1587 Cond => Cond, 1588 Loop_Stmt => Relocate_Node (Loop_Stmt), 1589 If_Stmt => Result, 1590 Blk_Stmt => Blk); 1591 end; 1592 end if; 1593 1594 Decls := Declarations (Blk); 1595 end if; 1596 1597 -- Step 3: Create a constant to capture the value of the prefix at the 1598 -- entry point into the loop. 1599 1600 Temp_Id := Make_Temporary (Loc, 'P'); 1601 1602 -- Preserve the tag of the prefix by offering a specific view of the 1603 -- class-wide version of the prefix. 1604 1605 if Is_Tagged_Type (Base_Typ) then 1606 Tagged_Case : declare 1607 CW_Temp : Entity_Id; 1608 CW_Typ : Entity_Id; 1609 1610 begin 1611 -- Generate: 1612 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref); 1613 1614 CW_Temp := Make_Temporary (Loc, 'T'); 1615 CW_Typ := Class_Wide_Type (Base_Typ); 1616 1617 Aux_Decl := 1618 Make_Object_Declaration (Loc, 1619 Defining_Identifier => CW_Temp, 1620 Constant_Present => True, 1621 Object_Definition => New_Occurrence_Of (CW_Typ, Loc), 1622 Expression => 1623 Convert_To (CW_Typ, Relocate_Node (Pref))); 1624 Append_To (Decls, Aux_Decl); 1625 1626 -- Generate: 1627 -- Temp : Base_Typ renames Base_Typ (CW_Temp); 1628 1629 Temp_Decl := 1630 Make_Object_Renaming_Declaration (Loc, 1631 Defining_Identifier => Temp_Id, 1632 Subtype_Mark => New_Occurrence_Of (Base_Typ, Loc), 1633 Name => 1634 Convert_To (Base_Typ, New_Occurrence_Of (CW_Temp, Loc))); 1635 Append_To (Decls, Temp_Decl); 1636 end Tagged_Case; 1637 1638 -- Untagged case 1639 1640 else 1641 Untagged_Case : declare 1642 Temp_Expr : Node_Id; 1643 1644 begin 1645 Aux_Decl := Empty; 1646 1647 -- Generate a nominal type for the constant when the prefix is of 1648 -- a constrained type. This is achieved by setting the Etype of 1649 -- the relocated prefix to its base type. Since the prefix is now 1650 -- the initialization expression of the constant, its freezing 1651 -- will produce a proper nominal type. 1652 1653 Temp_Expr := Relocate_Node (Pref); 1654 Set_Etype (Temp_Expr, Base_Typ); 1655 1656 -- Generate: 1657 -- Temp : constant Base_Typ := Pref; 1658 1659 Temp_Decl := 1660 Make_Object_Declaration (Loc, 1661 Defining_Identifier => Temp_Id, 1662 Constant_Present => True, 1663 Object_Definition => New_Occurrence_Of (Base_Typ, Loc), 1664 Expression => Temp_Expr); 1665 Append_To (Decls, Temp_Decl); 1666 end Untagged_Case; 1667 end if; 1668 1669 -- Step 4: Analyze all bits 1670 1671 Installed := Current_Scope = Scope (Loop_Id); 1672 1673 -- Depending on the pracement of attribute 'Loop_Entry relative to the 1674 -- associated loop, ensure the proper visibility for analysis. 1675 1676 if not Installed then 1677 Push_Scope (Scope (Loop_Id)); 1678 end if; 1679 1680 -- The analysis of the conditional block takes care of the constant 1681 -- declaration. 1682 1683 if Present (Result) then 1684 Rewrite (Loop_Stmt, Result); 1685 Analyze (Loop_Stmt); 1686 1687 -- The conditional block was analyzed when a previous 'Loop_Entry was 1688 -- expanded. There is no point in reanalyzing the block, simply analyze 1689 -- the declaration of the constant. 1690 1691 else 1692 if Present (Aux_Decl) then 1693 Analyze (Aux_Decl); 1694 end if; 1695 1696 Analyze (Temp_Decl); 1697 end if; 1698 1699 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); 1700 Analyze (N); 1701 1702 if not Installed then 1703 Pop_Scope; 1704 end if; 1705 end Expand_Loop_Entry_Attribute; 1706 1707 ------------------------------ 1708 -- Expand_Min_Max_Attribute -- 1709 ------------------------------ 1710 1711 procedure Expand_Min_Max_Attribute (N : Node_Id) is 1712 begin 1713 -- Min and Max are handled by the back end (except that static cases 1714 -- have already been evaluated during semantic processing, although the 1715 -- back end should not count on this). The one bit of special processing 1716 -- required in the normal case is that these two attributes typically 1717 -- generate conditionals in the code, so check the relevant restriction. 1718 1719 Check_Restriction (No_Implicit_Conditionals, N); 1720 end Expand_Min_Max_Attribute; 1721 1722 ---------------------------------- 1723 -- Expand_N_Attribute_Reference -- 1724 ---------------------------------- 1725 1726 procedure Expand_N_Attribute_Reference (N : Node_Id) is 1727 Loc : constant Source_Ptr := Sloc (N); 1728 Typ : constant Entity_Id := Etype (N); 1729 Btyp : constant Entity_Id := Base_Type (Typ); 1730 Pref : constant Node_Id := Prefix (N); 1731 Ptyp : constant Entity_Id := Etype (Pref); 1732 Exprs : constant List_Id := Expressions (N); 1733 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); 1734 1735 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id); 1736 -- Rewrites a stream attribute for Read, Write or Output with the 1737 -- procedure call. Pname is the entity for the procedure to call. 1738 1739 ------------------------------ 1740 -- Rewrite_Stream_Proc_Call -- 1741 ------------------------------ 1742 1743 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is 1744 Item : constant Node_Id := Next (First (Exprs)); 1745 Item_Typ : constant Entity_Id := Etype (Item); 1746 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname)); 1747 Formal_Typ : constant Entity_Id := Etype (Formal); 1748 Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter; 1749 1750 begin 1751 -- The expansion depends on Item, the second actual, which is 1752 -- the object being streamed in or out. 1753 1754 -- If the item is a component of a packed array type, and 1755 -- a conversion is needed on exit, we introduce a temporary to 1756 -- hold the value, because otherwise the packed reference will 1757 -- not be properly expanded. 1758 1759 if Nkind (Item) = N_Indexed_Component 1760 and then Is_Packed (Base_Type (Etype (Prefix (Item)))) 1761 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ) 1762 and then Is_Written 1763 then 1764 declare 1765 Temp : constant Entity_Id := Make_Temporary (Loc, 'V'); 1766 Decl : Node_Id; 1767 Assn : Node_Id; 1768 1769 begin 1770 Decl := 1771 Make_Object_Declaration (Loc, 1772 Defining_Identifier => Temp, 1773 Object_Definition => New_Occurrence_Of (Formal_Typ, Loc)); 1774 Set_Etype (Temp, Formal_Typ); 1775 1776 Assn := 1777 Make_Assignment_Statement (Loc, 1778 Name => New_Copy_Tree (Item), 1779 Expression => 1780 Unchecked_Convert_To 1781 (Item_Typ, New_Occurrence_Of (Temp, Loc))); 1782 1783 Rewrite (Item, New_Occurrence_Of (Temp, Loc)); 1784 Insert_Actions (N, 1785 New_List ( 1786 Decl, 1787 Make_Procedure_Call_Statement (Loc, 1788 Name => New_Occurrence_Of (Pname, Loc), 1789 Parameter_Associations => Exprs), 1790 Assn)); 1791 1792 Rewrite (N, Make_Null_Statement (Loc)); 1793 return; 1794 end; 1795 end if; 1796 1797 -- For the class-wide dispatching cases, and for cases in which 1798 -- the base type of the second argument matches the base type of 1799 -- the corresponding formal parameter (that is to say the stream 1800 -- operation is not inherited), we are all set, and can use the 1801 -- argument unchanged. 1802 1803 if not Is_Class_Wide_Type (Entity (Pref)) 1804 and then not Is_Class_Wide_Type (Etype (Item)) 1805 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ) 1806 then 1807 -- Perform a view conversion when either the argument or the 1808 -- formal parameter are of a private type. 1809 1810 if Is_Private_Type (Base_Type (Formal_Typ)) 1811 or else Is_Private_Type (Base_Type (Item_Typ)) 1812 then 1813 Rewrite (Item, 1814 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item))); 1815 1816 -- Otherwise perform a regular type conversion to ensure that all 1817 -- relevant checks are installed. 1818 1819 else 1820 Rewrite (Item, Convert_To (Formal_Typ, Relocate_Node (Item))); 1821 end if; 1822 1823 -- For untagged derived types set Assignment_OK, to prevent 1824 -- copies from being created when the unchecked conversion 1825 -- is expanded (which would happen in Remove_Side_Effects 1826 -- if Expand_N_Unchecked_Conversion were allowed to call 1827 -- Force_Evaluation). The copy could violate Ada semantics in 1828 -- cases such as an actual that is an out parameter. Note that 1829 -- this approach is also used in exp_ch7 for calls to controlled 1830 -- type operations to prevent problems with actuals wrapped in 1831 -- unchecked conversions. 1832 1833 if Is_Untagged_Derivation (Etype (Expression (Item))) then 1834 Set_Assignment_OK (Item); 1835 end if; 1836 end if; 1837 1838 -- The stream operation to call may be a renaming created by an 1839 -- attribute definition clause, and may not be frozen yet. Ensure 1840 -- that it has the necessary extra formals. 1841 1842 if not Is_Frozen (Pname) then 1843 Create_Extra_Formals (Pname); 1844 end if; 1845 1846 -- And now rewrite the call 1847 1848 Rewrite (N, 1849 Make_Procedure_Call_Statement (Loc, 1850 Name => New_Occurrence_Of (Pname, Loc), 1851 Parameter_Associations => Exprs)); 1852 1853 Analyze (N); 1854 end Rewrite_Stream_Proc_Call; 1855 1856 -- Start of processing for Expand_N_Attribute_Reference 1857 1858 begin 1859 -- Do required validity checking, if enabled. Do not apply check to 1860 -- output parameters of an Asm instruction, since the value of this 1861 -- is not set till after the attribute has been elaborated, and do 1862 -- not apply the check to the arguments of a 'Read or 'Input attribute 1863 -- reference since the scalar argument is an OUT scalar. 1864 1865 if Validity_Checks_On and then Validity_Check_Operands 1866 and then Id /= Attribute_Asm_Output 1867 and then Id /= Attribute_Read 1868 and then Id /= Attribute_Input 1869 then 1870 declare 1871 Expr : Node_Id; 1872 begin 1873 Expr := First (Expressions (N)); 1874 while Present (Expr) loop 1875 Ensure_Valid (Expr); 1876 Next (Expr); 1877 end loop; 1878 end; 1879 end if; 1880 1881 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in- 1882 -- place function, then a temporary return object needs to be created 1883 -- and access to it must be passed to the function. 1884 1885 if Is_Build_In_Place_Function_Call (Pref) then 1886 1887 -- If attribute is 'Old, the context is a postcondition, and 1888 -- the temporary must go in the corresponding subprogram, not 1889 -- the postcondition function or any created blocks, as when 1890 -- the attribute appears in a quantified expression. This is 1891 -- handled below in the expansion of the attribute. 1892 1893 if Attribute_Name (Parent (Pref)) = Name_Old then 1894 null; 1895 else 1896 Make_Build_In_Place_Call_In_Anonymous_Context (Pref); 1897 end if; 1898 1899 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 1900 -- containing build-in-place function calls whose returned object covers 1901 -- interface types. 1902 1903 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then 1904 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref); 1905 end if; 1906 1907 -- If prefix is a protected type name, this is a reference to the 1908 -- current instance of the type. For a component definition, nothing 1909 -- to do (expansion will occur in the init proc). In other contexts, 1910 -- rewrite into reference to current instance. 1911 1912 if Is_Protected_Self_Reference (Pref) 1913 and then not 1914 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint, 1915 N_Discriminant_Association) 1916 and then Nkind (Parent (Parent (Parent (Parent (N))))) = 1917 N_Component_Definition) 1918 1919 -- No action needed for these attributes since the current instance 1920 -- will be rewritten to be the name of the _object parameter 1921 -- associated with the enclosing protected subprogram (see below). 1922 1923 and then Id /= Attribute_Access 1924 and then Id /= Attribute_Unchecked_Access 1925 and then Id /= Attribute_Unrestricted_Access 1926 then 1927 Rewrite (Pref, Concurrent_Ref (Pref)); 1928 Analyze (Pref); 1929 end if; 1930 1931 -- Remaining processing depends on specific attribute 1932 1933 -- Note: individual sections of the following case statement are 1934 -- allowed to assume there is no code after the case statement, and 1935 -- are legitimately allowed to execute return statements if they have 1936 -- nothing more to do. 1937 1938 case Id is 1939 1940 -- Attributes related to Ada 2012 iterators 1941 1942 when Attribute_Constant_Indexing 1943 | Attribute_Default_Iterator 1944 | Attribute_Implicit_Dereference 1945 | Attribute_Iterable 1946 | Attribute_Iterator_Element 1947 | Attribute_Variable_Indexing 1948 => 1949 null; 1950 1951 -- Internal attributes used to deal with Ada 2012 delayed aspects. These 1952 -- were already rejected by the parser. Thus they shouldn't appear here. 1953 1954 when Internal_Attribute_Id => 1955 raise Program_Error; 1956 1957 ------------ 1958 -- Access -- 1959 ------------ 1960 1961 when Attribute_Access 1962 | Attribute_Unchecked_Access 1963 | Attribute_Unrestricted_Access 1964 => 1965 Access_Cases : declare 1966 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); 1967 Btyp_DDT : Entity_Id; 1968 1969 function Enclosing_Object (N : Node_Id) return Node_Id; 1970 -- If N denotes a compound name (selected component, indexed 1971 -- component, or slice), returns the name of the outermost such 1972 -- enclosing object. Otherwise returns N. If the object is a 1973 -- renaming, then the renamed object is returned. 1974 1975 ---------------------- 1976 -- Enclosing_Object -- 1977 ---------------------- 1978 1979 function Enclosing_Object (N : Node_Id) return Node_Id is 1980 Obj_Name : Node_Id; 1981 1982 begin 1983 Obj_Name := N; 1984 while Nkind_In (Obj_Name, N_Selected_Component, 1985 N_Indexed_Component, 1986 N_Slice) 1987 loop 1988 Obj_Name := Prefix (Obj_Name); 1989 end loop; 1990 1991 return Get_Referenced_Object (Obj_Name); 1992 end Enclosing_Object; 1993 1994 -- Local declarations 1995 1996 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object); 1997 1998 -- Start of processing for Access_Cases 1999 2000 begin 2001 Btyp_DDT := Designated_Type (Btyp); 2002 2003 -- Handle designated types that come from the limited view 2004 2005 if From_Limited_With (Btyp_DDT) 2006 and then Has_Non_Limited_View (Btyp_DDT) 2007 then 2008 Btyp_DDT := Non_Limited_View (Btyp_DDT); 2009 end if; 2010 2011 -- In order to improve the text of error messages, the designated 2012 -- type of access-to-subprogram itypes is set by the semantics as 2013 -- the associated subprogram entity (see sem_attr). Now we replace 2014 -- such node with the proper E_Subprogram_Type itype. 2015 2016 if Id = Attribute_Unrestricted_Access 2017 and then Is_Subprogram (Directly_Designated_Type (Typ)) 2018 then 2019 -- The following conditions ensure that this special management 2020 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes. 2021 -- At this stage other cases in which the designated type is 2022 -- still a subprogram (instead of an E_Subprogram_Type) are 2023 -- wrong because the semantics must have overridden the type of 2024 -- the node with the type imposed by the context. 2025 2026 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion 2027 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr) 2028 then 2029 Set_Etype (N, RTE (RE_Prim_Ptr)); 2030 2031 else 2032 declare 2033 Subp : constant Entity_Id := 2034 Directly_Designated_Type (Typ); 2035 Etyp : Entity_Id; 2036 Extra : Entity_Id := Empty; 2037 New_Formal : Entity_Id; 2038 Old_Formal : Entity_Id := First_Formal (Subp); 2039 Subp_Typ : Entity_Id; 2040 2041 begin 2042 Subp_Typ := Create_Itype (E_Subprogram_Type, N); 2043 Set_Etype (Subp_Typ, Etype (Subp)); 2044 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); 2045 2046 if Present (Old_Formal) then 2047 New_Formal := New_Copy (Old_Formal); 2048 Set_First_Entity (Subp_Typ, New_Formal); 2049 2050 loop 2051 Set_Scope (New_Formal, Subp_Typ); 2052 Etyp := Etype (New_Formal); 2053 2054 -- Handle itypes. There is no need to duplicate 2055 -- here the itypes associated with record types 2056 -- (i.e the implicit full view of private types). 2057 2058 if Is_Itype (Etyp) 2059 and then Ekind (Base_Type (Etyp)) /= E_Record_Type 2060 then 2061 Extra := New_Copy (Etyp); 2062 Set_Parent (Extra, New_Formal); 2063 Set_Etype (New_Formal, Extra); 2064 Set_Scope (Extra, Subp_Typ); 2065 end if; 2066 2067 Extra := New_Formal; 2068 Next_Formal (Old_Formal); 2069 exit when No (Old_Formal); 2070 2071 Link_Entities (New_Formal, New_Copy (Old_Formal)); 2072 Next_Entity (New_Formal); 2073 end loop; 2074 2075 Unlink_Next_Entity (New_Formal); 2076 Set_Last_Entity (Subp_Typ, Extra); 2077 end if; 2078 2079 -- Now that the explicit formals have been duplicated, 2080 -- any extra formals needed by the subprogram must be 2081 -- created. 2082 2083 if Present (Extra) then 2084 Set_Extra_Formal (Extra, Empty); 2085 end if; 2086 2087 Create_Extra_Formals (Subp_Typ); 2088 Set_Directly_Designated_Type (Typ, Subp_Typ); 2089 end; 2090 end if; 2091 end if; 2092 2093 if Is_Access_Protected_Subprogram_Type (Btyp) then 2094 Expand_Access_To_Protected_Op (N, Pref, Typ); 2095 2096 -- If prefix is a type name, this is a reference to the current 2097 -- instance of the type, within its initialization procedure. 2098 2099 elsif Is_Entity_Name (Pref) 2100 and then Is_Type (Entity (Pref)) 2101 then 2102 declare 2103 Par : Node_Id; 2104 Formal : Entity_Id; 2105 2106 begin 2107 -- If the current instance name denotes a task type, then 2108 -- the access attribute is rewritten to be the name of the 2109 -- "_task" parameter associated with the task type's task 2110 -- procedure. An unchecked conversion is applied to ensure 2111 -- a type match in cases of expander-generated calls (e.g. 2112 -- init procs). 2113 2114 if Is_Task_Type (Entity (Pref)) then 2115 Formal := 2116 First_Entity (Get_Task_Body_Procedure (Entity (Pref))); 2117 while Present (Formal) loop 2118 exit when Chars (Formal) = Name_uTask; 2119 Next_Entity (Formal); 2120 end loop; 2121 2122 pragma Assert (Present (Formal)); 2123 2124 Rewrite (N, 2125 Unchecked_Convert_To (Typ, 2126 New_Occurrence_Of (Formal, Loc))); 2127 Set_Etype (N, Typ); 2128 2129 elsif Is_Protected_Type (Entity (Pref)) then 2130 2131 -- No action needed for current instance located in a 2132 -- component definition (expansion will occur in the 2133 -- init proc) 2134 2135 if Is_Protected_Type (Current_Scope) then 2136 null; 2137 2138 -- If the current instance reference is located in a 2139 -- protected subprogram or entry then rewrite the access 2140 -- attribute to be the name of the "_object" parameter. 2141 -- An unchecked conversion is applied to ensure a type 2142 -- match in cases of expander-generated calls (e.g. init 2143 -- procs). 2144 2145 -- The code may be nested in a block, so find enclosing 2146 -- scope that is a protected operation. 2147 2148 else 2149 declare 2150 Subp : Entity_Id; 2151 2152 begin 2153 Subp := Current_Scope; 2154 while Ekind_In (Subp, E_Loop, E_Block) loop 2155 Subp := Scope (Subp); 2156 end loop; 2157 2158 Formal := 2159 First_Entity 2160 (Protected_Body_Subprogram (Subp)); 2161 2162 -- For a protected subprogram the _Object parameter 2163 -- is the protected record, so we create an access 2164 -- to it. The _Object parameter of an entry is an 2165 -- address. 2166 2167 if Ekind (Subp) = E_Entry then 2168 Rewrite (N, 2169 Unchecked_Convert_To (Typ, 2170 New_Occurrence_Of (Formal, Loc))); 2171 Set_Etype (N, Typ); 2172 2173 else 2174 Rewrite (N, 2175 Unchecked_Convert_To (Typ, 2176 Make_Attribute_Reference (Loc, 2177 Attribute_Name => Name_Unrestricted_Access, 2178 Prefix => 2179 New_Occurrence_Of (Formal, Loc)))); 2180 Analyze_And_Resolve (N); 2181 end if; 2182 end; 2183 end if; 2184 2185 -- The expression must appear in a default expression, 2186 -- (which in the initialization procedure is the right-hand 2187 -- side of an assignment), and not in a discriminant 2188 -- constraint. 2189 2190 else 2191 Par := Parent (N); 2192 while Present (Par) loop 2193 exit when Nkind (Par) = N_Assignment_Statement; 2194 2195 if Nkind (Par) = N_Component_Declaration then 2196 return; 2197 end if; 2198 2199 Par := Parent (Par); 2200 end loop; 2201 2202 if Present (Par) then 2203 Rewrite (N, 2204 Make_Attribute_Reference (Loc, 2205 Prefix => Make_Identifier (Loc, Name_uInit), 2206 Attribute_Name => Attribute_Name (N))); 2207 2208 Analyze_And_Resolve (N, Typ); 2209 end if; 2210 end if; 2211 end; 2212 2213 -- If the prefix of an Access attribute is a dereference of an 2214 -- access parameter (or a renaming of such a dereference, or a 2215 -- subcomponent of such a dereference) and the context is a 2216 -- general access type (including the type of an object or 2217 -- component with an access_definition, but not the anonymous 2218 -- type of an access parameter or access discriminant), then 2219 -- apply an accessibility check to the access parameter. We used 2220 -- to rewrite the access parameter as a type conversion, but that 2221 -- could only be done if the immediate prefix of the Access 2222 -- attribute was the dereference, and didn't handle cases where 2223 -- the attribute is applied to a subcomponent of the dereference, 2224 -- since there's generally no available, appropriate access type 2225 -- to convert to in that case. The attribute is passed as the 2226 -- point to insert the check, because the access parameter may 2227 -- come from a renaming, possibly in a different scope, and the 2228 -- check must be associated with the attribute itself. 2229 2230 elsif Id = Attribute_Access 2231 and then Nkind (Enc_Object) = N_Explicit_Dereference 2232 and then Is_Entity_Name (Prefix (Enc_Object)) 2233 and then (Ekind (Btyp) = E_General_Access_Type 2234 or else Is_Local_Anonymous_Access (Btyp)) 2235 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind 2236 and then Ekind (Etype (Entity (Prefix (Enc_Object)))) 2237 = E_Anonymous_Access_Type 2238 and then Present (Extra_Accessibility 2239 (Entity (Prefix (Enc_Object)))) 2240 then 2241 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N); 2242 2243 -- Ada 2005 (AI-251): If the designated type is an interface we 2244 -- add an implicit conversion to force the displacement of the 2245 -- pointer to reference the secondary dispatch table. 2246 2247 elsif Is_Interface (Btyp_DDT) 2248 and then (Comes_From_Source (N) 2249 or else Comes_From_Source (Ref_Object) 2250 or else (Nkind (Ref_Object) in N_Has_Chars 2251 and then Chars (Ref_Object) = Name_uInit)) 2252 then 2253 if Nkind (Ref_Object) /= N_Explicit_Dereference then 2254 2255 -- No implicit conversion required if types match, or if 2256 -- the prefix is the class_wide_type of the interface. In 2257 -- either case passing an object of the interface type has 2258 -- already set the pointer correctly. 2259 2260 if Btyp_DDT = Etype (Ref_Object) 2261 or else (Is_Class_Wide_Type (Etype (Ref_Object)) 2262 and then 2263 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object)) 2264 then 2265 null; 2266 2267 else 2268 Rewrite (Prefix (N), 2269 Convert_To (Btyp_DDT, 2270 New_Copy_Tree (Prefix (N)))); 2271 2272 Analyze_And_Resolve (Prefix (N), Btyp_DDT); 2273 end if; 2274 2275 -- When the object is an explicit dereference, convert the 2276 -- dereference's prefix. 2277 2278 else 2279 declare 2280 Obj_DDT : constant Entity_Id := 2281 Base_Type 2282 (Directly_Designated_Type 2283 (Etype (Prefix (Ref_Object)))); 2284 begin 2285 -- No implicit conversion required if designated types 2286 -- match. 2287 2288 if Obj_DDT /= Btyp_DDT 2289 and then not (Is_Class_Wide_Type (Obj_DDT) 2290 and then Etype (Obj_DDT) = Btyp_DDT) 2291 then 2292 Rewrite (N, 2293 Convert_To (Typ, 2294 New_Copy_Tree (Prefix (Ref_Object)))); 2295 Analyze_And_Resolve (N, Typ); 2296 end if; 2297 end; 2298 end if; 2299 end if; 2300 end Access_Cases; 2301 2302 -------------- 2303 -- Adjacent -- 2304 -------------- 2305 2306 -- Transforms 'Adjacent into a call to the floating-point attribute 2307 -- function Adjacent in Fat_xxx (where xxx is the root type) 2308 2309 when Attribute_Adjacent => 2310 Expand_Fpt_Attribute_RR (N); 2311 2312 ------------- 2313 -- Address -- 2314 ------------- 2315 2316 when Attribute_Address => Address : declare 2317 Task_Proc : Entity_Id; 2318 2319 function Is_Unnested_Component_Init (N : Node_Id) return Boolean; 2320 -- Returns True if N is being used to initialize a component of 2321 -- an activation record object where the component corresponds to 2322 -- the object denoted by the prefix of the attribute N. 2323 2324 function Is_Unnested_Component_Init (N : Node_Id) return Boolean is 2325 begin 2326 return Present (Parent (N)) 2327 and then Nkind (Parent (N)) = N_Assignment_Statement 2328 and then Is_Entity_Name (Pref) 2329 and then Present (Activation_Record_Component (Entity (Pref))) 2330 and then Nkind (Name (Parent (N))) = N_Selected_Component 2331 and then Entity (Selector_Name (Name (Parent (N)))) = 2332 Activation_Record_Component (Entity (Pref)); 2333 end Is_Unnested_Component_Init; 2334 2335 -- Start of processing for Address 2336 2337 begin 2338 -- If the prefix is a task or a task type, the useful address is that 2339 -- of the procedure for the task body, i.e. the actual program unit. 2340 -- We replace the original entity with that of the procedure. 2341 2342 if Is_Entity_Name (Pref) 2343 and then Is_Task_Type (Entity (Pref)) 2344 then 2345 Task_Proc := Next_Entity (Root_Type (Ptyp)); 2346 2347 while Present (Task_Proc) loop 2348 exit when Ekind (Task_Proc) = E_Procedure 2349 and then Etype (First_Formal (Task_Proc)) = 2350 Corresponding_Record_Type (Ptyp); 2351 Next_Entity (Task_Proc); 2352 end loop; 2353 2354 if Present (Task_Proc) then 2355 Set_Entity (Pref, Task_Proc); 2356 Set_Etype (Pref, Etype (Task_Proc)); 2357 end if; 2358 2359 -- Similarly, the address of a protected operation is the address 2360 -- of the corresponding protected body, regardless of the protected 2361 -- object from which it is selected. 2362 2363 elsif Nkind (Pref) = N_Selected_Component 2364 and then Is_Subprogram (Entity (Selector_Name (Pref))) 2365 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref)))) 2366 then 2367 Rewrite (Pref, 2368 New_Occurrence_Of ( 2369 External_Subprogram (Entity (Selector_Name (Pref))), Loc)); 2370 2371 elsif Nkind (Pref) = N_Explicit_Dereference 2372 and then Ekind (Ptyp) = E_Subprogram_Type 2373 and then Convention (Ptyp) = Convention_Protected 2374 then 2375 -- The prefix is be a dereference of an access_to_protected_ 2376 -- subprogram. The desired address is the second component of 2377 -- the record that represents the access. 2378 2379 declare 2380 Addr : constant Entity_Id := Etype (N); 2381 Ptr : constant Node_Id := Prefix (Pref); 2382 T : constant Entity_Id := 2383 Equivalent_Type (Base_Type (Etype (Ptr))); 2384 2385 begin 2386 Rewrite (N, 2387 Unchecked_Convert_To (Addr, 2388 Make_Selected_Component (Loc, 2389 Prefix => Unchecked_Convert_To (T, Ptr), 2390 Selector_Name => New_Occurrence_Of ( 2391 Next_Entity (First_Entity (T)), Loc)))); 2392 2393 Analyze_And_Resolve (N, Addr); 2394 end; 2395 2396 -- Ada 2005 (AI-251): Class-wide interface objects are always 2397 -- "displaced" to reference the tag associated with the interface 2398 -- type. In order to obtain the real address of such objects we 2399 -- generate a call to a run-time subprogram that returns the base 2400 -- address of the object. This call is not generated in cases where 2401 -- the attribute is being used to initialize a component of an 2402 -- activation record object where the component corresponds to 2403 -- prefix of the attribute (for back ends that require "unnesting" 2404 -- of nested subprograms), since the address needs to be assigned 2405 -- as-is to such components. 2406 2407 elsif Is_Class_Wide_Type (Ptyp) 2408 and then Is_Interface (Underlying_Type (Ptyp)) 2409 and then Tagged_Type_Expansion 2410 and then not (Nkind (Pref) in N_Has_Entity 2411 and then Is_Subprogram (Entity (Pref))) 2412 and then not Is_Unnested_Component_Init (N) 2413 then 2414 Rewrite (N, 2415 Make_Function_Call (Loc, 2416 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc), 2417 Parameter_Associations => New_List ( 2418 Relocate_Node (N)))); 2419 Analyze (N); 2420 return; 2421 end if; 2422 2423 -- Deal with packed array reference, other cases are handled by 2424 -- the back end. 2425 2426 if Involves_Packed_Array_Reference (Pref) then 2427 Expand_Packed_Address_Reference (N); 2428 end if; 2429 end Address; 2430 2431 --------------- 2432 -- Alignment -- 2433 --------------- 2434 2435 when Attribute_Alignment => Alignment : declare 2436 New_Node : Node_Id; 2437 2438 begin 2439 -- For class-wide types, X'Class'Alignment is transformed into a 2440 -- direct reference to the Alignment of the class type, so that the 2441 -- back end does not have to deal with the X'Class'Alignment 2442 -- reference. 2443 2444 if Is_Entity_Name (Pref) 2445 and then Is_Class_Wide_Type (Entity (Pref)) 2446 then 2447 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); 2448 return; 2449 2450 -- For x'Alignment applied to an object of a class wide type, 2451 -- transform X'Alignment into a call to the predefined primitive 2452 -- operation _Alignment applied to X. 2453 2454 elsif Is_Class_Wide_Type (Ptyp) then 2455 New_Node := 2456 Make_Attribute_Reference (Loc, 2457 Prefix => Pref, 2458 Attribute_Name => Name_Tag); 2459 2460 New_Node := Build_Get_Alignment (Loc, New_Node); 2461 2462 -- Case where the context is a specific integer type with which 2463 -- the original attribute was compatible. The function has a 2464 -- specific type as well, so to preserve the compatibility we 2465 -- must convert explicitly. 2466 2467 if Typ /= Standard_Integer then 2468 New_Node := Convert_To (Typ, New_Node); 2469 end if; 2470 2471 Rewrite (N, New_Node); 2472 Analyze_And_Resolve (N, Typ); 2473 return; 2474 2475 -- For all other cases, we just have to deal with the case of 2476 -- the fact that the result can be universal. 2477 2478 else 2479 Apply_Universal_Integer_Attribute_Checks (N); 2480 end if; 2481 end Alignment; 2482 2483 --------- 2484 -- Bit -- 2485 --------- 2486 2487 -- We compute this if a packed array reference was present, otherwise we 2488 -- leave the computation up to the back end. 2489 2490 when Attribute_Bit => 2491 if Involves_Packed_Array_Reference (Pref) then 2492 Expand_Packed_Bit_Reference (N); 2493 else 2494 Apply_Universal_Integer_Attribute_Checks (N); 2495 end if; 2496 2497 ------------------ 2498 -- Bit_Position -- 2499 ------------------ 2500 2501 -- We compute this if a component clause was present, otherwise we leave 2502 -- the computation up to the back end, since we don't know what layout 2503 -- will be chosen. 2504 2505 -- Note that the attribute can apply to a naked record component 2506 -- in generated code (i.e. the prefix is an identifier that 2507 -- references the component or discriminant entity). 2508 2509 when Attribute_Bit_Position => Bit_Position : declare 2510 CE : Entity_Id; 2511 2512 begin 2513 if Nkind (Pref) = N_Identifier then 2514 CE := Entity (Pref); 2515 else 2516 CE := Entity (Selector_Name (Pref)); 2517 end if; 2518 2519 if Known_Static_Component_Bit_Offset (CE) then 2520 Rewrite (N, 2521 Make_Integer_Literal (Loc, 2522 Intval => Component_Bit_Offset (CE))); 2523 Analyze_And_Resolve (N, Typ); 2524 2525 else 2526 Apply_Universal_Integer_Attribute_Checks (N); 2527 end if; 2528 end Bit_Position; 2529 2530 ------------------ 2531 -- Body_Version -- 2532 ------------------ 2533 2534 -- A reference to P'Body_Version or P'Version is expanded to 2535 2536 -- Vnn : Unsigned; 2537 -- pragma Import (C, Vnn, "uuuuT"); 2538 -- ... 2539 -- Get_Version_String (Vnn) 2540 2541 -- where uuuu is the unit name (dots replaced by double underscore) 2542 -- and T is B for the cases of Body_Version, or Version applied to a 2543 -- subprogram acting as its own spec, and S for Version applied to a 2544 -- subprogram spec or package. This sequence of code references the 2545 -- unsigned constant created in the main program by the binder. 2546 2547 -- A special exception occurs for Standard, where the string returned 2548 -- is a copy of the library string in gnatvsn.ads. 2549 2550 when Attribute_Body_Version 2551 | Attribute_Version 2552 => 2553 Version : declare 2554 E : constant Entity_Id := Make_Temporary (Loc, 'V'); 2555 Pent : Entity_Id; 2556 S : String_Id; 2557 2558 begin 2559 -- If not library unit, get to containing library unit 2560 2561 Pent := Entity (Pref); 2562 while Pent /= Standard_Standard 2563 and then Scope (Pent) /= Standard_Standard 2564 and then not Is_Child_Unit (Pent) 2565 loop 2566 Pent := Scope (Pent); 2567 end loop; 2568 2569 -- Special case Standard and Standard.ASCII 2570 2571 if Pent = Standard_Standard or else Pent = Standard_ASCII then 2572 Rewrite (N, 2573 Make_String_Literal (Loc, 2574 Strval => Verbose_Library_Version)); 2575 2576 -- All other cases 2577 2578 else 2579 -- Build required string constant 2580 2581 Get_Name_String (Get_Unit_Name (Pent)); 2582 2583 Start_String; 2584 for J in 1 .. Name_Len - 2 loop 2585 if Name_Buffer (J) = '.' then 2586 Store_String_Chars ("__"); 2587 else 2588 Store_String_Char (Get_Char_Code (Name_Buffer (J))); 2589 end if; 2590 end loop; 2591 2592 -- Case of subprogram acting as its own spec, always use body 2593 2594 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification 2595 and then Nkind (Parent (Declaration_Node (Pent))) = 2596 N_Subprogram_Body 2597 and then Acts_As_Spec (Parent (Declaration_Node (Pent))) 2598 then 2599 Store_String_Chars ("B"); 2600 2601 -- Case of no body present, always use spec 2602 2603 elsif not Unit_Requires_Body (Pent) then 2604 Store_String_Chars ("S"); 2605 2606 -- Otherwise use B for Body_Version, S for spec 2607 2608 elsif Id = Attribute_Body_Version then 2609 Store_String_Chars ("B"); 2610 else 2611 Store_String_Chars ("S"); 2612 end if; 2613 2614 S := End_String; 2615 Lib.Version_Referenced (S); 2616 2617 -- Insert the object declaration 2618 2619 Insert_Actions (N, New_List ( 2620 Make_Object_Declaration (Loc, 2621 Defining_Identifier => E, 2622 Object_Definition => 2623 New_Occurrence_Of (RTE (RE_Unsigned), Loc)))); 2624 2625 -- Set entity as imported with correct external name 2626 2627 Set_Is_Imported (E); 2628 Set_Interface_Name (E, Make_String_Literal (Loc, S)); 2629 2630 -- Set entity as internal to ensure proper Sprint output of its 2631 -- implicit importation. 2632 2633 Set_Is_Internal (E); 2634 2635 -- And now rewrite original reference 2636 2637 Rewrite (N, 2638 Make_Function_Call (Loc, 2639 Name => 2640 New_Occurrence_Of (RTE (RE_Get_Version_String), Loc), 2641 Parameter_Associations => New_List ( 2642 New_Occurrence_Of (E, Loc)))); 2643 end if; 2644 2645 Analyze_And_Resolve (N, RTE (RE_Version_String)); 2646 end Version; 2647 2648 ------------- 2649 -- Ceiling -- 2650 ------------- 2651 2652 -- Transforms 'Ceiling into a call to the floating-point attribute 2653 -- function Ceiling in Fat_xxx (where xxx is the root type) 2654 2655 when Attribute_Ceiling => 2656 Expand_Fpt_Attribute_R (N); 2657 2658 -------------- 2659 -- Callable -- 2660 -------------- 2661 2662 -- Transforms 'Callable attribute into a call to the Callable function 2663 2664 when Attribute_Callable => 2665 2666 -- We have an object of a task interface class-wide type as a prefix 2667 -- to Callable. Generate: 2668 -- callable (Task_Id (Pref._disp_get_task_id)); 2669 2670 if Ada_Version >= Ada_2005 2671 and then Ekind (Ptyp) = E_Class_Wide_Type 2672 and then Is_Interface (Ptyp) 2673 and then Is_Task_Interface (Ptyp) 2674 then 2675 Rewrite (N, 2676 Make_Function_Call (Loc, 2677 Name => 2678 New_Occurrence_Of (RTE (RE_Callable), Loc), 2679 Parameter_Associations => New_List ( 2680 Make_Unchecked_Type_Conversion (Loc, 2681 Subtype_Mark => 2682 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 2683 Expression => Build_Disp_Get_Task_Id_Call (Pref))))); 2684 2685 else 2686 Rewrite (N, Build_Call_With_Task (Pref, RTE (RE_Callable))); 2687 end if; 2688 2689 Analyze_And_Resolve (N, Standard_Boolean); 2690 2691 ------------ 2692 -- Caller -- 2693 ------------ 2694 2695 -- Transforms 'Caller attribute into a call to either the 2696 -- Task_Entry_Caller or the Protected_Entry_Caller function. 2697 2698 when Attribute_Caller => Caller : declare 2699 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id); 2700 Ent : constant Entity_Id := Entity (Pref); 2701 Conctype : constant Entity_Id := Scope (Ent); 2702 Nest_Depth : Integer := 0; 2703 Name : Node_Id; 2704 S : Entity_Id; 2705 2706 begin 2707 -- Protected case 2708 2709 if Is_Protected_Type (Conctype) then 2710 case Corresponding_Runtime_Package (Conctype) is 2711 when System_Tasking_Protected_Objects_Entries => 2712 Name := 2713 New_Occurrence_Of 2714 (RTE (RE_Protected_Entry_Caller), Loc); 2715 2716 when System_Tasking_Protected_Objects_Single_Entry => 2717 Name := 2718 New_Occurrence_Of 2719 (RTE (RE_Protected_Single_Entry_Caller), Loc); 2720 2721 when others => 2722 raise Program_Error; 2723 end case; 2724 2725 Rewrite (N, 2726 Unchecked_Convert_To (Id_Kind, 2727 Make_Function_Call (Loc, 2728 Name => Name, 2729 Parameter_Associations => New_List ( 2730 New_Occurrence_Of 2731 (Find_Protection_Object (Current_Scope), Loc))))); 2732 2733 -- Task case 2734 2735 else 2736 -- Determine the nesting depth of the E'Caller attribute, that 2737 -- is, how many accept statements are nested within the accept 2738 -- statement for E at the point of E'Caller. The runtime uses 2739 -- this depth to find the specified entry call. 2740 2741 for J in reverse 0 .. Scope_Stack.Last loop 2742 S := Scope_Stack.Table (J).Entity; 2743 2744 -- We should not reach the scope of the entry, as it should 2745 -- already have been checked in Sem_Attr that this attribute 2746 -- reference is within a matching accept statement. 2747 2748 pragma Assert (S /= Conctype); 2749 2750 if S = Ent then 2751 exit; 2752 2753 elsif Is_Entry (S) then 2754 Nest_Depth := Nest_Depth + 1; 2755 end if; 2756 end loop; 2757 2758 Rewrite (N, 2759 Unchecked_Convert_To (Id_Kind, 2760 Make_Function_Call (Loc, 2761 Name => 2762 New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc), 2763 Parameter_Associations => New_List ( 2764 Make_Integer_Literal (Loc, 2765 Intval => Int (Nest_Depth)))))); 2766 end if; 2767 2768 Analyze_And_Resolve (N, Id_Kind); 2769 end Caller; 2770 2771 ------------- 2772 -- Compose -- 2773 ------------- 2774 2775 -- Transforms 'Compose into a call to the floating-point attribute 2776 -- function Compose in Fat_xxx (where xxx is the root type) 2777 2778 -- Note: we strictly should have special code here to deal with the 2779 -- case of absurdly negative arguments (less than Integer'First) 2780 -- which will return a (signed) zero value, but it hardly seems 2781 -- worth the effort. Absurdly large positive arguments will raise 2782 -- constraint error which is fine. 2783 2784 when Attribute_Compose => 2785 Expand_Fpt_Attribute_RI (N); 2786 2787 ----------------- 2788 -- Constrained -- 2789 ----------------- 2790 2791 when Attribute_Constrained => Constrained : declare 2792 Formal_Ent : constant Entity_Id := Param_Entity (Pref); 2793 2794 -- Start of processing for Constrained 2795 2796 begin 2797 -- Reference to a parameter where the value is passed as an extra 2798 -- actual, corresponding to the extra formal referenced by the 2799 -- Extra_Constrained field of the corresponding formal. If this 2800 -- is an entry in-parameter, it is replaced by a constant renaming 2801 -- for which Extra_Constrained is never created. 2802 2803 if Present (Formal_Ent) 2804 and then Ekind (Formal_Ent) /= E_Constant 2805 and then Present (Extra_Constrained (Formal_Ent)) 2806 then 2807 Rewrite (N, 2808 New_Occurrence_Of 2809 (Extra_Constrained (Formal_Ent), Sloc (N))); 2810 2811 -- If the prefix is an access to object, the attribute applies to 2812 -- the designated object, so rewrite with an explicit dereference. 2813 2814 elsif Is_Access_Type (Etype (Pref)) 2815 and then 2816 (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref))) 2817 then 2818 Rewrite (Pref, 2819 Make_Explicit_Dereference (Loc, Relocate_Node (Pref))); 2820 Analyze_And_Resolve (N, Standard_Boolean); 2821 return; 2822 2823 -- For variables with a Extra_Constrained field, we use the 2824 -- corresponding entity. 2825 2826 elsif Nkind (Pref) = N_Identifier 2827 and then Ekind (Entity (Pref)) = E_Variable 2828 and then Present (Extra_Constrained (Entity (Pref))) 2829 then 2830 Rewrite (N, 2831 New_Occurrence_Of 2832 (Extra_Constrained (Entity (Pref)), Sloc (N))); 2833 2834 -- For all other cases, we can tell at compile time 2835 2836 else 2837 -- For access type, apply access check as needed 2838 2839 if Is_Entity_Name (Pref) 2840 and then not Is_Type (Entity (Pref)) 2841 and then Is_Access_Type (Ptyp) 2842 then 2843 Apply_Access_Check (N); 2844 end if; 2845 2846 Rewrite (N, 2847 New_Occurrence_Of 2848 (Boolean_Literals 2849 (Exp_Util.Attribute_Constrained_Static_Value 2850 (Pref)), Sloc (N))); 2851 end if; 2852 2853 Analyze_And_Resolve (N, Standard_Boolean); 2854 end Constrained; 2855 2856 --------------- 2857 -- Copy_Sign -- 2858 --------------- 2859 2860 -- Transforms 'Copy_Sign into a call to the floating-point attribute 2861 -- function Copy_Sign in Fat_xxx (where xxx is the root type) 2862 2863 when Attribute_Copy_Sign => 2864 Expand_Fpt_Attribute_RR (N); 2865 2866 ----------- 2867 -- Count -- 2868 ----------- 2869 2870 -- Transforms 'Count attribute into a call to the Count function 2871 2872 when Attribute_Count => Count : declare 2873 Call : Node_Id; 2874 Conctyp : Entity_Id; 2875 Entnam : Node_Id; 2876 Entry_Id : Entity_Id; 2877 Index : Node_Id; 2878 Name : Node_Id; 2879 2880 begin 2881 -- If the prefix is a member of an entry family, retrieve both 2882 -- entry name and index. For a simple entry there is no index. 2883 2884 if Nkind (Pref) = N_Indexed_Component then 2885 Entnam := Prefix (Pref); 2886 Index := First (Expressions (Pref)); 2887 else 2888 Entnam := Pref; 2889 Index := Empty; 2890 end if; 2891 2892 Entry_Id := Entity (Entnam); 2893 2894 -- Find the concurrent type in which this attribute is referenced 2895 -- (there had better be one). 2896 2897 Conctyp := Current_Scope; 2898 while not Is_Concurrent_Type (Conctyp) loop 2899 Conctyp := Scope (Conctyp); 2900 end loop; 2901 2902 -- Protected case 2903 2904 if Is_Protected_Type (Conctyp) then 2905 2906 -- No need to transform 'Count into a function call if the current 2907 -- scope has been eliminated. In this case such transformation is 2908 -- also not viable because the enclosing protected object is not 2909 -- available. 2910 2911 if Is_Eliminated (Current_Scope) then 2912 return; 2913 end if; 2914 2915 case Corresponding_Runtime_Package (Conctyp) is 2916 when System_Tasking_Protected_Objects_Entries => 2917 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc); 2918 2919 Call := 2920 Make_Function_Call (Loc, 2921 Name => Name, 2922 Parameter_Associations => New_List ( 2923 New_Occurrence_Of 2924 (Find_Protection_Object (Current_Scope), Loc), 2925 Entry_Index_Expression 2926 (Loc, Entry_Id, Index, Scope (Entry_Id)))); 2927 2928 when System_Tasking_Protected_Objects_Single_Entry => 2929 Name := 2930 New_Occurrence_Of (RTE (RE_Protected_Count_Entry), Loc); 2931 2932 Call := 2933 Make_Function_Call (Loc, 2934 Name => Name, 2935 Parameter_Associations => New_List ( 2936 New_Occurrence_Of 2937 (Find_Protection_Object (Current_Scope), Loc))); 2938 2939 when others => 2940 raise Program_Error; 2941 end case; 2942 2943 -- Task case 2944 2945 else 2946 Call := 2947 Make_Function_Call (Loc, 2948 Name => New_Occurrence_Of (RTE (RE_Task_Count), Loc), 2949 Parameter_Associations => New_List ( 2950 Entry_Index_Expression (Loc, 2951 Entry_Id, Index, Scope (Entry_Id)))); 2952 end if; 2953 2954 -- The call returns type Natural but the context is universal integer 2955 -- so any integer type is allowed. The attribute was already resolved 2956 -- so its Etype is the required result type. If the base type of the 2957 -- context type is other than Standard.Integer we put in a conversion 2958 -- to the required type. This can be a normal typed conversion since 2959 -- both input and output types of the conversion are integer types 2960 2961 if Base_Type (Typ) /= Base_Type (Standard_Integer) then 2962 Rewrite (N, Convert_To (Typ, Call)); 2963 else 2964 Rewrite (N, Call); 2965 end if; 2966 2967 Analyze_And_Resolve (N, Typ); 2968 end Count; 2969 2970 --------------------- 2971 -- Descriptor_Size -- 2972 --------------------- 2973 2974 when Attribute_Descriptor_Size => 2975 2976 -- Attribute Descriptor_Size is handled by the back end when applied 2977 -- to an unconstrained array type. 2978 2979 if Is_Array_Type (Ptyp) 2980 and then not Is_Constrained (Ptyp) 2981 then 2982 Apply_Universal_Integer_Attribute_Checks (N); 2983 2984 -- For any other type, the descriptor size is 0 because there is no 2985 -- actual descriptor, but the result is not formally static. 2986 2987 else 2988 Rewrite (N, Make_Integer_Literal (Loc, 0)); 2989 Analyze (N); 2990 Set_Is_Static_Expression (N, False); 2991 end if; 2992 2993 --------------- 2994 -- Elab_Body -- 2995 --------------- 2996 2997 -- This processing is shared by Elab_Spec 2998 2999 -- What we do is to insert the following declarations 3000 3001 -- procedure tnn; 3002 -- pragma Import (C, enn, "name___elabb/s"); 3003 3004 -- and then the Elab_Body/Spec attribute is replaced by a reference 3005 -- to this defining identifier. 3006 3007 when Attribute_Elab_Body 3008 | Attribute_Elab_Spec 3009 => 3010 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil 3011 -- back-end knows how to handle these attributes directly. 3012 3013 if CodePeer_Mode then 3014 return; 3015 end if; 3016 3017 Elab_Body : declare 3018 Ent : constant Entity_Id := Make_Temporary (Loc, 'E'); 3019 Str : String_Id; 3020 Lang : Node_Id; 3021 3022 procedure Make_Elab_String (Nod : Node_Id); 3023 -- Given Nod, an identifier, or a selected component, put the 3024 -- image into the current string literal, with double underline 3025 -- between components. 3026 3027 ---------------------- 3028 -- Make_Elab_String -- 3029 ---------------------- 3030 3031 procedure Make_Elab_String (Nod : Node_Id) is 3032 begin 3033 if Nkind (Nod) = N_Selected_Component then 3034 Make_Elab_String (Prefix (Nod)); 3035 Store_String_Char ('_'); 3036 Store_String_Char ('_'); 3037 Get_Name_String (Chars (Selector_Name (Nod))); 3038 3039 else 3040 pragma Assert (Nkind (Nod) = N_Identifier); 3041 Get_Name_String (Chars (Nod)); 3042 end if; 3043 3044 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 3045 end Make_Elab_String; 3046 3047 -- Start of processing for Elab_Body/Elab_Spec 3048 3049 begin 3050 -- First we need to prepare the string literal for the name of 3051 -- the elaboration routine to be referenced. 3052 3053 Start_String; 3054 Make_Elab_String (Pref); 3055 Store_String_Chars ("___elab"); 3056 Lang := Make_Identifier (Loc, Name_C); 3057 3058 if Id = Attribute_Elab_Body then 3059 Store_String_Char ('b'); 3060 else 3061 Store_String_Char ('s'); 3062 end if; 3063 3064 Str := End_String; 3065 3066 Insert_Actions (N, New_List ( 3067 Make_Subprogram_Declaration (Loc, 3068 Specification => 3069 Make_Procedure_Specification (Loc, 3070 Defining_Unit_Name => Ent)), 3071 3072 Make_Pragma (Loc, 3073 Chars => Name_Import, 3074 Pragma_Argument_Associations => New_List ( 3075 Make_Pragma_Argument_Association (Loc, Expression => Lang), 3076 3077 Make_Pragma_Argument_Association (Loc, 3078 Expression => Make_Identifier (Loc, Chars (Ent))), 3079 3080 Make_Pragma_Argument_Association (Loc, 3081 Expression => Make_String_Literal (Loc, Str)))))); 3082 3083 Set_Entity (N, Ent); 3084 Rewrite (N, New_Occurrence_Of (Ent, Loc)); 3085 end Elab_Body; 3086 3087 -------------------- 3088 -- Elab_Subp_Body -- 3089 -------------------- 3090 3091 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle 3092 -- this attribute directly, and if we are not in CodePeer mode it is 3093 -- entirely ignored ??? 3094 3095 when Attribute_Elab_Subp_Body => 3096 return; 3097 3098 ---------------- 3099 -- Elaborated -- 3100 ---------------- 3101 3102 -- Elaborated is always True for preelaborated units, predefined units, 3103 -- pure units and units which have Elaborate_Body pragmas. These units 3104 -- have no elaboration entity. 3105 3106 -- Note: The Elaborated attribute is never passed to the back end 3107 3108 when Attribute_Elaborated => Elaborated : declare 3109 Elab_Id : constant Entity_Id := Elaboration_Entity (Entity (Pref)); 3110 3111 begin 3112 if Present (Elab_Id) then 3113 Rewrite (N, 3114 Make_Op_Ne (Loc, 3115 Left_Opnd => New_Occurrence_Of (Elab_Id, Loc), 3116 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))); 3117 3118 Analyze_And_Resolve (N, Typ); 3119 else 3120 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 3121 end if; 3122 end Elaborated; 3123 3124 -------------- 3125 -- Enum_Rep -- 3126 -------------- 3127 3128 when Attribute_Enum_Rep => Enum_Rep : declare 3129 Expr : Node_Id; 3130 3131 begin 3132 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or 3133 -- X'Enum_Rep. 3134 3135 if Is_Non_Empty_List (Exprs) then 3136 Expr := First (Exprs); 3137 else 3138 Expr := Pref; 3139 end if; 3140 3141 -- If the expression is an enumeration literal, it is replaced by the 3142 -- literal value. 3143 3144 if Nkind (Expr) in N_Has_Entity 3145 and then Ekind (Entity (Expr)) = E_Enumeration_Literal 3146 then 3147 Rewrite (N, 3148 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Expr)))); 3149 3150 -- If this is a renaming of a literal, recover the representation 3151 -- of the original. If it renames an expression there is nothing to 3152 -- fold. 3153 3154 elsif Nkind (Expr) in N_Has_Entity 3155 and then Ekind (Entity (Expr)) = E_Constant 3156 and then Present (Renamed_Object (Entity (Expr))) 3157 and then Is_Entity_Name (Renamed_Object (Entity (Expr))) 3158 and then Ekind (Entity (Renamed_Object (Entity (Expr)))) = 3159 E_Enumeration_Literal 3160 then 3161 Rewrite (N, 3162 Make_Integer_Literal (Loc, 3163 Enumeration_Rep (Entity (Renamed_Object (Entity (Expr)))))); 3164 3165 -- If not constant-folded above, Enum_Type'Enum_Rep (X) or 3166 -- X'Enum_Rep expands to 3167 3168 -- target-type (X) 3169 3170 -- This is simply a direct conversion from the enumeration type to 3171 -- the target integer type, which is treated by the back end as a 3172 -- normal integer conversion, treating the enumeration type as an 3173 -- integer, which is exactly what we want. We set Conversion_OK to 3174 -- make sure that the analyzer does not complain about what otherwise 3175 -- might be an illegal conversion. 3176 3177 else 3178 Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr))); 3179 end if; 3180 3181 Set_Etype (N, Typ); 3182 Analyze_And_Resolve (N, Typ); 3183 end Enum_Rep; 3184 3185 -------------- 3186 -- Enum_Val -- 3187 -------------- 3188 3189 when Attribute_Enum_Val => Enum_Val : declare 3190 Expr : Node_Id; 3191 Btyp : constant Entity_Id := Base_Type (Ptyp); 3192 3193 begin 3194 -- X'Enum_Val (Y) expands to 3195 3196 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg] 3197 -- X!(Y); 3198 3199 Expr := Unchecked_Convert_To (Ptyp, First (Exprs)); 3200 3201 -- Ensure that the expression is not truncated since the "bad" bits 3202 -- are desired. 3203 3204 if Nkind (Expr) = N_Unchecked_Type_Conversion then 3205 Set_No_Truncation (Expr); 3206 end if; 3207 3208 Insert_Action (N, 3209 Make_Raise_Constraint_Error (Loc, 3210 Condition => 3211 Make_Op_Eq (Loc, 3212 Left_Opnd => 3213 Make_Function_Call (Loc, 3214 Name => 3215 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc), 3216 Parameter_Associations => New_List ( 3217 Relocate_Node (Duplicate_Subexpr (Expr)), 3218 New_Occurrence_Of (Standard_False, Loc))), 3219 3220 Right_Opnd => Make_Integer_Literal (Loc, -1)), 3221 Reason => CE_Range_Check_Failed)); 3222 3223 Rewrite (N, Expr); 3224 Analyze_And_Resolve (N, Ptyp); 3225 end Enum_Val; 3226 3227 -------------- 3228 -- Exponent -- 3229 -------------- 3230 3231 -- Transforms 'Exponent into a call to the floating-point attribute 3232 -- function Exponent in Fat_xxx (where xxx is the root type) 3233 3234 when Attribute_Exponent => 3235 Expand_Fpt_Attribute_R (N); 3236 3237 ------------------ 3238 -- External_Tag -- 3239 ------------------ 3240 3241 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag) 3242 3243 when Attribute_External_Tag => 3244 Rewrite (N, 3245 Make_Function_Call (Loc, 3246 Name => 3247 New_Occurrence_Of (RTE (RE_External_Tag), Loc), 3248 Parameter_Associations => New_List ( 3249 Make_Attribute_Reference (Loc, 3250 Attribute_Name => Name_Tag, 3251 Prefix => Prefix (N))))); 3252 3253 Analyze_And_Resolve (N, Standard_String); 3254 3255 ----------------------- 3256 -- Finalization_Size -- 3257 ----------------------- 3258 3259 when Attribute_Finalization_Size => Finalization_Size : declare 3260 function Calculate_Header_Size return Node_Id; 3261 -- Generate a runtime call to calculate the size of the hidden header 3262 -- along with any added padding which would precede a heap-allocated 3263 -- object of the prefix type. 3264 3265 --------------------------- 3266 -- Calculate_Header_Size -- 3267 --------------------------- 3268 3269 function Calculate_Header_Size return Node_Id is 3270 begin 3271 -- Generate: 3272 -- Universal_Integer 3273 -- (Header_Size_With_Padding (Pref'Alignment)) 3274 3275 return 3276 Convert_To (Universal_Integer, 3277 Make_Function_Call (Loc, 3278 Name => 3279 New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc), 3280 3281 Parameter_Associations => New_List ( 3282 Make_Attribute_Reference (Loc, 3283 Prefix => New_Copy_Tree (Pref), 3284 Attribute_Name => Name_Alignment)))); 3285 end Calculate_Header_Size; 3286 3287 -- Local variables 3288 3289 Size : Entity_Id; 3290 3291 -- Start of Finalization_Size 3292 3293 begin 3294 -- An object of a class-wide type first requires a runtime check to 3295 -- determine whether it is actually controlled or not. Depending on 3296 -- the outcome of this check, the Finalization_Size of the object 3297 -- may be zero or some positive value. 3298 -- 3299 -- In this scenario, Pref'Finalization_Size is expanded into 3300 -- 3301 -- Size : Integer := 0; 3302 -- 3303 -- if Needs_Finalization (Pref'Tag) then 3304 -- Size := 3305 -- Universal_Integer 3306 -- (Header_Size_With_Padding (Pref'Alignment)); 3307 -- end if; 3308 -- 3309 -- and the attribute reference is replaced with a reference to Size. 3310 3311 if Is_Class_Wide_Type (Ptyp) then 3312 Size := Make_Temporary (Loc, 'S'); 3313 3314 Insert_Actions (N, New_List ( 3315 3316 -- Generate: 3317 -- Size : Integer := 0; 3318 3319 Make_Object_Declaration (Loc, 3320 Defining_Identifier => Size, 3321 Object_Definition => 3322 New_Occurrence_Of (Standard_Integer, Loc), 3323 Expression => Make_Integer_Literal (Loc, 0)), 3324 3325 -- Generate: 3326 -- if Needs_Finalization (Pref'Tag) then 3327 -- Size := 3328 -- Universal_Integer 3329 -- (Header_Size_With_Padding (Pref'Alignment)); 3330 -- end if; 3331 3332 Make_If_Statement (Loc, 3333 Condition => 3334 Make_Function_Call (Loc, 3335 Name => 3336 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc), 3337 3338 Parameter_Associations => New_List ( 3339 Make_Attribute_Reference (Loc, 3340 Prefix => New_Copy_Tree (Pref), 3341 Attribute_Name => Name_Tag))), 3342 3343 Then_Statements => New_List ( 3344 Make_Assignment_Statement (Loc, 3345 Name => New_Occurrence_Of (Size, Loc), 3346 Expression => Calculate_Header_Size))))); 3347 3348 Rewrite (N, New_Occurrence_Of (Size, Loc)); 3349 3350 -- The prefix is known to be controlled at compile time. Calculate 3351 -- Finalization_Size by calling function Header_Size_With_Padding. 3352 3353 elsif Needs_Finalization (Ptyp) then 3354 Rewrite (N, Calculate_Header_Size); 3355 3356 -- The prefix is not an object with controlled parts, so its 3357 -- Finalization_Size is zero. 3358 3359 else 3360 Rewrite (N, Make_Integer_Literal (Loc, 0)); 3361 end if; 3362 3363 -- Due to cases where the entity type of the attribute is already 3364 -- resolved the rewritten N must get re-resolved to its appropriate 3365 -- type. 3366 3367 Analyze_And_Resolve (N, Typ); 3368 end Finalization_Size; 3369 3370 ----------- 3371 -- First -- 3372 ----------- 3373 3374 when Attribute_First => 3375 3376 -- If the prefix type is a constrained packed array type which 3377 -- already has a Packed_Array_Impl_Type representation defined, then 3378 -- replace this attribute with a direct reference to 'First of the 3379 -- appropriate index subtype (since otherwise the back end will try 3380 -- to give us the value of 'First for this implementation type). 3381 3382 if Is_Constrained_Packed_Array (Ptyp) then 3383 Rewrite (N, 3384 Make_Attribute_Reference (Loc, 3385 Attribute_Name => Name_First, 3386 Prefix => 3387 New_Occurrence_Of (Get_Index_Subtype (N), Loc))); 3388 Analyze_And_Resolve (N, Typ); 3389 3390 -- For access type, apply access check as needed 3391 3392 elsif Is_Access_Type (Ptyp) then 3393 Apply_Access_Check (N); 3394 3395 -- For scalar type, if low bound is a reference to an entity, just 3396 -- replace with a direct reference. Note that we can only have a 3397 -- reference to a constant entity at this stage, anything else would 3398 -- have already been rewritten. 3399 3400 elsif Is_Scalar_Type (Ptyp) then 3401 declare 3402 Lo : constant Node_Id := Type_Low_Bound (Ptyp); 3403 begin 3404 if Is_Entity_Name (Lo) then 3405 Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc)); 3406 end if; 3407 end; 3408 end if; 3409 3410 --------------- 3411 -- First_Bit -- 3412 --------------- 3413 3414 -- Compute this if component clause was present, otherwise we leave the 3415 -- computation to be completed in the back-end, since we don't know what 3416 -- layout will be chosen. 3417 3418 when Attribute_First_Bit => First_Bit_Attr : declare 3419 CE : constant Entity_Id := Entity (Selector_Name (Pref)); 3420 3421 begin 3422 -- In Ada 2005 (or later) if we have the non-default bit order, then 3423 -- we return the original value as given in the component clause 3424 -- (RM 2005 13.5.2(3/2)). 3425 3426 if Present (Component_Clause (CE)) 3427 and then Ada_Version >= Ada_2005 3428 and then Reverse_Bit_Order (Scope (CE)) 3429 then 3430 Rewrite (N, 3431 Make_Integer_Literal (Loc, 3432 Intval => Expr_Value (First_Bit (Component_Clause (CE))))); 3433 Analyze_And_Resolve (N, Typ); 3434 3435 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order), 3436 -- rewrite with normalized value if we know it statically. 3437 3438 elsif Known_Static_Component_Bit_Offset (CE) then 3439 Rewrite (N, 3440 Make_Integer_Literal (Loc, 3441 Component_Bit_Offset (CE) mod System_Storage_Unit)); 3442 Analyze_And_Resolve (N, Typ); 3443 3444 -- Otherwise left to back end, just do universal integer checks 3445 3446 else 3447 Apply_Universal_Integer_Attribute_Checks (N); 3448 end if; 3449 end First_Bit_Attr; 3450 3451 -------------------------------- 3452 -- Fixed_Value, Integer_Value -- 3453 -------------------------------- 3454 3455 -- We transform 3456 3457 -- fixtype'Fixed_Value (integer-value) 3458 -- inttype'Integer_Value (fixed-value) 3459 3460 -- into 3461 3462 -- fixtype (integer-value) 3463 -- inttype (fixed-value) 3464 3465 -- respectively. 3466 3467 -- We set Conversion_OK on the conversion because we do not want it 3468 -- to go through the fixed-point conversion circuits. 3469 3470 when Attribute_Fixed_Value 3471 | Attribute_Integer_Value 3472 => 3473 Rewrite (N, OK_Convert_To (Entity (Pref), First (Exprs))); 3474 3475 -- Note that it might appear that a properly analyzed unchecked 3476 -- conversion would be just fine here, but that's not the case, 3477 -- since the full range checks performed by the following calls 3478 -- are critical. 3479 3480 Apply_Type_Conversion_Checks (N); 3481 3482 -- Note that Apply_Type_Conversion_Checks only deals with the 3483 -- overflow checks on conversions involving fixed-point types 3484 -- so we must apply range checks manually on them and expand. 3485 3486 Apply_Scalar_Range_Check 3487 (Expression (N), Etype (N), Fixed_Int => True); 3488 3489 Set_Analyzed (N); 3490 Expand (N); 3491 3492 ----------- 3493 -- Floor -- 3494 ----------- 3495 3496 -- Transforms 'Floor into a call to the floating-point attribute 3497 -- function Floor in Fat_xxx (where xxx is the root type) 3498 3499 when Attribute_Floor => 3500 Expand_Fpt_Attribute_R (N); 3501 3502 ---------- 3503 -- Fore -- 3504 ---------- 3505 3506 -- For the fixed-point type Typ: 3507 3508 -- Typ'Fore 3509 3510 -- expands into 3511 3512 -- Result_Type (System.Fore (Universal_Real (Type'First)), 3513 -- Universal_Real (Type'Last)) 3514 3515 -- Note that we know that the type is a nonstatic subtype, or Fore would 3516 -- have itself been computed dynamically in Eval_Attribute. 3517 3518 when Attribute_Fore => 3519 Rewrite (N, 3520 Convert_To (Typ, 3521 Make_Function_Call (Loc, 3522 Name => 3523 New_Occurrence_Of (RTE (RE_Fore), Loc), 3524 3525 Parameter_Associations => New_List ( 3526 Convert_To (Universal_Real, 3527 Make_Attribute_Reference (Loc, 3528 Prefix => New_Occurrence_Of (Ptyp, Loc), 3529 Attribute_Name => Name_First)), 3530 3531 Convert_To (Universal_Real, 3532 Make_Attribute_Reference (Loc, 3533 Prefix => New_Occurrence_Of (Ptyp, Loc), 3534 Attribute_Name => Name_Last)))))); 3535 3536 Analyze_And_Resolve (N, Typ); 3537 3538 -------------- 3539 -- Fraction -- 3540 -------------- 3541 3542 -- Transforms 'Fraction into a call to the floating-point attribute 3543 -- function Fraction in Fat_xxx (where xxx is the root type) 3544 3545 when Attribute_Fraction => 3546 Expand_Fpt_Attribute_R (N); 3547 3548 -------------- 3549 -- From_Any -- 3550 -------------- 3551 3552 when Attribute_From_Any => From_Any : declare 3553 P_Type : constant Entity_Id := Etype (Pref); 3554 Decls : constant List_Id := New_List; 3555 3556 begin 3557 Rewrite (N, 3558 Build_From_Any_Call (P_Type, 3559 Relocate_Node (First (Exprs)), 3560 Decls)); 3561 Insert_Actions (N, Decls); 3562 Analyze_And_Resolve (N, P_Type); 3563 end From_Any; 3564 3565 ---------------------- 3566 -- Has_Same_Storage -- 3567 ---------------------- 3568 3569 when Attribute_Has_Same_Storage => Has_Same_Storage : declare 3570 Loc : constant Source_Ptr := Sloc (N); 3571 3572 X : constant Node_Id := Prefix (N); 3573 Y : constant Node_Id := First (Expressions (N)); 3574 -- The arguments 3575 3576 X_Addr : Node_Id; 3577 Y_Addr : Node_Id; 3578 -- Rhe expressions for their addresses 3579 3580 X_Size : Node_Id; 3581 Y_Size : Node_Id; 3582 -- Rhe expressions for their sizes 3583 3584 begin 3585 -- The attribute is expanded as: 3586 3587 -- (X'address = Y'address) 3588 -- and then (X'Size = Y'Size) 3589 3590 -- If both arguments have the same Etype the second conjunct can be 3591 -- omitted. 3592 3593 X_Addr := 3594 Make_Attribute_Reference (Loc, 3595 Attribute_Name => Name_Address, 3596 Prefix => New_Copy_Tree (X)); 3597 3598 Y_Addr := 3599 Make_Attribute_Reference (Loc, 3600 Attribute_Name => Name_Address, 3601 Prefix => New_Copy_Tree (Y)); 3602 3603 X_Size := 3604 Make_Attribute_Reference (Loc, 3605 Attribute_Name => Name_Size, 3606 Prefix => New_Copy_Tree (X)); 3607 3608 Y_Size := 3609 Make_Attribute_Reference (Loc, 3610 Attribute_Name => Name_Size, 3611 Prefix => New_Copy_Tree (Y)); 3612 3613 if Etype (X) = Etype (Y) then 3614 Rewrite (N, 3615 Make_Op_Eq (Loc, 3616 Left_Opnd => X_Addr, 3617 Right_Opnd => Y_Addr)); 3618 else 3619 Rewrite (N, 3620 Make_Op_And (Loc, 3621 Left_Opnd => 3622 Make_Op_Eq (Loc, 3623 Left_Opnd => X_Addr, 3624 Right_Opnd => Y_Addr), 3625 Right_Opnd => 3626 Make_Op_Eq (Loc, 3627 Left_Opnd => X_Size, 3628 Right_Opnd => Y_Size))); 3629 end if; 3630 3631 Analyze_And_Resolve (N, Standard_Boolean); 3632 end Has_Same_Storage; 3633 3634 -------------- 3635 -- Identity -- 3636 -------------- 3637 3638 -- For an exception returns a reference to the exception data: 3639 -- Exception_Id!(Prefix'Reference) 3640 3641 -- For a task it returns a reference to the _task_id component of 3642 -- corresponding record: 3643 3644 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined 3645 3646 -- in Ada.Task_Identification 3647 3648 when Attribute_Identity => Identity : declare 3649 Id_Kind : Entity_Id; 3650 3651 begin 3652 if Ptyp = Standard_Exception_Type then 3653 Id_Kind := RTE (RE_Exception_Id); 3654 3655 if Present (Renamed_Object (Entity (Pref))) then 3656 Set_Entity (Pref, Renamed_Object (Entity (Pref))); 3657 end if; 3658 3659 Rewrite (N, 3660 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref))); 3661 else 3662 Id_Kind := RTE (RO_AT_Task_Id); 3663 3664 -- If the prefix is a task interface, the Task_Id is obtained 3665 -- dynamically through a dispatching call, as for other task 3666 -- attributes applied to interfaces. 3667 3668 if Ada_Version >= Ada_2005 3669 and then Ekind (Ptyp) = E_Class_Wide_Type 3670 and then Is_Interface (Ptyp) 3671 and then Is_Task_Interface (Ptyp) 3672 then 3673 Rewrite (N, 3674 Unchecked_Convert_To 3675 (Id_Kind, Build_Disp_Get_Task_Id_Call (Pref))); 3676 3677 else 3678 Rewrite (N, 3679 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref))); 3680 end if; 3681 end if; 3682 3683 Analyze_And_Resolve (N, Id_Kind); 3684 end Identity; 3685 3686 ----------- 3687 -- Image -- 3688 ----------- 3689 3690 -- Image attribute is handled in separate unit Exp_Imgv 3691 3692 when Attribute_Image => 3693 3694 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil 3695 -- back-end knows how to handle this attribute directly. 3696 3697 if CodePeer_Mode then 3698 return; 3699 end if; 3700 3701 Expand_Image_Attribute (N); 3702 3703 --------- 3704 -- Img -- 3705 --------- 3706 3707 -- X'Img is expanded to typ'Image (X), where typ is the type of X 3708 3709 when Attribute_Img => 3710 Expand_Image_Attribute (N); 3711 3712 ----------- 3713 -- Input -- 3714 ----------- 3715 3716 when Attribute_Input => Input : declare 3717 P_Type : constant Entity_Id := Entity (Pref); 3718 B_Type : constant Entity_Id := Base_Type (P_Type); 3719 U_Type : constant Entity_Id := Underlying_Type (P_Type); 3720 Strm : constant Node_Id := First (Exprs); 3721 Fname : Entity_Id; 3722 Decl : Node_Id; 3723 Call : Node_Id; 3724 Prag : Node_Id; 3725 Arg2 : Node_Id; 3726 Rfunc : Node_Id; 3727 3728 Cntrl : Node_Id := Empty; 3729 -- Value for controlling argument in call. Always Empty except in 3730 -- the dispatching (class-wide type) case, where it is a reference 3731 -- to the dummy object initialized to the right internal tag. 3732 3733 procedure Freeze_Stream_Subprogram (F : Entity_Id); 3734 -- The expansion of the attribute reference may generate a call to 3735 -- a user-defined stream subprogram that is frozen by the call. This 3736 -- can lead to access-before-elaboration problem if the reference 3737 -- appears in an object declaration and the subprogram body has not 3738 -- been seen. The freezing of the subprogram requires special code 3739 -- because it appears in an expanded context where expressions do 3740 -- not freeze their constituents. 3741 3742 ------------------------------ 3743 -- Freeze_Stream_Subprogram -- 3744 ------------------------------ 3745 3746 procedure Freeze_Stream_Subprogram (F : Entity_Id) is 3747 Decl : constant Node_Id := Unit_Declaration_Node (F); 3748 Bod : Node_Id; 3749 3750 begin 3751 -- If this is user-defined subprogram, the corresponding 3752 -- stream function appears as a renaming-as-body, and the 3753 -- user subprogram must be retrieved by tree traversal. 3754 3755 if Present (Decl) 3756 and then Nkind (Decl) = N_Subprogram_Declaration 3757 and then Present (Corresponding_Body (Decl)) 3758 then 3759 Bod := Corresponding_Body (Decl); 3760 3761 if Nkind (Unit_Declaration_Node (Bod)) = 3762 N_Subprogram_Renaming_Declaration 3763 then 3764 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod)))); 3765 end if; 3766 end if; 3767 end Freeze_Stream_Subprogram; 3768 3769 -- Start of processing for Input 3770 3771 begin 3772 -- If no underlying type, we have an error that will be diagnosed 3773 -- elsewhere, so here we just completely ignore the expansion. 3774 3775 if No (U_Type) then 3776 return; 3777 end if; 3778 3779 -- Stream operations can appear in user code even if the restriction 3780 -- No_Streams is active (for example, when instantiating a predefined 3781 -- container). In that case rewrite the attribute as a Raise to 3782 -- prevent any run-time use. 3783 3784 if Restriction_Active (No_Streams) then 3785 Rewrite (N, 3786 Make_Raise_Program_Error (Sloc (N), 3787 Reason => PE_Stream_Operation_Not_Allowed)); 3788 Set_Etype (N, B_Type); 3789 return; 3790 end if; 3791 3792 -- If there is a TSS for Input, just call it 3793 3794 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input); 3795 3796 if Present (Fname) then 3797 null; 3798 3799 else 3800 -- If there is a Stream_Convert pragma, use it, we rewrite 3801 3802 -- sourcetyp'Input (stream) 3803 3804 -- as 3805 3806 -- sourcetyp (streamread (strmtyp'Input (stream))); 3807 3808 -- where streamread is the given Read function that converts an 3809 -- argument of type strmtyp to type sourcetyp or a type from which 3810 -- it is derived (extra conversion required for the derived case). 3811 3812 Prag := Get_Stream_Convert_Pragma (P_Type); 3813 3814 if Present (Prag) then 3815 Arg2 := Next (First (Pragma_Argument_Associations (Prag))); 3816 Rfunc := Entity (Expression (Arg2)); 3817 3818 Rewrite (N, 3819 Convert_To (B_Type, 3820 Make_Function_Call (Loc, 3821 Name => New_Occurrence_Of (Rfunc, Loc), 3822 Parameter_Associations => New_List ( 3823 Make_Attribute_Reference (Loc, 3824 Prefix => 3825 New_Occurrence_Of 3826 (Etype (First_Formal (Rfunc)), Loc), 3827 Attribute_Name => Name_Input, 3828 Expressions => Exprs))))); 3829 3830 Analyze_And_Resolve (N, B_Type); 3831 return; 3832 3833 -- Elementary types 3834 3835 elsif Is_Elementary_Type (U_Type) then 3836 3837 -- A special case arises if we have a defined _Read routine, 3838 -- since in this case we are required to call this routine. 3839 3840 declare 3841 Typ : Entity_Id := P_Type; 3842 begin 3843 if Present (Full_View (Typ)) then 3844 Typ := Full_View (Typ); 3845 end if; 3846 3847 if Present (TSS (Base_Type (Typ), TSS_Stream_Read)) then 3848 Build_Record_Or_Elementary_Input_Function 3849 (Loc, Typ, Decl, Fname, Use_Underlying => False); 3850 Insert_Action (N, Decl); 3851 3852 -- For normal cases, we call the I_xxx routine directly 3853 3854 else 3855 Rewrite (N, Build_Elementary_Input_Call (N)); 3856 Analyze_And_Resolve (N, P_Type); 3857 return; 3858 end if; 3859 end; 3860 3861 -- Array type case 3862 3863 elsif Is_Array_Type (U_Type) then 3864 Build_Array_Input_Function (Loc, U_Type, Decl, Fname); 3865 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 3866 3867 -- Dispatching case with class-wide type 3868 3869 elsif Is_Class_Wide_Type (P_Type) then 3870 3871 -- No need to do anything else compiling under restriction 3872 -- No_Dispatching_Calls. During the semantic analysis we 3873 -- already notified such violation. 3874 3875 if Restriction_Active (No_Dispatching_Calls) then 3876 return; 3877 end if; 3878 3879 declare 3880 Rtyp : constant Entity_Id := Root_Type (P_Type); 3881 3882 Expr : Node_Id; -- call to Descendant_Tag 3883 Get_Tag : Node_Id; -- expression to read the 'Tag 3884 3885 begin 3886 -- Read the internal tag (RM 13.13.2(34)) and use it to 3887 -- initialize a dummy tag value. We used to unconditionally 3888 -- generate: 3889 -- 3890 -- Descendant_Tag (String'Input (Strm), P_Type); 3891 -- 3892 -- which turns into a call to String_Input_Blk_IO. However, 3893 -- if the input is malformed, that could try to read an 3894 -- enormous String, causing chaos. So instead we call 3895 -- String_Input_Tag, which does the same thing as 3896 -- String_Input_Blk_IO, except that if the String is 3897 -- absurdly long, it raises an exception. 3898 -- 3899 -- However, if the No_Stream_Optimizations restriction 3900 -- is active, we disable this unnecessary attempt at 3901 -- robustness; we really need to read the string 3902 -- character-by-character. 3903 -- 3904 -- This value is used only to provide a controlling 3905 -- argument for the eventual _Input call. Descendant_Tag is 3906 -- called rather than Internal_Tag to ensure that we have a 3907 -- tag for a type that is descended from the prefix type and 3908 -- declared at the same accessibility level (the exception 3909 -- Tag_Error will be raised otherwise). The level check is 3910 -- required for Ada 2005 because tagged types can be 3911 -- extended in nested scopes (AI-344). 3912 3913 -- Note: we used to generate an explicit declaration of a 3914 -- constant Ada.Tags.Tag object, and use an occurrence of 3915 -- this constant in Cntrl, but this caused a secondary stack 3916 -- leak. 3917 3918 if Restriction_Active (No_Stream_Optimizations) then 3919 Get_Tag := 3920 Make_Attribute_Reference (Loc, 3921 Prefix => 3922 New_Occurrence_Of (Standard_String, Loc), 3923 Attribute_Name => Name_Input, 3924 Expressions => New_List ( 3925 Relocate_Node (Duplicate_Subexpr (Strm)))); 3926 else 3927 Get_Tag := 3928 Make_Function_Call (Loc, 3929 Name => 3930 New_Occurrence_Of 3931 (RTE (RE_String_Input_Tag), Loc), 3932 Parameter_Associations => New_List ( 3933 Relocate_Node (Duplicate_Subexpr (Strm)))); 3934 end if; 3935 3936 Expr := 3937 Make_Function_Call (Loc, 3938 Name => 3939 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), 3940 Parameter_Associations => New_List ( 3941 Get_Tag, 3942 Make_Attribute_Reference (Loc, 3943 Prefix => New_Occurrence_Of (P_Type, Loc), 3944 Attribute_Name => Name_Tag))); 3945 3946 Set_Etype (Expr, RTE (RE_Tag)); 3947 3948 -- Now we need to get the entity for the call, and construct 3949 -- a function call node, where we preset a reference to Dnn 3950 -- as the controlling argument (doing an unchecked convert 3951 -- to the class-wide tagged type to make it look like a real 3952 -- tagged object). 3953 3954 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input); 3955 Cntrl := Unchecked_Convert_To (P_Type, Expr); 3956 Set_Etype (Cntrl, P_Type); 3957 Set_Parent (Cntrl, N); 3958 end; 3959 3960 -- For tagged types, use the primitive Input function 3961 3962 elsif Is_Tagged_Type (U_Type) then 3963 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input); 3964 3965 -- All other record type cases, including protected records. The 3966 -- latter only arise for expander generated code for handling 3967 -- shared passive partition access. 3968 3969 else 3970 pragma Assert 3971 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 3972 3973 -- Ada 2005 (AI-216): Program_Error is raised executing default 3974 -- implementation of the Input attribute of an unchecked union 3975 -- type if the type lacks default discriminant values. 3976 3977 if Is_Unchecked_Union (Base_Type (U_Type)) 3978 and then No (Discriminant_Constraint (U_Type)) 3979 then 3980 Insert_Action (N, 3981 Make_Raise_Program_Error (Loc, 3982 Reason => PE_Unchecked_Union_Restriction)); 3983 3984 return; 3985 end if; 3986 3987 -- Build the type's Input function, passing the subtype rather 3988 -- than its base type, because checks are needed in the case of 3989 -- constrained discriminants (see Ada 2012 AI05-0192). 3990 3991 Build_Record_Or_Elementary_Input_Function 3992 (Loc, U_Type, Decl, Fname); 3993 Insert_Action (N, Decl); 3994 3995 if Nkind (Parent (N)) = N_Object_Declaration 3996 and then Is_Record_Type (U_Type) 3997 then 3998 -- The stream function may contain calls to user-defined 3999 -- Read procedures for individual components. 4000 4001 declare 4002 Comp : Entity_Id; 4003 Func : Entity_Id; 4004 4005 begin 4006 Comp := First_Component (U_Type); 4007 while Present (Comp) loop 4008 Func := 4009 Find_Stream_Subprogram 4010 (Etype (Comp), TSS_Stream_Read); 4011 4012 if Present (Func) then 4013 Freeze_Stream_Subprogram (Func); 4014 end if; 4015 4016 Next_Component (Comp); 4017 end loop; 4018 end; 4019 end if; 4020 end if; 4021 end if; 4022 4023 -- If we fall through, Fname is the function to be called. The result 4024 -- is obtained by calling the appropriate function, then converting 4025 -- the result. The conversion does a subtype check. 4026 4027 Call := 4028 Make_Function_Call (Loc, 4029 Name => New_Occurrence_Of (Fname, Loc), 4030 Parameter_Associations => New_List ( 4031 Relocate_Node (Strm))); 4032 4033 Set_Controlling_Argument (Call, Cntrl); 4034 Rewrite (N, Unchecked_Convert_To (P_Type, Call)); 4035 Analyze_And_Resolve (N, P_Type); 4036 4037 if Nkind (Parent (N)) = N_Object_Declaration then 4038 Freeze_Stream_Subprogram (Fname); 4039 end if; 4040 end Input; 4041 4042 ------------------- 4043 -- Invalid_Value -- 4044 ------------------- 4045 4046 when Attribute_Invalid_Value => 4047 Rewrite (N, Get_Simple_Init_Val (Ptyp, N)); 4048 4049 -- The value produced may be a conversion of a literal, which must be 4050 -- resolved to establish its proper type. 4051 4052 Analyze_And_Resolve (N); 4053 4054 ---------- 4055 -- Last -- 4056 ---------- 4057 4058 when Attribute_Last => 4059 4060 -- If the prefix type is a constrained packed array type which 4061 -- already has a Packed_Array_Impl_Type representation defined, then 4062 -- replace this attribute with a direct reference to 'Last of the 4063 -- appropriate index subtype (since otherwise the back end will try 4064 -- to give us the value of 'Last for this implementation type). 4065 4066 if Is_Constrained_Packed_Array (Ptyp) then 4067 Rewrite (N, 4068 Make_Attribute_Reference (Loc, 4069 Attribute_Name => Name_Last, 4070 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc))); 4071 Analyze_And_Resolve (N, Typ); 4072 4073 -- For access type, apply access check as needed 4074 4075 elsif Is_Access_Type (Ptyp) then 4076 Apply_Access_Check (N); 4077 4078 -- For scalar type, if low bound is a reference to an entity, just 4079 -- replace with a direct reference. Note that we can only have a 4080 -- reference to a constant entity at this stage, anything else would 4081 -- have already been rewritten. 4082 4083 elsif Is_Scalar_Type (Ptyp) then 4084 declare 4085 Hi : constant Node_Id := Type_High_Bound (Ptyp); 4086 begin 4087 if Is_Entity_Name (Hi) then 4088 Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc)); 4089 end if; 4090 end; 4091 end if; 4092 4093 -------------- 4094 -- Last_Bit -- 4095 -------------- 4096 4097 -- We compute this if a component clause was present, otherwise we leave 4098 -- the computation up to the back end, since we don't know what layout 4099 -- will be chosen. 4100 4101 when Attribute_Last_Bit => Last_Bit_Attr : declare 4102 CE : constant Entity_Id := Entity (Selector_Name (Pref)); 4103 4104 begin 4105 -- In Ada 2005 (or later) if we have the non-default bit order, then 4106 -- we return the original value as given in the component clause 4107 -- (RM 2005 13.5.2(3/2)). 4108 4109 if Present (Component_Clause (CE)) 4110 and then Ada_Version >= Ada_2005 4111 and then Reverse_Bit_Order (Scope (CE)) 4112 then 4113 Rewrite (N, 4114 Make_Integer_Literal (Loc, 4115 Intval => Expr_Value (Last_Bit (Component_Clause (CE))))); 4116 Analyze_And_Resolve (N, Typ); 4117 4118 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order), 4119 -- rewrite with normalized value if we know it statically. 4120 4121 elsif Known_Static_Component_Bit_Offset (CE) 4122 and then Known_Static_Esize (CE) 4123 then 4124 Rewrite (N, 4125 Make_Integer_Literal (Loc, 4126 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit) 4127 + Esize (CE) - 1)); 4128 Analyze_And_Resolve (N, Typ); 4129 4130 -- Otherwise leave to back end, just apply universal integer checks 4131 4132 else 4133 Apply_Universal_Integer_Attribute_Checks (N); 4134 end if; 4135 end Last_Bit_Attr; 4136 4137 ------------------ 4138 -- Leading_Part -- 4139 ------------------ 4140 4141 -- Transforms 'Leading_Part into a call to the floating-point attribute 4142 -- function Leading_Part in Fat_xxx (where xxx is the root type) 4143 4144 -- Note: strictly, we should generate special case code to deal with 4145 -- absurdly large positive arguments (greater than Integer'Last), which 4146 -- result in returning the first argument unchanged, but it hardly seems 4147 -- worth the effort. We raise constraint error for absurdly negative 4148 -- arguments which is fine. 4149 4150 when Attribute_Leading_Part => 4151 Expand_Fpt_Attribute_RI (N); 4152 4153 ------------ 4154 -- Length -- 4155 ------------ 4156 4157 when Attribute_Length => Length : declare 4158 Ityp : Entity_Id; 4159 Xnum : Uint; 4160 4161 begin 4162 -- Processing for packed array types 4163 4164 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then 4165 Ityp := Get_Index_Subtype (N); 4166 4167 -- If the index type, Ityp, is an enumeration type with holes, 4168 -- then we calculate X'Length explicitly using 4169 4170 -- Typ'Max 4171 -- (0, Ityp'Pos (X'Last (N)) - 4172 -- Ityp'Pos (X'First (N)) + 1); 4173 4174 -- Since the bounds in the template are the representation values 4175 -- and the back end would get the wrong value. 4176 4177 if Is_Enumeration_Type (Ityp) 4178 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp))) 4179 then 4180 if No (Exprs) then 4181 Xnum := Uint_1; 4182 else 4183 Xnum := Expr_Value (First (Expressions (N))); 4184 end if; 4185 4186 Rewrite (N, 4187 Make_Attribute_Reference (Loc, 4188 Prefix => New_Occurrence_Of (Typ, Loc), 4189 Attribute_Name => Name_Max, 4190 Expressions => New_List 4191 (Make_Integer_Literal (Loc, 0), 4192 4193 Make_Op_Add (Loc, 4194 Left_Opnd => 4195 Make_Op_Subtract (Loc, 4196 Left_Opnd => 4197 Make_Attribute_Reference (Loc, 4198 Prefix => New_Occurrence_Of (Ityp, Loc), 4199 Attribute_Name => Name_Pos, 4200 4201 Expressions => New_List ( 4202 Make_Attribute_Reference (Loc, 4203 Prefix => Duplicate_Subexpr (Pref), 4204 Attribute_Name => Name_Last, 4205 Expressions => New_List ( 4206 Make_Integer_Literal (Loc, Xnum))))), 4207 4208 Right_Opnd => 4209 Make_Attribute_Reference (Loc, 4210 Prefix => New_Occurrence_Of (Ityp, Loc), 4211 Attribute_Name => Name_Pos, 4212 4213 Expressions => New_List ( 4214 Make_Attribute_Reference (Loc, 4215 Prefix => 4216 Duplicate_Subexpr_No_Checks (Pref), 4217 Attribute_Name => Name_First, 4218 Expressions => New_List ( 4219 Make_Integer_Literal (Loc, Xnum)))))), 4220 4221 Right_Opnd => Make_Integer_Literal (Loc, 1))))); 4222 4223 Analyze_And_Resolve (N, Typ, Suppress => All_Checks); 4224 return; 4225 4226 -- If the prefix type is a constrained packed array type which 4227 -- already has a Packed_Array_Impl_Type representation defined, 4228 -- then replace this attribute with a reference to 'Range_Length 4229 -- of the appropriate index subtype (since otherwise the 4230 -- back end will try to give us the value of 'Length for 4231 -- this implementation type).s 4232 4233 elsif Is_Constrained (Ptyp) then 4234 Rewrite (N, 4235 Make_Attribute_Reference (Loc, 4236 Attribute_Name => Name_Range_Length, 4237 Prefix => New_Occurrence_Of (Ityp, Loc))); 4238 Analyze_And_Resolve (N, Typ); 4239 end if; 4240 4241 -- Access type case 4242 4243 elsif Is_Access_Type (Ptyp) then 4244 Apply_Access_Check (N); 4245 4246 -- If the designated type is a packed array type, then we convert 4247 -- the reference to: 4248 4249 -- typ'Max (0, 1 + 4250 -- xtyp'Pos (Pref'Last (Expr)) - 4251 -- xtyp'Pos (Pref'First (Expr))); 4252 4253 -- This is a bit complex, but it is the easiest thing to do that 4254 -- works in all cases including enum types with holes xtyp here 4255 -- is the appropriate index type. 4256 4257 declare 4258 Dtyp : constant Entity_Id := Designated_Type (Ptyp); 4259 Xtyp : Entity_Id; 4260 4261 begin 4262 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then 4263 Xtyp := Get_Index_Subtype (N); 4264 4265 Rewrite (N, 4266 Make_Attribute_Reference (Loc, 4267 Prefix => New_Occurrence_Of (Typ, Loc), 4268 Attribute_Name => Name_Max, 4269 Expressions => New_List ( 4270 Make_Integer_Literal (Loc, 0), 4271 4272 Make_Op_Add (Loc, 4273 Make_Integer_Literal (Loc, 1), 4274 Make_Op_Subtract (Loc, 4275 Left_Opnd => 4276 Make_Attribute_Reference (Loc, 4277 Prefix => New_Occurrence_Of (Xtyp, Loc), 4278 Attribute_Name => Name_Pos, 4279 Expressions => New_List ( 4280 Make_Attribute_Reference (Loc, 4281 Prefix => Duplicate_Subexpr (Pref), 4282 Attribute_Name => Name_Last, 4283 Expressions => 4284 New_Copy_List (Exprs)))), 4285 4286 Right_Opnd => 4287 Make_Attribute_Reference (Loc, 4288 Prefix => New_Occurrence_Of (Xtyp, Loc), 4289 Attribute_Name => Name_Pos, 4290 Expressions => New_List ( 4291 Make_Attribute_Reference (Loc, 4292 Prefix => 4293 Duplicate_Subexpr_No_Checks (Pref), 4294 Attribute_Name => Name_First, 4295 Expressions => 4296 New_Copy_List (Exprs))))))))); 4297 4298 Analyze_And_Resolve (N, Typ); 4299 end if; 4300 end; 4301 4302 -- Otherwise leave it to the back end 4303 4304 else 4305 Apply_Universal_Integer_Attribute_Checks (N); 4306 end if; 4307 end Length; 4308 4309 -- Attribute Loop_Entry is replaced with a reference to a constant value 4310 -- which captures the prefix at the entry point of the related loop. The 4311 -- loop itself may be transformed into a conditional block. 4312 4313 when Attribute_Loop_Entry => 4314 Expand_Loop_Entry_Attribute (N); 4315 4316 ------------- 4317 -- Machine -- 4318 ------------- 4319 4320 -- Transforms 'Machine into a call to the floating-point attribute 4321 -- function Machine in Fat_xxx (where xxx is the root type). 4322 -- Expansion is avoided for cases the back end can handle directly. 4323 4324 when Attribute_Machine => 4325 if not Is_Inline_Floating_Point_Attribute (N) then 4326 Expand_Fpt_Attribute_R (N); 4327 end if; 4328 4329 ---------------------- 4330 -- Machine_Rounding -- 4331 ---------------------- 4332 4333 -- Transforms 'Machine_Rounding into a call to the floating-point 4334 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root 4335 -- type). Expansion is avoided for cases the back end can handle 4336 -- directly. 4337 4338 when Attribute_Machine_Rounding => 4339 if not Is_Inline_Floating_Point_Attribute (N) then 4340 Expand_Fpt_Attribute_R (N); 4341 end if; 4342 4343 ------------------ 4344 -- Machine_Size -- 4345 ------------------ 4346 4347 -- Machine_Size is equivalent to Object_Size, so transform it into 4348 -- Object_Size and that way the back end never sees Machine_Size. 4349 4350 when Attribute_Machine_Size => 4351 Rewrite (N, 4352 Make_Attribute_Reference (Loc, 4353 Prefix => Prefix (N), 4354 Attribute_Name => Name_Object_Size)); 4355 4356 Analyze_And_Resolve (N, Typ); 4357 4358 -------------- 4359 -- Mantissa -- 4360 -------------- 4361 4362 -- The only case that can get this far is the dynamic case of the old 4363 -- Ada 83 Mantissa attribute for the fixed-point case. For this case, 4364 -- we expand: 4365 4366 -- typ'Mantissa 4367 4368 -- into 4369 4370 -- ityp (System.Mantissa.Mantissa_Value 4371 -- (Integer'Integer_Value (typ'First), 4372 -- Integer'Integer_Value (typ'Last))); 4373 4374 when Attribute_Mantissa => 4375 Rewrite (N, 4376 Convert_To (Typ, 4377 Make_Function_Call (Loc, 4378 Name => 4379 New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc), 4380 4381 Parameter_Associations => New_List ( 4382 Make_Attribute_Reference (Loc, 4383 Prefix => New_Occurrence_Of (Standard_Integer, Loc), 4384 Attribute_Name => Name_Integer_Value, 4385 Expressions => New_List ( 4386 Make_Attribute_Reference (Loc, 4387 Prefix => New_Occurrence_Of (Ptyp, Loc), 4388 Attribute_Name => Name_First))), 4389 4390 Make_Attribute_Reference (Loc, 4391 Prefix => New_Occurrence_Of (Standard_Integer, Loc), 4392 Attribute_Name => Name_Integer_Value, 4393 Expressions => New_List ( 4394 Make_Attribute_Reference (Loc, 4395 Prefix => New_Occurrence_Of (Ptyp, Loc), 4396 Attribute_Name => Name_Last))))))); 4397 4398 Analyze_And_Resolve (N, Typ); 4399 4400 --------- 4401 -- Max -- 4402 --------- 4403 4404 when Attribute_Max => 4405 Expand_Min_Max_Attribute (N); 4406 4407 ---------------------------------- 4408 -- Max_Size_In_Storage_Elements -- 4409 ---------------------------------- 4410 4411 when Attribute_Max_Size_In_Storage_Elements => declare 4412 Typ : constant Entity_Id := Etype (N); 4413 Attr : Node_Id; 4414 4415 Conversion_Added : Boolean := False; 4416 -- A flag which tracks whether the original attribute has been 4417 -- wrapped inside a type conversion. 4418 4419 begin 4420 -- If the prefix is X'Class, we transform it into a direct reference 4421 -- to the class-wide type, because the back end must not see a 'Class 4422 -- reference. See also 'Size. 4423 4424 if Is_Entity_Name (Pref) 4425 and then Is_Class_Wide_Type (Entity (Pref)) 4426 then 4427 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); 4428 return; 4429 end if; 4430 4431 Apply_Universal_Integer_Attribute_Checks (N); 4432 4433 -- The universal integer check may sometimes add a type conversion, 4434 -- retrieve the original attribute reference from the expression. 4435 4436 Attr := N; 4437 4438 if Nkind (Attr) = N_Type_Conversion then 4439 Attr := Expression (Attr); 4440 Conversion_Added := True; 4441 end if; 4442 4443 pragma Assert (Nkind (Attr) = N_Attribute_Reference); 4444 4445 -- Heap-allocated controlled objects contain two extra pointers which 4446 -- are not part of the actual type. Transform the attribute reference 4447 -- into a runtime expression to add the size of the hidden header. 4448 4449 if Needs_Finalization (Ptyp) 4450 and then not Header_Size_Added (Attr) 4451 then 4452 Set_Header_Size_Added (Attr); 4453 4454 -- Generate: 4455 -- P'Max_Size_In_Storage_Elements + 4456 -- Universal_Integer 4457 -- (Header_Size_With_Padding (Ptyp'Alignment)) 4458 4459 Rewrite (Attr, 4460 Make_Op_Add (Loc, 4461 Left_Opnd => Relocate_Node (Attr), 4462 Right_Opnd => 4463 Convert_To (Universal_Integer, 4464 Make_Function_Call (Loc, 4465 Name => 4466 New_Occurrence_Of 4467 (RTE (RE_Header_Size_With_Padding), Loc), 4468 4469 Parameter_Associations => New_List ( 4470 Make_Attribute_Reference (Loc, 4471 Prefix => 4472 New_Occurrence_Of (Ptyp, Loc), 4473 Attribute_Name => Name_Alignment)))))); 4474 4475 -- Add a conversion to the target type 4476 4477 if not Conversion_Added then 4478 Rewrite (Attr, 4479 Make_Type_Conversion (Loc, 4480 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 4481 Expression => Relocate_Node (Attr))); 4482 end if; 4483 4484 Analyze (Attr); 4485 return; 4486 end if; 4487 end; 4488 4489 -------------------- 4490 -- Mechanism_Code -- 4491 -------------------- 4492 4493 when Attribute_Mechanism_Code => 4494 4495 -- We must replace the prefix in the renamed case 4496 4497 if Is_Entity_Name (Pref) 4498 and then Present (Alias (Entity (Pref))) 4499 then 4500 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref))); 4501 end if; 4502 4503 --------- 4504 -- Min -- 4505 --------- 4506 4507 when Attribute_Min => 4508 Expand_Min_Max_Attribute (N); 4509 4510 --------- 4511 -- Mod -- 4512 --------- 4513 4514 when Attribute_Mod => Mod_Case : declare 4515 Arg : constant Node_Id := Relocate_Node (First (Exprs)); 4516 Hi : constant Node_Id := Type_High_Bound (Etype (Arg)); 4517 Modv : constant Uint := Modulus (Btyp); 4518 4519 begin 4520 4521 -- This is not so simple. The issue is what type to use for the 4522 -- computation of the modular value. 4523 4524 -- The easy case is when the modulus value is within the bounds 4525 -- of the signed integer type of the argument. In this case we can 4526 -- just do the computation in that signed integer type, and then 4527 -- do an ordinary conversion to the target type. 4528 4529 if Modv <= Expr_Value (Hi) then 4530 Rewrite (N, 4531 Convert_To (Btyp, 4532 Make_Op_Mod (Loc, 4533 Left_Opnd => Arg, 4534 Right_Opnd => Make_Integer_Literal (Loc, Modv)))); 4535 4536 -- Here we know that the modulus is larger than type'Last of the 4537 -- integer type. There are two cases to consider: 4538 4539 -- a) The integer value is non-negative. In this case, it is 4540 -- returned as the result (since it is less than the modulus). 4541 4542 -- b) The integer value is negative. In this case, we know that the 4543 -- result is modulus + value, where the value might be as small as 4544 -- -modulus. The trouble is what type do we use to do the subtract. 4545 -- No type will do, since modulus can be as big as 2**64, and no 4546 -- integer type accommodates this value. Let's do bit of algebra 4547 4548 -- modulus + value 4549 -- = modulus - (-value) 4550 -- = (modulus - 1) - (-value - 1) 4551 4552 -- Now modulus - 1 is certainly in range of the modular type. 4553 -- -value is in the range 1 .. modulus, so -value -1 is in the 4554 -- range 0 .. modulus-1 which is in range of the modular type. 4555 -- Furthermore, (-value - 1) can be expressed as -(value + 1) 4556 -- which we can compute using the integer base type. 4557 4558 -- Once this is done we analyze the if expression without range 4559 -- checks, because we know everything is in range, and we want 4560 -- to prevent spurious warnings on either branch. 4561 4562 else 4563 Rewrite (N, 4564 Make_If_Expression (Loc, 4565 Expressions => New_List ( 4566 Make_Op_Ge (Loc, 4567 Left_Opnd => Duplicate_Subexpr (Arg), 4568 Right_Opnd => Make_Integer_Literal (Loc, 0)), 4569 4570 Convert_To (Btyp, 4571 Duplicate_Subexpr_No_Checks (Arg)), 4572 4573 Make_Op_Subtract (Loc, 4574 Left_Opnd => 4575 Make_Integer_Literal (Loc, 4576 Intval => Modv - 1), 4577 Right_Opnd => 4578 Convert_To (Btyp, 4579 Make_Op_Minus (Loc, 4580 Right_Opnd => 4581 Make_Op_Add (Loc, 4582 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg), 4583 Right_Opnd => 4584 Make_Integer_Literal (Loc, 4585 Intval => 1)))))))); 4586 4587 end if; 4588 4589 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks); 4590 end Mod_Case; 4591 4592 ----------- 4593 -- Model -- 4594 ----------- 4595 4596 -- Transforms 'Model into a call to the floating-point attribute 4597 -- function Model in Fat_xxx (where xxx is the root type). 4598 -- Expansion is avoided for cases the back end can handle directly. 4599 4600 when Attribute_Model => 4601 if not Is_Inline_Floating_Point_Attribute (N) then 4602 Expand_Fpt_Attribute_R (N); 4603 end if; 4604 4605 ----------------- 4606 -- Object_Size -- 4607 ----------------- 4608 4609 -- The processing for Object_Size shares the processing for Size 4610 4611 --------- 4612 -- Old -- 4613 --------- 4614 4615 when Attribute_Old => Old : declare 4616 Typ : constant Entity_Id := Etype (N); 4617 CW_Temp : Entity_Id; 4618 CW_Typ : Entity_Id; 4619 Ins_Nod : Node_Id; 4620 Subp : Node_Id; 4621 Temp : Entity_Id; 4622 4623 begin 4624 -- Generating C code we don't need to expand this attribute when 4625 -- we are analyzing the internally built nested postconditions 4626 -- procedure since it will be expanded inline (and later it will 4627 -- be removed by Expand_N_Subprogram_Body). It this expansion is 4628 -- performed in such case then the compiler generates unreferenced 4629 -- extra temporaries. 4630 4631 if Modify_Tree_For_C 4632 and then Chars (Current_Scope) = Name_uPostconditions 4633 then 4634 return; 4635 end if; 4636 4637 -- Climb the parent chain looking for subprogram _Postconditions 4638 4639 Subp := N; 4640 while Present (Subp) loop 4641 exit when Nkind (Subp) = N_Subprogram_Body 4642 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions; 4643 4644 -- If assertions are disabled, no need to create the declaration 4645 -- that preserves the value. The postcondition pragma in which 4646 -- 'Old appears will be checked or disabled according to the 4647 -- current policy in effect. 4648 4649 if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then 4650 return; 4651 end if; 4652 4653 Subp := Parent (Subp); 4654 end loop; 4655 4656 -- 'Old can only appear in a postcondition, the generated body of 4657 -- _Postconditions must be in the tree (or inlined if we are 4658 -- generating C code). 4659 4660 pragma Assert 4661 (Present (Subp) 4662 or else (Modify_Tree_For_C and then In_Inlined_Body)); 4663 4664 Temp := Make_Temporary (Loc, 'T', Pref); 4665 4666 -- Set the entity kind now in order to mark the temporary as a 4667 -- handler of attribute 'Old's prefix. 4668 4669 Set_Ekind (Temp, E_Constant); 4670 Set_Stores_Attribute_Old_Prefix (Temp); 4671 4672 -- Push the scope of the related subprogram where _Postcondition 4673 -- resides as this ensures that the object will be analyzed in the 4674 -- proper context. 4675 4676 if Present (Subp) then 4677 Push_Scope (Scope (Defining_Entity (Subp))); 4678 4679 -- No need to push the scope when generating C code since the 4680 -- _Postcondition procedure has been inlined. 4681 4682 else pragma Assert (Modify_Tree_For_C); 4683 pragma Assert (In_Inlined_Body); 4684 null; 4685 end if; 4686 4687 -- Locate the insertion place of the internal temporary that saves 4688 -- the 'Old value. 4689 4690 if Present (Subp) then 4691 Ins_Nod := Subp; 4692 4693 -- Generating C, the postcondition procedure has been inlined and the 4694 -- temporary is added before the first declaration of the enclosing 4695 -- subprogram. 4696 4697 else pragma Assert (Modify_Tree_For_C); 4698 Ins_Nod := N; 4699 while Nkind (Ins_Nod) /= N_Subprogram_Body loop 4700 Ins_Nod := Parent (Ins_Nod); 4701 end loop; 4702 4703 Ins_Nod := First (Declarations (Ins_Nod)); 4704 end if; 4705 4706 -- Preserve the tag of the prefix by offering a specific view of the 4707 -- class-wide version of the prefix. 4708 4709 if Is_Tagged_Type (Typ) then 4710 4711 -- Generate: 4712 -- CW_Temp : constant Typ'Class := Typ'Class (Pref); 4713 4714 CW_Temp := Make_Temporary (Loc, 'T'); 4715 CW_Typ := Class_Wide_Type (Typ); 4716 4717 Insert_Before_And_Analyze (Ins_Nod, 4718 Make_Object_Declaration (Loc, 4719 Defining_Identifier => CW_Temp, 4720 Constant_Present => True, 4721 Object_Definition => New_Occurrence_Of (CW_Typ, Loc), 4722 Expression => 4723 Convert_To (CW_Typ, Relocate_Node (Pref)))); 4724 4725 -- Generate: 4726 -- Temp : Typ renames Typ (CW_Temp); 4727 4728 Insert_Before_And_Analyze (Ins_Nod, 4729 Make_Object_Renaming_Declaration (Loc, 4730 Defining_Identifier => Temp, 4731 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 4732 Name => 4733 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); 4734 4735 -- Non-tagged case 4736 4737 else 4738 -- Generate: 4739 -- Temp : constant Typ := Pref; 4740 4741 Insert_Before_And_Analyze (Ins_Nod, 4742 Make_Object_Declaration (Loc, 4743 Defining_Identifier => Temp, 4744 Constant_Present => True, 4745 Object_Definition => New_Occurrence_Of (Typ, Loc), 4746 Expression => Relocate_Node (Pref))); 4747 end if; 4748 4749 if Present (Subp) then 4750 Pop_Scope; 4751 end if; 4752 4753 -- Ensure that the prefix of attribute 'Old is valid. The check must 4754 -- be inserted after the expansion of the attribute has taken place 4755 -- to reflect the new placement of the prefix. 4756 4757 if Validity_Checks_On and then Validity_Check_Operands then 4758 Ensure_Valid (Pref); 4759 end if; 4760 4761 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 4762 end Old; 4763 4764 ---------------------- 4765 -- Overlaps_Storage -- 4766 ---------------------- 4767 4768 when Attribute_Overlaps_Storage => Overlaps_Storage : declare 4769 Loc : constant Source_Ptr := Sloc (N); 4770 4771 X : constant Node_Id := Prefix (N); 4772 Y : constant Node_Id := First (Expressions (N)); 4773 -- The arguments 4774 4775 X_Addr, Y_Addr : Node_Id; 4776 -- the expressions for their integer addresses 4777 4778 X_Size, Y_Size : Node_Id; 4779 -- the expressions for their sizes 4780 4781 Cond : Node_Id; 4782 4783 begin 4784 -- Attribute expands into: 4785 4786 -- if X'Address < Y'address then 4787 -- (X'address + X'Size - 1) >= Y'address 4788 -- else 4789 -- (Y'address + Y'size - 1) >= X'Address 4790 -- end if; 4791 4792 -- with the proper address operations. We convert addresses to 4793 -- integer addresses to use predefined arithmetic. The size is 4794 -- expressed in storage units. We add copies of X_Addr and Y_Addr 4795 -- to prevent the appearance of the same node in two places in 4796 -- the tree. 4797 4798 X_Addr := 4799 Unchecked_Convert_To (RTE (RE_Integer_Address), 4800 Make_Attribute_Reference (Loc, 4801 Attribute_Name => Name_Address, 4802 Prefix => New_Copy_Tree (X))); 4803 4804 Y_Addr := 4805 Unchecked_Convert_To (RTE (RE_Integer_Address), 4806 Make_Attribute_Reference (Loc, 4807 Attribute_Name => Name_Address, 4808 Prefix => New_Copy_Tree (Y))); 4809 4810 X_Size := 4811 Make_Op_Divide (Loc, 4812 Left_Opnd => 4813 Make_Attribute_Reference (Loc, 4814 Attribute_Name => Name_Size, 4815 Prefix => New_Copy_Tree (X)), 4816 Right_Opnd => 4817 Make_Integer_Literal (Loc, System_Storage_Unit)); 4818 4819 Y_Size := 4820 Make_Op_Divide (Loc, 4821 Left_Opnd => 4822 Make_Attribute_Reference (Loc, 4823 Attribute_Name => Name_Size, 4824 Prefix => New_Copy_Tree (Y)), 4825 Right_Opnd => 4826 Make_Integer_Literal (Loc, System_Storage_Unit)); 4827 4828 Cond := 4829 Make_Op_Le (Loc, 4830 Left_Opnd => X_Addr, 4831 Right_Opnd => Y_Addr); 4832 4833 Rewrite (N, 4834 Make_If_Expression (Loc, New_List ( 4835 Cond, 4836 4837 Make_Op_Ge (Loc, 4838 Left_Opnd => 4839 Make_Op_Add (Loc, 4840 Left_Opnd => New_Copy_Tree (X_Addr), 4841 Right_Opnd => 4842 Make_Op_Subtract (Loc, 4843 Left_Opnd => X_Size, 4844 Right_Opnd => Make_Integer_Literal (Loc, 1))), 4845 Right_Opnd => Y_Addr), 4846 4847 Make_Op_Ge (Loc, 4848 Left_Opnd => 4849 Make_Op_Add (Loc, 4850 Left_Opnd => New_Copy_Tree (Y_Addr), 4851 Right_Opnd => 4852 Make_Op_Subtract (Loc, 4853 Left_Opnd => Y_Size, 4854 Right_Opnd => Make_Integer_Literal (Loc, 1))), 4855 Right_Opnd => X_Addr)))); 4856 4857 Analyze_And_Resolve (N, Standard_Boolean); 4858 end Overlaps_Storage; 4859 4860 ------------ 4861 -- Output -- 4862 ------------ 4863 4864 when Attribute_Output => Output : declare 4865 P_Type : constant Entity_Id := Entity (Pref); 4866 U_Type : constant Entity_Id := Underlying_Type (P_Type); 4867 Pname : Entity_Id; 4868 Decl : Node_Id; 4869 Prag : Node_Id; 4870 Arg3 : Node_Id; 4871 Wfunc : Node_Id; 4872 4873 begin 4874 -- If no underlying type, we have an error that will be diagnosed 4875 -- elsewhere, so here we just completely ignore the expansion. 4876 4877 if No (U_Type) then 4878 return; 4879 end if; 4880 4881 -- Stream operations can appear in user code even if the restriction 4882 -- No_Streams is active (for example, when instantiating a predefined 4883 -- container). In that case rewrite the attribute as a Raise to 4884 -- prevent any run-time use. 4885 4886 if Restriction_Active (No_Streams) then 4887 Rewrite (N, 4888 Make_Raise_Program_Error (Sloc (N), 4889 Reason => PE_Stream_Operation_Not_Allowed)); 4890 Set_Etype (N, Standard_Void_Type); 4891 return; 4892 end if; 4893 4894 -- If TSS for Output is present, just call it 4895 4896 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output); 4897 4898 if Present (Pname) then 4899 null; 4900 4901 else 4902 -- If there is a Stream_Convert pragma, use it, we rewrite 4903 4904 -- sourcetyp'Output (stream, Item) 4905 4906 -- as 4907 4908 -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); 4909 4910 -- where strmwrite is the given Write function that converts an 4911 -- argument of type sourcetyp or a type acctyp, from which it is 4912 -- derived to type strmtyp. The conversion to acttyp is required 4913 -- for the derived case. 4914 4915 Prag := Get_Stream_Convert_Pragma (P_Type); 4916 4917 if Present (Prag) then 4918 Arg3 := 4919 Next (Next (First (Pragma_Argument_Associations (Prag)))); 4920 Wfunc := Entity (Expression (Arg3)); 4921 4922 Rewrite (N, 4923 Make_Attribute_Reference (Loc, 4924 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), 4925 Attribute_Name => Name_Output, 4926 Expressions => New_List ( 4927 Relocate_Node (First (Exprs)), 4928 Make_Function_Call (Loc, 4929 Name => New_Occurrence_Of (Wfunc, Loc), 4930 Parameter_Associations => New_List ( 4931 OK_Convert_To (Etype (First_Formal (Wfunc)), 4932 Relocate_Node (Next (First (Exprs))))))))); 4933 4934 Analyze (N); 4935 return; 4936 4937 -- For elementary types, we call the W_xxx routine directly. Note 4938 -- that the effect of Write and Output is identical for the case 4939 -- of an elementary type (there are no discriminants or bounds). 4940 4941 elsif Is_Elementary_Type (U_Type) then 4942 4943 -- A special case arises if we have a defined _Write routine, 4944 -- since in this case we are required to call this routine. 4945 4946 declare 4947 Typ : Entity_Id := P_Type; 4948 begin 4949 if Present (Full_View (Typ)) then 4950 Typ := Full_View (Typ); 4951 end if; 4952 4953 if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then 4954 Build_Record_Or_Elementary_Output_Procedure 4955 (Loc, Typ, Decl, Pname); 4956 Insert_Action (N, Decl); 4957 4958 -- For normal cases, we call the W_xxx routine directly 4959 4960 else 4961 Rewrite (N, Build_Elementary_Write_Call (N)); 4962 Analyze (N); 4963 return; 4964 end if; 4965 end; 4966 4967 -- Array type case 4968 4969 elsif Is_Array_Type (U_Type) then 4970 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname); 4971 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 4972 4973 -- Class-wide case, first output external tag, then dispatch 4974 -- to the appropriate primitive Output function (RM 13.13.2(31)). 4975 4976 elsif Is_Class_Wide_Type (P_Type) then 4977 4978 -- No need to do anything else compiling under restriction 4979 -- No_Dispatching_Calls. During the semantic analysis we 4980 -- already notified such violation. 4981 4982 if Restriction_Active (No_Dispatching_Calls) then 4983 return; 4984 end if; 4985 4986 Tag_Write : declare 4987 Strm : constant Node_Id := First (Exprs); 4988 Item : constant Node_Id := Next (Strm); 4989 4990 begin 4991 -- Ada 2005 (AI-344): Check that the accessibility level 4992 -- of the type of the output object is not deeper than 4993 -- that of the attribute's prefix type. 4994 4995 -- if Get_Access_Level (Item'Tag) 4996 -- /= Get_Access_Level (P_Type'Tag) 4997 -- then 4998 -- raise Tag_Error; 4999 -- end if; 5000 5001 -- String'Output (Strm, External_Tag (Item'Tag)); 5002 5003 -- We cannot figure out a practical way to implement this 5004 -- accessibility check on virtual machines, so we omit it. 5005 5006 if Ada_Version >= Ada_2005 5007 and then Tagged_Type_Expansion 5008 then 5009 Insert_Action (N, 5010 Make_Implicit_If_Statement (N, 5011 Condition => 5012 Make_Op_Ne (Loc, 5013 Left_Opnd => 5014 Build_Get_Access_Level (Loc, 5015 Make_Attribute_Reference (Loc, 5016 Prefix => 5017 Relocate_Node ( 5018 Duplicate_Subexpr (Item, 5019 Name_Req => True)), 5020 Attribute_Name => Name_Tag)), 5021 5022 Right_Opnd => 5023 Make_Integer_Literal (Loc, 5024 Type_Access_Level (P_Type))), 5025 5026 Then_Statements => 5027 New_List (Make_Raise_Statement (Loc, 5028 New_Occurrence_Of ( 5029 RTE (RE_Tag_Error), Loc))))); 5030 end if; 5031 5032 Insert_Action (N, 5033 Make_Attribute_Reference (Loc, 5034 Prefix => New_Occurrence_Of (Standard_String, Loc), 5035 Attribute_Name => Name_Output, 5036 Expressions => New_List ( 5037 Relocate_Node (Duplicate_Subexpr (Strm)), 5038 Make_Function_Call (Loc, 5039 Name => 5040 New_Occurrence_Of (RTE (RE_External_Tag), Loc), 5041 Parameter_Associations => New_List ( 5042 Make_Attribute_Reference (Loc, 5043 Prefix => 5044 Relocate_Node 5045 (Duplicate_Subexpr (Item, Name_Req => True)), 5046 Attribute_Name => Name_Tag)))))); 5047 end Tag_Write; 5048 5049 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); 5050 5051 -- Tagged type case, use the primitive Output function 5052 5053 elsif Is_Tagged_Type (U_Type) then 5054 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); 5055 5056 -- All other record type cases, including protected records. 5057 -- The latter only arise for expander generated code for 5058 -- handling shared passive partition access. 5059 5060 else 5061 pragma Assert 5062 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 5063 5064 -- Ada 2005 (AI-216): Program_Error is raised when executing 5065 -- the default implementation of the Output attribute of an 5066 -- unchecked union type if the type lacks default discriminant 5067 -- values. 5068 5069 if Is_Unchecked_Union (Base_Type (U_Type)) 5070 and then No (Discriminant_Constraint (U_Type)) 5071 then 5072 Insert_Action (N, 5073 Make_Raise_Program_Error (Loc, 5074 Reason => PE_Unchecked_Union_Restriction)); 5075 5076 return; 5077 end if; 5078 5079 Build_Record_Or_Elementary_Output_Procedure 5080 (Loc, Base_Type (U_Type), Decl, Pname); 5081 Insert_Action (N, Decl); 5082 end if; 5083 end if; 5084 5085 -- If we fall through, Pname is the name of the procedure to call 5086 5087 Rewrite_Stream_Proc_Call (Pname); 5088 end Output; 5089 5090 --------- 5091 -- Pos -- 5092 --------- 5093 5094 -- For enumeration types with a standard representation, Pos is 5095 -- handled by the back end. 5096 5097 -- For enumeration types, with a non-standard representation we generate 5098 -- a call to the _Rep_To_Pos function created when the type was frozen. 5099 -- The call has the form 5100 5101 -- _rep_to_pos (expr, flag) 5102 5103 -- The parameter flag is True if range checks are enabled, causing 5104 -- Program_Error to be raised if the expression has an invalid 5105 -- representation, and False if range checks are suppressed. 5106 5107 -- For integer types, Pos is equivalent to a simple integer 5108 -- conversion and we rewrite it as such 5109 5110 when Attribute_Pos => Pos : declare 5111 Etyp : Entity_Id := Base_Type (Entity (Pref)); 5112 5113 begin 5114 -- Deal with zero/non-zero boolean values 5115 5116 if Is_Boolean_Type (Etyp) then 5117 Adjust_Condition (First (Exprs)); 5118 Etyp := Standard_Boolean; 5119 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc)); 5120 end if; 5121 5122 -- Case of enumeration type 5123 5124 if Is_Enumeration_Type (Etyp) then 5125 5126 -- Non-standard enumeration type (generate call) 5127 5128 if Present (Enum_Pos_To_Rep (Etyp)) then 5129 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc)); 5130 Rewrite (N, 5131 Convert_To (Typ, 5132 Make_Function_Call (Loc, 5133 Name => 5134 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc), 5135 Parameter_Associations => Exprs))); 5136 5137 Analyze_And_Resolve (N, Typ); 5138 5139 -- Standard enumeration type (do universal integer check) 5140 5141 else 5142 Apply_Universal_Integer_Attribute_Checks (N); 5143 end if; 5144 5145 -- Deal with integer types (replace by conversion) 5146 5147 elsif Is_Integer_Type (Etyp) then 5148 Rewrite (N, Convert_To (Typ, First (Exprs))); 5149 Analyze_And_Resolve (N, Typ); 5150 end if; 5151 5152 end Pos; 5153 5154 -------------- 5155 -- Position -- 5156 -------------- 5157 5158 -- We compute this if a component clause was present, otherwise we leave 5159 -- the computation up to the back end, since we don't know what layout 5160 -- will be chosen. 5161 5162 when Attribute_Position => Position_Attr : declare 5163 CE : constant Entity_Id := Entity (Selector_Name (Pref)); 5164 5165 begin 5166 if Present (Component_Clause (CE)) then 5167 5168 -- In Ada 2005 (or later) if we have the non-default bit order, 5169 -- then we return the original value as given in the component 5170 -- clause (RM 2005 13.5.2(2/2)). 5171 5172 if Ada_Version >= Ada_2005 5173 and then Reverse_Bit_Order (Scope (CE)) 5174 then 5175 Rewrite (N, 5176 Make_Integer_Literal (Loc, 5177 Intval => Expr_Value (Position (Component_Clause (CE))))); 5178 5179 -- Otherwise (Ada 83 or 95, or default bit order specified in 5180 -- later Ada version), return the normalized value. 5181 5182 else 5183 Rewrite (N, 5184 Make_Integer_Literal (Loc, 5185 Intval => Component_Bit_Offset (CE) / System_Storage_Unit)); 5186 end if; 5187 5188 Analyze_And_Resolve (N, Typ); 5189 5190 -- If back end is doing things, just apply universal integer checks 5191 5192 else 5193 Apply_Universal_Integer_Attribute_Checks (N); 5194 end if; 5195 end Position_Attr; 5196 5197 ---------- 5198 -- Pred -- 5199 ---------- 5200 5201 -- 1. Deal with enumeration types with holes. 5202 -- 2. For floating-point, generate call to attribute function. 5203 -- 3. For other cases, deal with constraint checking. 5204 5205 when Attribute_Pred => Pred : declare 5206 Etyp : constant Entity_Id := Base_Type (Ptyp); 5207 5208 begin 5209 5210 -- For enumeration types with non-standard representations, we 5211 -- expand typ'Pred (x) into 5212 5213 -- Pos_To_Rep (Rep_To_Pos (x) - 1) 5214 5215 -- If the representation is contiguous, we compute instead 5216 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations. 5217 -- The conversion function Enum_Pos_To_Rep is defined on the 5218 -- base type, not the subtype, so we have to use the base type 5219 -- explicitly for this and other enumeration attributes. 5220 5221 if Is_Enumeration_Type (Ptyp) 5222 and then Present (Enum_Pos_To_Rep (Etyp)) 5223 then 5224 if Has_Contiguous_Rep (Etyp) then 5225 Rewrite (N, 5226 Unchecked_Convert_To (Ptyp, 5227 Make_Op_Add (Loc, 5228 Left_Opnd => 5229 Make_Integer_Literal (Loc, 5230 Enumeration_Rep (First_Literal (Ptyp))), 5231 Right_Opnd => 5232 Make_Function_Call (Loc, 5233 Name => 5234 New_Occurrence_Of 5235 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 5236 5237 Parameter_Associations => 5238 New_List ( 5239 Unchecked_Convert_To (Ptyp, 5240 Make_Op_Subtract (Loc, 5241 Left_Opnd => 5242 Unchecked_Convert_To (Standard_Integer, 5243 Relocate_Node (First (Exprs))), 5244 Right_Opnd => 5245 Make_Integer_Literal (Loc, 1))), 5246 Rep_To_Pos_Flag (Ptyp, Loc)))))); 5247 5248 else 5249 -- Add Boolean parameter True, to request program error if 5250 -- we have a bad representation on our hands. If checks are 5251 -- suppressed, then add False instead 5252 5253 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); 5254 Rewrite (N, 5255 Make_Indexed_Component (Loc, 5256 Prefix => 5257 New_Occurrence_Of 5258 (Enum_Pos_To_Rep (Etyp), Loc), 5259 Expressions => New_List ( 5260 Make_Op_Subtract (Loc, 5261 Left_Opnd => 5262 Make_Function_Call (Loc, 5263 Name => 5264 New_Occurrence_Of 5265 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 5266 Parameter_Associations => Exprs), 5267 Right_Opnd => Make_Integer_Literal (Loc, 1))))); 5268 end if; 5269 5270 Analyze_And_Resolve (N, Typ); 5271 5272 -- For floating-point, we transform 'Pred into a call to the Pred 5273 -- floating-point attribute function in Fat_xxx (xxx is root type). 5274 -- Note that this function takes care of the overflow case. 5275 5276 elsif Is_Floating_Point_Type (Ptyp) then 5277 Expand_Fpt_Attribute_R (N); 5278 Analyze_And_Resolve (N, Typ); 5279 5280 -- For modular types, nothing to do (no overflow, since wraps) 5281 5282 elsif Is_Modular_Integer_Type (Ptyp) then 5283 null; 5284 5285 -- For other types, if argument is marked as needing a range check or 5286 -- overflow checking is enabled, we must generate a check. 5287 5288 elsif not Overflow_Checks_Suppressed (Ptyp) 5289 or else Do_Range_Check (First (Exprs)) 5290 then 5291 Set_Do_Range_Check (First (Exprs), False); 5292 Expand_Pred_Succ_Attribute (N); 5293 end if; 5294 end Pred; 5295 5296 -------------- 5297 -- Priority -- 5298 -------------- 5299 5300 -- Ada 2005 (AI-327): Dynamic ceiling priorities 5301 5302 -- We rewrite X'Priority as the following run-time call: 5303 5304 -- Get_Ceiling (X._Object) 5305 5306 -- Note that although X'Priority is notionally an object, it is quite 5307 -- deliberately not defined as an aliased object in the RM. This means 5308 -- that it works fine to rewrite it as a call, without having to worry 5309 -- about complications that would other arise from X'Priority'Access, 5310 -- which is illegal, because of the lack of aliasing. 5311 5312 when Attribute_Priority => Priority : declare 5313 Call : Node_Id; 5314 Conctyp : Entity_Id; 5315 New_Itype : Entity_Id; 5316 Object_Parm : Node_Id; 5317 Subprg : Entity_Id; 5318 RT_Subprg_Name : Node_Id; 5319 5320 begin 5321 -- Look for the enclosing concurrent type 5322 5323 Conctyp := Current_Scope; 5324 while not Is_Concurrent_Type (Conctyp) loop 5325 Conctyp := Scope (Conctyp); 5326 end loop; 5327 5328 pragma Assert (Is_Protected_Type (Conctyp)); 5329 5330 -- Generate the actual of the call 5331 5332 Subprg := Current_Scope; 5333 while not Present (Protected_Body_Subprogram (Subprg)) loop 5334 Subprg := Scope (Subprg); 5335 end loop; 5336 5337 -- Use of 'Priority inside protected entries and barriers (in both 5338 -- cases the type of the first formal of their expanded subprogram 5339 -- is Address) 5340 5341 if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) = 5342 RTE (RE_Address) 5343 then 5344 -- In the expansion of protected entries the type of the first 5345 -- formal of the Protected_Body_Subprogram is an Address. In order 5346 -- to reference the _object component we generate: 5347 5348 -- type T is access p__ptTV; 5349 -- freeze T [] 5350 5351 New_Itype := Create_Itype (E_Access_Type, N); 5352 Set_Etype (New_Itype, New_Itype); 5353 Set_Directly_Designated_Type (New_Itype, 5354 Corresponding_Record_Type (Conctyp)); 5355 Freeze_Itype (New_Itype, N); 5356 5357 -- Generate: 5358 -- T!(O)._object'unchecked_access 5359 5360 Object_Parm := 5361 Make_Attribute_Reference (Loc, 5362 Prefix => 5363 Make_Selected_Component (Loc, 5364 Prefix => 5365 Unchecked_Convert_To (New_Itype, 5366 New_Occurrence_Of 5367 (First_Entity (Protected_Body_Subprogram (Subprg)), 5368 Loc)), 5369 Selector_Name => Make_Identifier (Loc, Name_uObject)), 5370 Attribute_Name => Name_Unchecked_Access); 5371 5372 -- Use of 'Priority inside a protected subprogram 5373 5374 else 5375 Object_Parm := 5376 Make_Attribute_Reference (Loc, 5377 Prefix => 5378 Make_Selected_Component (Loc, 5379 Prefix => 5380 New_Occurrence_Of 5381 (First_Entity (Protected_Body_Subprogram (Subprg)), 5382 Loc), 5383 Selector_Name => Make_Identifier (Loc, Name_uObject)), 5384 Attribute_Name => Name_Unchecked_Access); 5385 end if; 5386 5387 -- Select the appropriate run-time subprogram 5388 5389 if Number_Entries (Conctyp) = 0 then 5390 RT_Subprg_Name := New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc); 5391 else 5392 RT_Subprg_Name := New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc); 5393 end if; 5394 5395 Call := 5396 Make_Function_Call (Loc, 5397 Name => RT_Subprg_Name, 5398 Parameter_Associations => New_List (Object_Parm)); 5399 5400 Rewrite (N, Call); 5401 5402 -- Avoid the generation of extra checks on the pointer to the 5403 -- protected object. 5404 5405 Analyze_And_Resolve (N, Typ, Suppress => Access_Check); 5406 end Priority; 5407 5408 ------------------ 5409 -- Range_Length -- 5410 ------------------ 5411 5412 when Attribute_Range_Length => 5413 5414 -- The only special processing required is for the case where 5415 -- Range_Length is applied to an enumeration type with holes. 5416 -- In this case we transform 5417 5418 -- X'Range_Length 5419 5420 -- to 5421 5422 -- X'Pos (X'Last) - X'Pos (X'First) + 1 5423 5424 -- So that the result reflects the proper Pos values instead 5425 -- of the underlying representations. 5426 5427 if Is_Enumeration_Type (Ptyp) 5428 and then Has_Non_Standard_Rep (Ptyp) 5429 then 5430 Rewrite (N, 5431 Make_Op_Add (Loc, 5432 Left_Opnd => 5433 Make_Op_Subtract (Loc, 5434 Left_Opnd => 5435 Make_Attribute_Reference (Loc, 5436 Attribute_Name => Name_Pos, 5437 Prefix => New_Occurrence_Of (Ptyp, Loc), 5438 Expressions => New_List ( 5439 Make_Attribute_Reference (Loc, 5440 Attribute_Name => Name_Last, 5441 Prefix => 5442 New_Occurrence_Of (Ptyp, Loc)))), 5443 5444 Right_Opnd => 5445 Make_Attribute_Reference (Loc, 5446 Attribute_Name => Name_Pos, 5447 Prefix => New_Occurrence_Of (Ptyp, Loc), 5448 Expressions => New_List ( 5449 Make_Attribute_Reference (Loc, 5450 Attribute_Name => Name_First, 5451 Prefix => 5452 New_Occurrence_Of (Ptyp, Loc))))), 5453 5454 Right_Opnd => Make_Integer_Literal (Loc, 1))); 5455 5456 Analyze_And_Resolve (N, Typ); 5457 5458 -- For all other cases, the attribute is handled by the back end, but 5459 -- we need to deal with the case of the range check on a universal 5460 -- integer. 5461 5462 else 5463 Apply_Universal_Integer_Attribute_Checks (N); 5464 end if; 5465 5466 ------------ 5467 -- Reduce -- 5468 ------------ 5469 5470 when Attribute_Reduce => 5471 declare 5472 Loc : constant Source_Ptr := Sloc (N); 5473 E1 : constant Node_Id := First (Expressions (N)); 5474 E2 : constant Node_Id := Next (E1); 5475 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 5476 Typ : constant Entity_Id := Etype (N); 5477 New_Loop : Node_Id; 5478 5479 -- If the prefix is an aggregwte, its unique component is sn 5480 -- Iterated_Element, and we create a loop out of its itertor. 5481 5482 begin 5483 if Nkind (Prefix (N)) = N_Aggregate then 5484 declare 5485 Stream : constant Node_Id := 5486 First (Component_Associations (Prefix (N))); 5487 Id : constant Node_Id := Defining_Identifier (Stream); 5488 Expr : constant Node_Id := Expression (Stream); 5489 Ch : constant Node_Id := 5490 First (Discrete_Choices (Stream)); 5491 begin 5492 New_Loop := Make_Loop_Statement (Loc, 5493 Iteration_Scheme => 5494 Make_Iteration_Scheme (Loc, 5495 Iterator_Specification => Empty, 5496 Loop_Parameter_Specification => 5497 Make_Loop_Parameter_Specification (Loc, 5498 Defining_Identifier => New_Copy (Id), 5499 Discrete_Subtype_Definition => 5500 Relocate_Node (Ch))), 5501 End_Label => Empty, 5502 Statements => New_List ( 5503 Make_Assignment_Statement (Loc, 5504 Name => New_Occurrence_Of (Bnn, Loc), 5505 Expression => Make_Function_Call (Loc, 5506 Name => New_Occurrence_Of (Entity (E1), Loc), 5507 Parameter_Associations => New_List ( 5508 New_Occurrence_Of (Bnn, Loc), 5509 Relocate_Node (Expr)))))); 5510 end; 5511 else 5512 -- If the prefix is a name we construct an element iterwtor 5513 -- over it. Its expansion will verify that it is an array 5514 -- or a container with the proper aspects. 5515 5516 declare 5517 Iter : Node_Id; 5518 Elem : constant Entity_Id := Make_Temporary (Loc, 'E', N); 5519 5520 begin 5521 Iter := 5522 Make_Iterator_Specification (Loc, 5523 Defining_Identifier => Elem, 5524 Name => Relocate_Node (Prefix (N)), 5525 Subtype_Indication => Empty); 5526 Set_Of_Present (Iter); 5527 5528 New_Loop := Make_Loop_Statement (Loc, 5529 Iteration_Scheme => 5530 Make_Iteration_Scheme (Loc, 5531 Iterator_Specification => Iter, 5532 Loop_Parameter_Specification => Empty), 5533 End_Label => Empty, 5534 Statements => New_List ( 5535 Make_Assignment_Statement (Loc, 5536 Name => New_Occurrence_Of (Bnn, Loc), 5537 Expression => Make_Function_Call (Loc, 5538 Name => New_Occurrence_Of (Entity (E1), Loc), 5539 Parameter_Associations => New_List ( 5540 New_Occurrence_Of (Bnn, Loc), 5541 New_Occurrence_Of (Elem, Loc)))))); 5542 end; 5543 end if; 5544 5545 Rewrite (N, 5546 Make_Expression_With_Actions (Loc, 5547 Actions => New_List ( 5548 Make_Object_Declaration (Loc, 5549 Defining_Identifier => Bnn, 5550 Object_Definition => 5551 New_Occurrence_Of (Typ, Loc), 5552 Expression => Relocate_Node (E2)), New_Loop), 5553 Expression => New_Occurrence_Of (Bnn, Loc))); 5554 Analyze_And_Resolve (N, Typ); 5555 end; 5556 5557 ---------- 5558 -- Read -- 5559 ---------- 5560 5561 when Attribute_Read => Read : declare 5562 P_Type : constant Entity_Id := Entity (Pref); 5563 B_Type : constant Entity_Id := Base_Type (P_Type); 5564 U_Type : constant Entity_Id := Underlying_Type (P_Type); 5565 Pname : Entity_Id; 5566 Decl : Node_Id; 5567 Prag : Node_Id; 5568 Arg2 : Node_Id; 5569 Rfunc : Node_Id; 5570 Lhs : Node_Id; 5571 Rhs : Node_Id; 5572 5573 begin 5574 -- If no underlying type, we have an error that will be diagnosed 5575 -- elsewhere, so here we just completely ignore the expansion. 5576 5577 if No (U_Type) then 5578 return; 5579 end if; 5580 5581 -- Stream operations can appear in user code even if the restriction 5582 -- No_Streams is active (for example, when instantiating a predefined 5583 -- container). In that case rewrite the attribute as a Raise to 5584 -- prevent any run-time use. 5585 5586 if Restriction_Active (No_Streams) then 5587 Rewrite (N, 5588 Make_Raise_Program_Error (Sloc (N), 5589 Reason => PE_Stream_Operation_Not_Allowed)); 5590 Set_Etype (N, B_Type); 5591 return; 5592 end if; 5593 5594 -- The simple case, if there is a TSS for Read, just call it 5595 5596 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read); 5597 5598 if Present (Pname) then 5599 null; 5600 5601 else 5602 -- If there is a Stream_Convert pragma, use it, we rewrite 5603 5604 -- sourcetyp'Read (stream, Item) 5605 5606 -- as 5607 5608 -- Item := sourcetyp (strmread (strmtyp'Input (Stream))); 5609 5610 -- where strmread is the given Read function that converts an 5611 -- argument of type strmtyp to type sourcetyp or a type from which 5612 -- it is derived. The conversion to sourcetyp is required in the 5613 -- latter case. 5614 5615 -- A special case arises if Item is a type conversion in which 5616 -- case, we have to expand to: 5617 5618 -- Itemx := typex (strmread (strmtyp'Input (Stream))); 5619 5620 -- where Itemx is the expression of the type conversion (i.e. 5621 -- the actual object), and typex is the type of Itemx. 5622 5623 Prag := Get_Stream_Convert_Pragma (P_Type); 5624 5625 if Present (Prag) then 5626 Arg2 := Next (First (Pragma_Argument_Associations (Prag))); 5627 Rfunc := Entity (Expression (Arg2)); 5628 Lhs := Relocate_Node (Next (First (Exprs))); 5629 Rhs := 5630 OK_Convert_To (B_Type, 5631 Make_Function_Call (Loc, 5632 Name => New_Occurrence_Of (Rfunc, Loc), 5633 Parameter_Associations => New_List ( 5634 Make_Attribute_Reference (Loc, 5635 Prefix => 5636 New_Occurrence_Of 5637 (Etype (First_Formal (Rfunc)), Loc), 5638 Attribute_Name => Name_Input, 5639 Expressions => New_List ( 5640 Relocate_Node (First (Exprs))))))); 5641 5642 if Nkind (Lhs) = N_Type_Conversion then 5643 Lhs := Expression (Lhs); 5644 Rhs := Convert_To (Etype (Lhs), Rhs); 5645 end if; 5646 5647 Rewrite (N, 5648 Make_Assignment_Statement (Loc, 5649 Name => Lhs, 5650 Expression => Rhs)); 5651 Set_Assignment_OK (Lhs); 5652 Analyze (N); 5653 return; 5654 5655 -- For elementary types, we call the I_xxx routine using the first 5656 -- parameter and then assign the result into the second parameter. 5657 -- We set Assignment_OK to deal with the conversion case. 5658 5659 elsif Is_Elementary_Type (U_Type) then 5660 declare 5661 Lhs : Node_Id; 5662 Rhs : Node_Id; 5663 5664 begin 5665 Lhs := Relocate_Node (Next (First (Exprs))); 5666 Rhs := Build_Elementary_Input_Call (N); 5667 5668 if Nkind (Lhs) = N_Type_Conversion then 5669 Lhs := Expression (Lhs); 5670 Rhs := Convert_To (Etype (Lhs), Rhs); 5671 end if; 5672 5673 Set_Assignment_OK (Lhs); 5674 5675 Rewrite (N, 5676 Make_Assignment_Statement (Loc, 5677 Name => Lhs, 5678 Expression => Rhs)); 5679 5680 Analyze (N); 5681 return; 5682 end; 5683 5684 -- Array type case 5685 5686 elsif Is_Array_Type (U_Type) then 5687 Build_Array_Read_Procedure (N, U_Type, Decl, Pname); 5688 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 5689 5690 -- Tagged type case, use the primitive Read function. Note that 5691 -- this will dispatch in the class-wide case which is what we want 5692 5693 elsif Is_Tagged_Type (U_Type) then 5694 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read); 5695 5696 -- All other record type cases, including protected records. The 5697 -- latter only arise for expander generated code for handling 5698 -- shared passive partition access. 5699 5700 else 5701 pragma Assert 5702 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 5703 5704 -- Ada 2005 (AI-216): Program_Error is raised when executing 5705 -- the default implementation of the Read attribute of an 5706 -- Unchecked_Union type. We replace the attribute with a 5707 -- raise statement (rather than inserting it before) to handle 5708 -- properly the case of an unchecked union that is a record 5709 -- component. 5710 5711 if Is_Unchecked_Union (Base_Type (U_Type)) then 5712 Rewrite (N, 5713 Make_Raise_Program_Error (Loc, 5714 Reason => PE_Unchecked_Union_Restriction)); 5715 Set_Etype (N, B_Type); 5716 return; 5717 end if; 5718 5719 if Has_Discriminants (U_Type) 5720 and then Present 5721 (Discriminant_Default_Value (First_Discriminant (U_Type))) 5722 then 5723 Build_Mutable_Record_Read_Procedure 5724 (Loc, Full_Base (U_Type), Decl, Pname); 5725 else 5726 Build_Record_Read_Procedure 5727 (Loc, Full_Base (U_Type), Decl, Pname); 5728 end if; 5729 5730 -- Suppress checks, uninitialized or otherwise invalid 5731 -- data does not cause constraint errors to be raised for 5732 -- a complete record read. 5733 5734 Insert_Action (N, Decl, All_Checks); 5735 end if; 5736 end if; 5737 5738 Rewrite_Stream_Proc_Call (Pname); 5739 end Read; 5740 5741 --------- 5742 -- Ref -- 5743 --------- 5744 5745 -- Ref is identical to To_Address, see To_Address for processing 5746 5747 --------------- 5748 -- Remainder -- 5749 --------------- 5750 5751 -- Transforms 'Remainder into a call to the floating-point attribute 5752 -- function Remainder in Fat_xxx (where xxx is the root type) 5753 5754 when Attribute_Remainder => 5755 Expand_Fpt_Attribute_RR (N); 5756 5757 ------------ 5758 -- Result -- 5759 ------------ 5760 5761 -- Transform 'Result into reference to _Result formal. At the point 5762 -- where a legal 'Result attribute is expanded, we know that we are in 5763 -- the context of a _Postcondition function with a _Result parameter. 5764 5765 when Attribute_Result => 5766 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult)); 5767 Analyze_And_Resolve (N, Typ); 5768 5769 ----------- 5770 -- Round -- 5771 ----------- 5772 5773 -- The handling of the Round attribute is quite delicate. The processing 5774 -- in Sem_Attr introduced a conversion to universal real, reflecting the 5775 -- semantics of Round, but we do not want anything to do with universal 5776 -- real at runtime, since this corresponds to using floating-point 5777 -- arithmetic. 5778 5779 -- What we have now is that the Etype of the Round attribute correctly 5780 -- indicates the final result type. The operand of the Round is the 5781 -- conversion to universal real, described above, and the operand of 5782 -- this conversion is the actual operand of Round, which may be the 5783 -- special case of a fixed point multiplication or division (Etype = 5784 -- universal fixed) 5785 5786 -- The exapander will expand first the operand of the conversion, then 5787 -- the conversion, and finally the round attribute itself, since we 5788 -- always work inside out. But we cannot simply process naively in this 5789 -- order. In the semantic world where universal fixed and real really 5790 -- exist and have infinite precision, there is no problem, but in the 5791 -- implementation world, where universal real is a floating-point type, 5792 -- we would get the wrong result. 5793 5794 -- So the approach is as follows. First, when expanding a multiply or 5795 -- divide whose type is universal fixed, we do nothing at all, instead 5796 -- deferring the operation till later. 5797 5798 -- The actual processing is done in Expand_N_Type_Conversion which 5799 -- handles the special case of Round by looking at its parent to see if 5800 -- it is a Round attribute, and if it is, handling the conversion (or 5801 -- its fixed multiply/divide child) in an appropriate manner. 5802 5803 -- This means that by the time we get to expanding the Round attribute 5804 -- itself, the Round is nothing more than a type conversion (and will 5805 -- often be a null type conversion), so we just replace it with the 5806 -- appropriate conversion operation. 5807 5808 when Attribute_Round => 5809 Rewrite (N, 5810 Convert_To (Etype (N), Relocate_Node (First (Exprs)))); 5811 Analyze_And_Resolve (N); 5812 5813 -------------- 5814 -- Rounding -- 5815 -------------- 5816 5817 -- Transforms 'Rounding into a call to the floating-point attribute 5818 -- function Rounding in Fat_xxx (where xxx is the root type) 5819 -- Expansion is avoided for cases the back end can handle directly. 5820 5821 when Attribute_Rounding => 5822 if not Is_Inline_Floating_Point_Attribute (N) then 5823 Expand_Fpt_Attribute_R (N); 5824 end if; 5825 5826 ------------- 5827 -- Scaling -- 5828 ------------- 5829 5830 -- Transforms 'Scaling into a call to the floating-point attribute 5831 -- function Scaling in Fat_xxx (where xxx is the root type) 5832 5833 when Attribute_Scaling => 5834 Expand_Fpt_Attribute_RI (N); 5835 5836 ------------------------- 5837 -- Simple_Storage_Pool -- 5838 ------------------------- 5839 5840 when Attribute_Simple_Storage_Pool => 5841 Rewrite (N, 5842 Make_Type_Conversion (Loc, 5843 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), 5844 Expression => New_Occurrence_Of (Entity (N), Loc))); 5845 Analyze_And_Resolve (N, Typ); 5846 5847 ---------- 5848 -- Size -- 5849 ---------- 5850 5851 when Attribute_Object_Size 5852 | Attribute_Size 5853 | Attribute_Value_Size 5854 | Attribute_VADS_Size 5855 => 5856 Size : declare 5857 New_Node : Node_Id; 5858 5859 begin 5860 -- Processing for VADS_Size case. Note that this processing 5861 -- removes all traces of VADS_Size from the tree, and completes 5862 -- all required processing for VADS_Size by translating the 5863 -- attribute reference to an appropriate Size or Object_Size 5864 -- reference. 5865 5866 if Id = Attribute_VADS_Size 5867 or else (Use_VADS_Size and then Id = Attribute_Size) 5868 then 5869 -- If the size is specified, then we simply use the specified 5870 -- size. This applies to both types and objects. The size of an 5871 -- object can be specified in the following ways: 5872 5873 -- An explicit size object is given for an object 5874 -- A component size is specified for an indexed component 5875 -- A component clause is specified for a selected component 5876 -- The object is a component of a packed composite object 5877 5878 -- If the size is specified, then VADS_Size of an object 5879 5880 if (Is_Entity_Name (Pref) 5881 and then Present (Size_Clause (Entity (Pref)))) 5882 or else 5883 (Nkind (Pref) = N_Component_Clause 5884 and then (Present (Component_Clause 5885 (Entity (Selector_Name (Pref)))) 5886 or else Is_Packed (Etype (Prefix (Pref))))) 5887 or else 5888 (Nkind (Pref) = N_Indexed_Component 5889 and then (Component_Size (Etype (Prefix (Pref))) /= 0 5890 or else Is_Packed (Etype (Prefix (Pref))))) 5891 then 5892 Set_Attribute_Name (N, Name_Size); 5893 5894 -- Otherwise if we have an object rather than a type, then 5895 -- the VADS_Size attribute applies to the type of the object, 5896 -- rather than the object itself. This is one of the respects 5897 -- in which VADS_Size differs from Size. 5898 5899 else 5900 if (not Is_Entity_Name (Pref) 5901 or else not Is_Type (Entity (Pref))) 5902 and then (Is_Scalar_Type (Ptyp) 5903 or else Is_Constrained (Ptyp)) 5904 then 5905 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc)); 5906 end if; 5907 5908 -- For a scalar type for which no size was explicitly given, 5909 -- VADS_Size means Object_Size. This is the other respect in 5910 -- which VADS_Size differs from Size. 5911 5912 if Is_Scalar_Type (Ptyp) 5913 and then No (Size_Clause (Ptyp)) 5914 then 5915 Set_Attribute_Name (N, Name_Object_Size); 5916 5917 -- In all other cases, Size and VADS_Size are the sane 5918 5919 else 5920 Set_Attribute_Name (N, Name_Size); 5921 end if; 5922 end if; 5923 end if; 5924 5925 -- If the prefix is X'Class, transform it into a direct reference 5926 -- to the class-wide type, because the back end must not see a 5927 -- 'Class reference. 5928 5929 if Is_Entity_Name (Pref) 5930 and then Is_Class_Wide_Type (Entity (Pref)) 5931 then 5932 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); 5933 return; 5934 5935 -- For X'Size applied to an object of a class-wide type, transform 5936 -- X'Size into a call to the primitive operation _Size applied to 5937 -- X. 5938 5939 elsif Is_Class_Wide_Type (Ptyp) then 5940 5941 -- No need to do anything else compiling under restriction 5942 -- No_Dispatching_Calls. During the semantic analysis we 5943 -- already noted this restriction violation. 5944 5945 if Restriction_Active (No_Dispatching_Calls) then 5946 return; 5947 end if; 5948 5949 New_Node := 5950 Make_Function_Call (Loc, 5951 Name => 5952 New_Occurrence_Of (Find_Prim_Op (Ptyp, Name_uSize), Loc), 5953 Parameter_Associations => New_List (Pref)); 5954 5955 if Typ /= Standard_Long_Long_Integer then 5956 5957 -- The context is a specific integer type with which the 5958 -- original attribute was compatible. The function has a 5959 -- specific type as well, so to preserve the compatibility 5960 -- we must convert explicitly. 5961 5962 New_Node := Convert_To (Typ, New_Node); 5963 end if; 5964 5965 Rewrite (N, New_Node); 5966 Analyze_And_Resolve (N, Typ); 5967 return; 5968 end if; 5969 5970 -- Call Expand_Size_Attribute to do the final part of the 5971 -- expansion which is shared with GNATprove expansion. 5972 5973 Expand_Size_Attribute (N); 5974 end Size; 5975 5976 ------------------ 5977 -- Storage_Pool -- 5978 ------------------ 5979 5980 when Attribute_Storage_Pool => 5981 Rewrite (N, 5982 Make_Type_Conversion (Loc, 5983 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), 5984 Expression => New_Occurrence_Of (Entity (N), Loc))); 5985 Analyze_And_Resolve (N, Typ); 5986 5987 ------------------ 5988 -- Storage_Size -- 5989 ------------------ 5990 5991 when Attribute_Storage_Size => Storage_Size : declare 5992 Alloc_Op : Entity_Id := Empty; 5993 5994 begin 5995 5996 -- Access type case, always go to the root type 5997 5998 -- The case of access types results in a value of zero for the case 5999 -- where no storage size attribute clause has been given. If a 6000 -- storage size has been given, then the attribute is converted 6001 -- to a reference to the variable used to hold this value. 6002 6003 if Is_Access_Type (Ptyp) then 6004 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then 6005 Rewrite (N, 6006 Make_Attribute_Reference (Loc, 6007 Prefix => New_Occurrence_Of (Typ, Loc), 6008 Attribute_Name => Name_Max, 6009 Expressions => New_List ( 6010 Make_Integer_Literal (Loc, 0), 6011 Convert_To (Typ, 6012 New_Occurrence_Of 6013 (Storage_Size_Variable (Root_Type (Ptyp)), Loc))))); 6014 6015 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then 6016 6017 -- If the access type is associated with a simple storage pool 6018 -- object, then attempt to locate the optional Storage_Size 6019 -- function of the simple storage pool type. If not found, 6020 -- then the result will default to zero. 6021 6022 if Present (Get_Rep_Pragma (Root_Type (Ptyp), 6023 Name_Simple_Storage_Pool_Type)) 6024 then 6025 declare 6026 Pool_Type : constant Entity_Id := 6027 Base_Type (Etype (Entity (N))); 6028 6029 begin 6030 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size); 6031 while Present (Alloc_Op) loop 6032 if Scope (Alloc_Op) = Scope (Pool_Type) 6033 and then Present (First_Formal (Alloc_Op)) 6034 and then Etype (First_Formal (Alloc_Op)) = Pool_Type 6035 then 6036 exit; 6037 end if; 6038 6039 Alloc_Op := Homonym (Alloc_Op); 6040 end loop; 6041 end; 6042 6043 -- In the normal Storage_Pool case, retrieve the primitive 6044 -- function associated with the pool type. 6045 6046 else 6047 Alloc_Op := 6048 Find_Prim_Op 6049 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))), 6050 Attribute_Name (N)); 6051 end if; 6052 6053 -- If Storage_Size wasn't found (can only occur in the simple 6054 -- storage pool case), then simply use zero for the result. 6055 6056 if not Present (Alloc_Op) then 6057 Rewrite (N, Make_Integer_Literal (Loc, 0)); 6058 6059 -- Otherwise, rewrite the allocator as a call to pool type's 6060 -- Storage_Size function. 6061 6062 else 6063 Rewrite (N, 6064 OK_Convert_To (Typ, 6065 Make_Function_Call (Loc, 6066 Name => 6067 New_Occurrence_Of (Alloc_Op, Loc), 6068 6069 Parameter_Associations => New_List ( 6070 New_Occurrence_Of 6071 (Associated_Storage_Pool 6072 (Root_Type (Ptyp)), Loc))))); 6073 end if; 6074 6075 else 6076 Rewrite (N, Make_Integer_Literal (Loc, 0)); 6077 end if; 6078 6079 Analyze_And_Resolve (N, Typ); 6080 6081 -- For tasks, we retrieve the size directly from the TCB. The 6082 -- size may depend on a discriminant of the type, and therefore 6083 -- can be a per-object expression, so type-level information is 6084 -- not sufficient in general. There are four cases to consider: 6085 6086 -- a) If the attribute appears within a task body, the designated 6087 -- TCB is obtained by a call to Self. 6088 6089 -- b) If the prefix of the attribute is the name of a task object, 6090 -- the designated TCB is the one stored in the corresponding record. 6091 6092 -- c) If the prefix is a task type, the size is obtained from the 6093 -- size variable created for each task type 6094 6095 -- d) If no Storage_Size was specified for the type, there is no 6096 -- size variable, and the value is a system-specific default. 6097 6098 else 6099 if In_Open_Scopes (Ptyp) then 6100 6101 -- Storage_Size (Self) 6102 6103 Rewrite (N, 6104 Convert_To (Typ, 6105 Make_Function_Call (Loc, 6106 Name => 6107 New_Occurrence_Of (RTE (RE_Storage_Size), Loc), 6108 Parameter_Associations => 6109 New_List ( 6110 Make_Function_Call (Loc, 6111 Name => 6112 New_Occurrence_Of (RTE (RE_Self), Loc)))))); 6113 6114 elsif not Is_Entity_Name (Pref) 6115 or else not Is_Type (Entity (Pref)) 6116 then 6117 -- Storage_Size (Rec (Obj).Size) 6118 6119 Rewrite (N, 6120 Convert_To (Typ, 6121 Make_Function_Call (Loc, 6122 Name => 6123 New_Occurrence_Of (RTE (RE_Storage_Size), Loc), 6124 Parameter_Associations => 6125 New_List ( 6126 Make_Selected_Component (Loc, 6127 Prefix => 6128 Unchecked_Convert_To ( 6129 Corresponding_Record_Type (Ptyp), 6130 New_Copy_Tree (Pref)), 6131 Selector_Name => 6132 Make_Identifier (Loc, Name_uTask_Id)))))); 6133 6134 elsif Present (Storage_Size_Variable (Ptyp)) then 6135 6136 -- Static Storage_Size pragma given for type: retrieve value 6137 -- from its allocated storage variable. 6138 6139 Rewrite (N, 6140 Convert_To (Typ, 6141 Make_Function_Call (Loc, 6142 Name => New_Occurrence_Of ( 6143 RTE (RE_Adjust_Storage_Size), Loc), 6144 Parameter_Associations => 6145 New_List ( 6146 New_Occurrence_Of ( 6147 Storage_Size_Variable (Ptyp), Loc))))); 6148 else 6149 -- Get system default 6150 6151 Rewrite (N, 6152 Convert_To (Typ, 6153 Make_Function_Call (Loc, 6154 Name => 6155 New_Occurrence_Of ( 6156 RTE (RE_Default_Stack_Size), Loc)))); 6157 end if; 6158 6159 Analyze_And_Resolve (N, Typ); 6160 end if; 6161 end Storage_Size; 6162 6163 ----------------- 6164 -- Stream_Size -- 6165 ----------------- 6166 6167 when Attribute_Stream_Size => 6168 Rewrite (N, 6169 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp))); 6170 Analyze_And_Resolve (N, Typ); 6171 6172 ---------- 6173 -- Succ -- 6174 ---------- 6175 6176 -- 1. Deal with enumeration types with holes. 6177 -- 2. For floating-point, generate call to attribute function. 6178 -- 3. For other cases, deal with constraint checking. 6179 6180 when Attribute_Succ => Succ : declare 6181 Etyp : constant Entity_Id := Base_Type (Ptyp); 6182 6183 begin 6184 -- For enumeration types with non-standard representations, we 6185 -- expand typ'Succ (x) into 6186 6187 -- Pos_To_Rep (Rep_To_Pos (x) + 1) 6188 6189 -- If the representation is contiguous, we compute instead 6190 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations. 6191 6192 if Is_Enumeration_Type (Ptyp) 6193 and then Present (Enum_Pos_To_Rep (Etyp)) 6194 then 6195 if Has_Contiguous_Rep (Etyp) then 6196 Rewrite (N, 6197 Unchecked_Convert_To (Ptyp, 6198 Make_Op_Add (Loc, 6199 Left_Opnd => 6200 Make_Integer_Literal (Loc, 6201 Enumeration_Rep (First_Literal (Ptyp))), 6202 Right_Opnd => 6203 Make_Function_Call (Loc, 6204 Name => 6205 New_Occurrence_Of 6206 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 6207 6208 Parameter_Associations => 6209 New_List ( 6210 Unchecked_Convert_To (Ptyp, 6211 Make_Op_Add (Loc, 6212 Left_Opnd => 6213 Unchecked_Convert_To (Standard_Integer, 6214 Relocate_Node (First (Exprs))), 6215 Right_Opnd => 6216 Make_Integer_Literal (Loc, 1))), 6217 Rep_To_Pos_Flag (Ptyp, Loc)))))); 6218 else 6219 -- Add Boolean parameter True, to request program error if 6220 -- we have a bad representation on our hands. Add False if 6221 -- checks are suppressed. 6222 6223 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); 6224 Rewrite (N, 6225 Make_Indexed_Component (Loc, 6226 Prefix => 6227 New_Occurrence_Of 6228 (Enum_Pos_To_Rep (Etyp), Loc), 6229 Expressions => New_List ( 6230 Make_Op_Add (Loc, 6231 Left_Opnd => 6232 Make_Function_Call (Loc, 6233 Name => 6234 New_Occurrence_Of 6235 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 6236 Parameter_Associations => Exprs), 6237 Right_Opnd => Make_Integer_Literal (Loc, 1))))); 6238 end if; 6239 6240 Analyze_And_Resolve (N, Typ); 6241 6242 -- For floating-point, we transform 'Succ into a call to the Succ 6243 -- floating-point attribute function in Fat_xxx (xxx is root type) 6244 6245 elsif Is_Floating_Point_Type (Ptyp) then 6246 Expand_Fpt_Attribute_R (N); 6247 Analyze_And_Resolve (N, Typ); 6248 6249 -- For modular types, nothing to do (no overflow, since wraps) 6250 6251 elsif Is_Modular_Integer_Type (Ptyp) then 6252 null; 6253 6254 -- For other types, if argument is marked as needing a range check or 6255 -- overflow checking is enabled, we must generate a check. 6256 6257 elsif not Overflow_Checks_Suppressed (Ptyp) 6258 or else Do_Range_Check (First (Exprs)) 6259 then 6260 Set_Do_Range_Check (First (Exprs), False); 6261 Expand_Pred_Succ_Attribute (N); 6262 end if; 6263 end Succ; 6264 6265 --------- 6266 -- Tag -- 6267 --------- 6268 6269 -- Transforms X'Tag into a direct reference to the tag of X 6270 6271 when Attribute_Tag => Tag : declare 6272 Ttyp : Entity_Id; 6273 Prefix_Is_Type : Boolean; 6274 6275 begin 6276 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then 6277 Ttyp := Entity (Pref); 6278 Prefix_Is_Type := True; 6279 else 6280 Ttyp := Ptyp; 6281 Prefix_Is_Type := False; 6282 end if; 6283 6284 if Is_Class_Wide_Type (Ttyp) then 6285 Ttyp := Root_Type (Ttyp); 6286 end if; 6287 6288 Ttyp := Underlying_Type (Ttyp); 6289 6290 -- Ada 2005: The type may be a synchronized tagged type, in which 6291 -- case the tag information is stored in the corresponding record. 6292 6293 if Is_Concurrent_Type (Ttyp) then 6294 Ttyp := Corresponding_Record_Type (Ttyp); 6295 end if; 6296 6297 if Prefix_Is_Type then 6298 6299 -- For VMs we leave the type attribute unexpanded because 6300 -- there's not a dispatching table to reference. 6301 6302 if Tagged_Type_Expansion then 6303 Rewrite (N, 6304 Unchecked_Convert_To (RTE (RE_Tag), 6305 New_Occurrence_Of 6306 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc))); 6307 Analyze_And_Resolve (N, RTE (RE_Tag)); 6308 end if; 6309 6310 -- Ada 2005 (AI-251): The use of 'Tag in the sources always 6311 -- references the primary tag of the actual object. If 'Tag is 6312 -- applied to class-wide interface objects we generate code that 6313 -- displaces "this" to reference the base of the object. 6314 6315 elsif Comes_From_Source (N) 6316 and then Is_Class_Wide_Type (Etype (Prefix (N))) 6317 and then Is_Interface (Underlying_Type (Etype (Prefix (N)))) 6318 then 6319 -- Generate: 6320 -- (To_Tag_Ptr (Prefix'Address)).all 6321 6322 -- Note that Prefix'Address is recursively expanded into a call 6323 -- to Base_Address (Obj.Tag) 6324 6325 -- Not needed for VM targets, since all handled by the VM 6326 6327 if Tagged_Type_Expansion then 6328 Rewrite (N, 6329 Make_Explicit_Dereference (Loc, 6330 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 6331 Make_Attribute_Reference (Loc, 6332 Prefix => Relocate_Node (Pref), 6333 Attribute_Name => Name_Address)))); 6334 Analyze_And_Resolve (N, RTE (RE_Tag)); 6335 end if; 6336 6337 else 6338 Rewrite (N, 6339 Make_Selected_Component (Loc, 6340 Prefix => Relocate_Node (Pref), 6341 Selector_Name => 6342 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc))); 6343 Analyze_And_Resolve (N, RTE (RE_Tag)); 6344 end if; 6345 end Tag; 6346 6347 ---------------- 6348 -- Terminated -- 6349 ---------------- 6350 6351 -- Transforms 'Terminated attribute into a call to Terminated function 6352 6353 when Attribute_Terminated => Terminated : begin 6354 6355 -- The prefix of Terminated is of a task interface class-wide type. 6356 -- Generate: 6357 -- terminated (Task_Id (_disp_get_task_id (Pref))); 6358 6359 if Ada_Version >= Ada_2005 6360 and then Ekind (Ptyp) = E_Class_Wide_Type 6361 and then Is_Interface (Ptyp) 6362 and then Is_Task_Interface (Ptyp) 6363 then 6364 Rewrite (N, 6365 Make_Function_Call (Loc, 6366 Name => 6367 New_Occurrence_Of (RTE (RE_Terminated), Loc), 6368 Parameter_Associations => New_List ( 6369 Make_Unchecked_Type_Conversion (Loc, 6370 Subtype_Mark => 6371 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 6372 Expression => Build_Disp_Get_Task_Id_Call (Pref))))); 6373 6374 elsif Restricted_Profile then 6375 Rewrite (N, 6376 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated))); 6377 6378 else 6379 Rewrite (N, 6380 Build_Call_With_Task (Pref, RTE (RE_Terminated))); 6381 end if; 6382 6383 Analyze_And_Resolve (N, Standard_Boolean); 6384 end Terminated; 6385 6386 ---------------- 6387 -- To_Address -- 6388 ---------------- 6389 6390 -- Transforms System'To_Address (X) and System.Address'Ref (X) into 6391 -- unchecked conversion from (integral) type of X to type address. If 6392 -- the To_Address is a static expression, the transformed expression 6393 -- also needs to be static, because we do some legality checks (e.g. 6394 -- for Thread_Local_Storage) after this transformation. 6395 6396 when Attribute_Ref 6397 | Attribute_To_Address 6398 => 6399 To_Address : declare 6400 Is_Static : constant Boolean := Is_Static_Expression (N); 6401 6402 begin 6403 Rewrite (N, 6404 Unchecked_Convert_To (RTE (RE_Address), 6405 Relocate_Node (First (Exprs)))); 6406 Set_Is_Static_Expression (N, Is_Static); 6407 6408 Analyze_And_Resolve (N, RTE (RE_Address)); 6409 end To_Address; 6410 6411 ------------ 6412 -- To_Any -- 6413 ------------ 6414 6415 when Attribute_To_Any => To_Any : declare 6416 P_Type : constant Entity_Id := Etype (Pref); 6417 Decls : constant List_Id := New_List; 6418 begin 6419 Rewrite (N, 6420 Build_To_Any_Call 6421 (Loc, 6422 Convert_To (P_Type, 6423 Relocate_Node (First (Exprs))), Decls)); 6424 Insert_Actions (N, Decls); 6425 Analyze_And_Resolve (N, RTE (RE_Any)); 6426 end To_Any; 6427 6428 ---------------- 6429 -- Truncation -- 6430 ---------------- 6431 6432 -- Transforms 'Truncation into a call to the floating-point attribute 6433 -- function Truncation in Fat_xxx (where xxx is the root type). 6434 -- Expansion is avoided for cases the back end can handle directly. 6435 6436 when Attribute_Truncation => 6437 if not Is_Inline_Floating_Point_Attribute (N) then 6438 Expand_Fpt_Attribute_R (N); 6439 end if; 6440 6441 -------------- 6442 -- TypeCode -- 6443 -------------- 6444 6445 when Attribute_TypeCode => TypeCode : declare 6446 P_Type : constant Entity_Id := Etype (Pref); 6447 Decls : constant List_Id := New_List; 6448 begin 6449 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls)); 6450 Insert_Actions (N, Decls); 6451 Analyze_And_Resolve (N, RTE (RE_TypeCode)); 6452 end TypeCode; 6453 6454 ----------------------- 6455 -- Unbiased_Rounding -- 6456 ----------------------- 6457 6458 -- Transforms 'Unbiased_Rounding into a call to the floating-point 6459 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the 6460 -- root type). Expansion is avoided for cases the back end can handle 6461 -- directly. 6462 6463 when Attribute_Unbiased_Rounding => 6464 if not Is_Inline_Floating_Point_Attribute (N) then 6465 Expand_Fpt_Attribute_R (N); 6466 end if; 6467 6468 ------------ 6469 -- Update -- 6470 ------------ 6471 6472 when Attribute_Update => 6473 Expand_Update_Attribute (N); 6474 6475 --------------- 6476 -- VADS_Size -- 6477 --------------- 6478 6479 -- The processing for VADS_Size is shared with Size 6480 6481 --------- 6482 -- Val -- 6483 --------- 6484 6485 -- For enumeration types with a standard representation, and for all 6486 -- other types, Val is handled by the back end. For enumeration types 6487 -- with a non-standard representation we use the _Pos_To_Rep array that 6488 -- was created when the type was frozen. 6489 6490 when Attribute_Val => Val : declare 6491 Etyp : constant Entity_Id := Base_Type (Entity (Pref)); 6492 6493 begin 6494 if Is_Enumeration_Type (Etyp) 6495 and then Present (Enum_Pos_To_Rep (Etyp)) 6496 then 6497 if Has_Contiguous_Rep (Etyp) then 6498 declare 6499 Rep_Node : constant Node_Id := 6500 Unchecked_Convert_To (Etyp, 6501 Make_Op_Add (Loc, 6502 Left_Opnd => 6503 Make_Integer_Literal (Loc, 6504 Enumeration_Rep (First_Literal (Etyp))), 6505 Right_Opnd => 6506 (Convert_To (Standard_Integer, 6507 Relocate_Node (First (Exprs)))))); 6508 6509 begin 6510 Rewrite (N, 6511 Unchecked_Convert_To (Etyp, 6512 Make_Op_Add (Loc, 6513 Left_Opnd => 6514 Make_Integer_Literal (Loc, 6515 Enumeration_Rep (First_Literal (Etyp))), 6516 Right_Opnd => 6517 Make_Function_Call (Loc, 6518 Name => 6519 New_Occurrence_Of 6520 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 6521 Parameter_Associations => New_List ( 6522 Rep_Node, 6523 Rep_To_Pos_Flag (Etyp, Loc)))))); 6524 end; 6525 6526 else 6527 Rewrite (N, 6528 Make_Indexed_Component (Loc, 6529 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc), 6530 Expressions => New_List ( 6531 Convert_To (Standard_Integer, 6532 Relocate_Node (First (Exprs)))))); 6533 end if; 6534 6535 Analyze_And_Resolve (N, Typ); 6536 6537 -- If the argument is marked as requiring a range check then generate 6538 -- it here. 6539 6540 elsif Do_Range_Check (First (Exprs)) then 6541 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed); 6542 end if; 6543 end Val; 6544 6545 ----------- 6546 -- Valid -- 6547 ----------- 6548 6549 -- The code for valid is dependent on the particular types involved. 6550 -- See separate sections below for the generated code in each case. 6551 6552 when Attribute_Valid => Valid : declare 6553 PBtyp : Entity_Id := Base_Type (Ptyp); 6554 6555 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On; 6556 -- Save the validity checking mode. We always turn off validity 6557 -- checking during process of 'Valid since this is one place 6558 -- where we do not want the implicit validity checks to interfere 6559 -- with the explicit validity check that the programmer is doing. 6560 6561 function Make_Range_Test return Node_Id; 6562 -- Build the code for a range test of the form 6563 -- PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last) 6564 6565 --------------------- 6566 -- Make_Range_Test -- 6567 --------------------- 6568 6569 function Make_Range_Test return Node_Id is 6570 Temp : Node_Id; 6571 6572 begin 6573 -- The prefix of attribute 'Valid should always denote an object 6574 -- reference. The reference is either coming directly from source 6575 -- or is produced by validity check expansion. The object may be 6576 -- wrapped in a conversion in which case the call to Unqual_Conv 6577 -- will yield it. 6578 6579 -- If the prefix denotes a variable which captures the value of 6580 -- an object for validation purposes, use the variable in the 6581 -- range test. This ensures that no extra copies or extra reads 6582 -- are produced as part of the test. Generate: 6583 6584 -- Temp : ... := Object; 6585 -- if not Temp in ... then 6586 6587 if Is_Validation_Variable_Reference (Pref) then 6588 Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc); 6589 6590 -- Otherwise the prefix is either a source object or a constant 6591 -- produced by validity check expansion. Generate: 6592 6593 -- Temp : constant ... := Pref; 6594 -- if not Temp in ... then 6595 6596 else 6597 Temp := Duplicate_Subexpr (Pref); 6598 end if; 6599 6600 return 6601 Make_In (Loc, 6602 Left_Opnd => Unchecked_Convert_To (PBtyp, Temp), 6603 Right_Opnd => 6604 Make_Range (Loc, 6605 Low_Bound => 6606 Unchecked_Convert_To (PBtyp, 6607 Make_Attribute_Reference (Loc, 6608 Prefix => New_Occurrence_Of (Ptyp, Loc), 6609 Attribute_Name => Name_First)), 6610 High_Bound => 6611 Unchecked_Convert_To (PBtyp, 6612 Make_Attribute_Reference (Loc, 6613 Prefix => New_Occurrence_Of (Ptyp, Loc), 6614 Attribute_Name => Name_Last)))); 6615 end Make_Range_Test; 6616 6617 -- Local variables 6618 6619 Tst : Node_Id; 6620 6621 -- Start of processing for Attribute_Valid 6622 6623 begin 6624 -- Do not expand sourced code 'Valid reference in CodePeer mode, 6625 -- will be handled by the back-end directly. 6626 6627 if CodePeer_Mode and then Comes_From_Source (N) then 6628 return; 6629 end if; 6630 6631 -- Turn off validity checks. We do not want any implicit validity 6632 -- checks to intefere with the explicit check from the attribute 6633 6634 Validity_Checks_On := False; 6635 6636 -- Retrieve the base type. Handle the case where the base type is a 6637 -- private enumeration type. 6638 6639 if Is_Private_Type (PBtyp) and then Present (Full_View (PBtyp)) then 6640 PBtyp := Full_View (PBtyp); 6641 end if; 6642 6643 -- Floating-point case. This case is handled by the Valid attribute 6644 -- code in the floating-point attribute run-time library. 6645 6646 if Is_Floating_Point_Type (Ptyp) then 6647 Float_Valid : declare 6648 Pkg : RE_Id; 6649 Ftp : Entity_Id; 6650 6651 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id; 6652 -- Return entity for Pkg.Nam 6653 6654 -------------------- 6655 -- Get_Fat_Entity -- 6656 -------------------- 6657 6658 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is 6659 Exp_Name : constant Node_Id := 6660 Make_Selected_Component (Loc, 6661 Prefix => New_Occurrence_Of (RTE (Pkg), Loc), 6662 Selector_Name => Make_Identifier (Loc, Nam)); 6663 begin 6664 Find_Selected_Component (Exp_Name); 6665 return Entity (Exp_Name); 6666 end Get_Fat_Entity; 6667 6668 -- Start of processing for Float_Valid 6669 6670 begin 6671 -- The C and AAMP back-ends handle Valid for fpt types 6672 6673 if Modify_Tree_For_C or else Float_Rep (PBtyp) = AAMP then 6674 Analyze_And_Resolve (Pref, Ptyp); 6675 Set_Etype (N, Standard_Boolean); 6676 Set_Analyzed (N); 6677 6678 else 6679 Find_Fat_Info (Ptyp, Ftp, Pkg); 6680 6681 -- If the prefix is a reverse SSO component, or is possibly 6682 -- unaligned, first create a temporary copy that is in 6683 -- native SSO, and properly aligned. Make it Volatile to 6684 -- prevent folding in the back-end. Note that we use an 6685 -- intermediate constrained string type to initialize the 6686 -- temporary, as the value at hand might be invalid, and in 6687 -- that case it cannot be copied using a floating point 6688 -- register. 6689 6690 if In_Reverse_Storage_Order_Object (Pref) 6691 or else Is_Possibly_Unaligned_Object (Pref) 6692 then 6693 declare 6694 Temp : constant Entity_Id := 6695 Make_Temporary (Loc, 'F'); 6696 6697 Fat_S : constant Entity_Id := 6698 Get_Fat_Entity (Name_S); 6699 -- Constrained string subtype of appropriate size 6700 6701 Fat_P : constant Entity_Id := 6702 Get_Fat_Entity (Name_P); 6703 -- Access to Fat_S 6704 6705 Decl : constant Node_Id := 6706 Make_Object_Declaration (Loc, 6707 Defining_Identifier => Temp, 6708 Aliased_Present => True, 6709 Object_Definition => 6710 New_Occurrence_Of (Ptyp, Loc)); 6711 6712 begin 6713 Set_Aspect_Specifications (Decl, New_List ( 6714 Make_Aspect_Specification (Loc, 6715 Identifier => 6716 Make_Identifier (Loc, Name_Volatile)))); 6717 6718 Insert_Actions (N, 6719 New_List ( 6720 Decl, 6721 6722 Make_Assignment_Statement (Loc, 6723 Name => 6724 Make_Explicit_Dereference (Loc, 6725 Prefix => 6726 Unchecked_Convert_To (Fat_P, 6727 Make_Attribute_Reference (Loc, 6728 Prefix => 6729 New_Occurrence_Of (Temp, Loc), 6730 Attribute_Name => 6731 Name_Unrestricted_Access))), 6732 Expression => 6733 Unchecked_Convert_To (Fat_S, 6734 Relocate_Node (Pref)))), 6735 6736 Suppress => All_Checks); 6737 6738 Rewrite (Pref, New_Occurrence_Of (Temp, Loc)); 6739 end; 6740 end if; 6741 6742 -- We now have an object of the proper endianness and 6743 -- alignment, and can construct a Valid attribute. 6744 6745 -- We make sure the prefix of this valid attribute is 6746 -- marked as not coming from source, to avoid losing 6747 -- warnings from 'Valid looking like a possible update. 6748 6749 Set_Comes_From_Source (Pref, False); 6750 6751 Expand_Fpt_Attribute 6752 (N, Pkg, Name_Valid, 6753 New_List ( 6754 Make_Attribute_Reference (Loc, 6755 Prefix => Unchecked_Convert_To (Ftp, Pref), 6756 Attribute_Name => Name_Unrestricted_Access))); 6757 end if; 6758 6759 -- One more task, we still need a range check. Required 6760 -- only if we have a constraint, since the Valid routine 6761 -- catches infinities properly (infinities are never valid). 6762 6763 -- The way we do the range check is simply to create the 6764 -- expression: Valid (N) and then Base_Type(Pref) in Typ. 6765 6766 if not Subtypes_Statically_Match (Ptyp, PBtyp) then 6767 Rewrite (N, 6768 Make_And_Then (Loc, 6769 Left_Opnd => Relocate_Node (N), 6770 Right_Opnd => 6771 Make_In (Loc, 6772 Left_Opnd => Convert_To (PBtyp, Pref), 6773 Right_Opnd => New_Occurrence_Of (Ptyp, Loc)))); 6774 end if; 6775 end Float_Valid; 6776 6777 -- Enumeration type with holes 6778 6779 -- For enumeration types with holes, the Pos value constructed by 6780 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a 6781 -- second argument of False returns minus one for an invalid value, 6782 -- and the non-negative pos value for a valid value, so the 6783 -- expansion of X'Valid is simply: 6784 6785 -- type(X)'Pos (X) >= 0 6786 6787 -- We can't quite generate it that way because of the requirement 6788 -- for the non-standard second argument of False in the resulting 6789 -- rep_to_pos call, so we have to explicitly create: 6790 6791 -- _rep_to_pos (X, False) >= 0 6792 6793 -- If we have an enumeration subtype, we also check that the 6794 -- value is in range: 6795 6796 -- _rep_to_pos (X, False) >= 0 6797 -- and then 6798 -- (X >= type(X)'First and then type(X)'Last <= X) 6799 6800 elsif Is_Enumeration_Type (Ptyp) 6801 and then Present (Enum_Pos_To_Rep (PBtyp)) 6802 then 6803 Tst := 6804 Make_Op_Ge (Loc, 6805 Left_Opnd => 6806 Make_Function_Call (Loc, 6807 Name => 6808 New_Occurrence_Of (TSS (PBtyp, TSS_Rep_To_Pos), Loc), 6809 Parameter_Associations => New_List ( 6810 Pref, 6811 New_Occurrence_Of (Standard_False, Loc))), 6812 Right_Opnd => Make_Integer_Literal (Loc, 0)); 6813 6814 if Ptyp /= PBtyp 6815 and then 6816 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (PBtyp) 6817 or else 6818 Type_High_Bound (Ptyp) /= Type_High_Bound (PBtyp)) 6819 then 6820 -- The call to Make_Range_Test will create declarations 6821 -- that need a proper insertion point, but Pref is now 6822 -- attached to a node with no ancestor. Attach to tree 6823 -- even if it is to be rewritten below. 6824 6825 Set_Parent (Tst, Parent (N)); 6826 6827 Tst := 6828 Make_And_Then (Loc, 6829 Left_Opnd => Make_Range_Test, 6830 Right_Opnd => Tst); 6831 end if; 6832 6833 Rewrite (N, Tst); 6834 6835 -- Fortran convention booleans 6836 6837 -- For the very special case of Fortran convention booleans, the 6838 -- value is always valid, since it is an integer with the semantics 6839 -- that non-zero is true, and any value is permissible. 6840 6841 elsif Is_Boolean_Type (Ptyp) 6842 and then Convention (Ptyp) = Convention_Fortran 6843 then 6844 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 6845 6846 -- For biased representations, we will be doing an unchecked 6847 -- conversion without unbiasing the result. That means that the range 6848 -- test has to take this into account, and the proper form of the 6849 -- test is: 6850 6851 -- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length) 6852 6853 elsif Has_Biased_Representation (Ptyp) then 6854 PBtyp := RTE (RE_Unsigned_32); 6855 Rewrite (N, 6856 Make_Op_Lt (Loc, 6857 Left_Opnd => 6858 Unchecked_Convert_To (PBtyp, Duplicate_Subexpr (Pref)), 6859 Right_Opnd => 6860 Unchecked_Convert_To (PBtyp, 6861 Make_Attribute_Reference (Loc, 6862 Prefix => New_Occurrence_Of (Ptyp, Loc), 6863 Attribute_Name => Name_Range_Length)))); 6864 6865 -- For all other scalar types, what we want logically is a 6866 -- range test: 6867 6868 -- X in type(X)'First .. type(X)'Last 6869 6870 -- But that's precisely what won't work because of possible 6871 -- unwanted optimization (and indeed the basic motivation for 6872 -- the Valid attribute is exactly that this test does not work). 6873 -- What will work is: 6874 6875 -- PBtyp!(X) >= PBtyp!(type(X)'First) 6876 -- and then 6877 -- PBtyp!(X) <= PBtyp!(type(X)'Last) 6878 6879 -- where PBtyp is an integer type large enough to cover the full 6880 -- range of possible stored values (i.e. it is chosen on the basis 6881 -- of the size of the type, not the range of the values). We write 6882 -- this as two tests, rather than a range check, so that static 6883 -- evaluation will easily remove either or both of the checks if 6884 -- they can be -statically determined to be true (this happens 6885 -- when the type of X is static and the range extends to the full 6886 -- range of stored values). 6887 6888 -- Unsigned types. Note: it is safe to consider only whether the 6889 -- subtype is unsigned, since we will in that case be doing all 6890 -- unsigned comparisons based on the subtype range. Since we use the 6891 -- actual subtype object size, this is appropriate. 6892 6893 -- For example, if we have 6894 6895 -- subtype x is integer range 1 .. 200; 6896 -- for x'Object_Size use 8; 6897 6898 -- Now the base type is signed, but objects of this type are bits 6899 -- unsigned, and doing an unsigned test of the range 1 to 200 is 6900 -- correct, even though a value greater than 127 looks signed to a 6901 -- signed comparison. 6902 6903 elsif Is_Unsigned_Type (Ptyp) 6904 or else (Is_Private_Type (Ptyp) and then Is_Unsigned_Type (Btyp)) 6905 then 6906 if Esize (Ptyp) <= 32 then 6907 PBtyp := RTE (RE_Unsigned_32); 6908 else 6909 PBtyp := RTE (RE_Unsigned_64); 6910 end if; 6911 6912 Rewrite (N, Make_Range_Test); 6913 6914 -- Signed types 6915 6916 else 6917 if Esize (Ptyp) <= Esize (Standard_Integer) then 6918 PBtyp := Standard_Integer; 6919 else 6920 PBtyp := Universal_Integer; 6921 end if; 6922 6923 Rewrite (N, Make_Range_Test); 6924 end if; 6925 6926 -- If a predicate is present, then we do the predicate test, even if 6927 -- within the predicate function (infinite recursion is warned about 6928 -- in Sem_Attr in that case). 6929 6930 declare 6931 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp); 6932 6933 begin 6934 if Present (Pred_Func) then 6935 Rewrite (N, 6936 Make_And_Then (Loc, 6937 Left_Opnd => Relocate_Node (N), 6938 Right_Opnd => Make_Predicate_Call (Ptyp, Pref))); 6939 end if; 6940 end; 6941 6942 Analyze_And_Resolve (N, Standard_Boolean); 6943 Validity_Checks_On := Save_Validity_Checks_On; 6944 end Valid; 6945 6946 ------------------- 6947 -- Valid_Scalars -- 6948 ------------------- 6949 6950 when Attribute_Valid_Scalars => Valid_Scalars : declare 6951 Val_Typ : constant Entity_Id := Validated_View (Ptyp); 6952 Comp_Typ : Entity_Id; 6953 Expr : Node_Id; 6954 6955 begin 6956 -- Assume that the prefix does not need validation 6957 6958 Expr := Empty; 6959 6960 -- Attribute 'Valid_Scalars is not supported on private tagged types 6961 6962 if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then 6963 null; 6964 6965 -- Attribute 'Valid_Scalars evaluates to True when the type lacks 6966 -- scalars. 6967 6968 elsif not Scalar_Part_Present (Val_Typ) then 6969 null; 6970 6971 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the 6972 -- validated type is a scalar type. Generate: 6973 6974 -- Val_Typ (Pref)'Valid 6975 6976 elsif Is_Scalar_Type (Val_Typ) then 6977 Expr := 6978 Make_Attribute_Reference (Loc, 6979 Prefix => 6980 Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)), 6981 Attribute_Name => Name_Valid); 6982 6983 -- Validate the scalar components of an array by iterating over all 6984 -- dimensions of the array while checking individual components. 6985 6986 elsif Is_Array_Type (Val_Typ) then 6987 Comp_Typ := Validated_View (Component_Type (Val_Typ)); 6988 6989 if Scalar_Part_Present (Comp_Typ) then 6990 Expr := 6991 Make_Function_Call (Loc, 6992 Name => 6993 New_Occurrence_Of 6994 (Build_Array_VS_Func 6995 (Attr => N, 6996 Formal_Typ => Ptyp, 6997 Array_Typ => Val_Typ, 6998 Comp_Typ => Comp_Typ), 6999 Loc), 7000 Parameter_Associations => New_List (Pref)); 7001 end if; 7002 7003 -- Validate the scalar components, discriminants of a record type by 7004 -- examining the structure of a record type. 7005 7006 elsif Is_Record_Type (Val_Typ) then 7007 Expr := 7008 Make_Function_Call (Loc, 7009 Name => 7010 New_Occurrence_Of 7011 (Build_Record_VS_Func 7012 (Attr => N, 7013 Formal_Typ => Ptyp, 7014 Rec_Typ => Val_Typ), 7015 Loc), 7016 Parameter_Associations => New_List (Pref)); 7017 end if; 7018 7019 -- Default the attribute to True when the type of the prefix does not 7020 -- need validation. 7021 7022 if No (Expr) then 7023 Expr := New_Occurrence_Of (Standard_True, Loc); 7024 end if; 7025 7026 Rewrite (N, Expr); 7027 Analyze_And_Resolve (N, Standard_Boolean); 7028 Set_Is_Static_Expression (N, False); 7029 end Valid_Scalars; 7030 7031 ----------- 7032 -- Value -- 7033 ----------- 7034 7035 -- Value attribute is handled in separate unit Exp_Imgv 7036 7037 when Attribute_Value => 7038 Exp_Imgv.Expand_Value_Attribute (N); 7039 7040 ----------------- 7041 -- Value_Size -- 7042 ----------------- 7043 7044 -- The processing for Value_Size shares the processing for Size 7045 7046 ------------- 7047 -- Version -- 7048 ------------- 7049 7050 -- The processing for Version shares the processing for Body_Version 7051 7052 ---------------- 7053 -- Wide_Image -- 7054 ---------------- 7055 7056 -- Wide_Image attribute is handled in separate unit Exp_Imgv 7057 7058 when Attribute_Wide_Image => 7059 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil 7060 -- back-end knows how to handle this attribute directly. 7061 7062 if CodePeer_Mode then 7063 return; 7064 end if; 7065 7066 Exp_Imgv.Expand_Wide_Image_Attribute (N); 7067 7068 --------------------- 7069 -- Wide_Wide_Image -- 7070 --------------------- 7071 7072 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv 7073 7074 when Attribute_Wide_Wide_Image => 7075 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil 7076 -- back-end knows how to handle this attribute directly. 7077 7078 if CodePeer_Mode then 7079 return; 7080 end if; 7081 7082 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N); 7083 7084 ---------------- 7085 -- Wide_Value -- 7086 ---------------- 7087 7088 -- We expand typ'Wide_Value (X) into 7089 7090 -- typ'Value 7091 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method)) 7092 7093 -- Wide_String_To_String is a runtime function that converts its wide 7094 -- string argument to String, converting any non-translatable characters 7095 -- into appropriate escape sequences. This preserves the required 7096 -- semantics of Wide_Value in all cases, and results in a very simple 7097 -- implementation approach. 7098 7099 -- Note: for this approach to be fully standard compliant for the cases 7100 -- where typ is Wide_Character and Wide_Wide_Character, the encoding 7101 -- method must cover the entire character range (e.g. UTF-8). But that 7102 -- is a reasonable requirement when dealing with encoded character 7103 -- sequences. Presumably if one of the restrictive encoding mechanisms 7104 -- is in use such as Shift-JIS, then characters that cannot be 7105 -- represented using this encoding will not appear in any case. 7106 7107 when Attribute_Wide_Value => 7108 Rewrite (N, 7109 Make_Attribute_Reference (Loc, 7110 Prefix => Pref, 7111 Attribute_Name => Name_Value, 7112 7113 Expressions => New_List ( 7114 Make_Function_Call (Loc, 7115 Name => 7116 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc), 7117 7118 Parameter_Associations => New_List ( 7119 Relocate_Node (First (Exprs)), 7120 Make_Integer_Literal (Loc, 7121 Intval => Int (Wide_Character_Encoding_Method))))))); 7122 7123 Analyze_And_Resolve (N, Typ); 7124 7125 --------------------- 7126 -- Wide_Wide_Value -- 7127 --------------------- 7128 7129 -- We expand typ'Wide_Value_Value (X) into 7130 7131 -- typ'Value 7132 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method)) 7133 7134 -- Wide_Wide_String_To_String is a runtime function that converts its 7135 -- wide string argument to String, converting any non-translatable 7136 -- characters into appropriate escape sequences. This preserves the 7137 -- required semantics of Wide_Wide_Value in all cases, and results in a 7138 -- very simple implementation approach. 7139 7140 -- It's not quite right where typ = Wide_Wide_Character, because the 7141 -- encoding method may not cover the whole character type ??? 7142 7143 when Attribute_Wide_Wide_Value => 7144 Rewrite (N, 7145 Make_Attribute_Reference (Loc, 7146 Prefix => Pref, 7147 Attribute_Name => Name_Value, 7148 7149 Expressions => New_List ( 7150 Make_Function_Call (Loc, 7151 Name => 7152 New_Occurrence_Of 7153 (RTE (RE_Wide_Wide_String_To_String), Loc), 7154 7155 Parameter_Associations => New_List ( 7156 Relocate_Node (First (Exprs)), 7157 Make_Integer_Literal (Loc, 7158 Intval => Int (Wide_Character_Encoding_Method))))))); 7159 7160 Analyze_And_Resolve (N, Typ); 7161 7162 --------------------- 7163 -- Wide_Wide_Width -- 7164 --------------------- 7165 7166 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv 7167 7168 when Attribute_Wide_Wide_Width => 7169 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide); 7170 7171 ---------------- 7172 -- Wide_Width -- 7173 ---------------- 7174 7175 -- Wide_Width attribute is handled in separate unit Exp_Imgv 7176 7177 when Attribute_Wide_Width => 7178 Exp_Imgv.Expand_Width_Attribute (N, Wide); 7179 7180 ----------- 7181 -- Width -- 7182 ----------- 7183 7184 -- Width attribute is handled in separate unit Exp_Imgv 7185 7186 when Attribute_Width => 7187 Exp_Imgv.Expand_Width_Attribute (N, Normal); 7188 7189 ----------- 7190 -- Write -- 7191 ----------- 7192 7193 when Attribute_Write => Write : declare 7194 P_Type : constant Entity_Id := Entity (Pref); 7195 U_Type : constant Entity_Id := Underlying_Type (P_Type); 7196 Pname : Entity_Id; 7197 Decl : Node_Id; 7198 Prag : Node_Id; 7199 Arg3 : Node_Id; 7200 Wfunc : Node_Id; 7201 7202 begin 7203 -- If no underlying type, we have an error that will be diagnosed 7204 -- elsewhere, so here we just completely ignore the expansion. 7205 7206 if No (U_Type) then 7207 return; 7208 end if; 7209 7210 -- Stream operations can appear in user code even if the restriction 7211 -- No_Streams is active (for example, when instantiating a predefined 7212 -- container). In that case rewrite the attribute as a Raise to 7213 -- prevent any run-time use. 7214 7215 if Restriction_Active (No_Streams) then 7216 Rewrite (N, 7217 Make_Raise_Program_Error (Sloc (N), 7218 Reason => PE_Stream_Operation_Not_Allowed)); 7219 Set_Etype (N, U_Type); 7220 return; 7221 end if; 7222 7223 -- The simple case, if there is a TSS for Write, just call it 7224 7225 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write); 7226 7227 if Present (Pname) then 7228 null; 7229 7230 else 7231 -- If there is a Stream_Convert pragma, use it, we rewrite 7232 7233 -- sourcetyp'Output (stream, Item) 7234 7235 -- as 7236 7237 -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); 7238 7239 -- where strmwrite is the given Write function that converts an 7240 -- argument of type sourcetyp or a type acctyp, from which it is 7241 -- derived to type strmtyp. The conversion to acttyp is required 7242 -- for the derived case. 7243 7244 Prag := Get_Stream_Convert_Pragma (P_Type); 7245 7246 if Present (Prag) then 7247 Arg3 := 7248 Next (Next (First (Pragma_Argument_Associations (Prag)))); 7249 Wfunc := Entity (Expression (Arg3)); 7250 7251 Rewrite (N, 7252 Make_Attribute_Reference (Loc, 7253 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), 7254 Attribute_Name => Name_Output, 7255 Expressions => New_List ( 7256 Relocate_Node (First (Exprs)), 7257 Make_Function_Call (Loc, 7258 Name => New_Occurrence_Of (Wfunc, Loc), 7259 Parameter_Associations => New_List ( 7260 OK_Convert_To (Etype (First_Formal (Wfunc)), 7261 Relocate_Node (Next (First (Exprs))))))))); 7262 7263 Analyze (N); 7264 return; 7265 7266 -- For elementary types, we call the W_xxx routine directly 7267 7268 elsif Is_Elementary_Type (U_Type) then 7269 Rewrite (N, Build_Elementary_Write_Call (N)); 7270 Analyze (N); 7271 return; 7272 7273 -- Array type case 7274 7275 elsif Is_Array_Type (U_Type) then 7276 Build_Array_Write_Procedure (N, U_Type, Decl, Pname); 7277 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 7278 7279 -- Tagged type case, use the primitive Write function. Note that 7280 -- this will dispatch in the class-wide case which is what we want 7281 7282 elsif Is_Tagged_Type (U_Type) then 7283 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write); 7284 7285 -- All other record type cases, including protected records. 7286 -- The latter only arise for expander generated code for 7287 -- handling shared passive partition access. 7288 7289 else 7290 pragma Assert 7291 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 7292 7293 -- Ada 2005 (AI-216): Program_Error is raised when executing 7294 -- the default implementation of the Write attribute of an 7295 -- Unchecked_Union type. However, if the 'Write reference is 7296 -- within the generated Output stream procedure, Write outputs 7297 -- the components, and the default values of the discriminant 7298 -- are streamed by the Output procedure itself. If there are 7299 -- no default values this is also erroneous. 7300 7301 if Is_Unchecked_Union (Base_Type (U_Type)) then 7302 if (not Is_TSS (Current_Scope, TSS_Stream_Output) 7303 and not Is_TSS (Current_Scope, TSS_Stream_Write)) 7304 or else No (Discriminant_Default_Value 7305 (First_Discriminant (U_Type))) 7306 then 7307 Rewrite (N, 7308 Make_Raise_Program_Error (Loc, 7309 Reason => PE_Unchecked_Union_Restriction)); 7310 Set_Etype (N, U_Type); 7311 return; 7312 end if; 7313 end if; 7314 7315 if Has_Discriminants (U_Type) 7316 and then Present 7317 (Discriminant_Default_Value (First_Discriminant (U_Type))) 7318 then 7319 Build_Mutable_Record_Write_Procedure 7320 (Loc, Full_Base (U_Type), Decl, Pname); 7321 else 7322 Build_Record_Write_Procedure 7323 (Loc, Full_Base (U_Type), Decl, Pname); 7324 end if; 7325 7326 Insert_Action (N, Decl); 7327 end if; 7328 end if; 7329 7330 -- If we fall through, Pname is the procedure to be called 7331 7332 Rewrite_Stream_Proc_Call (Pname); 7333 end Write; 7334 7335 -- Component_Size is handled by the back end, unless the component size 7336 -- is known at compile time, which is always true in the packed array 7337 -- case. It is important that the packed array case is handled in the 7338 -- front end (see Eval_Attribute) since the back end would otherwise get 7339 -- confused by the equivalent packed array type. 7340 7341 when Attribute_Component_Size => 7342 null; 7343 7344 -- The following attributes are handled by the back end (except that 7345 -- static cases have already been evaluated during semantic processing, 7346 -- but in any case the back end should not count on this). 7347 7348 -- The back end also handles the non-class-wide cases of Size 7349 7350 when Attribute_Bit_Order 7351 | Attribute_Code_Address 7352 | Attribute_Definite 7353 | Attribute_Deref 7354 | Attribute_Null_Parameter 7355 | Attribute_Passed_By_Reference 7356 | Attribute_Pool_Address 7357 | Attribute_Scalar_Storage_Order 7358 => 7359 null; 7360 7361 -- The following attributes are also handled by the back end, but return 7362 -- a universal integer result, so may need a conversion for checking 7363 -- that the result is in range. 7364 7365 when Attribute_Aft 7366 | Attribute_Max_Alignment_For_Allocation 7367 => 7368 Apply_Universal_Integer_Attribute_Checks (N); 7369 7370 -- The following attributes should not appear at this stage, since they 7371 -- have already been handled by the analyzer (and properly rewritten 7372 -- with corresponding values or entities to represent the right values) 7373 7374 when Attribute_Abort_Signal 7375 | Attribute_Address_Size 7376 | Attribute_Atomic_Always_Lock_Free 7377 | Attribute_Base 7378 | Attribute_Class 7379 | Attribute_Compiler_Version 7380 | Attribute_Default_Bit_Order 7381 | Attribute_Default_Scalar_Storage_Order 7382 | Attribute_Delta 7383 | Attribute_Denorm 7384 | Attribute_Digits 7385 | Attribute_Emax 7386 | Attribute_Enabled 7387 | Attribute_Epsilon 7388 | Attribute_Fast_Math 7389 | Attribute_First_Valid 7390 | Attribute_Has_Access_Values 7391 | Attribute_Has_Discriminants 7392 | Attribute_Has_Tagged_Values 7393 | Attribute_Large 7394 | Attribute_Last_Valid 7395 | Attribute_Library_Level 7396 | Attribute_Lock_Free 7397 | Attribute_Machine_Emax 7398 | Attribute_Machine_Emin 7399 | Attribute_Machine_Mantissa 7400 | Attribute_Machine_Overflows 7401 | Attribute_Machine_Radix 7402 | Attribute_Machine_Rounds 7403 | Attribute_Maximum_Alignment 7404 | Attribute_Model_Emin 7405 | Attribute_Model_Epsilon 7406 | Attribute_Model_Mantissa 7407 | Attribute_Model_Small 7408 | Attribute_Modulus 7409 | Attribute_Partition_ID 7410 | Attribute_Range 7411 | Attribute_Restriction_Set 7412 | Attribute_Safe_Emax 7413 | Attribute_Safe_First 7414 | Attribute_Safe_Large 7415 | Attribute_Safe_Last 7416 | Attribute_Safe_Small 7417 | Attribute_Scale 7418 | Attribute_Signed_Zeros 7419 | Attribute_Small 7420 | Attribute_Storage_Unit 7421 | Attribute_Stub_Type 7422 | Attribute_System_Allocator_Alignment 7423 | Attribute_Target_Name 7424 | Attribute_Type_Class 7425 | Attribute_Type_Key 7426 | Attribute_Unconstrained_Array 7427 | Attribute_Universal_Literal_String 7428 | Attribute_Wchar_T_Size 7429 | Attribute_Word_Size 7430 => 7431 raise Program_Error; 7432 7433 -- The Asm_Input and Asm_Output attributes are not expanded at this 7434 -- stage, but will be eliminated in the expansion of the Asm call, see 7435 -- Exp_Intr for details. So the back end will never see these either. 7436 7437 when Attribute_Asm_Input 7438 | Attribute_Asm_Output 7439 => 7440 null; 7441 end case; 7442 7443 -- Note: as mentioned earlier, individual sections of the above case 7444 -- statement assume there is no code after the case statement, and are 7445 -- legitimately allowed to execute return statements if they have nothing 7446 -- more to do, so DO NOT add code at this point. 7447 7448 exception 7449 when RE_Not_Available => 7450 return; 7451 end Expand_N_Attribute_Reference; 7452 7453 -------------------------------- 7454 -- Expand_Pred_Succ_Attribute -- 7455 -------------------------------- 7456 7457 -- For typ'Pred (exp), we generate the check 7458 7459 -- [constraint_error when exp = typ'Base'First] 7460 7461 -- Similarly, for typ'Succ (exp), we generate the check 7462 7463 -- [constraint_error when exp = typ'Base'Last] 7464 7465 -- These checks are not generated for modular types, since the proper 7466 -- semantics for Succ and Pred on modular types is to wrap, not raise CE. 7467 -- We also suppress these checks if we are the right side of an assignment 7468 -- statement or the expression of an object declaration, where the flag 7469 -- Suppress_Assignment_Checks is set for the assignment/declaration. 7470 7471 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is 7472 Loc : constant Source_Ptr := Sloc (N); 7473 P : constant Node_Id := Parent (N); 7474 Cnam : Name_Id; 7475 7476 begin 7477 if Attribute_Name (N) = Name_Pred then 7478 Cnam := Name_First; 7479 else 7480 Cnam := Name_Last; 7481 end if; 7482 7483 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration) 7484 or else not Suppress_Assignment_Checks (P) 7485 then 7486 Insert_Action (N, 7487 Make_Raise_Constraint_Error (Loc, 7488 Condition => 7489 Make_Op_Eq (Loc, 7490 Left_Opnd => 7491 Duplicate_Subexpr_Move_Checks (First (Expressions (N))), 7492 Right_Opnd => 7493 Make_Attribute_Reference (Loc, 7494 Prefix => 7495 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc), 7496 Attribute_Name => Cnam)), 7497 Reason => CE_Overflow_Check_Failed)); 7498 end if; 7499 end Expand_Pred_Succ_Attribute; 7500 7501 --------------------------- 7502 -- Expand_Size_Attribute -- 7503 --------------------------- 7504 7505 procedure Expand_Size_Attribute (N : Node_Id) is 7506 Loc : constant Source_Ptr := Sloc (N); 7507 Typ : constant Entity_Id := Etype (N); 7508 Pref : constant Node_Id := Prefix (N); 7509 Ptyp : constant Entity_Id := Etype (Pref); 7510 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); 7511 Siz : Uint; 7512 7513 begin 7514 -- Case of known RM_Size of a type 7515 7516 if (Id = Attribute_Size or else Id = Attribute_Value_Size) 7517 and then Is_Entity_Name (Pref) 7518 and then Is_Type (Entity (Pref)) 7519 and then Known_Static_RM_Size (Entity (Pref)) 7520 then 7521 Siz := RM_Size (Entity (Pref)); 7522 7523 -- Case of known Esize of a type 7524 7525 elsif Id = Attribute_Object_Size 7526 and then Is_Entity_Name (Pref) 7527 and then Is_Type (Entity (Pref)) 7528 and then Known_Static_Esize (Entity (Pref)) 7529 then 7530 Siz := Esize (Entity (Pref)); 7531 7532 -- Case of known size of object 7533 7534 elsif Id = Attribute_Size 7535 and then Is_Entity_Name (Pref) 7536 and then Is_Object (Entity (Pref)) 7537 and then Known_Esize (Entity (Pref)) 7538 and then Known_Static_Esize (Entity (Pref)) 7539 then 7540 Siz := Esize (Entity (Pref)); 7541 7542 -- For an array component, we can do Size in the front end if the 7543 -- component_size of the array is set. 7544 7545 elsif Nkind (Pref) = N_Indexed_Component then 7546 Siz := Component_Size (Etype (Prefix (Pref))); 7547 7548 -- For a record component, we can do Size in the front end if there is a 7549 -- component clause, or if the record is packed and the component's size 7550 -- is known at compile time. 7551 7552 elsif Nkind (Pref) = N_Selected_Component then 7553 declare 7554 Rec : constant Entity_Id := Etype (Prefix (Pref)); 7555 Comp : constant Entity_Id := Entity (Selector_Name (Pref)); 7556 7557 begin 7558 if Present (Component_Clause (Comp)) then 7559 Siz := Esize (Comp); 7560 7561 elsif Is_Packed (Rec) then 7562 Siz := RM_Size (Ptyp); 7563 7564 else 7565 Apply_Universal_Integer_Attribute_Checks (N); 7566 return; 7567 end if; 7568 end; 7569 7570 -- All other cases are handled by the back end 7571 7572 else 7573 -- If Size is applied to a formal parameter that is of a packed 7574 -- array subtype, then apply Size to the actual subtype. 7575 7576 if Is_Entity_Name (Pref) 7577 and then Is_Formal (Entity (Pref)) 7578 and then Is_Array_Type (Ptyp) 7579 and then Is_Packed (Ptyp) 7580 then 7581 Rewrite (N, 7582 Make_Attribute_Reference (Loc, 7583 Prefix => 7584 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc), 7585 Attribute_Name => Name_Size)); 7586 Analyze_And_Resolve (N, Typ); 7587 7588 -- If Size is applied to a dereference of an access to unconstrained 7589 -- packed array, the back end needs to see its unconstrained nominal 7590 -- type, but also a hint to the actual constrained type. 7591 7592 elsif Nkind (Pref) = N_Explicit_Dereference 7593 and then Is_Array_Type (Ptyp) 7594 and then not Is_Constrained (Ptyp) 7595 and then Is_Packed (Ptyp) 7596 then 7597 Set_Actual_Designated_Subtype (Pref, Get_Actual_Subtype (Pref)); 7598 7599 -- If Size was applied to a slice of a bit-packed array, we rewrite 7600 -- it into the product of Length and Component_Size. We need to do so 7601 -- because bit-packed arrays are represented internally as arrays of 7602 -- System.Unsigned_Types.Packed_Byte for code generation purposes so 7603 -- the size is always rounded up in the back end. 7604 7605 elsif Nkind (Pref) = N_Slice and then Is_Bit_Packed_Array (Ptyp) then 7606 Rewrite (N, 7607 Make_Op_Multiply (Loc, 7608 Make_Attribute_Reference (Loc, 7609 Prefix => Duplicate_Subexpr (Pref, True), 7610 Attribute_Name => Name_Length), 7611 Make_Attribute_Reference (Loc, 7612 Prefix => Duplicate_Subexpr (Pref, True), 7613 Attribute_Name => Name_Component_Size))); 7614 Analyze_And_Resolve (N, Typ); 7615 end if; 7616 7617 -- Apply the required checks last, after rewriting has taken place 7618 7619 Apply_Universal_Integer_Attribute_Checks (N); 7620 return; 7621 end if; 7622 7623 -- Common processing for record and array component case 7624 7625 if Siz /= No_Uint and then Siz /= 0 then 7626 declare 7627 CS : constant Boolean := Comes_From_Source (N); 7628 7629 begin 7630 Rewrite (N, Make_Integer_Literal (Loc, Siz)); 7631 7632 -- This integer literal is not a static expression. We do not 7633 -- call Analyze_And_Resolve here, because this would activate 7634 -- the circuit for deciding that a static value was out of range, 7635 -- and we don't want that. 7636 7637 -- So just manually set the type, mark the expression as 7638 -- nonstatic, and then ensure that the result is checked 7639 -- properly if the attribute comes from source (if it was 7640 -- internally generated, we never need a constraint check). 7641 7642 Set_Etype (N, Typ); 7643 Set_Is_Static_Expression (N, False); 7644 7645 if CS then 7646 Apply_Constraint_Check (N, Typ); 7647 end if; 7648 end; 7649 end if; 7650 end Expand_Size_Attribute; 7651 7652 ----------------------------- 7653 -- Expand_Update_Attribute -- 7654 ----------------------------- 7655 7656 procedure Expand_Update_Attribute (N : Node_Id) is 7657 procedure Process_Component_Or_Element_Update 7658 (Temp : Entity_Id; 7659 Comp : Node_Id; 7660 Expr : Node_Id; 7661 Typ : Entity_Id); 7662 -- Generate the statements necessary to update a single component or an 7663 -- element of the prefix. The code is inserted before the attribute N. 7664 -- Temp denotes the entity of the anonymous object created to reflect 7665 -- the changes in values. Comp is the component/index expression to be 7666 -- updated. Expr is an expression yielding the new value of Comp. Typ 7667 -- is the type of the prefix of attribute Update. 7668 7669 procedure Process_Range_Update 7670 (Temp : Entity_Id; 7671 Comp : Node_Id; 7672 Expr : Node_Id; 7673 Typ : Entity_Id); 7674 -- Generate the statements necessary to update a slice of the prefix. 7675 -- The code is inserted before the attribute N. Temp denotes the entity 7676 -- of the anonymous object created to reflect the changes in values. 7677 -- Comp is range of the slice to be updated. Expr is an expression 7678 -- yielding the new value of Comp. Typ is the type of the prefix of 7679 -- attribute Update. 7680 7681 ----------------------------------------- 7682 -- Process_Component_Or_Element_Update -- 7683 ----------------------------------------- 7684 7685 procedure Process_Component_Or_Element_Update 7686 (Temp : Entity_Id; 7687 Comp : Node_Id; 7688 Expr : Node_Id; 7689 Typ : Entity_Id) 7690 is 7691 Loc : constant Source_Ptr := Sloc (Comp); 7692 Exprs : List_Id; 7693 LHS : Node_Id; 7694 7695 begin 7696 -- An array element may be modified by the following relations 7697 -- depending on the number of dimensions: 7698 7699 -- 1 => Expr -- one dimensional update 7700 -- (1, ..., N) => Expr -- multi dimensional update 7701 7702 -- The above forms are converted in assignment statements where the 7703 -- left hand side is an indexed component: 7704 7705 -- Temp (1) := Expr; -- one dimensional update 7706 -- Temp (1, ..., N) := Expr; -- multi dimensional update 7707 7708 if Is_Array_Type (Typ) then 7709 7710 -- The index expressions of a multi dimensional array update 7711 -- appear as an aggregate. 7712 7713 if Nkind (Comp) = N_Aggregate then 7714 Exprs := New_Copy_List_Tree (Expressions (Comp)); 7715 else 7716 Exprs := New_List (Relocate_Node (Comp)); 7717 end if; 7718 7719 LHS := 7720 Make_Indexed_Component (Loc, 7721 Prefix => New_Occurrence_Of (Temp, Loc), 7722 Expressions => Exprs); 7723 7724 -- A record component update appears in the following form: 7725 7726 -- Comp => Expr 7727 7728 -- The above relation is transformed into an assignment statement 7729 -- where the left hand side is a selected component: 7730 7731 -- Temp.Comp := Expr; 7732 7733 else pragma Assert (Is_Record_Type (Typ)); 7734 LHS := 7735 Make_Selected_Component (Loc, 7736 Prefix => New_Occurrence_Of (Temp, Loc), 7737 Selector_Name => Relocate_Node (Comp)); 7738 end if; 7739 7740 Insert_Action (N, 7741 Make_Assignment_Statement (Loc, 7742 Name => LHS, 7743 Expression => Relocate_Node (Expr))); 7744 end Process_Component_Or_Element_Update; 7745 7746 -------------------------- 7747 -- Process_Range_Update -- 7748 -------------------------- 7749 7750 procedure Process_Range_Update 7751 (Temp : Entity_Id; 7752 Comp : Node_Id; 7753 Expr : Node_Id; 7754 Typ : Entity_Id) 7755 is 7756 Index_Typ : constant Entity_Id := Etype (First_Index (Typ)); 7757 Loc : constant Source_Ptr := Sloc (Comp); 7758 Index : Entity_Id; 7759 7760 begin 7761 -- A range update appears as 7762 7763 -- (Low .. High => Expr) 7764 7765 -- The above construct is transformed into a loop that iterates over 7766 -- the given range and modifies the corresponding array values to the 7767 -- value of Expr: 7768 7769 -- for Index in Low .. High loop 7770 -- Temp (<Index_Typ> (Index)) := Expr; 7771 -- end loop; 7772 7773 Index := Make_Temporary (Loc, 'I'); 7774 7775 Insert_Action (N, 7776 Make_Loop_Statement (Loc, 7777 Iteration_Scheme => 7778 Make_Iteration_Scheme (Loc, 7779 Loop_Parameter_Specification => 7780 Make_Loop_Parameter_Specification (Loc, 7781 Defining_Identifier => Index, 7782 Discrete_Subtype_Definition => Relocate_Node (Comp))), 7783 7784 Statements => New_List ( 7785 Make_Assignment_Statement (Loc, 7786 Name => 7787 Make_Indexed_Component (Loc, 7788 Prefix => New_Occurrence_Of (Temp, Loc), 7789 Expressions => New_List ( 7790 Convert_To (Index_Typ, 7791 New_Occurrence_Of (Index, Loc)))), 7792 Expression => Relocate_Node (Expr))), 7793 7794 End_Label => Empty)); 7795 end Process_Range_Update; 7796 7797 -- Local variables 7798 7799 Aggr : constant Node_Id := First (Expressions (N)); 7800 Loc : constant Source_Ptr := Sloc (N); 7801 Pref : constant Node_Id := Prefix (N); 7802 Typ : constant Entity_Id := Etype (Pref); 7803 Assoc : Node_Id; 7804 Comp : Node_Id; 7805 CW_Temp : Entity_Id; 7806 CW_Typ : Entity_Id; 7807 Expr : Node_Id; 7808 Temp : Entity_Id; 7809 7810 -- Start of processing for Expand_Update_Attribute 7811 7812 begin 7813 -- Create the anonymous object to store the value of the prefix and 7814 -- capture subsequent changes in value. 7815 7816 Temp := Make_Temporary (Loc, 'T', Pref); 7817 7818 -- Preserve the tag of the prefix by offering a specific view of the 7819 -- class-wide version of the prefix. 7820 7821 if Is_Tagged_Type (Typ) then 7822 7823 -- Generate: 7824 -- CW_Temp : Typ'Class := Typ'Class (Pref); 7825 7826 CW_Temp := Make_Temporary (Loc, 'T'); 7827 CW_Typ := Class_Wide_Type (Typ); 7828 7829 Insert_Action (N, 7830 Make_Object_Declaration (Loc, 7831 Defining_Identifier => CW_Temp, 7832 Object_Definition => New_Occurrence_Of (CW_Typ, Loc), 7833 Expression => 7834 Convert_To (CW_Typ, Relocate_Node (Pref)))); 7835 7836 -- Generate: 7837 -- Temp : Typ renames Typ (CW_Temp); 7838 7839 Insert_Action (N, 7840 Make_Object_Renaming_Declaration (Loc, 7841 Defining_Identifier => Temp, 7842 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 7843 Name => 7844 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); 7845 7846 -- Non-tagged case 7847 7848 else 7849 -- Generate: 7850 -- Temp : Typ := Pref; 7851 7852 Insert_Action (N, 7853 Make_Object_Declaration (Loc, 7854 Defining_Identifier => Temp, 7855 Object_Definition => New_Occurrence_Of (Typ, Loc), 7856 Expression => Relocate_Node (Pref))); 7857 end if; 7858 7859 -- Process the update aggregate 7860 7861 Assoc := First (Component_Associations (Aggr)); 7862 while Present (Assoc) loop 7863 Comp := First (Choices (Assoc)); 7864 Expr := Expression (Assoc); 7865 while Present (Comp) loop 7866 if Nkind (Comp) = N_Range then 7867 Process_Range_Update (Temp, Comp, Expr, Typ); 7868 else 7869 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ); 7870 end if; 7871 7872 Next (Comp); 7873 end loop; 7874 7875 Next (Assoc); 7876 end loop; 7877 7878 -- The attribute is replaced by a reference to the anonymous object 7879 7880 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 7881 Analyze (N); 7882 end Expand_Update_Attribute; 7883 7884 ------------------- 7885 -- Find_Fat_Info -- 7886 ------------------- 7887 7888 procedure Find_Fat_Info 7889 (T : Entity_Id; 7890 Fat_Type : out Entity_Id; 7891 Fat_Pkg : out RE_Id) 7892 is 7893 Rtyp : constant Entity_Id := Root_Type (T); 7894 7895 begin 7896 -- All we do is use the root type (historically this dealt with 7897 -- VAX-float .. to be cleaned up further later ???) 7898 7899 Fat_Type := Rtyp; 7900 7901 if Fat_Type = Standard_Short_Float then 7902 Fat_Pkg := RE_Attr_Short_Float; 7903 7904 elsif Fat_Type = Standard_Float then 7905 Fat_Pkg := RE_Attr_Float; 7906 7907 elsif Fat_Type = Standard_Long_Float then 7908 Fat_Pkg := RE_Attr_Long_Float; 7909 7910 elsif Fat_Type = Standard_Long_Long_Float then 7911 Fat_Pkg := RE_Attr_Long_Long_Float; 7912 7913 -- Universal real (which is its own root type) is treated as being 7914 -- equivalent to Standard.Long_Long_Float, since it is defined to 7915 -- have the same precision as the longest Float type. 7916 7917 elsif Fat_Type = Universal_Real then 7918 Fat_Type := Standard_Long_Long_Float; 7919 Fat_Pkg := RE_Attr_Long_Long_Float; 7920 7921 else 7922 raise Program_Error; 7923 end if; 7924 end Find_Fat_Info; 7925 7926 ---------------------------- 7927 -- Find_Stream_Subprogram -- 7928 ---------------------------- 7929 7930 function Find_Stream_Subprogram 7931 (Typ : Entity_Id; 7932 Nam : TSS_Name_Type) return Entity_Id 7933 is 7934 Base_Typ : constant Entity_Id := Base_Type (Typ); 7935 Ent : constant Entity_Id := TSS (Typ, Nam); 7936 begin 7937 if Present (Ent) then 7938 return Ent; 7939 end if; 7940 7941 -- Stream attributes for strings are expanded into library calls. The 7942 -- following checks are disabled when the run-time is not available or 7943 -- when compiling predefined types due to bootstrap issues. As a result, 7944 -- the compiler will generate in-place stream routines for string types 7945 -- that appear in GNAT's library, but will generate calls via rtsfind 7946 -- to library routines for user code. 7947 7948 -- Note: In the case of using a configurable run time, it is very likely 7949 -- that stream routines for string types are not present (they require 7950 -- file system support). In this case, the specific stream routines for 7951 -- strings are not used, relying on the regular stream mechanism 7952 -- instead. That is why we include the test RTE_Available when dealing 7953 -- with these cases. 7954 7955 if not Is_Predefined_Unit (Current_Sem_Unit) then 7956 -- Storage_Array as defined in package System.Storage_Elements 7957 7958 if Is_RTE (Base_Typ, RE_Storage_Array) then 7959 7960 -- Case of No_Stream_Optimizations restriction active 7961 7962 if Restriction_Active (No_Stream_Optimizations) then 7963 if Nam = TSS_Stream_Input 7964 and then RTE_Available (RE_Storage_Array_Input) 7965 then 7966 return RTE (RE_Storage_Array_Input); 7967 7968 elsif Nam = TSS_Stream_Output 7969 and then RTE_Available (RE_Storage_Array_Output) 7970 then 7971 return RTE (RE_Storage_Array_Output); 7972 7973 elsif Nam = TSS_Stream_Read 7974 and then RTE_Available (RE_Storage_Array_Read) 7975 then 7976 return RTE (RE_Storage_Array_Read); 7977 7978 elsif Nam = TSS_Stream_Write 7979 and then RTE_Available (RE_Storage_Array_Write) 7980 then 7981 return RTE (RE_Storage_Array_Write); 7982 7983 elsif Nam /= TSS_Stream_Input and then 7984 Nam /= TSS_Stream_Output and then 7985 Nam /= TSS_Stream_Read and then 7986 Nam /= TSS_Stream_Write 7987 then 7988 raise Program_Error; 7989 end if; 7990 7991 -- Restriction No_Stream_Optimizations is not set, so we can go 7992 -- ahead and optimize using the block IO forms of the routines. 7993 7994 else 7995 if Nam = TSS_Stream_Input 7996 and then RTE_Available (RE_Storage_Array_Input_Blk_IO) 7997 then 7998 return RTE (RE_Storage_Array_Input_Blk_IO); 7999 8000 elsif Nam = TSS_Stream_Output 8001 and then RTE_Available (RE_Storage_Array_Output_Blk_IO) 8002 then 8003 return RTE (RE_Storage_Array_Output_Blk_IO); 8004 8005 elsif Nam = TSS_Stream_Read 8006 and then RTE_Available (RE_Storage_Array_Read_Blk_IO) 8007 then 8008 return RTE (RE_Storage_Array_Read_Blk_IO); 8009 8010 elsif Nam = TSS_Stream_Write 8011 and then RTE_Available (RE_Storage_Array_Write_Blk_IO) 8012 then 8013 return RTE (RE_Storage_Array_Write_Blk_IO); 8014 8015 elsif Nam /= TSS_Stream_Input and then 8016 Nam /= TSS_Stream_Output and then 8017 Nam /= TSS_Stream_Read and then 8018 Nam /= TSS_Stream_Write 8019 then 8020 raise Program_Error; 8021 end if; 8022 end if; 8023 8024 -- Stream_Element_Array as defined in package Ada.Streams 8025 8026 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then 8027 8028 -- Case of No_Stream_Optimizations restriction active 8029 8030 if Restriction_Active (No_Stream_Optimizations) then 8031 if Nam = TSS_Stream_Input 8032 and then RTE_Available (RE_Stream_Element_Array_Input) 8033 then 8034 return RTE (RE_Stream_Element_Array_Input); 8035 8036 elsif Nam = TSS_Stream_Output 8037 and then RTE_Available (RE_Stream_Element_Array_Output) 8038 then 8039 return RTE (RE_Stream_Element_Array_Output); 8040 8041 elsif Nam = TSS_Stream_Read 8042 and then RTE_Available (RE_Stream_Element_Array_Read) 8043 then 8044 return RTE (RE_Stream_Element_Array_Read); 8045 8046 elsif Nam = TSS_Stream_Write 8047 and then RTE_Available (RE_Stream_Element_Array_Write) 8048 then 8049 return RTE (RE_Stream_Element_Array_Write); 8050 8051 elsif Nam /= TSS_Stream_Input and then 8052 Nam /= TSS_Stream_Output and then 8053 Nam /= TSS_Stream_Read and then 8054 Nam /= TSS_Stream_Write 8055 then 8056 raise Program_Error; 8057 end if; 8058 8059 -- Restriction No_Stream_Optimizations is not set, so we can go 8060 -- ahead and optimize using the block IO forms of the routines. 8061 8062 else 8063 if Nam = TSS_Stream_Input 8064 and then RTE_Available (RE_Stream_Element_Array_Input_Blk_IO) 8065 then 8066 return RTE (RE_Stream_Element_Array_Input_Blk_IO); 8067 8068 elsif Nam = TSS_Stream_Output 8069 and then RTE_Available (RE_Stream_Element_Array_Output_Blk_IO) 8070 then 8071 return RTE (RE_Stream_Element_Array_Output_Blk_IO); 8072 8073 elsif Nam = TSS_Stream_Read 8074 and then RTE_Available (RE_Stream_Element_Array_Read_Blk_IO) 8075 then 8076 return RTE (RE_Stream_Element_Array_Read_Blk_IO); 8077 8078 elsif Nam = TSS_Stream_Write 8079 and then RTE_Available (RE_Stream_Element_Array_Write_Blk_IO) 8080 then 8081 return RTE (RE_Stream_Element_Array_Write_Blk_IO); 8082 8083 elsif Nam /= TSS_Stream_Input and then 8084 Nam /= TSS_Stream_Output and then 8085 Nam /= TSS_Stream_Read and then 8086 Nam /= TSS_Stream_Write 8087 then 8088 raise Program_Error; 8089 end if; 8090 end if; 8091 8092 -- String as defined in package Ada 8093 8094 elsif Base_Typ = Standard_String then 8095 8096 -- Case of No_Stream_Optimizations restriction active 8097 8098 if Restriction_Active (No_Stream_Optimizations) then 8099 if Nam = TSS_Stream_Input 8100 and then RTE_Available (RE_String_Input) 8101 then 8102 return RTE (RE_String_Input); 8103 8104 elsif Nam = TSS_Stream_Output 8105 and then RTE_Available (RE_String_Output) 8106 then 8107 return RTE (RE_String_Output); 8108 8109 elsif Nam = TSS_Stream_Read 8110 and then RTE_Available (RE_String_Read) 8111 then 8112 return RTE (RE_String_Read); 8113 8114 elsif Nam = TSS_Stream_Write 8115 and then RTE_Available (RE_String_Write) 8116 then 8117 return RTE (RE_String_Write); 8118 8119 elsif Nam /= TSS_Stream_Input and then 8120 Nam /= TSS_Stream_Output and then 8121 Nam /= TSS_Stream_Read and then 8122 Nam /= TSS_Stream_Write 8123 then 8124 raise Program_Error; 8125 end if; 8126 8127 -- Restriction No_Stream_Optimizations is not set, so we can go 8128 -- ahead and optimize using the block IO forms of the routines. 8129 8130 else 8131 if Nam = TSS_Stream_Input 8132 and then RTE_Available (RE_String_Input_Blk_IO) 8133 then 8134 return RTE (RE_String_Input_Blk_IO); 8135 8136 elsif Nam = TSS_Stream_Output 8137 and then RTE_Available (RE_String_Output_Blk_IO) 8138 then 8139 return RTE (RE_String_Output_Blk_IO); 8140 8141 elsif Nam = TSS_Stream_Read 8142 and then RTE_Available (RE_String_Read_Blk_IO) 8143 then 8144 return RTE (RE_String_Read_Blk_IO); 8145 8146 elsif Nam = TSS_Stream_Write 8147 and then RTE_Available (RE_String_Write_Blk_IO) 8148 then 8149 return RTE (RE_String_Write_Blk_IO); 8150 8151 elsif Nam /= TSS_Stream_Input and then 8152 Nam /= TSS_Stream_Output and then 8153 Nam /= TSS_Stream_Read and then 8154 Nam /= TSS_Stream_Write 8155 then 8156 raise Program_Error; 8157 end if; 8158 end if; 8159 8160 -- Wide_String as defined in package Ada 8161 8162 elsif Base_Typ = Standard_Wide_String then 8163 8164 -- Case of No_Stream_Optimizations restriction active 8165 8166 if Restriction_Active (No_Stream_Optimizations) then 8167 if Nam = TSS_Stream_Input 8168 and then RTE_Available (RE_Wide_String_Input) 8169 then 8170 return RTE (RE_Wide_String_Input); 8171 8172 elsif Nam = TSS_Stream_Output 8173 and then RTE_Available (RE_Wide_String_Output) 8174 then 8175 return RTE (RE_Wide_String_Output); 8176 8177 elsif Nam = TSS_Stream_Read 8178 and then RTE_Available (RE_Wide_String_Read) 8179 then 8180 return RTE (RE_Wide_String_Read); 8181 8182 elsif Nam = TSS_Stream_Write 8183 and then RTE_Available (RE_Wide_String_Write) 8184 then 8185 return RTE (RE_Wide_String_Write); 8186 8187 elsif Nam /= TSS_Stream_Input and then 8188 Nam /= TSS_Stream_Output and then 8189 Nam /= TSS_Stream_Read and then 8190 Nam /= TSS_Stream_Write 8191 then 8192 raise Program_Error; 8193 end if; 8194 8195 -- Restriction No_Stream_Optimizations is not set, so we can go 8196 -- ahead and optimize using the block IO forms of the routines. 8197 8198 else 8199 if Nam = TSS_Stream_Input 8200 and then RTE_Available (RE_Wide_String_Input_Blk_IO) 8201 then 8202 return RTE (RE_Wide_String_Input_Blk_IO); 8203 8204 elsif Nam = TSS_Stream_Output 8205 and then RTE_Available (RE_Wide_String_Output_Blk_IO) 8206 then 8207 return RTE (RE_Wide_String_Output_Blk_IO); 8208 8209 elsif Nam = TSS_Stream_Read 8210 and then RTE_Available (RE_Wide_String_Read_Blk_IO) 8211 then 8212 return RTE (RE_Wide_String_Read_Blk_IO); 8213 8214 elsif Nam = TSS_Stream_Write 8215 and then RTE_Available (RE_Wide_String_Write_Blk_IO) 8216 then 8217 return RTE (RE_Wide_String_Write_Blk_IO); 8218 8219 elsif Nam /= TSS_Stream_Input and then 8220 Nam /= TSS_Stream_Output and then 8221 Nam /= TSS_Stream_Read and then 8222 Nam /= TSS_Stream_Write 8223 then 8224 raise Program_Error; 8225 end if; 8226 end if; 8227 8228 -- Wide_Wide_String as defined in package Ada 8229 8230 elsif Base_Typ = Standard_Wide_Wide_String then 8231 8232 -- Case of No_Stream_Optimizations restriction active 8233 8234 if Restriction_Active (No_Stream_Optimizations) then 8235 if Nam = TSS_Stream_Input 8236 and then RTE_Available (RE_Wide_Wide_String_Input) 8237 then 8238 return RTE (RE_Wide_Wide_String_Input); 8239 8240 elsif Nam = TSS_Stream_Output 8241 and then RTE_Available (RE_Wide_Wide_String_Output) 8242 then 8243 return RTE (RE_Wide_Wide_String_Output); 8244 8245 elsif Nam = TSS_Stream_Read 8246 and then RTE_Available (RE_Wide_Wide_String_Read) 8247 then 8248 return RTE (RE_Wide_Wide_String_Read); 8249 8250 elsif Nam = TSS_Stream_Write 8251 and then RTE_Available (RE_Wide_Wide_String_Write) 8252 then 8253 return RTE (RE_Wide_Wide_String_Write); 8254 8255 elsif Nam /= TSS_Stream_Input and then 8256 Nam /= TSS_Stream_Output and then 8257 Nam /= TSS_Stream_Read and then 8258 Nam /= TSS_Stream_Write 8259 then 8260 raise Program_Error; 8261 end if; 8262 8263 -- Restriction No_Stream_Optimizations is not set, so we can go 8264 -- ahead and optimize using the block IO forms of the routines. 8265 8266 else 8267 if Nam = TSS_Stream_Input 8268 and then RTE_Available (RE_Wide_Wide_String_Input_Blk_IO) 8269 then 8270 return RTE (RE_Wide_Wide_String_Input_Blk_IO); 8271 8272 elsif Nam = TSS_Stream_Output 8273 and then RTE_Available (RE_Wide_Wide_String_Output_Blk_IO) 8274 then 8275 return RTE (RE_Wide_Wide_String_Output_Blk_IO); 8276 8277 elsif Nam = TSS_Stream_Read 8278 and then RTE_Available (RE_Wide_Wide_String_Read_Blk_IO) 8279 then 8280 return RTE (RE_Wide_Wide_String_Read_Blk_IO); 8281 8282 elsif Nam = TSS_Stream_Write 8283 and then RTE_Available (RE_Wide_Wide_String_Write_Blk_IO) 8284 then 8285 return RTE (RE_Wide_Wide_String_Write_Blk_IO); 8286 8287 elsif Nam /= TSS_Stream_Input and then 8288 Nam /= TSS_Stream_Output and then 8289 Nam /= TSS_Stream_Read and then 8290 Nam /= TSS_Stream_Write 8291 then 8292 raise Program_Error; 8293 end if; 8294 end if; 8295 end if; 8296 end if; 8297 8298 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then 8299 return Find_Prim_Op (Typ, Nam); 8300 else 8301 return Find_Inherited_TSS (Typ, Nam); 8302 end if; 8303 end Find_Stream_Subprogram; 8304 8305 --------------- 8306 -- Full_Base -- 8307 --------------- 8308 8309 function Full_Base (T : Entity_Id) return Entity_Id is 8310 BT : Entity_Id; 8311 8312 begin 8313 BT := Base_Type (T); 8314 8315 if Is_Private_Type (BT) 8316 and then Present (Full_View (BT)) 8317 then 8318 BT := Full_View (BT); 8319 end if; 8320 8321 return BT; 8322 end Full_Base; 8323 8324 ----------------------- 8325 -- Get_Index_Subtype -- 8326 ----------------------- 8327 8328 function Get_Index_Subtype (N : Node_Id) return Node_Id is 8329 P_Type : Entity_Id := Etype (Prefix (N)); 8330 Indx : Node_Id; 8331 J : Int; 8332 8333 begin 8334 if Is_Access_Type (P_Type) then 8335 P_Type := Designated_Type (P_Type); 8336 end if; 8337 8338 if No (Expressions (N)) then 8339 J := 1; 8340 else 8341 J := UI_To_Int (Expr_Value (First (Expressions (N)))); 8342 end if; 8343 8344 Indx := First_Index (P_Type); 8345 while J > 1 loop 8346 Next_Index (Indx); 8347 J := J - 1; 8348 end loop; 8349 8350 return Etype (Indx); 8351 end Get_Index_Subtype; 8352 8353 ------------------------------- 8354 -- Get_Stream_Convert_Pragma -- 8355 ------------------------------- 8356 8357 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is 8358 Typ : Entity_Id; 8359 N : Node_Id; 8360 8361 begin 8362 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity 8363 -- that a stream convert pragma for a tagged type is not inherited from 8364 -- its parent. Probably what is wrong here is that it is basically 8365 -- incorrect to consider a stream convert pragma to be a representation 8366 -- pragma at all ??? 8367 8368 N := First_Rep_Item (Implementation_Base_Type (T)); 8369 while Present (N) loop 8370 if Nkind (N) = N_Pragma 8371 and then Pragma_Name (N) = Name_Stream_Convert 8372 then 8373 -- For tagged types this pragma is not inherited, so we 8374 -- must verify that it is defined for the given type and 8375 -- not an ancestor. 8376 8377 Typ := 8378 Entity (Expression (First (Pragma_Argument_Associations (N)))); 8379 8380 if not Is_Tagged_Type (T) 8381 or else T = Typ 8382 or else (Is_Private_Type (Typ) and then T = Full_View (Typ)) 8383 then 8384 return N; 8385 end if; 8386 end if; 8387 8388 Next_Rep_Item (N); 8389 end loop; 8390 8391 return Empty; 8392 end Get_Stream_Convert_Pragma; 8393 8394 --------------------------------- 8395 -- Is_Constrained_Packed_Array -- 8396 --------------------------------- 8397 8398 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is 8399 Arr : Entity_Id := Typ; 8400 8401 begin 8402 if Is_Access_Type (Arr) then 8403 Arr := Designated_Type (Arr); 8404 end if; 8405 8406 return Is_Array_Type (Arr) 8407 and then Is_Constrained (Arr) 8408 and then Present (Packed_Array_Impl_Type (Arr)); 8409 end Is_Constrained_Packed_Array; 8410 8411 ---------------------------------------- 8412 -- Is_Inline_Floating_Point_Attribute -- 8413 ---------------------------------------- 8414 8415 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is 8416 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); 8417 8418 function Is_GCC_Target return Boolean; 8419 -- Return True if we are using a GCC target/back-end 8420 -- ??? Note: the implementation is kludgy/fragile 8421 8422 ------------------- 8423 -- Is_GCC_Target -- 8424 ------------------- 8425 8426 function Is_GCC_Target return Boolean is 8427 begin 8428 return not CodePeer_Mode 8429 and then not Modify_Tree_For_C; 8430 end Is_GCC_Target; 8431 8432 -- Start of processing for Is_Inline_Floating_Point_Attribute 8433 8434 begin 8435 -- Machine and Model can be expanded by the GCC back end only 8436 8437 if Id = Attribute_Machine or else Id = Attribute_Model then 8438 return Is_GCC_Target; 8439 8440 -- Remaining cases handled by all back ends are Rounding and Truncation 8441 -- when appearing as the operand of a conversion to some integer type. 8442 8443 elsif Nkind (Parent (N)) /= N_Type_Conversion 8444 or else not Is_Integer_Type (Etype (Parent (N))) 8445 then 8446 return False; 8447 end if; 8448 8449 -- Here we are in the integer conversion context. We reuse Rounding for 8450 -- Machine_Rounding as System.Fat_Gen, which is a permissible behavior. 8451 8452 return 8453 Id = Attribute_Rounding 8454 or else Id = Attribute_Machine_Rounding 8455 or else Id = Attribute_Truncation; 8456 end Is_Inline_Floating_Point_Attribute; 8457 8458end Exp_Attr; 8459