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 (Base_Type (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. In addition we need to use 4523 -- the base type as above to retrieve a static bound for the 4524 -- comparisons that follow. 4525 4526 -- The easy case is when the modulus value is within the bounds 4527 -- of the signed integer type of the argument. In this case we can 4528 -- just do the computation in that signed integer type, and then 4529 -- do an ordinary conversion to the target type. 4530 4531 if Modv <= Expr_Value (Hi) then 4532 Rewrite (N, 4533 Convert_To (Btyp, 4534 Make_Op_Mod (Loc, 4535 Left_Opnd => Arg, 4536 Right_Opnd => Make_Integer_Literal (Loc, Modv)))); 4537 4538 -- Here we know that the modulus is larger than type'Last of the 4539 -- integer type. There are two cases to consider: 4540 4541 -- a) The integer value is non-negative. In this case, it is 4542 -- returned as the result (since it is less than the modulus). 4543 4544 -- b) The integer value is negative. In this case, we know that the 4545 -- result is modulus + value, where the value might be as small as 4546 -- -modulus. The trouble is what type do we use to do the subtract. 4547 -- No type will do, since modulus can be as big as 2**64, and no 4548 -- integer type accommodates this value. Let's do bit of algebra 4549 4550 -- modulus + value 4551 -- = modulus - (-value) 4552 -- = (modulus - 1) - (-value - 1) 4553 4554 -- Now modulus - 1 is certainly in range of the modular type. 4555 -- -value is in the range 1 .. modulus, so -value -1 is in the 4556 -- range 0 .. modulus-1 which is in range of the modular type. 4557 -- Furthermore, (-value - 1) can be expressed as -(value + 1) 4558 -- which we can compute using the integer base type. 4559 4560 -- Once this is done we analyze the if expression without range 4561 -- checks, because we know everything is in range, and we want 4562 -- to prevent spurious warnings on either branch. 4563 4564 else 4565 Rewrite (N, 4566 Make_If_Expression (Loc, 4567 Expressions => New_List ( 4568 Make_Op_Ge (Loc, 4569 Left_Opnd => Duplicate_Subexpr (Arg), 4570 Right_Opnd => Make_Integer_Literal (Loc, 0)), 4571 4572 Convert_To (Btyp, 4573 Duplicate_Subexpr_No_Checks (Arg)), 4574 4575 Make_Op_Subtract (Loc, 4576 Left_Opnd => 4577 Make_Integer_Literal (Loc, 4578 Intval => Modv - 1), 4579 Right_Opnd => 4580 Convert_To (Btyp, 4581 Make_Op_Minus (Loc, 4582 Right_Opnd => 4583 Make_Op_Add (Loc, 4584 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg), 4585 Right_Opnd => 4586 Make_Integer_Literal (Loc, 4587 Intval => 1)))))))); 4588 4589 end if; 4590 4591 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks); 4592 end Mod_Case; 4593 4594 ----------- 4595 -- Model -- 4596 ----------- 4597 4598 -- Transforms 'Model into a call to the floating-point attribute 4599 -- function Model in Fat_xxx (where xxx is the root type). 4600 -- Expansion is avoided for cases the back end can handle directly. 4601 4602 when Attribute_Model => 4603 if not Is_Inline_Floating_Point_Attribute (N) then 4604 Expand_Fpt_Attribute_R (N); 4605 end if; 4606 4607 ----------------- 4608 -- Object_Size -- 4609 ----------------- 4610 4611 -- The processing for Object_Size shares the processing for Size 4612 4613 --------- 4614 -- Old -- 4615 --------- 4616 4617 when Attribute_Old => Old : declare 4618 Typ : constant Entity_Id := Etype (N); 4619 CW_Temp : Entity_Id; 4620 CW_Typ : Entity_Id; 4621 Ins_Nod : Node_Id; 4622 Subp : Node_Id; 4623 Temp : Entity_Id; 4624 4625 begin 4626 -- Generating C code we don't need to expand this attribute when 4627 -- we are analyzing the internally built nested postconditions 4628 -- procedure since it will be expanded inline (and later it will 4629 -- be removed by Expand_N_Subprogram_Body). It this expansion is 4630 -- performed in such case then the compiler generates unreferenced 4631 -- extra temporaries. 4632 4633 if Modify_Tree_For_C 4634 and then Chars (Current_Scope) = Name_uPostconditions 4635 then 4636 return; 4637 end if; 4638 4639 -- Climb the parent chain looking for subprogram _Postconditions 4640 4641 Subp := N; 4642 while Present (Subp) loop 4643 exit when Nkind (Subp) = N_Subprogram_Body 4644 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions; 4645 4646 -- If assertions are disabled, no need to create the declaration 4647 -- that preserves the value. The postcondition pragma in which 4648 -- 'Old appears will be checked or disabled according to the 4649 -- current policy in effect. 4650 4651 if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then 4652 return; 4653 end if; 4654 4655 Subp := Parent (Subp); 4656 end loop; 4657 4658 -- 'Old can only appear in a postcondition, the generated body of 4659 -- _Postconditions must be in the tree (or inlined if we are 4660 -- generating C code). 4661 4662 pragma Assert 4663 (Present (Subp) 4664 or else (Modify_Tree_For_C and then In_Inlined_Body)); 4665 4666 Temp := Make_Temporary (Loc, 'T', Pref); 4667 4668 -- Set the entity kind now in order to mark the temporary as a 4669 -- handler of attribute 'Old's prefix. 4670 4671 Set_Ekind (Temp, E_Constant); 4672 Set_Stores_Attribute_Old_Prefix (Temp); 4673 4674 -- Push the scope of the related subprogram where _Postcondition 4675 -- resides as this ensures that the object will be analyzed in the 4676 -- proper context. 4677 4678 if Present (Subp) then 4679 Push_Scope (Scope (Defining_Entity (Subp))); 4680 4681 -- No need to push the scope when generating C code since the 4682 -- _Postcondition procedure has been inlined. 4683 4684 else pragma Assert (Modify_Tree_For_C); 4685 pragma Assert (In_Inlined_Body); 4686 null; 4687 end if; 4688 4689 -- Locate the insertion place of the internal temporary that saves 4690 -- the 'Old value. 4691 4692 if Present (Subp) then 4693 Ins_Nod := Subp; 4694 4695 -- Generating C, the postcondition procedure has been inlined and the 4696 -- temporary is added before the first declaration of the enclosing 4697 -- subprogram. 4698 4699 else pragma Assert (Modify_Tree_For_C); 4700 Ins_Nod := N; 4701 while Nkind (Ins_Nod) /= N_Subprogram_Body loop 4702 Ins_Nod := Parent (Ins_Nod); 4703 end loop; 4704 4705 Ins_Nod := First (Declarations (Ins_Nod)); 4706 end if; 4707 4708 -- Preserve the tag of the prefix by offering a specific view of the 4709 -- class-wide version of the prefix. 4710 4711 if Is_Tagged_Type (Typ) then 4712 4713 -- Generate: 4714 -- CW_Temp : constant Typ'Class := Typ'Class (Pref); 4715 4716 CW_Temp := Make_Temporary (Loc, 'T'); 4717 CW_Typ := Class_Wide_Type (Typ); 4718 4719 Insert_Before_And_Analyze (Ins_Nod, 4720 Make_Object_Declaration (Loc, 4721 Defining_Identifier => CW_Temp, 4722 Constant_Present => True, 4723 Object_Definition => New_Occurrence_Of (CW_Typ, Loc), 4724 Expression => 4725 Convert_To (CW_Typ, Relocate_Node (Pref)))); 4726 4727 -- Generate: 4728 -- Temp : Typ renames Typ (CW_Temp); 4729 4730 Insert_Before_And_Analyze (Ins_Nod, 4731 Make_Object_Renaming_Declaration (Loc, 4732 Defining_Identifier => Temp, 4733 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 4734 Name => 4735 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); 4736 4737 -- Non-tagged case 4738 4739 else 4740 -- Generate: 4741 -- Temp : constant Typ := Pref; 4742 4743 Insert_Before_And_Analyze (Ins_Nod, 4744 Make_Object_Declaration (Loc, 4745 Defining_Identifier => Temp, 4746 Constant_Present => True, 4747 Object_Definition => New_Occurrence_Of (Typ, Loc), 4748 Expression => Relocate_Node (Pref))); 4749 end if; 4750 4751 if Present (Subp) then 4752 Pop_Scope; 4753 end if; 4754 4755 -- Ensure that the prefix of attribute 'Old is valid. The check must 4756 -- be inserted after the expansion of the attribute has taken place 4757 -- to reflect the new placement of the prefix. 4758 4759 if Validity_Checks_On and then Validity_Check_Operands then 4760 Ensure_Valid (Pref); 4761 end if; 4762 4763 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 4764 end Old; 4765 4766 ---------------------- 4767 -- Overlaps_Storage -- 4768 ---------------------- 4769 4770 when Attribute_Overlaps_Storage => Overlaps_Storage : declare 4771 Loc : constant Source_Ptr := Sloc (N); 4772 4773 X : constant Node_Id := Prefix (N); 4774 Y : constant Node_Id := First (Expressions (N)); 4775 -- The arguments 4776 4777 X_Addr, Y_Addr : Node_Id; 4778 -- the expressions for their integer addresses 4779 4780 X_Size, Y_Size : Node_Id; 4781 -- the expressions for their sizes 4782 4783 Cond : Node_Id; 4784 4785 begin 4786 -- Attribute expands into: 4787 4788 -- if X'Address < Y'address then 4789 -- (X'address + X'Size - 1) >= Y'address 4790 -- else 4791 -- (Y'address + Y'size - 1) >= X'Address 4792 -- end if; 4793 4794 -- with the proper address operations. We convert addresses to 4795 -- integer addresses to use predefined arithmetic. The size is 4796 -- expressed in storage units. We add copies of X_Addr and Y_Addr 4797 -- to prevent the appearance of the same node in two places in 4798 -- the tree. 4799 4800 X_Addr := 4801 Unchecked_Convert_To (RTE (RE_Integer_Address), 4802 Make_Attribute_Reference (Loc, 4803 Attribute_Name => Name_Address, 4804 Prefix => New_Copy_Tree (X))); 4805 4806 Y_Addr := 4807 Unchecked_Convert_To (RTE (RE_Integer_Address), 4808 Make_Attribute_Reference (Loc, 4809 Attribute_Name => Name_Address, 4810 Prefix => New_Copy_Tree (Y))); 4811 4812 X_Size := 4813 Make_Op_Divide (Loc, 4814 Left_Opnd => 4815 Make_Attribute_Reference (Loc, 4816 Attribute_Name => Name_Size, 4817 Prefix => New_Copy_Tree (X)), 4818 Right_Opnd => 4819 Make_Integer_Literal (Loc, System_Storage_Unit)); 4820 4821 Y_Size := 4822 Make_Op_Divide (Loc, 4823 Left_Opnd => 4824 Make_Attribute_Reference (Loc, 4825 Attribute_Name => Name_Size, 4826 Prefix => New_Copy_Tree (Y)), 4827 Right_Opnd => 4828 Make_Integer_Literal (Loc, System_Storage_Unit)); 4829 4830 Cond := 4831 Make_Op_Le (Loc, 4832 Left_Opnd => X_Addr, 4833 Right_Opnd => Y_Addr); 4834 4835 Rewrite (N, 4836 Make_If_Expression (Loc, New_List ( 4837 Cond, 4838 4839 Make_Op_Ge (Loc, 4840 Left_Opnd => 4841 Make_Op_Add (Loc, 4842 Left_Opnd => New_Copy_Tree (X_Addr), 4843 Right_Opnd => 4844 Make_Op_Subtract (Loc, 4845 Left_Opnd => X_Size, 4846 Right_Opnd => Make_Integer_Literal (Loc, 1))), 4847 Right_Opnd => Y_Addr), 4848 4849 Make_Op_Ge (Loc, 4850 Left_Opnd => 4851 Make_Op_Add (Loc, 4852 Left_Opnd => New_Copy_Tree (Y_Addr), 4853 Right_Opnd => 4854 Make_Op_Subtract (Loc, 4855 Left_Opnd => Y_Size, 4856 Right_Opnd => Make_Integer_Literal (Loc, 1))), 4857 Right_Opnd => X_Addr)))); 4858 4859 Analyze_And_Resolve (N, Standard_Boolean); 4860 end Overlaps_Storage; 4861 4862 ------------ 4863 -- Output -- 4864 ------------ 4865 4866 when Attribute_Output => Output : declare 4867 P_Type : constant Entity_Id := Entity (Pref); 4868 U_Type : constant Entity_Id := Underlying_Type (P_Type); 4869 Pname : Entity_Id; 4870 Decl : Node_Id; 4871 Prag : Node_Id; 4872 Arg3 : Node_Id; 4873 Wfunc : Node_Id; 4874 4875 begin 4876 -- If no underlying type, we have an error that will be diagnosed 4877 -- elsewhere, so here we just completely ignore the expansion. 4878 4879 if No (U_Type) then 4880 return; 4881 end if; 4882 4883 -- Stream operations can appear in user code even if the restriction 4884 -- No_Streams is active (for example, when instantiating a predefined 4885 -- container). In that case rewrite the attribute as a Raise to 4886 -- prevent any run-time use. 4887 4888 if Restriction_Active (No_Streams) then 4889 Rewrite (N, 4890 Make_Raise_Program_Error (Sloc (N), 4891 Reason => PE_Stream_Operation_Not_Allowed)); 4892 Set_Etype (N, Standard_Void_Type); 4893 return; 4894 end if; 4895 4896 -- If TSS for Output is present, just call it 4897 4898 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output); 4899 4900 if Present (Pname) then 4901 null; 4902 4903 else 4904 -- If there is a Stream_Convert pragma, use it, we rewrite 4905 4906 -- sourcetyp'Output (stream, Item) 4907 4908 -- as 4909 4910 -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); 4911 4912 -- where strmwrite is the given Write function that converts an 4913 -- argument of type sourcetyp or a type acctyp, from which it is 4914 -- derived to type strmtyp. The conversion to acttyp is required 4915 -- for the derived case. 4916 4917 Prag := Get_Stream_Convert_Pragma (P_Type); 4918 4919 if Present (Prag) then 4920 Arg3 := 4921 Next (Next (First (Pragma_Argument_Associations (Prag)))); 4922 Wfunc := Entity (Expression (Arg3)); 4923 4924 Rewrite (N, 4925 Make_Attribute_Reference (Loc, 4926 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), 4927 Attribute_Name => Name_Output, 4928 Expressions => New_List ( 4929 Relocate_Node (First (Exprs)), 4930 Make_Function_Call (Loc, 4931 Name => New_Occurrence_Of (Wfunc, Loc), 4932 Parameter_Associations => New_List ( 4933 OK_Convert_To (Etype (First_Formal (Wfunc)), 4934 Relocate_Node (Next (First (Exprs))))))))); 4935 4936 Analyze (N); 4937 return; 4938 4939 -- For elementary types, we call the W_xxx routine directly. Note 4940 -- that the effect of Write and Output is identical for the case 4941 -- of an elementary type (there are no discriminants or bounds). 4942 4943 elsif Is_Elementary_Type (U_Type) then 4944 4945 -- A special case arises if we have a defined _Write routine, 4946 -- since in this case we are required to call this routine. 4947 4948 declare 4949 Typ : Entity_Id := P_Type; 4950 begin 4951 if Present (Full_View (Typ)) then 4952 Typ := Full_View (Typ); 4953 end if; 4954 4955 if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then 4956 Build_Record_Or_Elementary_Output_Procedure 4957 (Loc, Typ, Decl, Pname); 4958 Insert_Action (N, Decl); 4959 4960 -- For normal cases, we call the W_xxx routine directly 4961 4962 else 4963 Rewrite (N, Build_Elementary_Write_Call (N)); 4964 Analyze (N); 4965 return; 4966 end if; 4967 end; 4968 4969 -- Array type case 4970 4971 elsif Is_Array_Type (U_Type) then 4972 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname); 4973 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 4974 4975 -- Class-wide case, first output external tag, then dispatch 4976 -- to the appropriate primitive Output function (RM 13.13.2(31)). 4977 4978 elsif Is_Class_Wide_Type (P_Type) then 4979 4980 -- No need to do anything else compiling under restriction 4981 -- No_Dispatching_Calls. During the semantic analysis we 4982 -- already notified such violation. 4983 4984 if Restriction_Active (No_Dispatching_Calls) then 4985 return; 4986 end if; 4987 4988 Tag_Write : declare 4989 Strm : constant Node_Id := First (Exprs); 4990 Item : constant Node_Id := Next (Strm); 4991 4992 begin 4993 -- Ada 2005 (AI-344): Check that the accessibility level 4994 -- of the type of the output object is not deeper than 4995 -- that of the attribute's prefix type. 4996 4997 -- if Get_Access_Level (Item'Tag) 4998 -- /= Get_Access_Level (P_Type'Tag) 4999 -- then 5000 -- raise Tag_Error; 5001 -- end if; 5002 5003 -- String'Output (Strm, External_Tag (Item'Tag)); 5004 5005 -- We cannot figure out a practical way to implement this 5006 -- accessibility check on virtual machines, so we omit it. 5007 5008 if Ada_Version >= Ada_2005 5009 and then Tagged_Type_Expansion 5010 then 5011 Insert_Action (N, 5012 Make_Implicit_If_Statement (N, 5013 Condition => 5014 Make_Op_Ne (Loc, 5015 Left_Opnd => 5016 Build_Get_Access_Level (Loc, 5017 Make_Attribute_Reference (Loc, 5018 Prefix => 5019 Relocate_Node ( 5020 Duplicate_Subexpr (Item, 5021 Name_Req => True)), 5022 Attribute_Name => Name_Tag)), 5023 5024 Right_Opnd => 5025 Make_Integer_Literal (Loc, 5026 Type_Access_Level (P_Type))), 5027 5028 Then_Statements => 5029 New_List (Make_Raise_Statement (Loc, 5030 New_Occurrence_Of ( 5031 RTE (RE_Tag_Error), Loc))))); 5032 end if; 5033 5034 Insert_Action (N, 5035 Make_Attribute_Reference (Loc, 5036 Prefix => New_Occurrence_Of (Standard_String, Loc), 5037 Attribute_Name => Name_Output, 5038 Expressions => New_List ( 5039 Relocate_Node (Duplicate_Subexpr (Strm)), 5040 Make_Function_Call (Loc, 5041 Name => 5042 New_Occurrence_Of (RTE (RE_External_Tag), Loc), 5043 Parameter_Associations => New_List ( 5044 Make_Attribute_Reference (Loc, 5045 Prefix => 5046 Relocate_Node 5047 (Duplicate_Subexpr (Item, Name_Req => True)), 5048 Attribute_Name => Name_Tag)))))); 5049 end Tag_Write; 5050 5051 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); 5052 5053 -- Tagged type case, use the primitive Output function 5054 5055 elsif Is_Tagged_Type (U_Type) then 5056 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); 5057 5058 -- All other record type cases, including protected records. 5059 -- The latter only arise for expander generated code for 5060 -- handling shared passive partition access. 5061 5062 else 5063 pragma Assert 5064 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 5065 5066 -- Ada 2005 (AI-216): Program_Error is raised when executing 5067 -- the default implementation of the Output attribute of an 5068 -- unchecked union type if the type lacks default discriminant 5069 -- values. 5070 5071 if Is_Unchecked_Union (Base_Type (U_Type)) 5072 and then No (Discriminant_Constraint (U_Type)) 5073 then 5074 Insert_Action (N, 5075 Make_Raise_Program_Error (Loc, 5076 Reason => PE_Unchecked_Union_Restriction)); 5077 5078 return; 5079 end if; 5080 5081 Build_Record_Or_Elementary_Output_Procedure 5082 (Loc, Base_Type (U_Type), Decl, Pname); 5083 Insert_Action (N, Decl); 5084 end if; 5085 end if; 5086 5087 -- If we fall through, Pname is the name of the procedure to call 5088 5089 Rewrite_Stream_Proc_Call (Pname); 5090 end Output; 5091 5092 --------- 5093 -- Pos -- 5094 --------- 5095 5096 -- For enumeration types with a standard representation, Pos is 5097 -- handled by the back end. 5098 5099 -- For enumeration types, with a non-standard representation we generate 5100 -- a call to the _Rep_To_Pos function created when the type was frozen. 5101 -- The call has the form 5102 5103 -- _rep_to_pos (expr, flag) 5104 5105 -- The parameter flag is True if range checks are enabled, causing 5106 -- Program_Error to be raised if the expression has an invalid 5107 -- representation, and False if range checks are suppressed. 5108 5109 -- For integer types, Pos is equivalent to a simple integer 5110 -- conversion and we rewrite it as such 5111 5112 when Attribute_Pos => Pos : declare 5113 Etyp : Entity_Id := Base_Type (Entity (Pref)); 5114 5115 begin 5116 -- Deal with zero/non-zero boolean values 5117 5118 if Is_Boolean_Type (Etyp) then 5119 Adjust_Condition (First (Exprs)); 5120 Etyp := Standard_Boolean; 5121 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc)); 5122 end if; 5123 5124 -- Case of enumeration type 5125 5126 if Is_Enumeration_Type (Etyp) then 5127 5128 -- Non-standard enumeration type (generate call) 5129 5130 if Present (Enum_Pos_To_Rep (Etyp)) then 5131 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc)); 5132 Rewrite (N, 5133 Convert_To (Typ, 5134 Make_Function_Call (Loc, 5135 Name => 5136 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc), 5137 Parameter_Associations => Exprs))); 5138 5139 Analyze_And_Resolve (N, Typ); 5140 5141 -- Standard enumeration type (do universal integer check) 5142 5143 else 5144 Apply_Universal_Integer_Attribute_Checks (N); 5145 end if; 5146 5147 -- Deal with integer types (replace by conversion) 5148 5149 elsif Is_Integer_Type (Etyp) then 5150 Rewrite (N, Convert_To (Typ, First (Exprs))); 5151 Analyze_And_Resolve (N, Typ); 5152 end if; 5153 5154 end Pos; 5155 5156 -------------- 5157 -- Position -- 5158 -------------- 5159 5160 -- We compute this if a component clause was present, otherwise we leave 5161 -- the computation up to the back end, since we don't know what layout 5162 -- will be chosen. 5163 5164 when Attribute_Position => Position_Attr : declare 5165 CE : constant Entity_Id := Entity (Selector_Name (Pref)); 5166 5167 begin 5168 if Present (Component_Clause (CE)) then 5169 5170 -- In Ada 2005 (or later) if we have the non-default bit order, 5171 -- then we return the original value as given in the component 5172 -- clause (RM 2005 13.5.2(2/2)). 5173 5174 if Ada_Version >= Ada_2005 5175 and then Reverse_Bit_Order (Scope (CE)) 5176 then 5177 Rewrite (N, 5178 Make_Integer_Literal (Loc, 5179 Intval => Expr_Value (Position (Component_Clause (CE))))); 5180 5181 -- Otherwise (Ada 83 or 95, or default bit order specified in 5182 -- later Ada version), return the normalized value. 5183 5184 else 5185 Rewrite (N, 5186 Make_Integer_Literal (Loc, 5187 Intval => Component_Bit_Offset (CE) / System_Storage_Unit)); 5188 end if; 5189 5190 Analyze_And_Resolve (N, Typ); 5191 5192 -- If back end is doing things, just apply universal integer checks 5193 5194 else 5195 Apply_Universal_Integer_Attribute_Checks (N); 5196 end if; 5197 end Position_Attr; 5198 5199 ---------- 5200 -- Pred -- 5201 ---------- 5202 5203 -- 1. Deal with enumeration types with holes. 5204 -- 2. For floating-point, generate call to attribute function. 5205 -- 3. For other cases, deal with constraint checking. 5206 5207 when Attribute_Pred => Pred : declare 5208 Etyp : constant Entity_Id := Base_Type (Ptyp); 5209 5210 begin 5211 5212 -- For enumeration types with non-standard representations, we 5213 -- expand typ'Pred (x) into 5214 5215 -- Pos_To_Rep (Rep_To_Pos (x) - 1) 5216 5217 -- If the representation is contiguous, we compute instead 5218 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations. 5219 -- The conversion function Enum_Pos_To_Rep is defined on the 5220 -- base type, not the subtype, so we have to use the base type 5221 -- explicitly for this and other enumeration attributes. 5222 5223 if Is_Enumeration_Type (Ptyp) 5224 and then Present (Enum_Pos_To_Rep (Etyp)) 5225 then 5226 if Has_Contiguous_Rep (Etyp) then 5227 Rewrite (N, 5228 Unchecked_Convert_To (Ptyp, 5229 Make_Op_Add (Loc, 5230 Left_Opnd => 5231 Make_Integer_Literal (Loc, 5232 Enumeration_Rep (First_Literal (Ptyp))), 5233 Right_Opnd => 5234 Make_Function_Call (Loc, 5235 Name => 5236 New_Occurrence_Of 5237 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 5238 5239 Parameter_Associations => 5240 New_List ( 5241 Unchecked_Convert_To (Ptyp, 5242 Make_Op_Subtract (Loc, 5243 Left_Opnd => 5244 Unchecked_Convert_To (Standard_Integer, 5245 Relocate_Node (First (Exprs))), 5246 Right_Opnd => 5247 Make_Integer_Literal (Loc, 1))), 5248 Rep_To_Pos_Flag (Ptyp, Loc)))))); 5249 5250 else 5251 -- Add Boolean parameter True, to request program error if 5252 -- we have a bad representation on our hands. If checks are 5253 -- suppressed, then add False instead 5254 5255 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); 5256 Rewrite (N, 5257 Make_Indexed_Component (Loc, 5258 Prefix => 5259 New_Occurrence_Of 5260 (Enum_Pos_To_Rep (Etyp), Loc), 5261 Expressions => New_List ( 5262 Make_Op_Subtract (Loc, 5263 Left_Opnd => 5264 Make_Function_Call (Loc, 5265 Name => 5266 New_Occurrence_Of 5267 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 5268 Parameter_Associations => Exprs), 5269 Right_Opnd => Make_Integer_Literal (Loc, 1))))); 5270 end if; 5271 5272 Analyze_And_Resolve (N, Typ); 5273 5274 -- For floating-point, we transform 'Pred into a call to the Pred 5275 -- floating-point attribute function in Fat_xxx (xxx is root type). 5276 -- Note that this function takes care of the overflow case. 5277 5278 elsif Is_Floating_Point_Type (Ptyp) then 5279 Expand_Fpt_Attribute_R (N); 5280 Analyze_And_Resolve (N, Typ); 5281 5282 -- For modular types, nothing to do (no overflow, since wraps) 5283 5284 elsif Is_Modular_Integer_Type (Ptyp) then 5285 null; 5286 5287 -- For other types, if argument is marked as needing a range check or 5288 -- overflow checking is enabled, we must generate a check. 5289 5290 elsif not Overflow_Checks_Suppressed (Ptyp) 5291 or else Do_Range_Check (First (Exprs)) 5292 then 5293 Set_Do_Range_Check (First (Exprs), False); 5294 Expand_Pred_Succ_Attribute (N); 5295 end if; 5296 end Pred; 5297 5298 -------------- 5299 -- Priority -- 5300 -------------- 5301 5302 -- Ada 2005 (AI-327): Dynamic ceiling priorities 5303 5304 -- We rewrite X'Priority as the following run-time call: 5305 5306 -- Get_Ceiling (X._Object) 5307 5308 -- Note that although X'Priority is notionally an object, it is quite 5309 -- deliberately not defined as an aliased object in the RM. This means 5310 -- that it works fine to rewrite it as a call, without having to worry 5311 -- about complications that would other arise from X'Priority'Access, 5312 -- which is illegal, because of the lack of aliasing. 5313 5314 when Attribute_Priority => Priority : declare 5315 Call : Node_Id; 5316 Conctyp : Entity_Id; 5317 New_Itype : Entity_Id; 5318 Object_Parm : Node_Id; 5319 Subprg : Entity_Id; 5320 RT_Subprg_Name : Node_Id; 5321 5322 begin 5323 -- Look for the enclosing concurrent type 5324 5325 Conctyp := Current_Scope; 5326 while not Is_Concurrent_Type (Conctyp) loop 5327 Conctyp := Scope (Conctyp); 5328 end loop; 5329 5330 pragma Assert (Is_Protected_Type (Conctyp)); 5331 5332 -- Generate the actual of the call 5333 5334 Subprg := Current_Scope; 5335 while not Present (Protected_Body_Subprogram (Subprg)) loop 5336 Subprg := Scope (Subprg); 5337 end loop; 5338 5339 -- Use of 'Priority inside protected entries and barriers (in both 5340 -- cases the type of the first formal of their expanded subprogram 5341 -- is Address) 5342 5343 if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) = 5344 RTE (RE_Address) 5345 then 5346 -- In the expansion of protected entries the type of the first 5347 -- formal of the Protected_Body_Subprogram is an Address. In order 5348 -- to reference the _object component we generate: 5349 5350 -- type T is access p__ptTV; 5351 -- freeze T [] 5352 5353 New_Itype := Create_Itype (E_Access_Type, N); 5354 Set_Etype (New_Itype, New_Itype); 5355 Set_Directly_Designated_Type (New_Itype, 5356 Corresponding_Record_Type (Conctyp)); 5357 Freeze_Itype (New_Itype, N); 5358 5359 -- Generate: 5360 -- T!(O)._object'unchecked_access 5361 5362 Object_Parm := 5363 Make_Attribute_Reference (Loc, 5364 Prefix => 5365 Make_Selected_Component (Loc, 5366 Prefix => 5367 Unchecked_Convert_To (New_Itype, 5368 New_Occurrence_Of 5369 (First_Entity (Protected_Body_Subprogram (Subprg)), 5370 Loc)), 5371 Selector_Name => Make_Identifier (Loc, Name_uObject)), 5372 Attribute_Name => Name_Unchecked_Access); 5373 5374 -- Use of 'Priority inside a protected subprogram 5375 5376 else 5377 Object_Parm := 5378 Make_Attribute_Reference (Loc, 5379 Prefix => 5380 Make_Selected_Component (Loc, 5381 Prefix => 5382 New_Occurrence_Of 5383 (First_Entity (Protected_Body_Subprogram (Subprg)), 5384 Loc), 5385 Selector_Name => Make_Identifier (Loc, Name_uObject)), 5386 Attribute_Name => Name_Unchecked_Access); 5387 end if; 5388 5389 -- Select the appropriate run-time subprogram 5390 5391 if Number_Entries (Conctyp) = 0 then 5392 RT_Subprg_Name := New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc); 5393 else 5394 RT_Subprg_Name := New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc); 5395 end if; 5396 5397 Call := 5398 Make_Function_Call (Loc, 5399 Name => RT_Subprg_Name, 5400 Parameter_Associations => New_List (Object_Parm)); 5401 5402 Rewrite (N, Call); 5403 5404 -- Avoid the generation of extra checks on the pointer to the 5405 -- protected object. 5406 5407 Analyze_And_Resolve (N, Typ, Suppress => Access_Check); 5408 end Priority; 5409 5410 ------------------ 5411 -- Range_Length -- 5412 ------------------ 5413 5414 when Attribute_Range_Length => 5415 5416 -- The only special processing required is for the case where 5417 -- Range_Length is applied to an enumeration type with holes. 5418 -- In this case we transform 5419 5420 -- X'Range_Length 5421 5422 -- to 5423 5424 -- X'Pos (X'Last) - X'Pos (X'First) + 1 5425 5426 -- So that the result reflects the proper Pos values instead 5427 -- of the underlying representations. 5428 5429 if Is_Enumeration_Type (Ptyp) 5430 and then Has_Non_Standard_Rep (Ptyp) 5431 then 5432 Rewrite (N, 5433 Make_Op_Add (Loc, 5434 Left_Opnd => 5435 Make_Op_Subtract (Loc, 5436 Left_Opnd => 5437 Make_Attribute_Reference (Loc, 5438 Attribute_Name => Name_Pos, 5439 Prefix => New_Occurrence_Of (Ptyp, Loc), 5440 Expressions => New_List ( 5441 Make_Attribute_Reference (Loc, 5442 Attribute_Name => Name_Last, 5443 Prefix => 5444 New_Occurrence_Of (Ptyp, Loc)))), 5445 5446 Right_Opnd => 5447 Make_Attribute_Reference (Loc, 5448 Attribute_Name => Name_Pos, 5449 Prefix => New_Occurrence_Of (Ptyp, Loc), 5450 Expressions => New_List ( 5451 Make_Attribute_Reference (Loc, 5452 Attribute_Name => Name_First, 5453 Prefix => 5454 New_Occurrence_Of (Ptyp, Loc))))), 5455 5456 Right_Opnd => Make_Integer_Literal (Loc, 1))); 5457 5458 Analyze_And_Resolve (N, Typ); 5459 5460 -- For all other cases, the attribute is handled by the back end, but 5461 -- we need to deal with the case of the range check on a universal 5462 -- integer. 5463 5464 else 5465 Apply_Universal_Integer_Attribute_Checks (N); 5466 end if; 5467 5468 ------------ 5469 -- Reduce -- 5470 ------------ 5471 5472 when Attribute_Reduce => 5473 declare 5474 Loc : constant Source_Ptr := Sloc (N); 5475 E1 : constant Node_Id := First (Expressions (N)); 5476 E2 : constant Node_Id := Next (E1); 5477 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 5478 Typ : constant Entity_Id := Etype (N); 5479 New_Loop : Node_Id; 5480 5481 -- If the prefix is an aggregwte, its unique component is sn 5482 -- Iterated_Element, and we create a loop out of its itertor. 5483 5484 begin 5485 if Nkind (Prefix (N)) = N_Aggregate then 5486 declare 5487 Stream : constant Node_Id := 5488 First (Component_Associations (Prefix (N))); 5489 Id : constant Node_Id := Defining_Identifier (Stream); 5490 Expr : constant Node_Id := Expression (Stream); 5491 Ch : constant Node_Id := 5492 First (Discrete_Choices (Stream)); 5493 begin 5494 New_Loop := Make_Loop_Statement (Loc, 5495 Iteration_Scheme => 5496 Make_Iteration_Scheme (Loc, 5497 Iterator_Specification => Empty, 5498 Loop_Parameter_Specification => 5499 Make_Loop_Parameter_Specification (Loc, 5500 Defining_Identifier => New_Copy (Id), 5501 Discrete_Subtype_Definition => 5502 Relocate_Node (Ch))), 5503 End_Label => Empty, 5504 Statements => New_List ( 5505 Make_Assignment_Statement (Loc, 5506 Name => New_Occurrence_Of (Bnn, Loc), 5507 Expression => Make_Function_Call (Loc, 5508 Name => New_Occurrence_Of (Entity (E1), Loc), 5509 Parameter_Associations => New_List ( 5510 New_Occurrence_Of (Bnn, Loc), 5511 Relocate_Node (Expr)))))); 5512 end; 5513 else 5514 -- If the prefix is a name we construct an element iterwtor 5515 -- over it. Its expansion will verify that it is an array 5516 -- or a container with the proper aspects. 5517 5518 declare 5519 Iter : Node_Id; 5520 Elem : constant Entity_Id := Make_Temporary (Loc, 'E', N); 5521 5522 begin 5523 Iter := 5524 Make_Iterator_Specification (Loc, 5525 Defining_Identifier => Elem, 5526 Name => Relocate_Node (Prefix (N)), 5527 Subtype_Indication => Empty); 5528 Set_Of_Present (Iter); 5529 5530 New_Loop := Make_Loop_Statement (Loc, 5531 Iteration_Scheme => 5532 Make_Iteration_Scheme (Loc, 5533 Iterator_Specification => Iter, 5534 Loop_Parameter_Specification => Empty), 5535 End_Label => Empty, 5536 Statements => New_List ( 5537 Make_Assignment_Statement (Loc, 5538 Name => New_Occurrence_Of (Bnn, Loc), 5539 Expression => Make_Function_Call (Loc, 5540 Name => New_Occurrence_Of (Entity (E1), Loc), 5541 Parameter_Associations => New_List ( 5542 New_Occurrence_Of (Bnn, Loc), 5543 New_Occurrence_Of (Elem, Loc)))))); 5544 end; 5545 end if; 5546 5547 Rewrite (N, 5548 Make_Expression_With_Actions (Loc, 5549 Actions => New_List ( 5550 Make_Object_Declaration (Loc, 5551 Defining_Identifier => Bnn, 5552 Object_Definition => 5553 New_Occurrence_Of (Typ, Loc), 5554 Expression => Relocate_Node (E2)), New_Loop), 5555 Expression => New_Occurrence_Of (Bnn, Loc))); 5556 Analyze_And_Resolve (N, Typ); 5557 end; 5558 5559 ---------- 5560 -- Read -- 5561 ---------- 5562 5563 when Attribute_Read => Read : declare 5564 P_Type : constant Entity_Id := Entity (Pref); 5565 B_Type : constant Entity_Id := Base_Type (P_Type); 5566 U_Type : constant Entity_Id := Underlying_Type (P_Type); 5567 Pname : Entity_Id; 5568 Decl : Node_Id; 5569 Prag : Node_Id; 5570 Arg2 : Node_Id; 5571 Rfunc : Node_Id; 5572 Lhs : Node_Id; 5573 Rhs : Node_Id; 5574 5575 begin 5576 -- If no underlying type, we have an error that will be diagnosed 5577 -- elsewhere, so here we just completely ignore the expansion. 5578 5579 if No (U_Type) then 5580 return; 5581 end if; 5582 5583 -- Stream operations can appear in user code even if the restriction 5584 -- No_Streams is active (for example, when instantiating a predefined 5585 -- container). In that case rewrite the attribute as a Raise to 5586 -- prevent any run-time use. 5587 5588 if Restriction_Active (No_Streams) then 5589 Rewrite (N, 5590 Make_Raise_Program_Error (Sloc (N), 5591 Reason => PE_Stream_Operation_Not_Allowed)); 5592 Set_Etype (N, B_Type); 5593 return; 5594 end if; 5595 5596 -- The simple case, if there is a TSS for Read, just call it 5597 5598 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read); 5599 5600 if Present (Pname) then 5601 null; 5602 5603 else 5604 -- If there is a Stream_Convert pragma, use it, we rewrite 5605 5606 -- sourcetyp'Read (stream, Item) 5607 5608 -- as 5609 5610 -- Item := sourcetyp (strmread (strmtyp'Input (Stream))); 5611 5612 -- where strmread is the given Read function that converts an 5613 -- argument of type strmtyp to type sourcetyp or a type from which 5614 -- it is derived. The conversion to sourcetyp is required in the 5615 -- latter case. 5616 5617 -- A special case arises if Item is a type conversion in which 5618 -- case, we have to expand to: 5619 5620 -- Itemx := typex (strmread (strmtyp'Input (Stream))); 5621 5622 -- where Itemx is the expression of the type conversion (i.e. 5623 -- the actual object), and typex is the type of Itemx. 5624 5625 Prag := Get_Stream_Convert_Pragma (P_Type); 5626 5627 if Present (Prag) then 5628 Arg2 := Next (First (Pragma_Argument_Associations (Prag))); 5629 Rfunc := Entity (Expression (Arg2)); 5630 Lhs := Relocate_Node (Next (First (Exprs))); 5631 Rhs := 5632 OK_Convert_To (B_Type, 5633 Make_Function_Call (Loc, 5634 Name => New_Occurrence_Of (Rfunc, Loc), 5635 Parameter_Associations => New_List ( 5636 Make_Attribute_Reference (Loc, 5637 Prefix => 5638 New_Occurrence_Of 5639 (Etype (First_Formal (Rfunc)), Loc), 5640 Attribute_Name => Name_Input, 5641 Expressions => New_List ( 5642 Relocate_Node (First (Exprs))))))); 5643 5644 if Nkind (Lhs) = N_Type_Conversion then 5645 Lhs := Expression (Lhs); 5646 Rhs := Convert_To (Etype (Lhs), Rhs); 5647 end if; 5648 5649 Rewrite (N, 5650 Make_Assignment_Statement (Loc, 5651 Name => Lhs, 5652 Expression => Rhs)); 5653 Set_Assignment_OK (Lhs); 5654 Analyze (N); 5655 return; 5656 5657 -- For elementary types, we call the I_xxx routine using the first 5658 -- parameter and then assign the result into the second parameter. 5659 -- We set Assignment_OK to deal with the conversion case. 5660 5661 elsif Is_Elementary_Type (U_Type) then 5662 declare 5663 Lhs : Node_Id; 5664 Rhs : Node_Id; 5665 5666 begin 5667 Lhs := Relocate_Node (Next (First (Exprs))); 5668 Rhs := Build_Elementary_Input_Call (N); 5669 5670 if Nkind (Lhs) = N_Type_Conversion then 5671 Lhs := Expression (Lhs); 5672 Rhs := Convert_To (Etype (Lhs), Rhs); 5673 end if; 5674 5675 Set_Assignment_OK (Lhs); 5676 5677 Rewrite (N, 5678 Make_Assignment_Statement (Loc, 5679 Name => Lhs, 5680 Expression => Rhs)); 5681 5682 Analyze (N); 5683 return; 5684 end; 5685 5686 -- Array type case 5687 5688 elsif Is_Array_Type (U_Type) then 5689 Build_Array_Read_Procedure (N, U_Type, Decl, Pname); 5690 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 5691 5692 -- Tagged type case, use the primitive Read function. Note that 5693 -- this will dispatch in the class-wide case which is what we want 5694 5695 elsif Is_Tagged_Type (U_Type) then 5696 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read); 5697 5698 -- All other record type cases, including protected records. The 5699 -- latter only arise for expander generated code for handling 5700 -- shared passive partition access. 5701 5702 else 5703 pragma Assert 5704 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 5705 5706 -- Ada 2005 (AI-216): Program_Error is raised when executing 5707 -- the default implementation of the Read attribute of an 5708 -- Unchecked_Union type. We replace the attribute with a 5709 -- raise statement (rather than inserting it before) to handle 5710 -- properly the case of an unchecked union that is a record 5711 -- component. 5712 5713 if Is_Unchecked_Union (Base_Type (U_Type)) then 5714 Rewrite (N, 5715 Make_Raise_Program_Error (Loc, 5716 Reason => PE_Unchecked_Union_Restriction)); 5717 Set_Etype (N, B_Type); 5718 return; 5719 end if; 5720 5721 if Has_Discriminants (U_Type) 5722 and then Present 5723 (Discriminant_Default_Value (First_Discriminant (U_Type))) 5724 then 5725 Build_Mutable_Record_Read_Procedure 5726 (Loc, Full_Base (U_Type), Decl, Pname); 5727 else 5728 Build_Record_Read_Procedure 5729 (Loc, Full_Base (U_Type), Decl, Pname); 5730 end if; 5731 5732 -- Suppress checks, uninitialized or otherwise invalid 5733 -- data does not cause constraint errors to be raised for 5734 -- a complete record read. 5735 5736 Insert_Action (N, Decl, All_Checks); 5737 end if; 5738 end if; 5739 5740 Rewrite_Stream_Proc_Call (Pname); 5741 end Read; 5742 5743 --------- 5744 -- Ref -- 5745 --------- 5746 5747 -- Ref is identical to To_Address, see To_Address for processing 5748 5749 --------------- 5750 -- Remainder -- 5751 --------------- 5752 5753 -- Transforms 'Remainder into a call to the floating-point attribute 5754 -- function Remainder in Fat_xxx (where xxx is the root type) 5755 5756 when Attribute_Remainder => 5757 Expand_Fpt_Attribute_RR (N); 5758 5759 ------------ 5760 -- Result -- 5761 ------------ 5762 5763 -- Transform 'Result into reference to _Result formal. At the point 5764 -- where a legal 'Result attribute is expanded, we know that we are in 5765 -- the context of a _Postcondition function with a _Result parameter. 5766 5767 when Attribute_Result => 5768 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult)); 5769 Analyze_And_Resolve (N, Typ); 5770 5771 ----------- 5772 -- Round -- 5773 ----------- 5774 5775 -- The handling of the Round attribute is quite delicate. The processing 5776 -- in Sem_Attr introduced a conversion to universal real, reflecting the 5777 -- semantics of Round, but we do not want anything to do with universal 5778 -- real at runtime, since this corresponds to using floating-point 5779 -- arithmetic. 5780 5781 -- What we have now is that the Etype of the Round attribute correctly 5782 -- indicates the final result type. The operand of the Round is the 5783 -- conversion to universal real, described above, and the operand of 5784 -- this conversion is the actual operand of Round, which may be the 5785 -- special case of a fixed point multiplication or division (Etype = 5786 -- universal fixed) 5787 5788 -- The exapander will expand first the operand of the conversion, then 5789 -- the conversion, and finally the round attribute itself, since we 5790 -- always work inside out. But we cannot simply process naively in this 5791 -- order. In the semantic world where universal fixed and real really 5792 -- exist and have infinite precision, there is no problem, but in the 5793 -- implementation world, where universal real is a floating-point type, 5794 -- we would get the wrong result. 5795 5796 -- So the approach is as follows. First, when expanding a multiply or 5797 -- divide whose type is universal fixed, we do nothing at all, instead 5798 -- deferring the operation till later. 5799 5800 -- The actual processing is done in Expand_N_Type_Conversion which 5801 -- handles the special case of Round by looking at its parent to see if 5802 -- it is a Round attribute, and if it is, handling the conversion (or 5803 -- its fixed multiply/divide child) in an appropriate manner. 5804 5805 -- This means that by the time we get to expanding the Round attribute 5806 -- itself, the Round is nothing more than a type conversion (and will 5807 -- often be a null type conversion), so we just replace it with the 5808 -- appropriate conversion operation. 5809 5810 when Attribute_Round => 5811 Rewrite (N, 5812 Convert_To (Etype (N), Relocate_Node (First (Exprs)))); 5813 Analyze_And_Resolve (N); 5814 5815 -------------- 5816 -- Rounding -- 5817 -------------- 5818 5819 -- Transforms 'Rounding into a call to the floating-point attribute 5820 -- function Rounding in Fat_xxx (where xxx is the root type) 5821 -- Expansion is avoided for cases the back end can handle directly. 5822 5823 when Attribute_Rounding => 5824 if not Is_Inline_Floating_Point_Attribute (N) then 5825 Expand_Fpt_Attribute_R (N); 5826 end if; 5827 5828 ------------- 5829 -- Scaling -- 5830 ------------- 5831 5832 -- Transforms 'Scaling into a call to the floating-point attribute 5833 -- function Scaling in Fat_xxx (where xxx is the root type) 5834 5835 when Attribute_Scaling => 5836 Expand_Fpt_Attribute_RI (N); 5837 5838 ------------------------- 5839 -- Simple_Storage_Pool -- 5840 ------------------------- 5841 5842 when Attribute_Simple_Storage_Pool => 5843 Rewrite (N, 5844 Make_Type_Conversion (Loc, 5845 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), 5846 Expression => New_Occurrence_Of (Entity (N), Loc))); 5847 Analyze_And_Resolve (N, Typ); 5848 5849 ---------- 5850 -- Size -- 5851 ---------- 5852 5853 when Attribute_Object_Size 5854 | Attribute_Size 5855 | Attribute_Value_Size 5856 | Attribute_VADS_Size 5857 => 5858 Size : declare 5859 New_Node : Node_Id; 5860 5861 begin 5862 -- Processing for VADS_Size case. Note that this processing 5863 -- removes all traces of VADS_Size from the tree, and completes 5864 -- all required processing for VADS_Size by translating the 5865 -- attribute reference to an appropriate Size or Object_Size 5866 -- reference. 5867 5868 if Id = Attribute_VADS_Size 5869 or else (Use_VADS_Size and then Id = Attribute_Size) 5870 then 5871 -- If the size is specified, then we simply use the specified 5872 -- size. This applies to both types and objects. The size of an 5873 -- object can be specified in the following ways: 5874 5875 -- An explicit size object is given for an object 5876 -- A component size is specified for an indexed component 5877 -- A component clause is specified for a selected component 5878 -- The object is a component of a packed composite object 5879 5880 -- If the size is specified, then VADS_Size of an object 5881 5882 if (Is_Entity_Name (Pref) 5883 and then Present (Size_Clause (Entity (Pref)))) 5884 or else 5885 (Nkind (Pref) = N_Component_Clause 5886 and then (Present (Component_Clause 5887 (Entity (Selector_Name (Pref)))) 5888 or else Is_Packed (Etype (Prefix (Pref))))) 5889 or else 5890 (Nkind (Pref) = N_Indexed_Component 5891 and then (Component_Size (Etype (Prefix (Pref))) /= 0 5892 or else Is_Packed (Etype (Prefix (Pref))))) 5893 then 5894 Set_Attribute_Name (N, Name_Size); 5895 5896 -- Otherwise if we have an object rather than a type, then 5897 -- the VADS_Size attribute applies to the type of the object, 5898 -- rather than the object itself. This is one of the respects 5899 -- in which VADS_Size differs from Size. 5900 5901 else 5902 if (not Is_Entity_Name (Pref) 5903 or else not Is_Type (Entity (Pref))) 5904 and then (Is_Scalar_Type (Ptyp) 5905 or else Is_Constrained (Ptyp)) 5906 then 5907 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc)); 5908 end if; 5909 5910 -- For a scalar type for which no size was explicitly given, 5911 -- VADS_Size means Object_Size. This is the other respect in 5912 -- which VADS_Size differs from Size. 5913 5914 if Is_Scalar_Type (Ptyp) 5915 and then No (Size_Clause (Ptyp)) 5916 then 5917 Set_Attribute_Name (N, Name_Object_Size); 5918 5919 -- In all other cases, Size and VADS_Size are the sane 5920 5921 else 5922 Set_Attribute_Name (N, Name_Size); 5923 end if; 5924 end if; 5925 end if; 5926 5927 -- If the prefix is X'Class, transform it into a direct reference 5928 -- to the class-wide type, because the back end must not see a 5929 -- 'Class reference. 5930 5931 if Is_Entity_Name (Pref) 5932 and then Is_Class_Wide_Type (Entity (Pref)) 5933 then 5934 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); 5935 return; 5936 5937 -- For X'Size applied to an object of a class-wide type, transform 5938 -- X'Size into a call to the primitive operation _Size applied to 5939 -- X. 5940 5941 elsif Is_Class_Wide_Type (Ptyp) then 5942 5943 -- No need to do anything else compiling under restriction 5944 -- No_Dispatching_Calls. During the semantic analysis we 5945 -- already noted this restriction violation. 5946 5947 if Restriction_Active (No_Dispatching_Calls) then 5948 return; 5949 end if; 5950 5951 New_Node := 5952 Make_Function_Call (Loc, 5953 Name => 5954 New_Occurrence_Of (Find_Prim_Op (Ptyp, Name_uSize), Loc), 5955 Parameter_Associations => New_List (Pref)); 5956 5957 if Typ /= Standard_Long_Long_Integer then 5958 5959 -- The context is a specific integer type with which the 5960 -- original attribute was compatible. The function has a 5961 -- specific type as well, so to preserve the compatibility 5962 -- we must convert explicitly. 5963 5964 New_Node := Convert_To (Typ, New_Node); 5965 end if; 5966 5967 Rewrite (N, New_Node); 5968 Analyze_And_Resolve (N, Typ); 5969 return; 5970 end if; 5971 5972 -- Call Expand_Size_Attribute to do the final part of the 5973 -- expansion which is shared with GNATprove expansion. 5974 5975 Expand_Size_Attribute (N); 5976 end Size; 5977 5978 ------------------ 5979 -- Storage_Pool -- 5980 ------------------ 5981 5982 when Attribute_Storage_Pool => 5983 Rewrite (N, 5984 Make_Type_Conversion (Loc, 5985 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), 5986 Expression => New_Occurrence_Of (Entity (N), Loc))); 5987 Analyze_And_Resolve (N, Typ); 5988 5989 ------------------ 5990 -- Storage_Size -- 5991 ------------------ 5992 5993 when Attribute_Storage_Size => Storage_Size : declare 5994 Alloc_Op : Entity_Id := Empty; 5995 5996 begin 5997 5998 -- Access type case, always go to the root type 5999 6000 -- The case of access types results in a value of zero for the case 6001 -- where no storage size attribute clause has been given. If a 6002 -- storage size has been given, then the attribute is converted 6003 -- to a reference to the variable used to hold this value. 6004 6005 if Is_Access_Type (Ptyp) then 6006 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then 6007 Rewrite (N, 6008 Make_Attribute_Reference (Loc, 6009 Prefix => New_Occurrence_Of (Typ, Loc), 6010 Attribute_Name => Name_Max, 6011 Expressions => New_List ( 6012 Make_Integer_Literal (Loc, 0), 6013 Convert_To (Typ, 6014 New_Occurrence_Of 6015 (Storage_Size_Variable (Root_Type (Ptyp)), Loc))))); 6016 6017 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then 6018 6019 -- If the access type is associated with a simple storage pool 6020 -- object, then attempt to locate the optional Storage_Size 6021 -- function of the simple storage pool type. If not found, 6022 -- then the result will default to zero. 6023 6024 if Present (Get_Rep_Pragma (Root_Type (Ptyp), 6025 Name_Simple_Storage_Pool_Type)) 6026 then 6027 declare 6028 Pool_Type : constant Entity_Id := 6029 Base_Type (Etype (Entity (N))); 6030 6031 begin 6032 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size); 6033 while Present (Alloc_Op) loop 6034 if Scope (Alloc_Op) = Scope (Pool_Type) 6035 and then Present (First_Formal (Alloc_Op)) 6036 and then Etype (First_Formal (Alloc_Op)) = Pool_Type 6037 then 6038 exit; 6039 end if; 6040 6041 Alloc_Op := Homonym (Alloc_Op); 6042 end loop; 6043 end; 6044 6045 -- In the normal Storage_Pool case, retrieve the primitive 6046 -- function associated with the pool type. 6047 6048 else 6049 Alloc_Op := 6050 Find_Prim_Op 6051 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))), 6052 Attribute_Name (N)); 6053 end if; 6054 6055 -- If Storage_Size wasn't found (can only occur in the simple 6056 -- storage pool case), then simply use zero for the result. 6057 6058 if not Present (Alloc_Op) then 6059 Rewrite (N, Make_Integer_Literal (Loc, 0)); 6060 6061 -- Otherwise, rewrite the allocator as a call to pool type's 6062 -- Storage_Size function. 6063 6064 else 6065 Rewrite (N, 6066 OK_Convert_To (Typ, 6067 Make_Function_Call (Loc, 6068 Name => 6069 New_Occurrence_Of (Alloc_Op, Loc), 6070 6071 Parameter_Associations => New_List ( 6072 New_Occurrence_Of 6073 (Associated_Storage_Pool 6074 (Root_Type (Ptyp)), Loc))))); 6075 end if; 6076 6077 else 6078 Rewrite (N, Make_Integer_Literal (Loc, 0)); 6079 end if; 6080 6081 Analyze_And_Resolve (N, Typ); 6082 6083 -- For tasks, we retrieve the size directly from the TCB. The 6084 -- size may depend on a discriminant of the type, and therefore 6085 -- can be a per-object expression, so type-level information is 6086 -- not sufficient in general. There are four cases to consider: 6087 6088 -- a) If the attribute appears within a task body, the designated 6089 -- TCB is obtained by a call to Self. 6090 6091 -- b) If the prefix of the attribute is the name of a task object, 6092 -- the designated TCB is the one stored in the corresponding record. 6093 6094 -- c) If the prefix is a task type, the size is obtained from the 6095 -- size variable created for each task type 6096 6097 -- d) If no Storage_Size was specified for the type, there is no 6098 -- size variable, and the value is a system-specific default. 6099 6100 else 6101 if In_Open_Scopes (Ptyp) then 6102 6103 -- Storage_Size (Self) 6104 6105 Rewrite (N, 6106 Convert_To (Typ, 6107 Make_Function_Call (Loc, 6108 Name => 6109 New_Occurrence_Of (RTE (RE_Storage_Size), Loc), 6110 Parameter_Associations => 6111 New_List ( 6112 Make_Function_Call (Loc, 6113 Name => 6114 New_Occurrence_Of (RTE (RE_Self), Loc)))))); 6115 6116 elsif not Is_Entity_Name (Pref) 6117 or else not Is_Type (Entity (Pref)) 6118 then 6119 -- Storage_Size (Rec (Obj).Size) 6120 6121 Rewrite (N, 6122 Convert_To (Typ, 6123 Make_Function_Call (Loc, 6124 Name => 6125 New_Occurrence_Of (RTE (RE_Storage_Size), Loc), 6126 Parameter_Associations => 6127 New_List ( 6128 Make_Selected_Component (Loc, 6129 Prefix => 6130 Unchecked_Convert_To ( 6131 Corresponding_Record_Type (Ptyp), 6132 New_Copy_Tree (Pref)), 6133 Selector_Name => 6134 Make_Identifier (Loc, Name_uTask_Id)))))); 6135 6136 elsif Present (Storage_Size_Variable (Ptyp)) then 6137 6138 -- Static Storage_Size pragma given for type: retrieve value 6139 -- from its allocated storage variable. 6140 6141 Rewrite (N, 6142 Convert_To (Typ, 6143 Make_Function_Call (Loc, 6144 Name => New_Occurrence_Of ( 6145 RTE (RE_Adjust_Storage_Size), Loc), 6146 Parameter_Associations => 6147 New_List ( 6148 New_Occurrence_Of ( 6149 Storage_Size_Variable (Ptyp), Loc))))); 6150 else 6151 -- Get system default 6152 6153 Rewrite (N, 6154 Convert_To (Typ, 6155 Make_Function_Call (Loc, 6156 Name => 6157 New_Occurrence_Of ( 6158 RTE (RE_Default_Stack_Size), Loc)))); 6159 end if; 6160 6161 Analyze_And_Resolve (N, Typ); 6162 end if; 6163 end Storage_Size; 6164 6165 ----------------- 6166 -- Stream_Size -- 6167 ----------------- 6168 6169 when Attribute_Stream_Size => 6170 Rewrite (N, 6171 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp))); 6172 Analyze_And_Resolve (N, Typ); 6173 6174 ---------- 6175 -- Succ -- 6176 ---------- 6177 6178 -- 1. Deal with enumeration types with holes. 6179 -- 2. For floating-point, generate call to attribute function. 6180 -- 3. For other cases, deal with constraint checking. 6181 6182 when Attribute_Succ => Succ : declare 6183 Etyp : constant Entity_Id := Base_Type (Ptyp); 6184 6185 begin 6186 -- For enumeration types with non-standard representations, we 6187 -- expand typ'Succ (x) into 6188 6189 -- Pos_To_Rep (Rep_To_Pos (x) + 1) 6190 6191 -- If the representation is contiguous, we compute instead 6192 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations. 6193 6194 if Is_Enumeration_Type (Ptyp) 6195 and then Present (Enum_Pos_To_Rep (Etyp)) 6196 then 6197 if Has_Contiguous_Rep (Etyp) then 6198 Rewrite (N, 6199 Unchecked_Convert_To (Ptyp, 6200 Make_Op_Add (Loc, 6201 Left_Opnd => 6202 Make_Integer_Literal (Loc, 6203 Enumeration_Rep (First_Literal (Ptyp))), 6204 Right_Opnd => 6205 Make_Function_Call (Loc, 6206 Name => 6207 New_Occurrence_Of 6208 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 6209 6210 Parameter_Associations => 6211 New_List ( 6212 Unchecked_Convert_To (Ptyp, 6213 Make_Op_Add (Loc, 6214 Left_Opnd => 6215 Unchecked_Convert_To (Standard_Integer, 6216 Relocate_Node (First (Exprs))), 6217 Right_Opnd => 6218 Make_Integer_Literal (Loc, 1))), 6219 Rep_To_Pos_Flag (Ptyp, Loc)))))); 6220 else 6221 -- Add Boolean parameter True, to request program error if 6222 -- we have a bad representation on our hands. Add False if 6223 -- checks are suppressed. 6224 6225 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); 6226 Rewrite (N, 6227 Make_Indexed_Component (Loc, 6228 Prefix => 6229 New_Occurrence_Of 6230 (Enum_Pos_To_Rep (Etyp), Loc), 6231 Expressions => New_List ( 6232 Make_Op_Add (Loc, 6233 Left_Opnd => 6234 Make_Function_Call (Loc, 6235 Name => 6236 New_Occurrence_Of 6237 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 6238 Parameter_Associations => Exprs), 6239 Right_Opnd => Make_Integer_Literal (Loc, 1))))); 6240 end if; 6241 6242 Analyze_And_Resolve (N, Typ); 6243 6244 -- For floating-point, we transform 'Succ into a call to the Succ 6245 -- floating-point attribute function in Fat_xxx (xxx is root type) 6246 6247 elsif Is_Floating_Point_Type (Ptyp) then 6248 Expand_Fpt_Attribute_R (N); 6249 Analyze_And_Resolve (N, Typ); 6250 6251 -- For modular types, nothing to do (no overflow, since wraps) 6252 6253 elsif Is_Modular_Integer_Type (Ptyp) then 6254 null; 6255 6256 -- For other types, if argument is marked as needing a range check or 6257 -- overflow checking is enabled, we must generate a check. 6258 6259 elsif not Overflow_Checks_Suppressed (Ptyp) 6260 or else Do_Range_Check (First (Exprs)) 6261 then 6262 Set_Do_Range_Check (First (Exprs), False); 6263 Expand_Pred_Succ_Attribute (N); 6264 end if; 6265 end Succ; 6266 6267 --------- 6268 -- Tag -- 6269 --------- 6270 6271 -- Transforms X'Tag into a direct reference to the tag of X 6272 6273 when Attribute_Tag => Tag : declare 6274 Ttyp : Entity_Id; 6275 Prefix_Is_Type : Boolean; 6276 6277 begin 6278 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then 6279 Ttyp := Entity (Pref); 6280 Prefix_Is_Type := True; 6281 else 6282 Ttyp := Ptyp; 6283 Prefix_Is_Type := False; 6284 end if; 6285 6286 if Is_Class_Wide_Type (Ttyp) then 6287 Ttyp := Root_Type (Ttyp); 6288 end if; 6289 6290 Ttyp := Underlying_Type (Ttyp); 6291 6292 -- Ada 2005: The type may be a synchronized tagged type, in which 6293 -- case the tag information is stored in the corresponding record. 6294 6295 if Is_Concurrent_Type (Ttyp) then 6296 Ttyp := Corresponding_Record_Type (Ttyp); 6297 end if; 6298 6299 if Prefix_Is_Type then 6300 6301 -- For VMs we leave the type attribute unexpanded because 6302 -- there's not a dispatching table to reference. 6303 6304 if Tagged_Type_Expansion then 6305 Rewrite (N, 6306 Unchecked_Convert_To (RTE (RE_Tag), 6307 New_Occurrence_Of 6308 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc))); 6309 Analyze_And_Resolve (N, RTE (RE_Tag)); 6310 end if; 6311 6312 -- Ada 2005 (AI-251): The use of 'Tag in the sources always 6313 -- references the primary tag of the actual object. If 'Tag is 6314 -- applied to class-wide interface objects we generate code that 6315 -- displaces "this" to reference the base of the object. 6316 6317 elsif Comes_From_Source (N) 6318 and then Is_Class_Wide_Type (Etype (Prefix (N))) 6319 and then Is_Interface (Underlying_Type (Etype (Prefix (N)))) 6320 then 6321 -- Generate: 6322 -- (To_Tag_Ptr (Prefix'Address)).all 6323 6324 -- Note that Prefix'Address is recursively expanded into a call 6325 -- to Base_Address (Obj.Tag) 6326 6327 -- Not needed for VM targets, since all handled by the VM 6328 6329 if Tagged_Type_Expansion then 6330 Rewrite (N, 6331 Make_Explicit_Dereference (Loc, 6332 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 6333 Make_Attribute_Reference (Loc, 6334 Prefix => Relocate_Node (Pref), 6335 Attribute_Name => Name_Address)))); 6336 Analyze_And_Resolve (N, RTE (RE_Tag)); 6337 end if; 6338 6339 else 6340 Rewrite (N, 6341 Make_Selected_Component (Loc, 6342 Prefix => Relocate_Node (Pref), 6343 Selector_Name => 6344 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc))); 6345 Analyze_And_Resolve (N, RTE (RE_Tag)); 6346 end if; 6347 end Tag; 6348 6349 ---------------- 6350 -- Terminated -- 6351 ---------------- 6352 6353 -- Transforms 'Terminated attribute into a call to Terminated function 6354 6355 when Attribute_Terminated => Terminated : begin 6356 6357 -- The prefix of Terminated is of a task interface class-wide type. 6358 -- Generate: 6359 -- terminated (Task_Id (_disp_get_task_id (Pref))); 6360 6361 if Ada_Version >= Ada_2005 6362 and then Ekind (Ptyp) = E_Class_Wide_Type 6363 and then Is_Interface (Ptyp) 6364 and then Is_Task_Interface (Ptyp) 6365 then 6366 Rewrite (N, 6367 Make_Function_Call (Loc, 6368 Name => 6369 New_Occurrence_Of (RTE (RE_Terminated), Loc), 6370 Parameter_Associations => New_List ( 6371 Make_Unchecked_Type_Conversion (Loc, 6372 Subtype_Mark => 6373 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 6374 Expression => Build_Disp_Get_Task_Id_Call (Pref))))); 6375 6376 elsif Restricted_Profile then 6377 Rewrite (N, 6378 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated))); 6379 6380 else 6381 Rewrite (N, 6382 Build_Call_With_Task (Pref, RTE (RE_Terminated))); 6383 end if; 6384 6385 Analyze_And_Resolve (N, Standard_Boolean); 6386 end Terminated; 6387 6388 ---------------- 6389 -- To_Address -- 6390 ---------------- 6391 6392 -- Transforms System'To_Address (X) and System.Address'Ref (X) into 6393 -- unchecked conversion from (integral) type of X to type address. If 6394 -- the To_Address is a static expression, the transformed expression 6395 -- also needs to be static, because we do some legality checks (e.g. 6396 -- for Thread_Local_Storage) after this transformation. 6397 6398 when Attribute_Ref 6399 | Attribute_To_Address 6400 => 6401 To_Address : declare 6402 Is_Static : constant Boolean := Is_Static_Expression (N); 6403 6404 begin 6405 Rewrite (N, 6406 Unchecked_Convert_To (RTE (RE_Address), 6407 Relocate_Node (First (Exprs)))); 6408 Set_Is_Static_Expression (N, Is_Static); 6409 6410 Analyze_And_Resolve (N, RTE (RE_Address)); 6411 end To_Address; 6412 6413 ------------ 6414 -- To_Any -- 6415 ------------ 6416 6417 when Attribute_To_Any => To_Any : declare 6418 P_Type : constant Entity_Id := Etype (Pref); 6419 Decls : constant List_Id := New_List; 6420 begin 6421 Rewrite (N, 6422 Build_To_Any_Call 6423 (Loc, 6424 Convert_To (P_Type, 6425 Relocate_Node (First (Exprs))), Decls)); 6426 Insert_Actions (N, Decls); 6427 Analyze_And_Resolve (N, RTE (RE_Any)); 6428 end To_Any; 6429 6430 ---------------- 6431 -- Truncation -- 6432 ---------------- 6433 6434 -- Transforms 'Truncation into a call to the floating-point attribute 6435 -- function Truncation in Fat_xxx (where xxx is the root type). 6436 -- Expansion is avoided for cases the back end can handle directly. 6437 6438 when Attribute_Truncation => 6439 if not Is_Inline_Floating_Point_Attribute (N) then 6440 Expand_Fpt_Attribute_R (N); 6441 end if; 6442 6443 -------------- 6444 -- TypeCode -- 6445 -------------- 6446 6447 when Attribute_TypeCode => TypeCode : declare 6448 P_Type : constant Entity_Id := Etype (Pref); 6449 Decls : constant List_Id := New_List; 6450 begin 6451 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls)); 6452 Insert_Actions (N, Decls); 6453 Analyze_And_Resolve (N, RTE (RE_TypeCode)); 6454 end TypeCode; 6455 6456 ----------------------- 6457 -- Unbiased_Rounding -- 6458 ----------------------- 6459 6460 -- Transforms 'Unbiased_Rounding into a call to the floating-point 6461 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the 6462 -- root type). Expansion is avoided for cases the back end can handle 6463 -- directly. 6464 6465 when Attribute_Unbiased_Rounding => 6466 if not Is_Inline_Floating_Point_Attribute (N) then 6467 Expand_Fpt_Attribute_R (N); 6468 end if; 6469 6470 ------------ 6471 -- Update -- 6472 ------------ 6473 6474 when Attribute_Update => 6475 Expand_Update_Attribute (N); 6476 6477 --------------- 6478 -- VADS_Size -- 6479 --------------- 6480 6481 -- The processing for VADS_Size is shared with Size 6482 6483 --------- 6484 -- Val -- 6485 --------- 6486 6487 -- For enumeration types with a standard representation, and for all 6488 -- other types, Val is handled by the back end. For enumeration types 6489 -- with a non-standard representation we use the _Pos_To_Rep array that 6490 -- was created when the type was frozen. 6491 6492 when Attribute_Val => Val : declare 6493 Etyp : constant Entity_Id := Base_Type (Entity (Pref)); 6494 6495 begin 6496 if Is_Enumeration_Type (Etyp) 6497 and then Present (Enum_Pos_To_Rep (Etyp)) 6498 then 6499 if Has_Contiguous_Rep (Etyp) then 6500 declare 6501 Rep_Node : constant Node_Id := 6502 Unchecked_Convert_To (Etyp, 6503 Make_Op_Add (Loc, 6504 Left_Opnd => 6505 Make_Integer_Literal (Loc, 6506 Enumeration_Rep (First_Literal (Etyp))), 6507 Right_Opnd => 6508 (Convert_To (Standard_Integer, 6509 Relocate_Node (First (Exprs)))))); 6510 6511 begin 6512 Rewrite (N, 6513 Unchecked_Convert_To (Etyp, 6514 Make_Op_Add (Loc, 6515 Left_Opnd => 6516 Make_Integer_Literal (Loc, 6517 Enumeration_Rep (First_Literal (Etyp))), 6518 Right_Opnd => 6519 Make_Function_Call (Loc, 6520 Name => 6521 New_Occurrence_Of 6522 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 6523 Parameter_Associations => New_List ( 6524 Rep_Node, 6525 Rep_To_Pos_Flag (Etyp, Loc)))))); 6526 end; 6527 6528 else 6529 Rewrite (N, 6530 Make_Indexed_Component (Loc, 6531 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc), 6532 Expressions => New_List ( 6533 Convert_To (Standard_Integer, 6534 Relocate_Node (First (Exprs)))))); 6535 end if; 6536 6537 Analyze_And_Resolve (N, Typ); 6538 6539 -- If the argument is marked as requiring a range check then generate 6540 -- it here. 6541 6542 elsif Do_Range_Check (First (Exprs)) then 6543 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed); 6544 end if; 6545 end Val; 6546 6547 ----------- 6548 -- Valid -- 6549 ----------- 6550 6551 -- The code for valid is dependent on the particular types involved. 6552 -- See separate sections below for the generated code in each case. 6553 6554 when Attribute_Valid => Valid : declare 6555 PBtyp : Entity_Id := Base_Type (Ptyp); 6556 6557 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On; 6558 -- Save the validity checking mode. We always turn off validity 6559 -- checking during process of 'Valid since this is one place 6560 -- where we do not want the implicit validity checks to interfere 6561 -- with the explicit validity check that the programmer is doing. 6562 6563 function Make_Range_Test return Node_Id; 6564 -- Build the code for a range test of the form 6565 -- PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last) 6566 6567 --------------------- 6568 -- Make_Range_Test -- 6569 --------------------- 6570 6571 function Make_Range_Test return Node_Id is 6572 Temp : Node_Id; 6573 6574 begin 6575 -- The prefix of attribute 'Valid should always denote an object 6576 -- reference. The reference is either coming directly from source 6577 -- or is produced by validity check expansion. The object may be 6578 -- wrapped in a conversion in which case the call to Unqual_Conv 6579 -- will yield it. 6580 6581 -- If the prefix denotes a variable which captures the value of 6582 -- an object for validation purposes, use the variable in the 6583 -- range test. This ensures that no extra copies or extra reads 6584 -- are produced as part of the test. Generate: 6585 6586 -- Temp : ... := Object; 6587 -- if not Temp in ... then 6588 6589 if Is_Validation_Variable_Reference (Pref) then 6590 Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc); 6591 6592 -- Otherwise the prefix is either a source object or a constant 6593 -- produced by validity check expansion. Generate: 6594 6595 -- Temp : constant ... := Pref; 6596 -- if not Temp in ... then 6597 6598 else 6599 Temp := Duplicate_Subexpr (Pref); 6600 end if; 6601 6602 return 6603 Make_In (Loc, 6604 Left_Opnd => Unchecked_Convert_To (PBtyp, Temp), 6605 Right_Opnd => 6606 Make_Range (Loc, 6607 Low_Bound => 6608 Unchecked_Convert_To (PBtyp, 6609 Make_Attribute_Reference (Loc, 6610 Prefix => New_Occurrence_Of (Ptyp, Loc), 6611 Attribute_Name => Name_First)), 6612 High_Bound => 6613 Unchecked_Convert_To (PBtyp, 6614 Make_Attribute_Reference (Loc, 6615 Prefix => New_Occurrence_Of (Ptyp, Loc), 6616 Attribute_Name => Name_Last)))); 6617 end Make_Range_Test; 6618 6619 -- Local variables 6620 6621 Tst : Node_Id; 6622 6623 -- Start of processing for Attribute_Valid 6624 6625 begin 6626 -- Do not expand sourced code 'Valid reference in CodePeer mode, 6627 -- will be handled by the back-end directly. 6628 6629 if CodePeer_Mode and then Comes_From_Source (N) then 6630 return; 6631 end if; 6632 6633 -- Turn off validity checks. We do not want any implicit validity 6634 -- checks to intefere with the explicit check from the attribute 6635 6636 Validity_Checks_On := False; 6637 6638 -- Retrieve the base type. Handle the case where the base type is a 6639 -- private enumeration type. 6640 6641 if Is_Private_Type (PBtyp) and then Present (Full_View (PBtyp)) then 6642 PBtyp := Full_View (PBtyp); 6643 end if; 6644 6645 -- Floating-point case. This case is handled by the Valid attribute 6646 -- code in the floating-point attribute run-time library. 6647 6648 if Is_Floating_Point_Type (Ptyp) then 6649 Float_Valid : declare 6650 Pkg : RE_Id; 6651 Ftp : Entity_Id; 6652 6653 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id; 6654 -- Return entity for Pkg.Nam 6655 6656 -------------------- 6657 -- Get_Fat_Entity -- 6658 -------------------- 6659 6660 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is 6661 Exp_Name : constant Node_Id := 6662 Make_Selected_Component (Loc, 6663 Prefix => New_Occurrence_Of (RTE (Pkg), Loc), 6664 Selector_Name => Make_Identifier (Loc, Nam)); 6665 begin 6666 Find_Selected_Component (Exp_Name); 6667 return Entity (Exp_Name); 6668 end Get_Fat_Entity; 6669 6670 -- Start of processing for Float_Valid 6671 6672 begin 6673 -- The C and AAMP back-ends handle Valid for fpt types 6674 6675 if Modify_Tree_For_C or else Float_Rep (PBtyp) = AAMP then 6676 Analyze_And_Resolve (Pref, Ptyp); 6677 Set_Etype (N, Standard_Boolean); 6678 Set_Analyzed (N); 6679 6680 else 6681 Find_Fat_Info (Ptyp, Ftp, Pkg); 6682 6683 -- If the prefix is a reverse SSO component, or is possibly 6684 -- unaligned, first create a temporary copy that is in 6685 -- native SSO, and properly aligned. Make it Volatile to 6686 -- prevent folding in the back-end. Note that we use an 6687 -- intermediate constrained string type to initialize the 6688 -- temporary, as the value at hand might be invalid, and in 6689 -- that case it cannot be copied using a floating point 6690 -- register. 6691 6692 if In_Reverse_Storage_Order_Object (Pref) 6693 or else Is_Possibly_Unaligned_Object (Pref) 6694 then 6695 declare 6696 Temp : constant Entity_Id := 6697 Make_Temporary (Loc, 'F'); 6698 6699 Fat_S : constant Entity_Id := 6700 Get_Fat_Entity (Name_S); 6701 -- Constrained string subtype of appropriate size 6702 6703 Fat_P : constant Entity_Id := 6704 Get_Fat_Entity (Name_P); 6705 -- Access to Fat_S 6706 6707 Decl : constant Node_Id := 6708 Make_Object_Declaration (Loc, 6709 Defining_Identifier => Temp, 6710 Aliased_Present => True, 6711 Object_Definition => 6712 New_Occurrence_Of (Ptyp, Loc)); 6713 6714 begin 6715 Set_Aspect_Specifications (Decl, New_List ( 6716 Make_Aspect_Specification (Loc, 6717 Identifier => 6718 Make_Identifier (Loc, Name_Volatile)))); 6719 6720 Insert_Actions (N, 6721 New_List ( 6722 Decl, 6723 6724 Make_Assignment_Statement (Loc, 6725 Name => 6726 Make_Explicit_Dereference (Loc, 6727 Prefix => 6728 Unchecked_Convert_To (Fat_P, 6729 Make_Attribute_Reference (Loc, 6730 Prefix => 6731 New_Occurrence_Of (Temp, Loc), 6732 Attribute_Name => 6733 Name_Unrestricted_Access))), 6734 Expression => 6735 Unchecked_Convert_To (Fat_S, 6736 Relocate_Node (Pref)))), 6737 6738 Suppress => All_Checks); 6739 6740 Rewrite (Pref, New_Occurrence_Of (Temp, Loc)); 6741 end; 6742 end if; 6743 6744 -- We now have an object of the proper endianness and 6745 -- alignment, and can construct a Valid attribute. 6746 6747 -- We make sure the prefix of this valid attribute is 6748 -- marked as not coming from source, to avoid losing 6749 -- warnings from 'Valid looking like a possible update. 6750 6751 Set_Comes_From_Source (Pref, False); 6752 6753 Expand_Fpt_Attribute 6754 (N, Pkg, Name_Valid, 6755 New_List ( 6756 Make_Attribute_Reference (Loc, 6757 Prefix => Unchecked_Convert_To (Ftp, Pref), 6758 Attribute_Name => Name_Unrestricted_Access))); 6759 end if; 6760 6761 -- One more task, we still need a range check. Required 6762 -- only if we have a constraint, since the Valid routine 6763 -- catches infinities properly (infinities are never valid). 6764 6765 -- The way we do the range check is simply to create the 6766 -- expression: Valid (N) and then Base_Type(Pref) in Typ. 6767 6768 if not Subtypes_Statically_Match (Ptyp, PBtyp) then 6769 Rewrite (N, 6770 Make_And_Then (Loc, 6771 Left_Opnd => Relocate_Node (N), 6772 Right_Opnd => 6773 Make_In (Loc, 6774 Left_Opnd => Convert_To (PBtyp, Pref), 6775 Right_Opnd => New_Occurrence_Of (Ptyp, Loc)))); 6776 end if; 6777 end Float_Valid; 6778 6779 -- Enumeration type with holes 6780 6781 -- For enumeration types with holes, the Pos value constructed by 6782 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a 6783 -- second argument of False returns minus one for an invalid value, 6784 -- and the non-negative pos value for a valid value, so the 6785 -- expansion of X'Valid is simply: 6786 6787 -- type(X)'Pos (X) >= 0 6788 6789 -- We can't quite generate it that way because of the requirement 6790 -- for the non-standard second argument of False in the resulting 6791 -- rep_to_pos call, so we have to explicitly create: 6792 6793 -- _rep_to_pos (X, False) >= 0 6794 6795 -- If we have an enumeration subtype, we also check that the 6796 -- value is in range: 6797 6798 -- _rep_to_pos (X, False) >= 0 6799 -- and then 6800 -- (X >= type(X)'First and then type(X)'Last <= X) 6801 6802 elsif Is_Enumeration_Type (Ptyp) 6803 and then Present (Enum_Pos_To_Rep (PBtyp)) 6804 then 6805 Tst := 6806 Make_Op_Ge (Loc, 6807 Left_Opnd => 6808 Make_Function_Call (Loc, 6809 Name => 6810 New_Occurrence_Of (TSS (PBtyp, TSS_Rep_To_Pos), Loc), 6811 Parameter_Associations => New_List ( 6812 Pref, 6813 New_Occurrence_Of (Standard_False, Loc))), 6814 Right_Opnd => Make_Integer_Literal (Loc, 0)); 6815 6816 if Ptyp /= PBtyp 6817 and then 6818 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (PBtyp) 6819 or else 6820 Type_High_Bound (Ptyp) /= Type_High_Bound (PBtyp)) 6821 then 6822 -- The call to Make_Range_Test will create declarations 6823 -- that need a proper insertion point, but Pref is now 6824 -- attached to a node with no ancestor. Attach to tree 6825 -- even if it is to be rewritten below. 6826 6827 Set_Parent (Tst, Parent (N)); 6828 6829 Tst := 6830 Make_And_Then (Loc, 6831 Left_Opnd => Make_Range_Test, 6832 Right_Opnd => Tst); 6833 end if; 6834 6835 Rewrite (N, Tst); 6836 6837 -- Fortran convention booleans 6838 6839 -- For the very special case of Fortran convention booleans, the 6840 -- value is always valid, since it is an integer with the semantics 6841 -- that non-zero is true, and any value is permissible. 6842 6843 elsif Is_Boolean_Type (Ptyp) 6844 and then Convention (Ptyp) = Convention_Fortran 6845 then 6846 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 6847 6848 -- For biased representations, we will be doing an unchecked 6849 -- conversion without unbiasing the result. That means that the range 6850 -- test has to take this into account, and the proper form of the 6851 -- test is: 6852 6853 -- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length) 6854 6855 elsif Has_Biased_Representation (Ptyp) then 6856 PBtyp := RTE (RE_Unsigned_32); 6857 Rewrite (N, 6858 Make_Op_Lt (Loc, 6859 Left_Opnd => 6860 Unchecked_Convert_To (PBtyp, Duplicate_Subexpr (Pref)), 6861 Right_Opnd => 6862 Unchecked_Convert_To (PBtyp, 6863 Make_Attribute_Reference (Loc, 6864 Prefix => New_Occurrence_Of (Ptyp, Loc), 6865 Attribute_Name => Name_Range_Length)))); 6866 6867 -- For all other scalar types, what we want logically is a 6868 -- range test: 6869 6870 -- X in type(X)'First .. type(X)'Last 6871 6872 -- But that's precisely what won't work because of possible 6873 -- unwanted optimization (and indeed the basic motivation for 6874 -- the Valid attribute is exactly that this test does not work). 6875 -- What will work is: 6876 6877 -- PBtyp!(X) >= PBtyp!(type(X)'First) 6878 -- and then 6879 -- PBtyp!(X) <= PBtyp!(type(X)'Last) 6880 6881 -- where PBtyp is an integer type large enough to cover the full 6882 -- range of possible stored values (i.e. it is chosen on the basis 6883 -- of the size of the type, not the range of the values). We write 6884 -- this as two tests, rather than a range check, so that static 6885 -- evaluation will easily remove either or both of the checks if 6886 -- they can be -statically determined to be true (this happens 6887 -- when the type of X is static and the range extends to the full 6888 -- range of stored values). 6889 6890 -- Unsigned types. Note: it is safe to consider only whether the 6891 -- subtype is unsigned, since we will in that case be doing all 6892 -- unsigned comparisons based on the subtype range. Since we use the 6893 -- actual subtype object size, this is appropriate. 6894 6895 -- For example, if we have 6896 6897 -- subtype x is integer range 1 .. 200; 6898 -- for x'Object_Size use 8; 6899 6900 -- Now the base type is signed, but objects of this type are bits 6901 -- unsigned, and doing an unsigned test of the range 1 to 200 is 6902 -- correct, even though a value greater than 127 looks signed to a 6903 -- signed comparison. 6904 6905 elsif Is_Unsigned_Type (Ptyp) 6906 or else (Is_Private_Type (Ptyp) and then Is_Unsigned_Type (Btyp)) 6907 then 6908 if Esize (Ptyp) <= 32 then 6909 PBtyp := RTE (RE_Unsigned_32); 6910 else 6911 PBtyp := RTE (RE_Unsigned_64); 6912 end if; 6913 6914 Rewrite (N, Make_Range_Test); 6915 6916 -- Signed types 6917 6918 else 6919 if Esize (Ptyp) <= Esize (Standard_Integer) then 6920 PBtyp := Standard_Integer; 6921 else 6922 PBtyp := Universal_Integer; 6923 end if; 6924 6925 Rewrite (N, Make_Range_Test); 6926 end if; 6927 6928 -- If a predicate is present, then we do the predicate test, even if 6929 -- within the predicate function (infinite recursion is warned about 6930 -- in Sem_Attr in that case). 6931 6932 declare 6933 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp); 6934 6935 begin 6936 if Present (Pred_Func) then 6937 Rewrite (N, 6938 Make_And_Then (Loc, 6939 Left_Opnd => Relocate_Node (N), 6940 Right_Opnd => Make_Predicate_Call (Ptyp, Pref))); 6941 end if; 6942 end; 6943 6944 Analyze_And_Resolve (N, Standard_Boolean); 6945 Validity_Checks_On := Save_Validity_Checks_On; 6946 end Valid; 6947 6948 ------------------- 6949 -- Valid_Scalars -- 6950 ------------------- 6951 6952 when Attribute_Valid_Scalars => Valid_Scalars : declare 6953 Val_Typ : constant Entity_Id := Validated_View (Ptyp); 6954 Comp_Typ : Entity_Id; 6955 Expr : Node_Id; 6956 6957 begin 6958 -- Assume that the prefix does not need validation 6959 6960 Expr := Empty; 6961 6962 -- Attribute 'Valid_Scalars is not supported on private tagged types 6963 6964 if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then 6965 null; 6966 6967 -- Attribute 'Valid_Scalars evaluates to True when the type lacks 6968 -- scalars. 6969 6970 elsif not Scalar_Part_Present (Val_Typ) then 6971 null; 6972 6973 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the 6974 -- validated type is a scalar type. Generate: 6975 6976 -- Val_Typ (Pref)'Valid 6977 6978 elsif Is_Scalar_Type (Val_Typ) then 6979 Expr := 6980 Make_Attribute_Reference (Loc, 6981 Prefix => 6982 Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)), 6983 Attribute_Name => Name_Valid); 6984 6985 -- Validate the scalar components of an array by iterating over all 6986 -- dimensions of the array while checking individual components. 6987 6988 elsif Is_Array_Type (Val_Typ) then 6989 Comp_Typ := Validated_View (Component_Type (Val_Typ)); 6990 6991 if Scalar_Part_Present (Comp_Typ) then 6992 Expr := 6993 Make_Function_Call (Loc, 6994 Name => 6995 New_Occurrence_Of 6996 (Build_Array_VS_Func 6997 (Attr => N, 6998 Formal_Typ => Ptyp, 6999 Array_Typ => Val_Typ, 7000 Comp_Typ => Comp_Typ), 7001 Loc), 7002 Parameter_Associations => New_List (Pref)); 7003 end if; 7004 7005 -- Validate the scalar components, discriminants of a record type by 7006 -- examining the structure of a record type. 7007 7008 elsif Is_Record_Type (Val_Typ) then 7009 Expr := 7010 Make_Function_Call (Loc, 7011 Name => 7012 New_Occurrence_Of 7013 (Build_Record_VS_Func 7014 (Attr => N, 7015 Formal_Typ => Ptyp, 7016 Rec_Typ => Val_Typ), 7017 Loc), 7018 Parameter_Associations => New_List (Pref)); 7019 end if; 7020 7021 -- Default the attribute to True when the type of the prefix does not 7022 -- need validation. 7023 7024 if No (Expr) then 7025 Expr := New_Occurrence_Of (Standard_True, Loc); 7026 end if; 7027 7028 Rewrite (N, Expr); 7029 Analyze_And_Resolve (N, Standard_Boolean); 7030 Set_Is_Static_Expression (N, False); 7031 end Valid_Scalars; 7032 7033 ----------- 7034 -- Value -- 7035 ----------- 7036 7037 -- Value attribute is handled in separate unit Exp_Imgv 7038 7039 when Attribute_Value => 7040 Exp_Imgv.Expand_Value_Attribute (N); 7041 7042 ----------------- 7043 -- Value_Size -- 7044 ----------------- 7045 7046 -- The processing for Value_Size shares the processing for Size 7047 7048 ------------- 7049 -- Version -- 7050 ------------- 7051 7052 -- The processing for Version shares the processing for Body_Version 7053 7054 ---------------- 7055 -- Wide_Image -- 7056 ---------------- 7057 7058 -- Wide_Image attribute is handled in separate unit Exp_Imgv 7059 7060 when Attribute_Wide_Image => 7061 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil 7062 -- back-end knows how to handle this attribute directly. 7063 7064 if CodePeer_Mode then 7065 return; 7066 end if; 7067 7068 Exp_Imgv.Expand_Wide_Image_Attribute (N); 7069 7070 --------------------- 7071 -- Wide_Wide_Image -- 7072 --------------------- 7073 7074 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv 7075 7076 when Attribute_Wide_Wide_Image => 7077 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil 7078 -- back-end knows how to handle this attribute directly. 7079 7080 if CodePeer_Mode then 7081 return; 7082 end if; 7083 7084 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N); 7085 7086 ---------------- 7087 -- Wide_Value -- 7088 ---------------- 7089 7090 -- We expand typ'Wide_Value (X) into 7091 7092 -- typ'Value 7093 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method)) 7094 7095 -- Wide_String_To_String is a runtime function that converts its wide 7096 -- string argument to String, converting any non-translatable characters 7097 -- into appropriate escape sequences. This preserves the required 7098 -- semantics of Wide_Value in all cases, and results in a very simple 7099 -- implementation approach. 7100 7101 -- Note: for this approach to be fully standard compliant for the cases 7102 -- where typ is Wide_Character and Wide_Wide_Character, the encoding 7103 -- method must cover the entire character range (e.g. UTF-8). But that 7104 -- is a reasonable requirement when dealing with encoded character 7105 -- sequences. Presumably if one of the restrictive encoding mechanisms 7106 -- is in use such as Shift-JIS, then characters that cannot be 7107 -- represented using this encoding will not appear in any case. 7108 7109 when Attribute_Wide_Value => 7110 Rewrite (N, 7111 Make_Attribute_Reference (Loc, 7112 Prefix => Pref, 7113 Attribute_Name => Name_Value, 7114 7115 Expressions => New_List ( 7116 Make_Function_Call (Loc, 7117 Name => 7118 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc), 7119 7120 Parameter_Associations => New_List ( 7121 Relocate_Node (First (Exprs)), 7122 Make_Integer_Literal (Loc, 7123 Intval => Int (Wide_Character_Encoding_Method))))))); 7124 7125 Analyze_And_Resolve (N, Typ); 7126 7127 --------------------- 7128 -- Wide_Wide_Value -- 7129 --------------------- 7130 7131 -- We expand typ'Wide_Value_Value (X) into 7132 7133 -- typ'Value 7134 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method)) 7135 7136 -- Wide_Wide_String_To_String is a runtime function that converts its 7137 -- wide string argument to String, converting any non-translatable 7138 -- characters into appropriate escape sequences. This preserves the 7139 -- required semantics of Wide_Wide_Value in all cases, and results in a 7140 -- very simple implementation approach. 7141 7142 -- It's not quite right where typ = Wide_Wide_Character, because the 7143 -- encoding method may not cover the whole character type ??? 7144 7145 when Attribute_Wide_Wide_Value => 7146 Rewrite (N, 7147 Make_Attribute_Reference (Loc, 7148 Prefix => Pref, 7149 Attribute_Name => Name_Value, 7150 7151 Expressions => New_List ( 7152 Make_Function_Call (Loc, 7153 Name => 7154 New_Occurrence_Of 7155 (RTE (RE_Wide_Wide_String_To_String), Loc), 7156 7157 Parameter_Associations => New_List ( 7158 Relocate_Node (First (Exprs)), 7159 Make_Integer_Literal (Loc, 7160 Intval => Int (Wide_Character_Encoding_Method))))))); 7161 7162 Analyze_And_Resolve (N, Typ); 7163 7164 --------------------- 7165 -- Wide_Wide_Width -- 7166 --------------------- 7167 7168 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv 7169 7170 when Attribute_Wide_Wide_Width => 7171 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide); 7172 7173 ---------------- 7174 -- Wide_Width -- 7175 ---------------- 7176 7177 -- Wide_Width attribute is handled in separate unit Exp_Imgv 7178 7179 when Attribute_Wide_Width => 7180 Exp_Imgv.Expand_Width_Attribute (N, Wide); 7181 7182 ----------- 7183 -- Width -- 7184 ----------- 7185 7186 -- Width attribute is handled in separate unit Exp_Imgv 7187 7188 when Attribute_Width => 7189 Exp_Imgv.Expand_Width_Attribute (N, Normal); 7190 7191 ----------- 7192 -- Write -- 7193 ----------- 7194 7195 when Attribute_Write => Write : declare 7196 P_Type : constant Entity_Id := Entity (Pref); 7197 U_Type : constant Entity_Id := Underlying_Type (P_Type); 7198 Pname : Entity_Id; 7199 Decl : Node_Id; 7200 Prag : Node_Id; 7201 Arg3 : Node_Id; 7202 Wfunc : Node_Id; 7203 7204 begin 7205 -- If no underlying type, we have an error that will be diagnosed 7206 -- elsewhere, so here we just completely ignore the expansion. 7207 7208 if No (U_Type) then 7209 return; 7210 end if; 7211 7212 -- Stream operations can appear in user code even if the restriction 7213 -- No_Streams is active (for example, when instantiating a predefined 7214 -- container). In that case rewrite the attribute as a Raise to 7215 -- prevent any run-time use. 7216 7217 if Restriction_Active (No_Streams) then 7218 Rewrite (N, 7219 Make_Raise_Program_Error (Sloc (N), 7220 Reason => PE_Stream_Operation_Not_Allowed)); 7221 Set_Etype (N, U_Type); 7222 return; 7223 end if; 7224 7225 -- The simple case, if there is a TSS for Write, just call it 7226 7227 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write); 7228 7229 if Present (Pname) then 7230 null; 7231 7232 else 7233 -- If there is a Stream_Convert pragma, use it, we rewrite 7234 7235 -- sourcetyp'Output (stream, Item) 7236 7237 -- as 7238 7239 -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); 7240 7241 -- where strmwrite is the given Write function that converts an 7242 -- argument of type sourcetyp or a type acctyp, from which it is 7243 -- derived to type strmtyp. The conversion to acttyp is required 7244 -- for the derived case. 7245 7246 Prag := Get_Stream_Convert_Pragma (P_Type); 7247 7248 if Present (Prag) then 7249 Arg3 := 7250 Next (Next (First (Pragma_Argument_Associations (Prag)))); 7251 Wfunc := Entity (Expression (Arg3)); 7252 7253 Rewrite (N, 7254 Make_Attribute_Reference (Loc, 7255 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), 7256 Attribute_Name => Name_Output, 7257 Expressions => New_List ( 7258 Relocate_Node (First (Exprs)), 7259 Make_Function_Call (Loc, 7260 Name => New_Occurrence_Of (Wfunc, Loc), 7261 Parameter_Associations => New_List ( 7262 OK_Convert_To (Etype (First_Formal (Wfunc)), 7263 Relocate_Node (Next (First (Exprs))))))))); 7264 7265 Analyze (N); 7266 return; 7267 7268 -- For elementary types, we call the W_xxx routine directly 7269 7270 elsif Is_Elementary_Type (U_Type) then 7271 Rewrite (N, Build_Elementary_Write_Call (N)); 7272 Analyze (N); 7273 return; 7274 7275 -- Array type case 7276 7277 elsif Is_Array_Type (U_Type) then 7278 Build_Array_Write_Procedure (N, U_Type, Decl, Pname); 7279 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 7280 7281 -- Tagged type case, use the primitive Write function. Note that 7282 -- this will dispatch in the class-wide case which is what we want 7283 7284 elsif Is_Tagged_Type (U_Type) then 7285 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write); 7286 7287 -- All other record type cases, including protected records. 7288 -- The latter only arise for expander generated code for 7289 -- handling shared passive partition access. 7290 7291 else 7292 pragma Assert 7293 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 7294 7295 -- Ada 2005 (AI-216): Program_Error is raised when executing 7296 -- the default implementation of the Write attribute of an 7297 -- Unchecked_Union type. However, if the 'Write reference is 7298 -- within the generated Output stream procedure, Write outputs 7299 -- the components, and the default values of the discriminant 7300 -- are streamed by the Output procedure itself. If there are 7301 -- no default values this is also erroneous. 7302 7303 if Is_Unchecked_Union (Base_Type (U_Type)) then 7304 if (not Is_TSS (Current_Scope, TSS_Stream_Output) 7305 and not Is_TSS (Current_Scope, TSS_Stream_Write)) 7306 or else No (Discriminant_Default_Value 7307 (First_Discriminant (U_Type))) 7308 then 7309 Rewrite (N, 7310 Make_Raise_Program_Error (Loc, 7311 Reason => PE_Unchecked_Union_Restriction)); 7312 Set_Etype (N, U_Type); 7313 return; 7314 end if; 7315 end if; 7316 7317 if Has_Discriminants (U_Type) 7318 and then Present 7319 (Discriminant_Default_Value (First_Discriminant (U_Type))) 7320 then 7321 Build_Mutable_Record_Write_Procedure 7322 (Loc, Full_Base (U_Type), Decl, Pname); 7323 else 7324 Build_Record_Write_Procedure 7325 (Loc, Full_Base (U_Type), Decl, Pname); 7326 end if; 7327 7328 Insert_Action (N, Decl); 7329 end if; 7330 end if; 7331 7332 -- If we fall through, Pname is the procedure to be called 7333 7334 Rewrite_Stream_Proc_Call (Pname); 7335 end Write; 7336 7337 -- Component_Size is handled by the back end, unless the component size 7338 -- is known at compile time, which is always true in the packed array 7339 -- case. It is important that the packed array case is handled in the 7340 -- front end (see Eval_Attribute) since the back end would otherwise get 7341 -- confused by the equivalent packed array type. 7342 7343 when Attribute_Component_Size => 7344 null; 7345 7346 -- The following attributes are handled by the back end (except that 7347 -- static cases have already been evaluated during semantic processing, 7348 -- but in any case the back end should not count on this). 7349 7350 -- The back end also handles the non-class-wide cases of Size 7351 7352 when Attribute_Bit_Order 7353 | Attribute_Code_Address 7354 | Attribute_Definite 7355 | Attribute_Deref 7356 | Attribute_Null_Parameter 7357 | Attribute_Passed_By_Reference 7358 | Attribute_Pool_Address 7359 | Attribute_Scalar_Storage_Order 7360 => 7361 null; 7362 7363 -- The following attributes are also handled by the back end, but return 7364 -- a universal integer result, so may need a conversion for checking 7365 -- that the result is in range. 7366 7367 when Attribute_Aft 7368 | Attribute_Max_Alignment_For_Allocation 7369 => 7370 Apply_Universal_Integer_Attribute_Checks (N); 7371 7372 -- The following attributes should not appear at this stage, since they 7373 -- have already been handled by the analyzer (and properly rewritten 7374 -- with corresponding values or entities to represent the right values) 7375 7376 when Attribute_Abort_Signal 7377 | Attribute_Address_Size 7378 | Attribute_Atomic_Always_Lock_Free 7379 | Attribute_Base 7380 | Attribute_Class 7381 | Attribute_Compiler_Version 7382 | Attribute_Default_Bit_Order 7383 | Attribute_Default_Scalar_Storage_Order 7384 | Attribute_Delta 7385 | Attribute_Denorm 7386 | Attribute_Digits 7387 | Attribute_Emax 7388 | Attribute_Enabled 7389 | Attribute_Epsilon 7390 | Attribute_Fast_Math 7391 | Attribute_First_Valid 7392 | Attribute_Has_Access_Values 7393 | Attribute_Has_Discriminants 7394 | Attribute_Has_Tagged_Values 7395 | Attribute_Large 7396 | Attribute_Last_Valid 7397 | Attribute_Library_Level 7398 | Attribute_Lock_Free 7399 | Attribute_Machine_Emax 7400 | Attribute_Machine_Emin 7401 | Attribute_Machine_Mantissa 7402 | Attribute_Machine_Overflows 7403 | Attribute_Machine_Radix 7404 | Attribute_Machine_Rounds 7405 | Attribute_Maximum_Alignment 7406 | Attribute_Model_Emin 7407 | Attribute_Model_Epsilon 7408 | Attribute_Model_Mantissa 7409 | Attribute_Model_Small 7410 | Attribute_Modulus 7411 | Attribute_Partition_ID 7412 | Attribute_Range 7413 | Attribute_Restriction_Set 7414 | Attribute_Safe_Emax 7415 | Attribute_Safe_First 7416 | Attribute_Safe_Large 7417 | Attribute_Safe_Last 7418 | Attribute_Safe_Small 7419 | Attribute_Scale 7420 | Attribute_Signed_Zeros 7421 | Attribute_Small 7422 | Attribute_Storage_Unit 7423 | Attribute_Stub_Type 7424 | Attribute_System_Allocator_Alignment 7425 | Attribute_Target_Name 7426 | Attribute_Type_Class 7427 | Attribute_Type_Key 7428 | Attribute_Unconstrained_Array 7429 | Attribute_Universal_Literal_String 7430 | Attribute_Wchar_T_Size 7431 | Attribute_Word_Size 7432 => 7433 raise Program_Error; 7434 7435 -- The Asm_Input and Asm_Output attributes are not expanded at this 7436 -- stage, but will be eliminated in the expansion of the Asm call, see 7437 -- Exp_Intr for details. So the back end will never see these either. 7438 7439 when Attribute_Asm_Input 7440 | Attribute_Asm_Output 7441 => 7442 null; 7443 end case; 7444 7445 -- Note: as mentioned earlier, individual sections of the above case 7446 -- statement assume there is no code after the case statement, and are 7447 -- legitimately allowed to execute return statements if they have nothing 7448 -- more to do, so DO NOT add code at this point. 7449 7450 exception 7451 when RE_Not_Available => 7452 return; 7453 end Expand_N_Attribute_Reference; 7454 7455 -------------------------------- 7456 -- Expand_Pred_Succ_Attribute -- 7457 -------------------------------- 7458 7459 -- For typ'Pred (exp), we generate the check 7460 7461 -- [constraint_error when exp = typ'Base'First] 7462 7463 -- Similarly, for typ'Succ (exp), we generate the check 7464 7465 -- [constraint_error when exp = typ'Base'Last] 7466 7467 -- These checks are not generated for modular types, since the proper 7468 -- semantics for Succ and Pred on modular types is to wrap, not raise CE. 7469 -- We also suppress these checks if we are the right side of an assignment 7470 -- statement or the expression of an object declaration, where the flag 7471 -- Suppress_Assignment_Checks is set for the assignment/declaration. 7472 7473 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is 7474 Loc : constant Source_Ptr := Sloc (N); 7475 P : constant Node_Id := Parent (N); 7476 Cnam : Name_Id; 7477 7478 begin 7479 if Attribute_Name (N) = Name_Pred then 7480 Cnam := Name_First; 7481 else 7482 Cnam := Name_Last; 7483 end if; 7484 7485 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration) 7486 or else not Suppress_Assignment_Checks (P) 7487 then 7488 Insert_Action (N, 7489 Make_Raise_Constraint_Error (Loc, 7490 Condition => 7491 Make_Op_Eq (Loc, 7492 Left_Opnd => 7493 Duplicate_Subexpr_Move_Checks (First (Expressions (N))), 7494 Right_Opnd => 7495 Make_Attribute_Reference (Loc, 7496 Prefix => 7497 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc), 7498 Attribute_Name => Cnam)), 7499 Reason => CE_Overflow_Check_Failed)); 7500 end if; 7501 end Expand_Pred_Succ_Attribute; 7502 7503 --------------------------- 7504 -- Expand_Size_Attribute -- 7505 --------------------------- 7506 7507 procedure Expand_Size_Attribute (N : Node_Id) is 7508 Loc : constant Source_Ptr := Sloc (N); 7509 Typ : constant Entity_Id := Etype (N); 7510 Pref : constant Node_Id := Prefix (N); 7511 Ptyp : constant Entity_Id := Etype (Pref); 7512 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); 7513 Siz : Uint; 7514 7515 begin 7516 -- Case of known RM_Size of a type 7517 7518 if (Id = Attribute_Size or else Id = Attribute_Value_Size) 7519 and then Is_Entity_Name (Pref) 7520 and then Is_Type (Entity (Pref)) 7521 and then Known_Static_RM_Size (Entity (Pref)) 7522 then 7523 Siz := RM_Size (Entity (Pref)); 7524 7525 -- Case of known Esize of a type 7526 7527 elsif Id = Attribute_Object_Size 7528 and then Is_Entity_Name (Pref) 7529 and then Is_Type (Entity (Pref)) 7530 and then Known_Static_Esize (Entity (Pref)) 7531 then 7532 Siz := Esize (Entity (Pref)); 7533 7534 -- Case of known size of object 7535 7536 elsif Id = Attribute_Size 7537 and then Is_Entity_Name (Pref) 7538 and then Is_Object (Entity (Pref)) 7539 and then Known_Esize (Entity (Pref)) 7540 and then Known_Static_Esize (Entity (Pref)) 7541 then 7542 Siz := Esize (Entity (Pref)); 7543 7544 -- For an array component, we can do Size in the front end if the 7545 -- component_size of the array is set. 7546 7547 elsif Nkind (Pref) = N_Indexed_Component then 7548 Siz := Component_Size (Etype (Prefix (Pref))); 7549 7550 -- For a record component, we can do Size in the front end if there is a 7551 -- component clause, or if the record is packed and the component's size 7552 -- is known at compile time. 7553 7554 elsif Nkind (Pref) = N_Selected_Component then 7555 declare 7556 Rec : constant Entity_Id := Etype (Prefix (Pref)); 7557 Comp : constant Entity_Id := Entity (Selector_Name (Pref)); 7558 7559 begin 7560 if Present (Component_Clause (Comp)) then 7561 Siz := Esize (Comp); 7562 7563 elsif Is_Packed (Rec) then 7564 Siz := RM_Size (Ptyp); 7565 7566 else 7567 Apply_Universal_Integer_Attribute_Checks (N); 7568 return; 7569 end if; 7570 end; 7571 7572 -- All other cases are handled by the back end 7573 7574 else 7575 -- If Size is applied to a formal parameter that is of a packed 7576 -- array subtype, then apply Size to the actual subtype. 7577 7578 if Is_Entity_Name (Pref) 7579 and then Is_Formal (Entity (Pref)) 7580 and then Is_Array_Type (Ptyp) 7581 and then Is_Packed (Ptyp) 7582 then 7583 Rewrite (N, 7584 Make_Attribute_Reference (Loc, 7585 Prefix => 7586 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc), 7587 Attribute_Name => Name_Size)); 7588 Analyze_And_Resolve (N, Typ); 7589 7590 -- If Size is applied to a dereference of an access to unconstrained 7591 -- packed array, the back end needs to see its unconstrained nominal 7592 -- type, but also a hint to the actual constrained type. 7593 7594 elsif Nkind (Pref) = N_Explicit_Dereference 7595 and then Is_Array_Type (Ptyp) 7596 and then not Is_Constrained (Ptyp) 7597 and then Is_Packed (Ptyp) 7598 then 7599 Set_Actual_Designated_Subtype (Pref, Get_Actual_Subtype (Pref)); 7600 7601 -- If Size was applied to a slice of a bit-packed array, we rewrite 7602 -- it into the product of Length and Component_Size. We need to do so 7603 -- because bit-packed arrays are represented internally as arrays of 7604 -- System.Unsigned_Types.Packed_Byte for code generation purposes so 7605 -- the size is always rounded up in the back end. 7606 7607 elsif Nkind (Pref) = N_Slice and then Is_Bit_Packed_Array (Ptyp) then 7608 Rewrite (N, 7609 Make_Op_Multiply (Loc, 7610 Make_Attribute_Reference (Loc, 7611 Prefix => Duplicate_Subexpr (Pref, True), 7612 Attribute_Name => Name_Length), 7613 Make_Attribute_Reference (Loc, 7614 Prefix => Duplicate_Subexpr (Pref, True), 7615 Attribute_Name => Name_Component_Size))); 7616 Analyze_And_Resolve (N, Typ); 7617 end if; 7618 7619 -- Apply the required checks last, after rewriting has taken place 7620 7621 Apply_Universal_Integer_Attribute_Checks (N); 7622 return; 7623 end if; 7624 7625 -- Common processing for record and array component case 7626 7627 if Siz /= No_Uint and then Siz /= 0 then 7628 declare 7629 CS : constant Boolean := Comes_From_Source (N); 7630 7631 begin 7632 Rewrite (N, Make_Integer_Literal (Loc, Siz)); 7633 7634 -- This integer literal is not a static expression. We do not 7635 -- call Analyze_And_Resolve here, because this would activate 7636 -- the circuit for deciding that a static value was out of range, 7637 -- and we don't want that. 7638 7639 -- So just manually set the type, mark the expression as 7640 -- nonstatic, and then ensure that the result is checked 7641 -- properly if the attribute comes from source (if it was 7642 -- internally generated, we never need a constraint check). 7643 7644 Set_Etype (N, Typ); 7645 Set_Is_Static_Expression (N, False); 7646 7647 if CS then 7648 Apply_Constraint_Check (N, Typ); 7649 end if; 7650 end; 7651 end if; 7652 end Expand_Size_Attribute; 7653 7654 ----------------------------- 7655 -- Expand_Update_Attribute -- 7656 ----------------------------- 7657 7658 procedure Expand_Update_Attribute (N : Node_Id) is 7659 procedure Process_Component_Or_Element_Update 7660 (Temp : Entity_Id; 7661 Comp : Node_Id; 7662 Expr : Node_Id; 7663 Typ : Entity_Id); 7664 -- Generate the statements necessary to update a single component or an 7665 -- element of the prefix. The code is inserted before the attribute N. 7666 -- Temp denotes the entity of the anonymous object created to reflect 7667 -- the changes in values. Comp is the component/index expression to be 7668 -- updated. Expr is an expression yielding the new value of Comp. Typ 7669 -- is the type of the prefix of attribute Update. 7670 7671 procedure Process_Range_Update 7672 (Temp : Entity_Id; 7673 Comp : Node_Id; 7674 Expr : Node_Id; 7675 Typ : Entity_Id); 7676 -- Generate the statements necessary to update a slice of the prefix. 7677 -- The code is inserted before the attribute N. Temp denotes the entity 7678 -- of the anonymous object created to reflect the changes in values. 7679 -- Comp is range of the slice to be updated. Expr is an expression 7680 -- yielding the new value of Comp. Typ is the type of the prefix of 7681 -- attribute Update. 7682 7683 ----------------------------------------- 7684 -- Process_Component_Or_Element_Update -- 7685 ----------------------------------------- 7686 7687 procedure Process_Component_Or_Element_Update 7688 (Temp : Entity_Id; 7689 Comp : Node_Id; 7690 Expr : Node_Id; 7691 Typ : Entity_Id) 7692 is 7693 Loc : constant Source_Ptr := Sloc (Comp); 7694 Exprs : List_Id; 7695 LHS : Node_Id; 7696 7697 begin 7698 -- An array element may be modified by the following relations 7699 -- depending on the number of dimensions: 7700 7701 -- 1 => Expr -- one dimensional update 7702 -- (1, ..., N) => Expr -- multi dimensional update 7703 7704 -- The above forms are converted in assignment statements where the 7705 -- left hand side is an indexed component: 7706 7707 -- Temp (1) := Expr; -- one dimensional update 7708 -- Temp (1, ..., N) := Expr; -- multi dimensional update 7709 7710 if Is_Array_Type (Typ) then 7711 7712 -- The index expressions of a multi dimensional array update 7713 -- appear as an aggregate. 7714 7715 if Nkind (Comp) = N_Aggregate then 7716 Exprs := New_Copy_List_Tree (Expressions (Comp)); 7717 else 7718 Exprs := New_List (Relocate_Node (Comp)); 7719 end if; 7720 7721 LHS := 7722 Make_Indexed_Component (Loc, 7723 Prefix => New_Occurrence_Of (Temp, Loc), 7724 Expressions => Exprs); 7725 7726 -- A record component update appears in the following form: 7727 7728 -- Comp => Expr 7729 7730 -- The above relation is transformed into an assignment statement 7731 -- where the left hand side is a selected component: 7732 7733 -- Temp.Comp := Expr; 7734 7735 else pragma Assert (Is_Record_Type (Typ)); 7736 LHS := 7737 Make_Selected_Component (Loc, 7738 Prefix => New_Occurrence_Of (Temp, Loc), 7739 Selector_Name => Relocate_Node (Comp)); 7740 end if; 7741 7742 Insert_Action (N, 7743 Make_Assignment_Statement (Loc, 7744 Name => LHS, 7745 Expression => Relocate_Node (Expr))); 7746 end Process_Component_Or_Element_Update; 7747 7748 -------------------------- 7749 -- Process_Range_Update -- 7750 -------------------------- 7751 7752 procedure Process_Range_Update 7753 (Temp : Entity_Id; 7754 Comp : Node_Id; 7755 Expr : Node_Id; 7756 Typ : Entity_Id) 7757 is 7758 Index_Typ : constant Entity_Id := Etype (First_Index (Typ)); 7759 Loc : constant Source_Ptr := Sloc (Comp); 7760 Index : Entity_Id; 7761 7762 begin 7763 -- A range update appears as 7764 7765 -- (Low .. High => Expr) 7766 7767 -- The above construct is transformed into a loop that iterates over 7768 -- the given range and modifies the corresponding array values to the 7769 -- value of Expr: 7770 7771 -- for Index in Low .. High loop 7772 -- Temp (<Index_Typ> (Index)) := Expr; 7773 -- end loop; 7774 7775 Index := Make_Temporary (Loc, 'I'); 7776 7777 Insert_Action (N, 7778 Make_Loop_Statement (Loc, 7779 Iteration_Scheme => 7780 Make_Iteration_Scheme (Loc, 7781 Loop_Parameter_Specification => 7782 Make_Loop_Parameter_Specification (Loc, 7783 Defining_Identifier => Index, 7784 Discrete_Subtype_Definition => Relocate_Node (Comp))), 7785 7786 Statements => New_List ( 7787 Make_Assignment_Statement (Loc, 7788 Name => 7789 Make_Indexed_Component (Loc, 7790 Prefix => New_Occurrence_Of (Temp, Loc), 7791 Expressions => New_List ( 7792 Convert_To (Index_Typ, 7793 New_Occurrence_Of (Index, Loc)))), 7794 Expression => Relocate_Node (Expr))), 7795 7796 End_Label => Empty)); 7797 end Process_Range_Update; 7798 7799 -- Local variables 7800 7801 Aggr : constant Node_Id := First (Expressions (N)); 7802 Loc : constant Source_Ptr := Sloc (N); 7803 Pref : constant Node_Id := Prefix (N); 7804 Typ : constant Entity_Id := Etype (Pref); 7805 Assoc : Node_Id; 7806 Comp : Node_Id; 7807 CW_Temp : Entity_Id; 7808 CW_Typ : Entity_Id; 7809 Expr : Node_Id; 7810 Temp : Entity_Id; 7811 7812 -- Start of processing for Expand_Update_Attribute 7813 7814 begin 7815 -- Create the anonymous object to store the value of the prefix and 7816 -- capture subsequent changes in value. 7817 7818 Temp := Make_Temporary (Loc, 'T', Pref); 7819 7820 -- Preserve the tag of the prefix by offering a specific view of the 7821 -- class-wide version of the prefix. 7822 7823 if Is_Tagged_Type (Typ) then 7824 7825 -- Generate: 7826 -- CW_Temp : Typ'Class := Typ'Class (Pref); 7827 7828 CW_Temp := Make_Temporary (Loc, 'T'); 7829 CW_Typ := Class_Wide_Type (Typ); 7830 7831 Insert_Action (N, 7832 Make_Object_Declaration (Loc, 7833 Defining_Identifier => CW_Temp, 7834 Object_Definition => New_Occurrence_Of (CW_Typ, Loc), 7835 Expression => 7836 Convert_To (CW_Typ, Relocate_Node (Pref)))); 7837 7838 -- Generate: 7839 -- Temp : Typ renames Typ (CW_Temp); 7840 7841 Insert_Action (N, 7842 Make_Object_Renaming_Declaration (Loc, 7843 Defining_Identifier => Temp, 7844 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 7845 Name => 7846 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); 7847 7848 -- Non-tagged case 7849 7850 else 7851 -- Generate: 7852 -- Temp : Typ := Pref; 7853 7854 Insert_Action (N, 7855 Make_Object_Declaration (Loc, 7856 Defining_Identifier => Temp, 7857 Object_Definition => New_Occurrence_Of (Typ, Loc), 7858 Expression => Relocate_Node (Pref))); 7859 end if; 7860 7861 -- Process the update aggregate 7862 7863 Assoc := First (Component_Associations (Aggr)); 7864 while Present (Assoc) loop 7865 Comp := First (Choices (Assoc)); 7866 Expr := Expression (Assoc); 7867 while Present (Comp) loop 7868 if Nkind (Comp) = N_Range then 7869 Process_Range_Update (Temp, Comp, Expr, Typ); 7870 else 7871 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ); 7872 end if; 7873 7874 Next (Comp); 7875 end loop; 7876 7877 Next (Assoc); 7878 end loop; 7879 7880 -- The attribute is replaced by a reference to the anonymous object 7881 7882 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 7883 Analyze (N); 7884 end Expand_Update_Attribute; 7885 7886 ------------------- 7887 -- Find_Fat_Info -- 7888 ------------------- 7889 7890 procedure Find_Fat_Info 7891 (T : Entity_Id; 7892 Fat_Type : out Entity_Id; 7893 Fat_Pkg : out RE_Id) 7894 is 7895 Rtyp : constant Entity_Id := Root_Type (T); 7896 7897 begin 7898 -- All we do is use the root type (historically this dealt with 7899 -- VAX-float .. to be cleaned up further later ???) 7900 7901 Fat_Type := Rtyp; 7902 7903 if Fat_Type = Standard_Short_Float then 7904 Fat_Pkg := RE_Attr_Short_Float; 7905 7906 elsif Fat_Type = Standard_Float then 7907 Fat_Pkg := RE_Attr_Float; 7908 7909 elsif Fat_Type = Standard_Long_Float then 7910 Fat_Pkg := RE_Attr_Long_Float; 7911 7912 elsif Fat_Type = Standard_Long_Long_Float then 7913 Fat_Pkg := RE_Attr_Long_Long_Float; 7914 7915 -- Universal real (which is its own root type) is treated as being 7916 -- equivalent to Standard.Long_Long_Float, since it is defined to 7917 -- have the same precision as the longest Float type. 7918 7919 elsif Fat_Type = Universal_Real then 7920 Fat_Type := Standard_Long_Long_Float; 7921 Fat_Pkg := RE_Attr_Long_Long_Float; 7922 7923 else 7924 raise Program_Error; 7925 end if; 7926 end Find_Fat_Info; 7927 7928 ---------------------------- 7929 -- Find_Stream_Subprogram -- 7930 ---------------------------- 7931 7932 function Find_Stream_Subprogram 7933 (Typ : Entity_Id; 7934 Nam : TSS_Name_Type) return Entity_Id 7935 is 7936 Base_Typ : constant Entity_Id := Base_Type (Typ); 7937 Ent : constant Entity_Id := TSS (Typ, Nam); 7938 begin 7939 if Present (Ent) then 7940 return Ent; 7941 end if; 7942 7943 -- Stream attributes for strings are expanded into library calls. The 7944 -- following checks are disabled when the run-time is not available or 7945 -- when compiling predefined types due to bootstrap issues. As a result, 7946 -- the compiler will generate in-place stream routines for string types 7947 -- that appear in GNAT's library, but will generate calls via rtsfind 7948 -- to library routines for user code. 7949 7950 -- Note: In the case of using a configurable run time, it is very likely 7951 -- that stream routines for string types are not present (they require 7952 -- file system support). In this case, the specific stream routines for 7953 -- strings are not used, relying on the regular stream mechanism 7954 -- instead. That is why we include the test RTE_Available when dealing 7955 -- with these cases. 7956 7957 if not Is_Predefined_Unit (Current_Sem_Unit) then 7958 -- Storage_Array as defined in package System.Storage_Elements 7959 7960 if Is_RTE (Base_Typ, RE_Storage_Array) then 7961 7962 -- Case of No_Stream_Optimizations restriction active 7963 7964 if Restriction_Active (No_Stream_Optimizations) then 7965 if Nam = TSS_Stream_Input 7966 and then RTE_Available (RE_Storage_Array_Input) 7967 then 7968 return RTE (RE_Storage_Array_Input); 7969 7970 elsif Nam = TSS_Stream_Output 7971 and then RTE_Available (RE_Storage_Array_Output) 7972 then 7973 return RTE (RE_Storage_Array_Output); 7974 7975 elsif Nam = TSS_Stream_Read 7976 and then RTE_Available (RE_Storage_Array_Read) 7977 then 7978 return RTE (RE_Storage_Array_Read); 7979 7980 elsif Nam = TSS_Stream_Write 7981 and then RTE_Available (RE_Storage_Array_Write) 7982 then 7983 return RTE (RE_Storage_Array_Write); 7984 7985 elsif Nam /= TSS_Stream_Input and then 7986 Nam /= TSS_Stream_Output and then 7987 Nam /= TSS_Stream_Read and then 7988 Nam /= TSS_Stream_Write 7989 then 7990 raise Program_Error; 7991 end if; 7992 7993 -- Restriction No_Stream_Optimizations is not set, so we can go 7994 -- ahead and optimize using the block IO forms of the routines. 7995 7996 else 7997 if Nam = TSS_Stream_Input 7998 and then RTE_Available (RE_Storage_Array_Input_Blk_IO) 7999 then 8000 return RTE (RE_Storage_Array_Input_Blk_IO); 8001 8002 elsif Nam = TSS_Stream_Output 8003 and then RTE_Available (RE_Storage_Array_Output_Blk_IO) 8004 then 8005 return RTE (RE_Storage_Array_Output_Blk_IO); 8006 8007 elsif Nam = TSS_Stream_Read 8008 and then RTE_Available (RE_Storage_Array_Read_Blk_IO) 8009 then 8010 return RTE (RE_Storage_Array_Read_Blk_IO); 8011 8012 elsif Nam = TSS_Stream_Write 8013 and then RTE_Available (RE_Storage_Array_Write_Blk_IO) 8014 then 8015 return RTE (RE_Storage_Array_Write_Blk_IO); 8016 8017 elsif Nam /= TSS_Stream_Input and then 8018 Nam /= TSS_Stream_Output and then 8019 Nam /= TSS_Stream_Read and then 8020 Nam /= TSS_Stream_Write 8021 then 8022 raise Program_Error; 8023 end if; 8024 end if; 8025 8026 -- Stream_Element_Array as defined in package Ada.Streams 8027 8028 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then 8029 8030 -- Case of No_Stream_Optimizations restriction active 8031 8032 if Restriction_Active (No_Stream_Optimizations) then 8033 if Nam = TSS_Stream_Input 8034 and then RTE_Available (RE_Stream_Element_Array_Input) 8035 then 8036 return RTE (RE_Stream_Element_Array_Input); 8037 8038 elsif Nam = TSS_Stream_Output 8039 and then RTE_Available (RE_Stream_Element_Array_Output) 8040 then 8041 return RTE (RE_Stream_Element_Array_Output); 8042 8043 elsif Nam = TSS_Stream_Read 8044 and then RTE_Available (RE_Stream_Element_Array_Read) 8045 then 8046 return RTE (RE_Stream_Element_Array_Read); 8047 8048 elsif Nam = TSS_Stream_Write 8049 and then RTE_Available (RE_Stream_Element_Array_Write) 8050 then 8051 return RTE (RE_Stream_Element_Array_Write); 8052 8053 elsif Nam /= TSS_Stream_Input and then 8054 Nam /= TSS_Stream_Output and then 8055 Nam /= TSS_Stream_Read and then 8056 Nam /= TSS_Stream_Write 8057 then 8058 raise Program_Error; 8059 end if; 8060 8061 -- Restriction No_Stream_Optimizations is not set, so we can go 8062 -- ahead and optimize using the block IO forms of the routines. 8063 8064 else 8065 if Nam = TSS_Stream_Input 8066 and then RTE_Available (RE_Stream_Element_Array_Input_Blk_IO) 8067 then 8068 return RTE (RE_Stream_Element_Array_Input_Blk_IO); 8069 8070 elsif Nam = TSS_Stream_Output 8071 and then RTE_Available (RE_Stream_Element_Array_Output_Blk_IO) 8072 then 8073 return RTE (RE_Stream_Element_Array_Output_Blk_IO); 8074 8075 elsif Nam = TSS_Stream_Read 8076 and then RTE_Available (RE_Stream_Element_Array_Read_Blk_IO) 8077 then 8078 return RTE (RE_Stream_Element_Array_Read_Blk_IO); 8079 8080 elsif Nam = TSS_Stream_Write 8081 and then RTE_Available (RE_Stream_Element_Array_Write_Blk_IO) 8082 then 8083 return RTE (RE_Stream_Element_Array_Write_Blk_IO); 8084 8085 elsif Nam /= TSS_Stream_Input and then 8086 Nam /= TSS_Stream_Output and then 8087 Nam /= TSS_Stream_Read and then 8088 Nam /= TSS_Stream_Write 8089 then 8090 raise Program_Error; 8091 end if; 8092 end if; 8093 8094 -- String as defined in package Ada 8095 8096 elsif Base_Typ = Standard_String then 8097 8098 -- Case of No_Stream_Optimizations restriction active 8099 8100 if Restriction_Active (No_Stream_Optimizations) then 8101 if Nam = TSS_Stream_Input 8102 and then RTE_Available (RE_String_Input) 8103 then 8104 return RTE (RE_String_Input); 8105 8106 elsif Nam = TSS_Stream_Output 8107 and then RTE_Available (RE_String_Output) 8108 then 8109 return RTE (RE_String_Output); 8110 8111 elsif Nam = TSS_Stream_Read 8112 and then RTE_Available (RE_String_Read) 8113 then 8114 return RTE (RE_String_Read); 8115 8116 elsif Nam = TSS_Stream_Write 8117 and then RTE_Available (RE_String_Write) 8118 then 8119 return RTE (RE_String_Write); 8120 8121 elsif Nam /= TSS_Stream_Input and then 8122 Nam /= TSS_Stream_Output and then 8123 Nam /= TSS_Stream_Read and then 8124 Nam /= TSS_Stream_Write 8125 then 8126 raise Program_Error; 8127 end if; 8128 8129 -- Restriction No_Stream_Optimizations is not set, so we can go 8130 -- ahead and optimize using the block IO forms of the routines. 8131 8132 else 8133 if Nam = TSS_Stream_Input 8134 and then RTE_Available (RE_String_Input_Blk_IO) 8135 then 8136 return RTE (RE_String_Input_Blk_IO); 8137 8138 elsif Nam = TSS_Stream_Output 8139 and then RTE_Available (RE_String_Output_Blk_IO) 8140 then 8141 return RTE (RE_String_Output_Blk_IO); 8142 8143 elsif Nam = TSS_Stream_Read 8144 and then RTE_Available (RE_String_Read_Blk_IO) 8145 then 8146 return RTE (RE_String_Read_Blk_IO); 8147 8148 elsif Nam = TSS_Stream_Write 8149 and then RTE_Available (RE_String_Write_Blk_IO) 8150 then 8151 return RTE (RE_String_Write_Blk_IO); 8152 8153 elsif Nam /= TSS_Stream_Input and then 8154 Nam /= TSS_Stream_Output and then 8155 Nam /= TSS_Stream_Read and then 8156 Nam /= TSS_Stream_Write 8157 then 8158 raise Program_Error; 8159 end if; 8160 end if; 8161 8162 -- Wide_String as defined in package Ada 8163 8164 elsif Base_Typ = Standard_Wide_String then 8165 8166 -- Case of No_Stream_Optimizations restriction active 8167 8168 if Restriction_Active (No_Stream_Optimizations) then 8169 if Nam = TSS_Stream_Input 8170 and then RTE_Available (RE_Wide_String_Input) 8171 then 8172 return RTE (RE_Wide_String_Input); 8173 8174 elsif Nam = TSS_Stream_Output 8175 and then RTE_Available (RE_Wide_String_Output) 8176 then 8177 return RTE (RE_Wide_String_Output); 8178 8179 elsif Nam = TSS_Stream_Read 8180 and then RTE_Available (RE_Wide_String_Read) 8181 then 8182 return RTE (RE_Wide_String_Read); 8183 8184 elsif Nam = TSS_Stream_Write 8185 and then RTE_Available (RE_Wide_String_Write) 8186 then 8187 return RTE (RE_Wide_String_Write); 8188 8189 elsif Nam /= TSS_Stream_Input and then 8190 Nam /= TSS_Stream_Output and then 8191 Nam /= TSS_Stream_Read and then 8192 Nam /= TSS_Stream_Write 8193 then 8194 raise Program_Error; 8195 end if; 8196 8197 -- Restriction No_Stream_Optimizations is not set, so we can go 8198 -- ahead and optimize using the block IO forms of the routines. 8199 8200 else 8201 if Nam = TSS_Stream_Input 8202 and then RTE_Available (RE_Wide_String_Input_Blk_IO) 8203 then 8204 return RTE (RE_Wide_String_Input_Blk_IO); 8205 8206 elsif Nam = TSS_Stream_Output 8207 and then RTE_Available (RE_Wide_String_Output_Blk_IO) 8208 then 8209 return RTE (RE_Wide_String_Output_Blk_IO); 8210 8211 elsif Nam = TSS_Stream_Read 8212 and then RTE_Available (RE_Wide_String_Read_Blk_IO) 8213 then 8214 return RTE (RE_Wide_String_Read_Blk_IO); 8215 8216 elsif Nam = TSS_Stream_Write 8217 and then RTE_Available (RE_Wide_String_Write_Blk_IO) 8218 then 8219 return RTE (RE_Wide_String_Write_Blk_IO); 8220 8221 elsif Nam /= TSS_Stream_Input and then 8222 Nam /= TSS_Stream_Output and then 8223 Nam /= TSS_Stream_Read and then 8224 Nam /= TSS_Stream_Write 8225 then 8226 raise Program_Error; 8227 end if; 8228 end if; 8229 8230 -- Wide_Wide_String as defined in package Ada 8231 8232 elsif Base_Typ = Standard_Wide_Wide_String then 8233 8234 -- Case of No_Stream_Optimizations restriction active 8235 8236 if Restriction_Active (No_Stream_Optimizations) then 8237 if Nam = TSS_Stream_Input 8238 and then RTE_Available (RE_Wide_Wide_String_Input) 8239 then 8240 return RTE (RE_Wide_Wide_String_Input); 8241 8242 elsif Nam = TSS_Stream_Output 8243 and then RTE_Available (RE_Wide_Wide_String_Output) 8244 then 8245 return RTE (RE_Wide_Wide_String_Output); 8246 8247 elsif Nam = TSS_Stream_Read 8248 and then RTE_Available (RE_Wide_Wide_String_Read) 8249 then 8250 return RTE (RE_Wide_Wide_String_Read); 8251 8252 elsif Nam = TSS_Stream_Write 8253 and then RTE_Available (RE_Wide_Wide_String_Write) 8254 then 8255 return RTE (RE_Wide_Wide_String_Write); 8256 8257 elsif Nam /= TSS_Stream_Input and then 8258 Nam /= TSS_Stream_Output and then 8259 Nam /= TSS_Stream_Read and then 8260 Nam /= TSS_Stream_Write 8261 then 8262 raise Program_Error; 8263 end if; 8264 8265 -- Restriction No_Stream_Optimizations is not set, so we can go 8266 -- ahead and optimize using the block IO forms of the routines. 8267 8268 else 8269 if Nam = TSS_Stream_Input 8270 and then RTE_Available (RE_Wide_Wide_String_Input_Blk_IO) 8271 then 8272 return RTE (RE_Wide_Wide_String_Input_Blk_IO); 8273 8274 elsif Nam = TSS_Stream_Output 8275 and then RTE_Available (RE_Wide_Wide_String_Output_Blk_IO) 8276 then 8277 return RTE (RE_Wide_Wide_String_Output_Blk_IO); 8278 8279 elsif Nam = TSS_Stream_Read 8280 and then RTE_Available (RE_Wide_Wide_String_Read_Blk_IO) 8281 then 8282 return RTE (RE_Wide_Wide_String_Read_Blk_IO); 8283 8284 elsif Nam = TSS_Stream_Write 8285 and then RTE_Available (RE_Wide_Wide_String_Write_Blk_IO) 8286 then 8287 return RTE (RE_Wide_Wide_String_Write_Blk_IO); 8288 8289 elsif Nam /= TSS_Stream_Input and then 8290 Nam /= TSS_Stream_Output and then 8291 Nam /= TSS_Stream_Read and then 8292 Nam /= TSS_Stream_Write 8293 then 8294 raise Program_Error; 8295 end if; 8296 end if; 8297 end if; 8298 end if; 8299 8300 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then 8301 return Find_Prim_Op (Typ, Nam); 8302 else 8303 return Find_Inherited_TSS (Typ, Nam); 8304 end if; 8305 end Find_Stream_Subprogram; 8306 8307 --------------- 8308 -- Full_Base -- 8309 --------------- 8310 8311 function Full_Base (T : Entity_Id) return Entity_Id is 8312 BT : Entity_Id; 8313 8314 begin 8315 BT := Base_Type (T); 8316 8317 if Is_Private_Type (BT) 8318 and then Present (Full_View (BT)) 8319 then 8320 BT := Full_View (BT); 8321 end if; 8322 8323 return BT; 8324 end Full_Base; 8325 8326 ----------------------- 8327 -- Get_Index_Subtype -- 8328 ----------------------- 8329 8330 function Get_Index_Subtype (N : Node_Id) return Node_Id is 8331 P_Type : Entity_Id := Etype (Prefix (N)); 8332 Indx : Node_Id; 8333 J : Int; 8334 8335 begin 8336 if Is_Access_Type (P_Type) then 8337 P_Type := Designated_Type (P_Type); 8338 end if; 8339 8340 if No (Expressions (N)) then 8341 J := 1; 8342 else 8343 J := UI_To_Int (Expr_Value (First (Expressions (N)))); 8344 end if; 8345 8346 Indx := First_Index (P_Type); 8347 while J > 1 loop 8348 Next_Index (Indx); 8349 J := J - 1; 8350 end loop; 8351 8352 return Etype (Indx); 8353 end Get_Index_Subtype; 8354 8355 ------------------------------- 8356 -- Get_Stream_Convert_Pragma -- 8357 ------------------------------- 8358 8359 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is 8360 Typ : Entity_Id; 8361 N : Node_Id; 8362 8363 begin 8364 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity 8365 -- that a stream convert pragma for a tagged type is not inherited from 8366 -- its parent. Probably what is wrong here is that it is basically 8367 -- incorrect to consider a stream convert pragma to be a representation 8368 -- pragma at all ??? 8369 8370 N := First_Rep_Item (Implementation_Base_Type (T)); 8371 while Present (N) loop 8372 if Nkind (N) = N_Pragma 8373 and then Pragma_Name (N) = Name_Stream_Convert 8374 then 8375 -- For tagged types this pragma is not inherited, so we 8376 -- must verify that it is defined for the given type and 8377 -- not an ancestor. 8378 8379 Typ := 8380 Entity (Expression (First (Pragma_Argument_Associations (N)))); 8381 8382 if not Is_Tagged_Type (T) 8383 or else T = Typ 8384 or else (Is_Private_Type (Typ) and then T = Full_View (Typ)) 8385 then 8386 return N; 8387 end if; 8388 end if; 8389 8390 Next_Rep_Item (N); 8391 end loop; 8392 8393 return Empty; 8394 end Get_Stream_Convert_Pragma; 8395 8396 --------------------------------- 8397 -- Is_Constrained_Packed_Array -- 8398 --------------------------------- 8399 8400 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is 8401 Arr : Entity_Id := Typ; 8402 8403 begin 8404 if Is_Access_Type (Arr) then 8405 Arr := Designated_Type (Arr); 8406 end if; 8407 8408 return Is_Array_Type (Arr) 8409 and then Is_Constrained (Arr) 8410 and then Present (Packed_Array_Impl_Type (Arr)); 8411 end Is_Constrained_Packed_Array; 8412 8413 ---------------------------------------- 8414 -- Is_Inline_Floating_Point_Attribute -- 8415 ---------------------------------------- 8416 8417 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is 8418 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); 8419 8420 function Is_GCC_Target return Boolean; 8421 -- Return True if we are using a GCC target/back-end 8422 -- ??? Note: the implementation is kludgy/fragile 8423 8424 ------------------- 8425 -- Is_GCC_Target -- 8426 ------------------- 8427 8428 function Is_GCC_Target return Boolean is 8429 begin 8430 return not CodePeer_Mode 8431 and then not Modify_Tree_For_C; 8432 end Is_GCC_Target; 8433 8434 -- Start of processing for Is_Inline_Floating_Point_Attribute 8435 8436 begin 8437 -- Machine and Model can be expanded by the GCC back end only 8438 8439 if Id = Attribute_Machine or else Id = Attribute_Model then 8440 return Is_GCC_Target; 8441 8442 -- Remaining cases handled by all back ends are Rounding and Truncation 8443 -- when appearing as the operand of a conversion to some integer type. 8444 8445 elsif Nkind (Parent (N)) /= N_Type_Conversion 8446 or else not Is_Integer_Type (Etype (Parent (N))) 8447 then 8448 return False; 8449 end if; 8450 8451 -- Here we are in the integer conversion context. We reuse Rounding for 8452 -- Machine_Rounding as System.Fat_Gen, which is a permissible behavior. 8453 8454 return 8455 Id = Attribute_Rounding 8456 or else Id = Attribute_Machine_Rounding 8457 or else Id = Attribute_Truncation; 8458 end Is_Inline_Floating_Point_Attribute; 8459 8460end Exp_Attr; 8461