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