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