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