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