1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ I M G V -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2013, 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 Atree; use Atree; 27with Casing; use Casing; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Exp_Util; use Exp_Util; 31with Lib; use Lib; 32with Namet; use Namet; 33with Nmake; use Nmake; 34with Nlists; use Nlists; 35with Opt; use Opt; 36with Rtsfind; use Rtsfind; 37with Sem_Aux; use Sem_Aux; 38with Sem_Res; use Sem_Res; 39with Sinfo; use Sinfo; 40with Snames; use Snames; 41with Stand; use Stand; 42with Stringt; use Stringt; 43with Tbuild; use Tbuild; 44with Ttypes; use Ttypes; 45with Uintp; use Uintp; 46with Urealp; use Urealp; 47 48package body Exp_Imgv is 49 50 function Has_Decimal_Small (E : Entity_Id) return Boolean; 51 -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an 52 -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. 53 -- Shouldn't this be in einfo.adb or sem_aux.adb??? 54 55 ------------------------------------ 56 -- Build_Enumeration_Image_Tables -- 57 ------------------------------------ 58 59 procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is 60 Loc : constant Source_Ptr := Sloc (E); 61 Str : String_Id; 62 Ind : List_Id; 63 Lit : Entity_Id; 64 Nlit : Nat; 65 Len : Nat; 66 Estr : Entity_Id; 67 Eind : Entity_Id; 68 Ityp : Node_Id; 69 70 begin 71 -- Nothing to do for other than a root enumeration type 72 73 if E /= Root_Type (E) then 74 return; 75 76 -- Nothing to do if pragma Discard_Names applies 77 78 elsif Discard_Names (E) then 79 return; 80 end if; 81 82 -- Otherwise tables need constructing 83 84 Start_String; 85 Ind := New_List; 86 Lit := First_Literal (E); 87 Len := 1; 88 Nlit := 0; 89 90 loop 91 Append_To (Ind, 92 Make_Integer_Literal (Loc, UI_From_Int (Len))); 93 94 exit when No (Lit); 95 Nlit := Nlit + 1; 96 97 Get_Unqualified_Decoded_Name_String (Chars (Lit)); 98 99 if Name_Buffer (1) /= ''' then 100 Set_Casing (All_Upper_Case); 101 end if; 102 103 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 104 Len := Len + Int (Name_Len); 105 Next_Literal (Lit); 106 end loop; 107 108 if Len < Int (2 ** (8 - 1)) then 109 Ityp := Standard_Integer_8; 110 elsif Len < Int (2 ** (16 - 1)) then 111 Ityp := Standard_Integer_16; 112 else 113 Ityp := Standard_Integer_32; 114 end if; 115 116 Str := End_String; 117 118 Estr := 119 Make_Defining_Identifier (Loc, 120 Chars => New_External_Name (Chars (E), 'S')); 121 122 Eind := 123 Make_Defining_Identifier (Loc, 124 Chars => New_External_Name (Chars (E), 'N')); 125 126 Set_Lit_Strings (E, Estr); 127 Set_Lit_Indexes (E, Eind); 128 129 Insert_Actions (N, 130 New_List ( 131 Make_Object_Declaration (Loc, 132 Defining_Identifier => Estr, 133 Constant_Present => True, 134 Object_Definition => 135 New_Occurrence_Of (Standard_String, Loc), 136 Expression => 137 Make_String_Literal (Loc, 138 Strval => Str)), 139 140 Make_Object_Declaration (Loc, 141 Defining_Identifier => Eind, 142 Constant_Present => True, 143 144 Object_Definition => 145 Make_Constrained_Array_Definition (Loc, 146 Discrete_Subtype_Definitions => New_List ( 147 Make_Range (Loc, 148 Low_Bound => Make_Integer_Literal (Loc, 0), 149 High_Bound => Make_Integer_Literal (Loc, Nlit))), 150 Component_Definition => 151 Make_Component_Definition (Loc, 152 Aliased_Present => False, 153 Subtype_Indication => New_Occurrence_Of (Ityp, Loc))), 154 155 Expression => 156 Make_Aggregate (Loc, 157 Expressions => Ind))), 158 Suppress => All_Checks); 159 end Build_Enumeration_Image_Tables; 160 161 ---------------------------- 162 -- Expand_Image_Attribute -- 163 ---------------------------- 164 165 -- For all cases other than user defined enumeration types, the scheme 166 -- is as follows. First we insert the following code: 167 168 -- Snn : String (1 .. rt'Width); 169 -- Pnn : Natural; 170 -- Image_xx (tv, Snn, Pnn [,pm]); 171 -- 172 -- and then Expr is replaced by Snn (1 .. Pnn) 173 174 -- In the above expansion: 175 176 -- rt is the root type of the expression 177 -- tv is the expression with the value, usually a type conversion 178 -- pm is an extra parameter present in some cases 179 180 -- The following table shows tv, xx, and (if used) pm for the various 181 -- possible types of the argument: 182 183 -- For types whose root type is Character 184 -- xx = Character 185 -- tv = Character (Expr) 186 187 -- For types whose root type is Boolean 188 -- xx = Boolean 189 -- tv = Boolean (Expr) 190 191 -- For signed integer types with size <= Integer'Size 192 -- xx = Integer 193 -- tv = Integer (Expr) 194 195 -- For other signed integer types 196 -- xx = Long_Long_Integer 197 -- tv = Long_Long_Integer (Expr) 198 199 -- For modular types with modulus <= System.Unsigned_Types.Unsigned 200 -- xx = Unsigned 201 -- tv = System.Unsigned_Types.Unsigned (Expr) 202 203 -- For other modular integer types 204 -- xx = Long_Long_Unsigned 205 -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr) 206 207 -- For types whose root type is Wide_Character 208 -- xx = Wide_Character 209 -- tv = Wide_Character (Expr) 210 -- pm = Boolean, true if Ada 2005 mode, False otherwise 211 212 -- For types whose root type is Wide_Wide_Character 213 -- xx = Wide_Wide_Character 214 -- tv = Wide_Wide_Character (Expr) 215 216 -- For floating-point types 217 -- xx = Floating_Point 218 -- tv = Long_Long_Float (Expr) 219 -- pm = typ'Digits (typ = subtype of expression) 220 221 -- For ordinary fixed-point types 222 -- xx = Ordinary_Fixed_Point 223 -- tv = Long_Long_Float (Expr) 224 -- pm = typ'Aft (typ = subtype of expression) 225 226 -- For decimal fixed-point types with size = Integer'Size 227 -- xx = Decimal 228 -- tv = Integer (Expr) 229 -- pm = typ'Scale (typ = subtype of expression) 230 231 -- For decimal fixed-point types with size > Integer'Size 232 -- xx = Long_Long_Decimal 233 -- tv = Long_Long_Integer?(Expr) [convert with no scaling] 234 -- pm = typ'Scale (typ = subtype of expression) 235 236 -- For enumeration types other than those declared packages Standard 237 -- or System, Snn, Pnn, are expanded as above, but the call looks like: 238 239 -- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address) 240 241 -- where rt is the root type of the expression, and typS and typI are 242 -- the entities constructed as described in the spec for the procedure 243 -- Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the 244 -- element type of Lit_Indexes. The rewriting of the expression to 245 -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is 246 -- when pragma Discard_Names applies, in which case we replace expr by: 247 248 -- (rt'Pos (expr))'Img 249 250 -- So that the result is a space followed by the decimal value for the 251 -- position of the enumeration value in the enumeration type. 252 253 procedure Expand_Image_Attribute (N : Node_Id) is 254 Loc : constant Source_Ptr := Sloc (N); 255 Exprs : constant List_Id := Expressions (N); 256 Pref : constant Node_Id := Prefix (N); 257 Ptyp : constant Entity_Id := Entity (Pref); 258 Rtyp : constant Entity_Id := Root_Type (Ptyp); 259 Expr : constant Node_Id := Relocate_Node (First (Exprs)); 260 Imid : RE_Id; 261 Tent : Entity_Id; 262 Ttyp : Entity_Id; 263 Proc_Ent : Entity_Id; 264 Enum_Case : Boolean; 265 266 Arg_List : List_Id; 267 -- List of arguments for run-time procedure call 268 269 Ins_List : List_Id; 270 -- List of actions to be inserted 271 272 Snn : constant Entity_Id := Make_Temporary (Loc, 'S'); 273 Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); 274 275 begin 276 -- Build declarations of Snn and Pnn to be inserted 277 278 Ins_List := New_List ( 279 280 -- Snn : String (1 .. typ'Width); 281 282 Make_Object_Declaration (Loc, 283 Defining_Identifier => Snn, 284 Object_Definition => 285 Make_Subtype_Indication (Loc, 286 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), 287 Constraint => 288 Make_Index_Or_Discriminant_Constraint (Loc, 289 Constraints => New_List ( 290 Make_Range (Loc, 291 Low_Bound => Make_Integer_Literal (Loc, 1), 292 High_Bound => 293 Make_Attribute_Reference (Loc, 294 Prefix => New_Occurrence_Of (Rtyp, Loc), 295 Attribute_Name => Name_Width)))))), 296 297 -- Pnn : Natural; 298 299 Make_Object_Declaration (Loc, 300 Defining_Identifier => Pnn, 301 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc))); 302 303 -- Set Imid (RE_Id of procedure to call), and Tent, target for the 304 -- type conversion of the first argument for all possibilities. 305 306 Enum_Case := False; 307 308 if Rtyp = Standard_Boolean then 309 Imid := RE_Image_Boolean; 310 Tent := Rtyp; 311 312 -- For standard character, we have to select the version which handles 313 -- soft hyphen correctly, based on the version of Ada in use (this is 314 -- ugly, but we have no choice). 315 316 elsif Rtyp = Standard_Character then 317 if Ada_Version < Ada_2005 then 318 Imid := RE_Image_Character; 319 else 320 Imid := RE_Image_Character_05; 321 end if; 322 323 Tent := Rtyp; 324 325 elsif Rtyp = Standard_Wide_Character then 326 Imid := RE_Image_Wide_Character; 327 Tent := Rtyp; 328 329 elsif Rtyp = Standard_Wide_Wide_Character then 330 Imid := RE_Image_Wide_Wide_Character; 331 Tent := Rtyp; 332 333 elsif Is_Signed_Integer_Type (Rtyp) then 334 if Esize (Rtyp) <= Esize (Standard_Integer) then 335 Imid := RE_Image_Integer; 336 Tent := Standard_Integer; 337 else 338 Imid := RE_Image_Long_Long_Integer; 339 Tent := Standard_Long_Long_Integer; 340 end if; 341 342 elsif Is_Modular_Integer_Type (Rtyp) then 343 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then 344 Imid := RE_Image_Unsigned; 345 Tent := RTE (RE_Unsigned); 346 else 347 Imid := RE_Image_Long_Long_Unsigned; 348 Tent := RTE (RE_Long_Long_Unsigned); 349 end if; 350 351 elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then 352 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 353 Imid := RE_Image_Decimal; 354 Tent := Standard_Integer; 355 else 356 Imid := RE_Image_Long_Long_Decimal; 357 Tent := Standard_Long_Long_Integer; 358 end if; 359 360 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then 361 Imid := RE_Image_Ordinary_Fixed_Point; 362 Tent := Standard_Long_Long_Float; 363 364 elsif Is_Floating_Point_Type (Rtyp) then 365 Imid := RE_Image_Floating_Point; 366 Tent := Standard_Long_Long_Float; 367 368 -- Only other possibility is user defined enumeration type 369 370 else 371 if Discard_Names (First_Subtype (Ptyp)) 372 or else No (Lit_Strings (Root_Type (Ptyp))) 373 then 374 -- When pragma Discard_Names applies to the first subtype, build 375 -- (Pref'Pos (Expr))'Img. 376 377 Rewrite (N, 378 Make_Attribute_Reference (Loc, 379 Prefix => 380 Make_Attribute_Reference (Loc, 381 Prefix => Pref, 382 Attribute_Name => Name_Pos, 383 Expressions => New_List (Expr)), 384 Attribute_Name => 385 Name_Img)); 386 Analyze_And_Resolve (N, Standard_String); 387 return; 388 389 else 390 -- Here for enumeration type case 391 392 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); 393 394 if Ttyp = Standard_Integer_8 then 395 Imid := RE_Image_Enumeration_8; 396 397 elsif Ttyp = Standard_Integer_16 then 398 Imid := RE_Image_Enumeration_16; 399 400 else 401 Imid := RE_Image_Enumeration_32; 402 end if; 403 404 -- Apply a validity check, since it is a bit drastic to get a 405 -- completely junk image value for an invalid value. 406 407 if not Expr_Known_Valid (Expr) then 408 Insert_Valid_Check (Expr); 409 end if; 410 411 Enum_Case := True; 412 end if; 413 end if; 414 415 -- Build first argument for call 416 417 if Enum_Case then 418 Arg_List := New_List ( 419 Make_Attribute_Reference (Loc, 420 Attribute_Name => Name_Pos, 421 Prefix => New_Occurrence_Of (Ptyp, Loc), 422 Expressions => New_List (Expr))); 423 424 else 425 Arg_List := New_List (Convert_To (Tent, Expr)); 426 end if; 427 428 -- Append Snn, Pnn arguments 429 430 Append_To (Arg_List, New_Occurrence_Of (Snn, Loc)); 431 Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc)); 432 433 -- Get entity of procedure to call 434 435 Proc_Ent := RTE (Imid); 436 437 -- If the procedure entity is empty, that means we have a case in 438 -- no run time mode where the operation is not allowed, and an 439 -- appropriate diagnostic has already been issued. 440 441 if No (Proc_Ent) then 442 return; 443 end if; 444 445 -- Otherwise complete preparation of arguments for run-time call 446 447 -- Add extra arguments for Enumeration case 448 449 if Enum_Case then 450 Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); 451 Append_To (Arg_List, 452 Make_Attribute_Reference (Loc, 453 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), 454 Attribute_Name => Name_Address)); 455 456 -- For floating-point types, append Digits argument 457 458 elsif Is_Floating_Point_Type (Rtyp) then 459 Append_To (Arg_List, 460 Make_Attribute_Reference (Loc, 461 Prefix => New_Occurrence_Of (Ptyp, Loc), 462 Attribute_Name => Name_Digits)); 463 464 -- For ordinary fixed-point types, append Aft parameter 465 466 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then 467 Append_To (Arg_List, 468 Make_Attribute_Reference (Loc, 469 Prefix => New_Occurrence_Of (Ptyp, Loc), 470 Attribute_Name => Name_Aft)); 471 472 if Has_Decimal_Small (Rtyp) then 473 Set_Conversion_OK (First (Arg_List)); 474 Set_Etype (First (Arg_List), Tent); 475 end if; 476 477 -- For decimal, append Scale and also set to do literal conversion 478 479 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then 480 Append_To (Arg_List, 481 Make_Attribute_Reference (Loc, 482 Prefix => New_Occurrence_Of (Ptyp, Loc), 483 Attribute_Name => Name_Scale)); 484 485 Set_Conversion_OK (First (Arg_List)); 486 Set_Etype (First (Arg_List), Tent); 487 488 -- For Wide_Character, append Ada 2005 indication 489 490 elsif Rtyp = Standard_Wide_Character then 491 Append_To (Arg_List, 492 New_Occurrence_Of 493 (Boolean_Literals (Ada_Version >= Ada_2005), Loc)); 494 end if; 495 496 -- Now append the procedure call to the insert list 497 498 Append_To (Ins_List, 499 Make_Procedure_Call_Statement (Loc, 500 Name => New_Occurrence_Of (Proc_Ent, Loc), 501 Parameter_Associations => Arg_List)); 502 503 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress 504 -- checks because we are sure that everything is in range at this stage. 505 506 Insert_Actions (N, Ins_List, Suppress => All_Checks); 507 508 -- Final step is to rewrite the expression as a slice and analyze, 509 -- again with no checks, since we are sure that everything is OK. 510 511 Rewrite (N, 512 Make_Slice (Loc, 513 Prefix => New_Occurrence_Of (Snn, Loc), 514 Discrete_Range => 515 Make_Range (Loc, 516 Low_Bound => Make_Integer_Literal (Loc, 1), 517 High_Bound => New_Occurrence_Of (Pnn, Loc)))); 518 519 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks); 520 end Expand_Image_Attribute; 521 522 ---------------------------- 523 -- Expand_Value_Attribute -- 524 ---------------------------- 525 526 -- For scalar types derived from Boolean, Character and integer types 527 -- in package Standard, typ'Value (X) expands into: 528 529 -- btyp (Value_xx (X)) 530 531 -- where btyp is he base type of the prefix 532 533 -- For types whose root type is Character 534 -- xx = Character 535 536 -- For types whose root type is Wide_Character 537 -- xx = Wide_Character 538 539 -- For types whose root type is Wide_Wide_Character 540 -- xx = Wide_Wide_Character 541 542 -- For types whose root type is Boolean 543 -- xx = Boolean 544 545 -- For signed integer types with size <= Integer'Size 546 -- xx = Integer 547 548 -- For other signed integer types 549 -- xx = Long_Long_Integer 550 551 -- For modular types with modulus <= System.Unsigned_Types.Unsigned 552 -- xx = Unsigned 553 554 -- For other modular integer types 555 -- xx = Long_Long_Unsigned 556 557 -- For floating-point types and ordinary fixed-point types 558 -- xx = Real 559 560 -- For Wide_[Wide_]Character types, typ'Value (X) expands into: 561 562 -- btyp (Value_xx (X, EM)) 563 564 -- where btyp is the base type of the prefix, and EM is the encoding method 565 566 -- For decimal types with size <= Integer'Size, typ'Value (X) 567 -- expands into 568 569 -- btyp?(Value_Decimal (X, typ'Scale)); 570 571 -- For all other decimal types, typ'Value (X) expands into 572 573 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale)) 574 575 -- For enumeration types other than those derived from types Boolean, 576 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to: 577 578 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) 579 580 -- where typS and typI and the Lit_Strings and Lit_Indexes entities 581 -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The 582 -- Value_Enumeration_NN function will search the tables looking for 583 -- X and return the position number in the table if found which is 584 -- used to provide the result of 'Value (using Enum'Val). If the 585 -- value is not found Constraint_Error is raised. The suffix _NN 586 -- depends on the element type of typI. 587 588 procedure Expand_Value_Attribute (N : Node_Id) is 589 Loc : constant Source_Ptr := Sloc (N); 590 Typ : constant Entity_Id := Etype (N); 591 Btyp : constant Entity_Id := Base_Type (Typ); 592 Rtyp : constant Entity_Id := Root_Type (Typ); 593 Exprs : constant List_Id := Expressions (N); 594 Vid : RE_Id; 595 Args : List_Id; 596 Func : RE_Id; 597 Ttyp : Entity_Id; 598 599 begin 600 Args := Exprs; 601 602 if Rtyp = Standard_Character then 603 Vid := RE_Value_Character; 604 605 elsif Rtyp = Standard_Boolean then 606 Vid := RE_Value_Boolean; 607 608 elsif Rtyp = Standard_Wide_Character then 609 Vid := RE_Value_Wide_Character; 610 611 Append_To (Args, 612 Make_Integer_Literal (Loc, 613 Intval => Int (Wide_Character_Encoding_Method))); 614 615 elsif Rtyp = Standard_Wide_Wide_Character then 616 Vid := RE_Value_Wide_Wide_Character; 617 618 Append_To (Args, 619 Make_Integer_Literal (Loc, 620 Intval => Int (Wide_Character_Encoding_Method))); 621 622 elsif Rtyp = Base_Type (Standard_Short_Short_Integer) 623 or else Rtyp = Base_Type (Standard_Short_Integer) 624 or else Rtyp = Base_Type (Standard_Integer) 625 then 626 Vid := RE_Value_Integer; 627 628 elsif Is_Signed_Integer_Type (Rtyp) then 629 Vid := RE_Value_Long_Long_Integer; 630 631 elsif Is_Modular_Integer_Type (Rtyp) then 632 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then 633 Vid := RE_Value_Unsigned; 634 else 635 Vid := RE_Value_Long_Long_Unsigned; 636 end if; 637 638 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then 639 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 640 Vid := RE_Value_Decimal; 641 else 642 Vid := RE_Value_Long_Long_Decimal; 643 end if; 644 645 Append_To (Args, 646 Make_Attribute_Reference (Loc, 647 Prefix => New_Occurrence_Of (Typ, Loc), 648 Attribute_Name => Name_Scale)); 649 650 Rewrite (N, 651 OK_Convert_To (Btyp, 652 Make_Function_Call (Loc, 653 Name => New_Occurrence_Of (RTE (Vid), Loc), 654 Parameter_Associations => Args))); 655 656 Set_Etype (N, Btyp); 657 Analyze_And_Resolve (N, Btyp); 658 return; 659 660 elsif Is_Real_Type (Rtyp) then 661 Vid := RE_Value_Real; 662 663 -- Only other possibility is user defined enumeration type 664 665 else 666 pragma Assert (Is_Enumeration_Type (Rtyp)); 667 668 -- Case of pragma Discard_Names, transform the Value 669 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args)) 670 671 if Discard_Names (First_Subtype (Typ)) 672 or else No (Lit_Strings (Rtyp)) 673 then 674 Rewrite (N, 675 Make_Attribute_Reference (Loc, 676 Prefix => New_Occurrence_Of (Btyp, Loc), 677 Attribute_Name => Name_Val, 678 Expressions => New_List ( 679 Make_Attribute_Reference (Loc, 680 Prefix => 681 New_Occurrence_Of (Standard_Long_Long_Integer, Loc), 682 Attribute_Name => Name_Value, 683 Expressions => Args)))); 684 685 Analyze_And_Resolve (N, Btyp); 686 687 -- Here for normal case where we have enumeration tables, this 688 -- is where we build 689 690 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) 691 692 else 693 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); 694 695 if Ttyp = Standard_Integer_8 then 696 Func := RE_Value_Enumeration_8; 697 elsif Ttyp = Standard_Integer_16 then 698 Func := RE_Value_Enumeration_16; 699 else 700 Func := RE_Value_Enumeration_32; 701 end if; 702 703 Prepend_To (Args, 704 Make_Attribute_Reference (Loc, 705 Prefix => New_Occurrence_Of (Rtyp, Loc), 706 Attribute_Name => Name_Pos, 707 Expressions => New_List ( 708 Make_Attribute_Reference (Loc, 709 Prefix => New_Occurrence_Of (Rtyp, Loc), 710 Attribute_Name => Name_Last)))); 711 712 Prepend_To (Args, 713 Make_Attribute_Reference (Loc, 714 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), 715 Attribute_Name => Name_Address)); 716 717 Prepend_To (Args, 718 New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); 719 720 Rewrite (N, 721 Make_Attribute_Reference (Loc, 722 Prefix => New_Occurrence_Of (Typ, Loc), 723 Attribute_Name => Name_Val, 724 Expressions => New_List ( 725 Make_Function_Call (Loc, 726 Name => 727 New_Occurrence_Of (RTE (Func), Loc), 728 Parameter_Associations => Args)))); 729 730 Analyze_And_Resolve (N, Btyp); 731 end if; 732 733 return; 734 end if; 735 736 -- Fall through for all cases except user defined enumeration type 737 -- and decimal types, with Vid set to the Id of the entity for the 738 -- Value routine and Args set to the list of parameters for the call. 739 740 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the 741 -- expansion of the attribute into the function call statement to avoid 742 -- generating spurious errors caused by the use of Integer_Address'Value 743 -- in our implementation of Ada.Tags.Internal_Tag 744 745 -- Seems like a bit of a kludge, there should be a better way ??? 746 747 -- There is a better way, you should also test RTE_Available ??? 748 749 if No_Run_Time_Mode 750 and then Rtyp = RTE (RE_Integer_Address) 751 and then RTU_Loaded (Ada_Tags) 752 and then Cunit_Entity (Current_Sem_Unit) 753 = Body_Entity (RTU_Entity (Ada_Tags)) 754 then 755 Rewrite (N, 756 Unchecked_Convert_To (Rtyp, 757 Make_Integer_Literal (Loc, Uint_0))); 758 else 759 Rewrite (N, 760 Convert_To (Btyp, 761 Make_Function_Call (Loc, 762 Name => New_Occurrence_Of (RTE (Vid), Loc), 763 Parameter_Associations => Args))); 764 end if; 765 766 Analyze_And_Resolve (N, Btyp); 767 end Expand_Value_Attribute; 768 769 --------------------------------- 770 -- Expand_Wide_Image_Attribute -- 771 --------------------------------- 772 773 -- We expand typ'Wide_Image (X) as follows. First we insert this code: 774 775 -- Rnn : Wide_String (1 .. rt'Wide_Width); 776 -- Lnn : Natural; 777 -- String_To_Wide_String 778 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method); 779 780 -- where rt is the root type of the prefix type 781 782 -- Now we replace the Wide_Image reference by 783 784 -- Rnn (1 .. Lnn) 785 786 -- This works in all cases because String_To_Wide_String converts any 787 -- wide character escape sequences resulting from the Image call to the 788 -- proper Wide_Character equivalent 789 790 -- not quite right for typ = Wide_Character ??? 791 792 procedure Expand_Wide_Image_Attribute (N : Node_Id) is 793 Loc : constant Source_Ptr := Sloc (N); 794 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); 795 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); 796 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); 797 798 begin 799 Insert_Actions (N, New_List ( 800 801 -- Rnn : Wide_String (1 .. base_typ'Width); 802 803 Make_Object_Declaration (Loc, 804 Defining_Identifier => Rnn, 805 Object_Definition => 806 Make_Subtype_Indication (Loc, 807 Subtype_Mark => 808 New_Occurrence_Of (Standard_Wide_String, Loc), 809 Constraint => 810 Make_Index_Or_Discriminant_Constraint (Loc, 811 Constraints => New_List ( 812 Make_Range (Loc, 813 Low_Bound => Make_Integer_Literal (Loc, 1), 814 High_Bound => 815 Make_Attribute_Reference (Loc, 816 Prefix => New_Occurrence_Of (Rtyp, Loc), 817 Attribute_Name => Name_Wide_Width)))))), 818 819 -- Lnn : Natural; 820 821 Make_Object_Declaration (Loc, 822 Defining_Identifier => Lnn, 823 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)), 824 825 -- String_To_Wide_String 826 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method); 827 828 Make_Procedure_Call_Statement (Loc, 829 Name => 830 New_Occurrence_Of (RTE (RE_String_To_Wide_String), Loc), 831 832 Parameter_Associations => New_List ( 833 Make_Attribute_Reference (Loc, 834 Prefix => Prefix (N), 835 Attribute_Name => Name_Image, 836 Expressions => Expressions (N)), 837 New_Occurrence_Of (Rnn, Loc), 838 New_Occurrence_Of (Lnn, Loc), 839 Make_Integer_Literal (Loc, 840 Intval => Int (Wide_Character_Encoding_Method))))), 841 842 -- Suppress checks because we know everything is properly in range 843 844 Suppress => All_Checks); 845 846 -- Final step is to rewrite the expression as a slice and analyze, 847 -- again with no checks, since we are sure that everything is OK. 848 849 Rewrite (N, 850 Make_Slice (Loc, 851 Prefix => New_Occurrence_Of (Rnn, Loc), 852 Discrete_Range => 853 Make_Range (Loc, 854 Low_Bound => Make_Integer_Literal (Loc, 1), 855 High_Bound => New_Occurrence_Of (Lnn, Loc)))); 856 857 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks); 858 end Expand_Wide_Image_Attribute; 859 860 -------------------------------------- 861 -- Expand_Wide_Wide_Image_Attribute -- 862 -------------------------------------- 863 864 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code: 865 866 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); 867 -- Lnn : Natural; 868 -- String_To_Wide_Wide_String 869 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method); 870 871 -- where rt is the root type of the prefix type 872 873 -- Now we replace the Wide_Wide_Image reference by 874 875 -- Rnn (1 .. Lnn) 876 877 -- This works in all cases because String_To_Wide_Wide_String converts any 878 -- wide character escape sequences resulting from the Image call to the 879 -- proper Wide_Wide_Character equivalent 880 881 -- not quite right for typ = Wide_Wide_Character ??? 882 883 procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is 884 Loc : constant Source_Ptr := Sloc (N); 885 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); 886 887 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); 888 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); 889 890 begin 891 Insert_Actions (N, New_List ( 892 893 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); 894 895 Make_Object_Declaration (Loc, 896 Defining_Identifier => Rnn, 897 Object_Definition => 898 Make_Subtype_Indication (Loc, 899 Subtype_Mark => 900 New_Occurrence_Of (Standard_Wide_Wide_String, Loc), 901 Constraint => 902 Make_Index_Or_Discriminant_Constraint (Loc, 903 Constraints => New_List ( 904 Make_Range (Loc, 905 Low_Bound => Make_Integer_Literal (Loc, 1), 906 High_Bound => 907 Make_Attribute_Reference (Loc, 908 Prefix => New_Occurrence_Of (Rtyp, Loc), 909 Attribute_Name => Name_Wide_Wide_Width)))))), 910 911 -- Lnn : Natural; 912 913 Make_Object_Declaration (Loc, 914 Defining_Identifier => Lnn, 915 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)), 916 917 -- String_To_Wide_Wide_String 918 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method); 919 920 Make_Procedure_Call_Statement (Loc, 921 Name => 922 New_Occurrence_Of (RTE (RE_String_To_Wide_Wide_String), Loc), 923 924 Parameter_Associations => New_List ( 925 Make_Attribute_Reference (Loc, 926 Prefix => Prefix (N), 927 Attribute_Name => Name_Image, 928 Expressions => Expressions (N)), 929 New_Occurrence_Of (Rnn, Loc), 930 New_Occurrence_Of (Lnn, Loc), 931 Make_Integer_Literal (Loc, 932 Intval => Int (Wide_Character_Encoding_Method))))), 933 934 -- Suppress checks because we know everything is properly in range 935 936 Suppress => All_Checks); 937 938 -- Final step is to rewrite the expression as a slice and analyze, 939 -- again with no checks, since we are sure that everything is OK. 940 941 Rewrite (N, 942 Make_Slice (Loc, 943 Prefix => New_Occurrence_Of (Rnn, Loc), 944 Discrete_Range => 945 Make_Range (Loc, 946 Low_Bound => Make_Integer_Literal (Loc, 1), 947 High_Bound => New_Occurrence_Of (Lnn, Loc)))); 948 949 Analyze_And_Resolve 950 (N, Standard_Wide_Wide_String, Suppress => All_Checks); 951 end Expand_Wide_Wide_Image_Attribute; 952 953 ---------------------------- 954 -- Expand_Width_Attribute -- 955 ---------------------------- 956 957 -- The processing here also handles the case of Wide_[Wide_]Width. With the 958 -- exceptions noted, the processing is identical 959 960 -- For scalar types derived from Boolean, character and integer types 961 -- in package Standard. Note that the Width attribute is computed at 962 -- compile time for all cases except those involving non-static sub- 963 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into: 964 965 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last))) 966 967 -- where 968 969 -- For types whose root type is Character 970 -- xx = Width_Character 971 -- yy = Character 972 973 -- For types whose root type is Wide_Character 974 -- xx = Wide_Width_Character 975 -- yy = Character 976 977 -- For types whose root type is Wide_Wide_Character 978 -- xx = Wide_Wide_Width_Character 979 -- yy = Character 980 981 -- For types whose root type is Boolean 982 -- xx = Width_Boolean 983 -- yy = Boolean 984 985 -- For signed integer types 986 -- xx = Width_Long_Long_Integer 987 -- yy = Long_Long_Integer 988 989 -- For modular integer types 990 -- xx = Width_Long_Long_Unsigned 991 -- yy = Long_Long_Unsigned 992 993 -- For types derived from Wide_Character, typ'Width expands into 994 995 -- Result_Type (Width_Wide_Character ( 996 -- Wide_Character (typ'First), 997 -- Wide_Character (typ'Last), 998 999 -- and typ'Wide_Width expands into: 1000 1001 -- Result_Type (Wide_Width_Wide_Character ( 1002 -- Wide_Character (typ'First), 1003 -- Wide_Character (typ'Last)); 1004 1005 -- and typ'Wide_Wide_Width expands into 1006 1007 -- Result_Type (Wide_Wide_Width_Wide_Character ( 1008 -- Wide_Character (typ'First), 1009 -- Wide_Character (typ'Last)); 1010 1011 -- For types derived from Wide_Wide_Character, typ'Width expands into 1012 1013 -- Result_Type (Width_Wide_Wide_Character ( 1014 -- Wide_Wide_Character (typ'First), 1015 -- Wide_Wide_Character (typ'Last), 1016 1017 -- and typ'Wide_Width expands into: 1018 1019 -- Result_Type (Wide_Width_Wide_Wide_Character ( 1020 -- Wide_Wide_Character (typ'First), 1021 -- Wide_Wide_Character (typ'Last)); 1022 1023 -- and typ'Wide_Wide_Width expands into 1024 1025 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char ( 1026 -- Wide_Wide_Character (typ'First), 1027 -- Wide_Wide_Character (typ'Last)); 1028 1029 -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into 1030 1031 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if 1032 1033 -- where btyp is the base type. This looks recursive but it isn't 1034 -- because the base type is always static, and hence the expression 1035 -- in the else is reduced to an integer literal. 1036 1037 -- For user defined enumeration types, typ'Width expands into 1038 1039 -- Result_Type (Width_Enumeration_NN 1040 -- (typS, 1041 -- typI'Address, 1042 -- typ'Pos (typ'First), 1043 -- typ'Pos (Typ'Last))); 1044 1045 -- and typ'Wide_Width expands into: 1046 1047 -- Result_Type (Wide_Width_Enumeration_NN 1048 -- (typS, 1049 -- typI, 1050 -- typ'Pos (typ'First), 1051 -- typ'Pos (Typ'Last)) 1052 -- Wide_Character_Encoding_Method); 1053 1054 -- and typ'Wide_Wide_Width expands into: 1055 1056 -- Result_Type (Wide_Wide_Width_Enumeration_NN 1057 -- (typS, 1058 -- typI, 1059 -- typ'Pos (typ'First), 1060 -- typ'Pos (Typ'Last)) 1061 -- Wide_Character_Encoding_Method); 1062 1063 -- where typS and typI are the enumeration image strings and indexes 1064 -- table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32 1065 -- for depending on the element type for typI. 1066 1067 -- Finally if Discard_Names is in effect for an enumeration type, then 1068 -- a special if expression is built that yields the space needed for the 1069 -- decimal representation of the largest pos value in the subtype. See 1070 -- code below for details. 1071 1072 procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is 1073 Loc : constant Source_Ptr := Sloc (N); 1074 Typ : constant Entity_Id := Etype (N); 1075 Pref : constant Node_Id := Prefix (N); 1076 Ptyp : constant Entity_Id := Etype (Pref); 1077 Rtyp : constant Entity_Id := Root_Type (Ptyp); 1078 Arglist : List_Id; 1079 Ttyp : Entity_Id; 1080 XX : RE_Id; 1081 YY : Entity_Id; 1082 1083 begin 1084 -- Types derived from Standard.Boolean 1085 1086 if Rtyp = Standard_Boolean then 1087 XX := RE_Width_Boolean; 1088 YY := Rtyp; 1089 1090 -- Types derived from Standard.Character 1091 1092 elsif Rtyp = Standard_Character then 1093 case Attr is 1094 when Normal => XX := RE_Width_Character; 1095 when Wide => XX := RE_Wide_Width_Character; 1096 when Wide_Wide => XX := RE_Wide_Wide_Width_Character; 1097 end case; 1098 1099 YY := Rtyp; 1100 1101 -- Types derived from Standard.Wide_Character 1102 1103 elsif Rtyp = Standard_Wide_Character then 1104 case Attr is 1105 when Normal => XX := RE_Width_Wide_Character; 1106 when Wide => XX := RE_Wide_Width_Wide_Character; 1107 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character; 1108 end case; 1109 1110 YY := Rtyp; 1111 1112 -- Types derived from Standard.Wide_Wide_Character 1113 1114 elsif Rtyp = Standard_Wide_Wide_Character then 1115 case Attr is 1116 when Normal => XX := RE_Width_Wide_Wide_Character; 1117 when Wide => XX := RE_Wide_Width_Wide_Wide_Character; 1118 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char; 1119 end case; 1120 1121 YY := Rtyp; 1122 1123 -- Signed integer types 1124 1125 elsif Is_Signed_Integer_Type (Rtyp) then 1126 XX := RE_Width_Long_Long_Integer; 1127 YY := Standard_Long_Long_Integer; 1128 1129 -- Modular integer types 1130 1131 elsif Is_Modular_Integer_Type (Rtyp) then 1132 XX := RE_Width_Long_Long_Unsigned; 1133 YY := RTE (RE_Long_Long_Unsigned); 1134 1135 -- Real types 1136 1137 elsif Is_Real_Type (Rtyp) then 1138 Rewrite (N, 1139 Make_If_Expression (Loc, 1140 Expressions => New_List ( 1141 1142 Make_Op_Gt (Loc, 1143 Left_Opnd => 1144 Make_Attribute_Reference (Loc, 1145 Prefix => New_Occurrence_Of (Ptyp, Loc), 1146 Attribute_Name => Name_First), 1147 1148 Right_Opnd => 1149 Make_Attribute_Reference (Loc, 1150 Prefix => New_Occurrence_Of (Ptyp, Loc), 1151 Attribute_Name => Name_Last)), 1152 1153 Make_Integer_Literal (Loc, 0), 1154 1155 Make_Attribute_Reference (Loc, 1156 Prefix => New_Occurrence_Of (Base_Type (Ptyp), Loc), 1157 Attribute_Name => Name_Width)))); 1158 1159 Analyze_And_Resolve (N, Typ); 1160 return; 1161 1162 -- User defined enumeration types 1163 1164 else 1165 pragma Assert (Is_Enumeration_Type (Rtyp)); 1166 1167 -- Whenever pragma Discard_Names is in effect, the value we need 1168 -- is the value needed to accomodate the largest integer pos value 1169 -- in the range of the subtype + 1 for the space at the start. We 1170 -- build: 1171 1172 -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last) 1173 1174 -- and replace the expression by 1175 1176 -- (if Ptyp'Range_Length = 0 then 0 1177 -- else (if Tnn < 10 then 2 1178 -- else (if Tnn < 100 then 3 1179 -- ... 1180 -- else n)))... 1181 1182 -- where n is equal to Rtyp'Pos (Ptyp'Last) + 1 1183 1184 -- Note: The above processing is in accordance with the intent of 1185 -- the RM, which is that Width should be related to the impl-defined 1186 -- behavior of Image. It is not clear what this means if Image is 1187 -- not defined (as in the configurable run-time case for GNAT) and 1188 -- gives an error at compile time. 1189 1190 -- We choose in this case to just go ahead and implement Width the 1191 -- same way, returning what Image would have returned if it has been 1192 -- available in the configurable run-time library. 1193 1194 if Discard_Names (Rtyp) then 1195 declare 1196 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T'); 1197 Cexpr : Node_Id; 1198 P : Int; 1199 M : Int; 1200 K : Int; 1201 1202 begin 1203 Insert_Action (N, 1204 Make_Object_Declaration (Loc, 1205 Defining_Identifier => Tnn, 1206 Constant_Present => True, 1207 Object_Definition => 1208 New_Occurrence_Of (Standard_Integer, Loc), 1209 Expression => 1210 Make_Attribute_Reference (Loc, 1211 Prefix => New_Occurrence_Of (Rtyp, Loc), 1212 Attribute_Name => Name_Pos, 1213 Expressions => New_List ( 1214 Convert_To (Rtyp, 1215 Make_Attribute_Reference (Loc, 1216 Prefix => New_Occurrence_Of (Ptyp, Loc), 1217 Attribute_Name => Name_Last)))))); 1218 1219 -- OK, now we need to build the if expression. First get the 1220 -- value of M, the largest possible value needed. 1221 1222 P := UI_To_Int 1223 (Enumeration_Pos (Entity (Type_High_Bound (Rtyp)))); 1224 1225 K := 1; 1226 M := 1; 1227 while M < P loop 1228 M := M * 10; 1229 K := K + 1; 1230 end loop; 1231 1232 -- Build inner else 1233 1234 Cexpr := Make_Integer_Literal (Loc, K); 1235 1236 -- Wrap in inner if's until counted down to 2 1237 1238 while K > 2 loop 1239 M := M / 10; 1240 K := K - 1; 1241 1242 Cexpr := 1243 Make_If_Expression (Loc, 1244 Expressions => New_List ( 1245 Make_Op_Lt (Loc, 1246 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 1247 Right_Opnd => Make_Integer_Literal (Loc, M)), 1248 Make_Integer_Literal (Loc, K), 1249 Cexpr)); 1250 end loop; 1251 1252 -- Add initial comparison for null range and we are done, so 1253 -- rewrite the attribute occurrence with this expression. 1254 1255 Rewrite (N, 1256 Convert_To (Typ, 1257 Make_If_Expression (Loc, 1258 Expressions => New_List ( 1259 Make_Op_Eq (Loc, 1260 Left_Opnd => 1261 Make_Attribute_Reference (Loc, 1262 Prefix => New_Occurrence_Of (Ptyp, Loc), 1263 Attribute_Name => Name_Range_Length), 1264 Right_Opnd => Make_Integer_Literal (Loc, 0)), 1265 Make_Integer_Literal (Loc, 0), 1266 Cexpr)))); 1267 1268 Analyze_And_Resolve (N, Typ); 1269 return; 1270 end; 1271 end if; 1272 1273 -- Normal case, not Discard_Names 1274 1275 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); 1276 1277 case Attr is 1278 when Normal => 1279 if Ttyp = Standard_Integer_8 then 1280 XX := RE_Width_Enumeration_8; 1281 elsif Ttyp = Standard_Integer_16 then 1282 XX := RE_Width_Enumeration_16; 1283 else 1284 XX := RE_Width_Enumeration_32; 1285 end if; 1286 1287 when Wide => 1288 if Ttyp = Standard_Integer_8 then 1289 XX := RE_Wide_Width_Enumeration_8; 1290 elsif Ttyp = Standard_Integer_16 then 1291 XX := RE_Wide_Width_Enumeration_16; 1292 else 1293 XX := RE_Wide_Width_Enumeration_32; 1294 end if; 1295 1296 when Wide_Wide => 1297 if Ttyp = Standard_Integer_8 then 1298 XX := RE_Wide_Wide_Width_Enumeration_8; 1299 elsif Ttyp = Standard_Integer_16 then 1300 XX := RE_Wide_Wide_Width_Enumeration_16; 1301 else 1302 XX := RE_Wide_Wide_Width_Enumeration_32; 1303 end if; 1304 end case; 1305 1306 Arglist := 1307 New_List ( 1308 New_Occurrence_Of (Lit_Strings (Rtyp), Loc), 1309 1310 Make_Attribute_Reference (Loc, 1311 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), 1312 Attribute_Name => Name_Address), 1313 1314 Make_Attribute_Reference (Loc, 1315 Prefix => New_Occurrence_Of (Ptyp, Loc), 1316 Attribute_Name => Name_Pos, 1317 1318 Expressions => New_List ( 1319 Make_Attribute_Reference (Loc, 1320 Prefix => New_Occurrence_Of (Ptyp, Loc), 1321 Attribute_Name => Name_First))), 1322 1323 Make_Attribute_Reference (Loc, 1324 Prefix => New_Occurrence_Of (Ptyp, Loc), 1325 Attribute_Name => Name_Pos, 1326 1327 Expressions => New_List ( 1328 Make_Attribute_Reference (Loc, 1329 Prefix => New_Occurrence_Of (Ptyp, Loc), 1330 Attribute_Name => Name_Last)))); 1331 1332 Rewrite (N, 1333 Convert_To (Typ, 1334 Make_Function_Call (Loc, 1335 Name => New_Occurrence_Of (RTE (XX), Loc), 1336 Parameter_Associations => Arglist))); 1337 1338 Analyze_And_Resolve (N, Typ); 1339 return; 1340 end if; 1341 1342 -- If we fall through XX and YY are set 1343 1344 Arglist := New_List ( 1345 Convert_To (YY, 1346 Make_Attribute_Reference (Loc, 1347 Prefix => New_Occurrence_Of (Ptyp, Loc), 1348 Attribute_Name => Name_First)), 1349 1350 Convert_To (YY, 1351 Make_Attribute_Reference (Loc, 1352 Prefix => New_Occurrence_Of (Ptyp, Loc), 1353 Attribute_Name => Name_Last))); 1354 1355 Rewrite (N, 1356 Convert_To (Typ, 1357 Make_Function_Call (Loc, 1358 Name => New_Occurrence_Of (RTE (XX), Loc), 1359 Parameter_Associations => Arglist))); 1360 1361 Analyze_And_Resolve (N, Typ); 1362 end Expand_Width_Attribute; 1363 1364 ----------------------- 1365 -- Has_Decimal_Small -- 1366 ----------------------- 1367 1368 function Has_Decimal_Small (E : Entity_Id) return Boolean is 1369 begin 1370 return Is_Decimal_Fixed_Point_Type (E) 1371 or else 1372 (Is_Ordinary_Fixed_Point_Type (E) 1373 and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); 1374 end Has_Decimal_Small; 1375 1376end Exp_Imgv; 1377