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-2012, 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 (ugly!) 314 315 elsif Rtyp = Standard_Character then 316 if Ada_Version < Ada_2005 then 317 Imid := RE_Image_Character; 318 else 319 Imid := RE_Image_Character_05; 320 end if; 321 322 Tent := Rtyp; 323 324 elsif Rtyp = Standard_Wide_Character then 325 Imid := RE_Image_Wide_Character; 326 Tent := Rtyp; 327 328 elsif Rtyp = Standard_Wide_Wide_Character then 329 Imid := RE_Image_Wide_Wide_Character; 330 Tent := Rtyp; 331 332 elsif Is_Signed_Integer_Type (Rtyp) then 333 if Esize (Rtyp) <= Esize (Standard_Integer) then 334 Imid := RE_Image_Integer; 335 Tent := Standard_Integer; 336 else 337 Imid := RE_Image_Long_Long_Integer; 338 Tent := Standard_Long_Long_Integer; 339 end if; 340 341 elsif Is_Modular_Integer_Type (Rtyp) then 342 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then 343 Imid := RE_Image_Unsigned; 344 Tent := RTE (RE_Unsigned); 345 else 346 Imid := RE_Image_Long_Long_Unsigned; 347 Tent := RTE (RE_Long_Long_Unsigned); 348 end if; 349 350 elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then 351 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 352 Imid := RE_Image_Decimal; 353 Tent := Standard_Integer; 354 else 355 Imid := RE_Image_Long_Long_Decimal; 356 Tent := Standard_Long_Long_Integer; 357 end if; 358 359 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then 360 Imid := RE_Image_Ordinary_Fixed_Point; 361 Tent := Standard_Long_Long_Float; 362 363 elsif Is_Floating_Point_Type (Rtyp) then 364 Imid := RE_Image_Floating_Point; 365 Tent := Standard_Long_Long_Float; 366 367 -- Only other possibility is user defined enumeration type 368 369 else 370 if Discard_Names (First_Subtype (Ptyp)) 371 or else No (Lit_Strings (Root_Type (Ptyp))) 372 then 373 -- When pragma Discard_Names applies to the first subtype, build 374 -- (Pref'Pos (Expr))'Img. 375 376 Rewrite (N, 377 Make_Attribute_Reference (Loc, 378 Prefix => 379 Make_Attribute_Reference (Loc, 380 Prefix => Pref, 381 Attribute_Name => Name_Pos, 382 Expressions => New_List (Expr)), 383 Attribute_Name => 384 Name_Img)); 385 Analyze_And_Resolve (N, Standard_String); 386 return; 387 388 else 389 -- Here for enumeration type case 390 391 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); 392 393 if Ttyp = Standard_Integer_8 then 394 Imid := RE_Image_Enumeration_8; 395 396 elsif Ttyp = Standard_Integer_16 then 397 Imid := RE_Image_Enumeration_16; 398 399 else 400 Imid := RE_Image_Enumeration_32; 401 end if; 402 403 -- Apply a validity check, since it is a bit drastic to get a 404 -- completely junk image value for an invalid value. 405 406 if not Expr_Known_Valid (Expr) then 407 Insert_Valid_Check (Expr); 408 end if; 409 410 Enum_Case := True; 411 end if; 412 end if; 413 414 -- Build first argument for call 415 416 if Enum_Case then 417 Arg_List := New_List ( 418 Make_Attribute_Reference (Loc, 419 Attribute_Name => Name_Pos, 420 Prefix => New_Occurrence_Of (Ptyp, Loc), 421 Expressions => New_List (Expr))); 422 423 else 424 Arg_List := New_List (Convert_To (Tent, Expr)); 425 end if; 426 427 -- Append Snn, Pnn arguments 428 429 Append_To (Arg_List, New_Occurrence_Of (Snn, Loc)); 430 Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc)); 431 432 -- Get entity of procedure to call 433 434 Proc_Ent := RTE (Imid); 435 436 -- If the procedure entity is empty, that means we have a case in 437 -- no run time mode where the operation is not allowed, and an 438 -- appropriate diagnostic has already been issued. 439 440 if No (Proc_Ent) then 441 return; 442 end if; 443 444 -- Otherwise complete preparation of arguments for run-time call 445 446 -- Add extra arguments for Enumeration case 447 448 if Enum_Case then 449 Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); 450 Append_To (Arg_List, 451 Make_Attribute_Reference (Loc, 452 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), 453 Attribute_Name => Name_Address)); 454 455 -- For floating-point types, append Digits argument 456 457 elsif Is_Floating_Point_Type (Rtyp) then 458 Append_To (Arg_List, 459 Make_Attribute_Reference (Loc, 460 Prefix => New_Reference_To (Ptyp, Loc), 461 Attribute_Name => Name_Digits)); 462 463 -- For ordinary fixed-point types, append Aft parameter 464 465 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then 466 Append_To (Arg_List, 467 Make_Attribute_Reference (Loc, 468 Prefix => New_Reference_To (Ptyp, Loc), 469 Attribute_Name => Name_Aft)); 470 471 if Has_Decimal_Small (Rtyp) then 472 Set_Conversion_OK (First (Arg_List)); 473 Set_Etype (First (Arg_List), Tent); 474 end if; 475 476 -- For decimal, append Scale and also set to do literal conversion 477 478 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then 479 Append_To (Arg_List, 480 Make_Attribute_Reference (Loc, 481 Prefix => New_Reference_To (Ptyp, Loc), 482 Attribute_Name => Name_Scale)); 483 484 Set_Conversion_OK (First (Arg_List)); 485 Set_Etype (First (Arg_List), Tent); 486 487 -- For Wide_Character, append Ada 2005 indication 488 489 elsif Rtyp = Standard_Wide_Character then 490 Append_To (Arg_List, 491 New_Reference_To (Boolean_Literals (Ada_Version >= Ada_2005), Loc)); 492 end if; 493 494 -- Now append the procedure call to the insert list 495 496 Append_To (Ins_List, 497 Make_Procedure_Call_Statement (Loc, 498 Name => New_Reference_To (Proc_Ent, Loc), 499 Parameter_Associations => Arg_List)); 500 501 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress 502 -- checks because we are sure that everything is in range at this stage. 503 504 Insert_Actions (N, Ins_List, Suppress => All_Checks); 505 506 -- Final step is to rewrite the expression as a slice and analyze, 507 -- again with no checks, since we are sure that everything is OK. 508 509 Rewrite (N, 510 Make_Slice (Loc, 511 Prefix => New_Occurrence_Of (Snn, Loc), 512 Discrete_Range => 513 Make_Range (Loc, 514 Low_Bound => Make_Integer_Literal (Loc, 1), 515 High_Bound => New_Occurrence_Of (Pnn, Loc)))); 516 517 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks); 518 end Expand_Image_Attribute; 519 520 ---------------------------- 521 -- Expand_Value_Attribute -- 522 ---------------------------- 523 524 -- For scalar types derived from Boolean, Character and integer types 525 -- in package Standard, typ'Value (X) expands into: 526 527 -- btyp (Value_xx (X)) 528 529 -- where btyp is he base type of the prefix 530 531 -- For types whose root type is Character 532 -- xx = Character 533 534 -- For types whose root type is Wide_Character 535 -- xx = Wide_Character 536 537 -- For types whose root type is Wide_Wide_Character 538 -- xx = Wide_Wide_Character 539 540 -- For types whose root type is Boolean 541 -- xx = Boolean 542 543 -- For signed integer types with size <= Integer'Size 544 -- xx = Integer 545 546 -- For other signed integer types 547 -- xx = Long_Long_Integer 548 549 -- For modular types with modulus <= System.Unsigned_Types.Unsigned 550 -- xx = Unsigned 551 552 -- For other modular integer types 553 -- xx = Long_Long_Unsigned 554 555 -- For floating-point types and ordinary fixed-point types 556 -- xx = Real 557 558 -- For Wide_[Wide_]Character types, typ'Value (X) expands into: 559 560 -- btyp (Value_xx (X, EM)) 561 562 -- where btyp is the base type of the prefix, and EM is the encoding method 563 564 -- For decimal types with size <= Integer'Size, typ'Value (X) 565 -- expands into 566 567 -- btyp?(Value_Decimal (X, typ'Scale)); 568 569 -- For all other decimal types, typ'Value (X) expands into 570 571 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale)) 572 573 -- For enumeration types other than those derived from types Boolean, 574 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to: 575 576 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) 577 578 -- where typS and typI and the Lit_Strings and Lit_Indexes entities 579 -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The 580 -- Value_Enumeration_NN function will search the tables looking for 581 -- X and return the position number in the table if found which is 582 -- used to provide the result of 'Value (using Enum'Val). If the 583 -- value is not found Constraint_Error is raised. The suffix _NN 584 -- depends on the element type of typI. 585 586 procedure Expand_Value_Attribute (N : Node_Id) is 587 Loc : constant Source_Ptr := Sloc (N); 588 Typ : constant Entity_Id := Etype (N); 589 Btyp : constant Entity_Id := Base_Type (Typ); 590 Rtyp : constant Entity_Id := Root_Type (Typ); 591 Exprs : constant List_Id := Expressions (N); 592 Vid : RE_Id; 593 Args : List_Id; 594 Func : RE_Id; 595 Ttyp : Entity_Id; 596 597 begin 598 Args := Exprs; 599 600 if Rtyp = Standard_Character then 601 Vid := RE_Value_Character; 602 603 elsif Rtyp = Standard_Boolean then 604 Vid := RE_Value_Boolean; 605 606 elsif Rtyp = Standard_Wide_Character then 607 Vid := RE_Value_Wide_Character; 608 609 Append_To (Args, 610 Make_Integer_Literal (Loc, 611 Intval => Int (Wide_Character_Encoding_Method))); 612 613 elsif Rtyp = Standard_Wide_Wide_Character then 614 Vid := RE_Value_Wide_Wide_Character; 615 616 Append_To (Args, 617 Make_Integer_Literal (Loc, 618 Intval => Int (Wide_Character_Encoding_Method))); 619 620 elsif Rtyp = Base_Type (Standard_Short_Short_Integer) 621 or else Rtyp = Base_Type (Standard_Short_Integer) 622 or else Rtyp = Base_Type (Standard_Integer) 623 then 624 Vid := RE_Value_Integer; 625 626 elsif Is_Signed_Integer_Type (Rtyp) then 627 Vid := RE_Value_Long_Long_Integer; 628 629 elsif Is_Modular_Integer_Type (Rtyp) then 630 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then 631 Vid := RE_Value_Unsigned; 632 else 633 Vid := RE_Value_Long_Long_Unsigned; 634 end if; 635 636 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then 637 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 638 Vid := RE_Value_Decimal; 639 else 640 Vid := RE_Value_Long_Long_Decimal; 641 end if; 642 643 Append_To (Args, 644 Make_Attribute_Reference (Loc, 645 Prefix => New_Reference_To (Typ, Loc), 646 Attribute_Name => Name_Scale)); 647 648 Rewrite (N, 649 OK_Convert_To (Btyp, 650 Make_Function_Call (Loc, 651 Name => New_Reference_To (RTE (Vid), Loc), 652 Parameter_Associations => Args))); 653 654 Set_Etype (N, Btyp); 655 Analyze_And_Resolve (N, Btyp); 656 return; 657 658 elsif Is_Real_Type (Rtyp) then 659 Vid := RE_Value_Real; 660 661 -- Only other possibility is user defined enumeration type 662 663 else 664 pragma Assert (Is_Enumeration_Type (Rtyp)); 665 666 -- Case of pragma Discard_Names, transform the Value 667 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args)) 668 669 if Discard_Names (First_Subtype (Typ)) 670 or else No (Lit_Strings (Rtyp)) 671 then 672 Rewrite (N, 673 Make_Attribute_Reference (Loc, 674 Prefix => New_Reference_To (Btyp, Loc), 675 Attribute_Name => Name_Val, 676 Expressions => New_List ( 677 Make_Attribute_Reference (Loc, 678 Prefix => 679 New_Occurrence_Of (Standard_Long_Long_Integer, Loc), 680 Attribute_Name => Name_Value, 681 Expressions => Args)))); 682 683 Analyze_And_Resolve (N, Btyp); 684 685 -- Here for normal case where we have enumeration tables, this 686 -- is where we build 687 688 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) 689 690 else 691 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); 692 693 if Ttyp = Standard_Integer_8 then 694 Func := RE_Value_Enumeration_8; 695 elsif Ttyp = Standard_Integer_16 then 696 Func := RE_Value_Enumeration_16; 697 else 698 Func := RE_Value_Enumeration_32; 699 end if; 700 701 Prepend_To (Args, 702 Make_Attribute_Reference (Loc, 703 Prefix => New_Occurrence_Of (Rtyp, Loc), 704 Attribute_Name => Name_Pos, 705 Expressions => New_List ( 706 Make_Attribute_Reference (Loc, 707 Prefix => New_Occurrence_Of (Rtyp, Loc), 708 Attribute_Name => Name_Last)))); 709 710 Prepend_To (Args, 711 Make_Attribute_Reference (Loc, 712 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), 713 Attribute_Name => Name_Address)); 714 715 Prepend_To (Args, 716 New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); 717 718 Rewrite (N, 719 Make_Attribute_Reference (Loc, 720 Prefix => New_Reference_To (Typ, Loc), 721 Attribute_Name => Name_Val, 722 Expressions => New_List ( 723 Make_Function_Call (Loc, 724 Name => 725 New_Reference_To (RTE (Func), Loc), 726 Parameter_Associations => Args)))); 727 728 Analyze_And_Resolve (N, Btyp); 729 end if; 730 731 return; 732 end if; 733 734 -- Fall through for all cases except user defined enumeration type 735 -- and decimal types, with Vid set to the Id of the entity for the 736 -- Value routine and Args set to the list of parameters for the call. 737 738 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the 739 -- expansion of the attribute into the function call statement to avoid 740 -- generating spurious errors caused by the use of Integer_Address'Value 741 -- in our implementation of Ada.Tags.Internal_Tag 742 743 -- Seems like a bit of a kludge, there should be a better way ??? 744 745 -- There is a better way, you should also test RTE_Available ??? 746 747 if No_Run_Time_Mode 748 and then Rtyp = RTE (RE_Integer_Address) 749 and then RTU_Loaded (Ada_Tags) 750 and then Cunit_Entity (Current_Sem_Unit) 751 = Body_Entity (RTU_Entity (Ada_Tags)) 752 then 753 Rewrite (N, 754 Unchecked_Convert_To (Rtyp, 755 Make_Integer_Literal (Loc, Uint_0))); 756 else 757 Rewrite (N, 758 Convert_To (Btyp, 759 Make_Function_Call (Loc, 760 Name => New_Reference_To (RTE (Vid), Loc), 761 Parameter_Associations => Args))); 762 end if; 763 764 Analyze_And_Resolve (N, Btyp); 765 end Expand_Value_Attribute; 766 767 --------------------------------- 768 -- Expand_Wide_Image_Attribute -- 769 --------------------------------- 770 771 -- We expand typ'Wide_Image (X) as follows. First we insert this code: 772 773 -- Rnn : Wide_String (1 .. rt'Wide_Width); 774 -- Lnn : Natural; 775 -- String_To_Wide_String 776 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method); 777 778 -- where rt is the root type of the prefix type 779 780 -- Now we replace the Wide_Image reference by 781 782 -- Rnn (1 .. Lnn) 783 784 -- This works in all cases because String_To_Wide_String converts any 785 -- wide character escape sequences resulting from the Image call to the 786 -- proper Wide_Character equivalent 787 788 -- not quite right for typ = Wide_Character ??? 789 790 procedure Expand_Wide_Image_Attribute (N : Node_Id) is 791 Loc : constant Source_Ptr := Sloc (N); 792 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); 793 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); 794 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); 795 796 begin 797 Insert_Actions (N, New_List ( 798 799 -- Rnn : Wide_String (1 .. base_typ'Width); 800 801 Make_Object_Declaration (Loc, 802 Defining_Identifier => Rnn, 803 Object_Definition => 804 Make_Subtype_Indication (Loc, 805 Subtype_Mark => 806 New_Occurrence_Of (Standard_Wide_String, Loc), 807 Constraint => 808 Make_Index_Or_Discriminant_Constraint (Loc, 809 Constraints => New_List ( 810 Make_Range (Loc, 811 Low_Bound => Make_Integer_Literal (Loc, 1), 812 High_Bound => 813 Make_Attribute_Reference (Loc, 814 Prefix => New_Occurrence_Of (Rtyp, Loc), 815 Attribute_Name => Name_Wide_Width)))))), 816 817 -- Lnn : Natural; 818 819 Make_Object_Declaration (Loc, 820 Defining_Identifier => Lnn, 821 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)), 822 823 -- String_To_Wide_String 824 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method); 825 826 Make_Procedure_Call_Statement (Loc, 827 Name => 828 New_Reference_To (RTE (RE_String_To_Wide_String), Loc), 829 830 Parameter_Associations => New_List ( 831 Make_Attribute_Reference (Loc, 832 Prefix => Prefix (N), 833 Attribute_Name => Name_Image, 834 Expressions => Expressions (N)), 835 New_Reference_To (Rnn, Loc), 836 New_Reference_To (Lnn, Loc), 837 Make_Integer_Literal (Loc, 838 Intval => Int (Wide_Character_Encoding_Method))))), 839 840 -- Suppress checks because we know everything is properly in range 841 842 Suppress => All_Checks); 843 844 -- Final step is to rewrite the expression as a slice and analyze, 845 -- again with no checks, since we are sure that everything is OK. 846 847 Rewrite (N, 848 Make_Slice (Loc, 849 Prefix => New_Occurrence_Of (Rnn, Loc), 850 Discrete_Range => 851 Make_Range (Loc, 852 Low_Bound => Make_Integer_Literal (Loc, 1), 853 High_Bound => New_Occurrence_Of (Lnn, Loc)))); 854 855 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks); 856 end Expand_Wide_Image_Attribute; 857 858 -------------------------------------- 859 -- Expand_Wide_Wide_Image_Attribute -- 860 -------------------------------------- 861 862 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code: 863 864 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); 865 -- Lnn : Natural; 866 -- String_To_Wide_Wide_String 867 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method); 868 869 -- where rt is the root type of the prefix type 870 871 -- Now we replace the Wide_Wide_Image reference by 872 873 -- Rnn (1 .. Lnn) 874 875 -- This works in all cases because String_To_Wide_Wide_String converts any 876 -- wide character escape sequences resulting from the Image call to the 877 -- proper Wide_Wide_Character equivalent 878 879 -- not quite right for typ = Wide_Wide_Character ??? 880 881 procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is 882 Loc : constant Source_Ptr := Sloc (N); 883 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); 884 885 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); 886 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); 887 888 begin 889 Insert_Actions (N, New_List ( 890 891 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); 892 893 Make_Object_Declaration (Loc, 894 Defining_Identifier => Rnn, 895 Object_Definition => 896 Make_Subtype_Indication (Loc, 897 Subtype_Mark => 898 New_Occurrence_Of (Standard_Wide_Wide_String, Loc), 899 Constraint => 900 Make_Index_Or_Discriminant_Constraint (Loc, 901 Constraints => New_List ( 902 Make_Range (Loc, 903 Low_Bound => Make_Integer_Literal (Loc, 1), 904 High_Bound => 905 Make_Attribute_Reference (Loc, 906 Prefix => New_Occurrence_Of (Rtyp, Loc), 907 Attribute_Name => Name_Wide_Wide_Width)))))), 908 909 -- Lnn : Natural; 910 911 Make_Object_Declaration (Loc, 912 Defining_Identifier => Lnn, 913 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)), 914 915 -- String_To_Wide_Wide_String 916 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method); 917 918 Make_Procedure_Call_Statement (Loc, 919 Name => 920 New_Reference_To (RTE (RE_String_To_Wide_Wide_String), Loc), 921 922 Parameter_Associations => New_List ( 923 Make_Attribute_Reference (Loc, 924 Prefix => Prefix (N), 925 Attribute_Name => Name_Image, 926 Expressions => Expressions (N)), 927 New_Reference_To (Rnn, Loc), 928 New_Reference_To (Lnn, Loc), 929 Make_Integer_Literal (Loc, 930 Intval => Int (Wide_Character_Encoding_Method))))), 931 932 -- Suppress checks because we know everything is properly in range 933 934 Suppress => All_Checks); 935 936 -- Final step is to rewrite the expression as a slice and analyze, 937 -- again with no checks, since we are sure that everything is OK. 938 939 Rewrite (N, 940 Make_Slice (Loc, 941 Prefix => New_Occurrence_Of (Rnn, Loc), 942 Discrete_Range => 943 Make_Range (Loc, 944 Low_Bound => Make_Integer_Literal (Loc, 1), 945 High_Bound => New_Occurrence_Of (Lnn, Loc)))); 946 947 Analyze_And_Resolve 948 (N, Standard_Wide_Wide_String, Suppress => All_Checks); 949 end Expand_Wide_Wide_Image_Attribute; 950 951 ---------------------------- 952 -- Expand_Width_Attribute -- 953 ---------------------------- 954 955 -- The processing here also handles the case of Wide_[Wide_]Width. With the 956 -- exceptions noted, the processing is identical 957 958 -- For scalar types derived from Boolean, character and integer types 959 -- in package Standard. Note that the Width attribute is computed at 960 -- compile time for all cases except those involving non-static sub- 961 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into: 962 963 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last))) 964 965 -- where 966 967 -- For types whose root type is Character 968 -- xx = Width_Character 969 -- yy = Character 970 971 -- For types whose root type is Wide_Character 972 -- xx = Wide_Width_Character 973 -- yy = Character 974 975 -- For types whose root type is Wide_Wide_Character 976 -- xx = Wide_Wide_Width_Character 977 -- yy = Character 978 979 -- For types whose root type is Boolean 980 -- xx = Width_Boolean 981 -- yy = Boolean 982 983 -- For signed integer types 984 -- xx = Width_Long_Long_Integer 985 -- yy = Long_Long_Integer 986 987 -- For modular integer types 988 -- xx = Width_Long_Long_Unsigned 989 -- yy = Long_Long_Unsigned 990 991 -- For types derived from Wide_Character, typ'Width expands into 992 993 -- Result_Type (Width_Wide_Character ( 994 -- Wide_Character (typ'First), 995 -- Wide_Character (typ'Last), 996 997 -- and typ'Wide_Width expands into: 998 999 -- Result_Type (Wide_Width_Wide_Character ( 1000 -- Wide_Character (typ'First), 1001 -- Wide_Character (typ'Last)); 1002 1003 -- and typ'Wide_Wide_Width expands into 1004 1005 -- Result_Type (Wide_Wide_Width_Wide_Character ( 1006 -- Wide_Character (typ'First), 1007 -- Wide_Character (typ'Last)); 1008 1009 -- For types derived from Wide_Wide_Character, typ'Width expands into 1010 1011 -- Result_Type (Width_Wide_Wide_Character ( 1012 -- Wide_Wide_Character (typ'First), 1013 -- Wide_Wide_Character (typ'Last), 1014 1015 -- and typ'Wide_Width expands into: 1016 1017 -- Result_Type (Wide_Width_Wide_Wide_Character ( 1018 -- Wide_Wide_Character (typ'First), 1019 -- Wide_Wide_Character (typ'Last)); 1020 1021 -- and typ'Wide_Wide_Width expands into 1022 1023 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char ( 1024 -- Wide_Wide_Character (typ'First), 1025 -- Wide_Wide_Character (typ'Last)); 1026 1027 -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into 1028 1029 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if 1030 1031 -- where btyp is the base type. This looks recursive but it isn't 1032 -- because the base type is always static, and hence the expression 1033 -- in the else is reduced to an integer literal. 1034 1035 -- For user defined enumeration types, typ'Width expands into 1036 1037 -- Result_Type (Width_Enumeration_NN 1038 -- (typS, 1039 -- typI'Address, 1040 -- typ'Pos (typ'First), 1041 -- typ'Pos (Typ'Last))); 1042 1043 -- and typ'Wide_Width expands into: 1044 1045 -- Result_Type (Wide_Width_Enumeration_NN 1046 -- (typS, 1047 -- typI, 1048 -- typ'Pos (typ'First), 1049 -- typ'Pos (Typ'Last)) 1050 -- Wide_Character_Encoding_Method); 1051 1052 -- and typ'Wide_Wide_Width expands into: 1053 1054 -- Result_Type (Wide_Wide_Width_Enumeration_NN 1055 -- (typS, 1056 -- typI, 1057 -- typ'Pos (typ'First), 1058 -- typ'Pos (Typ'Last)) 1059 -- Wide_Character_Encoding_Method); 1060 1061 -- where typS and typI are the enumeration image strings and indexes 1062 -- table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32 1063 -- for depending on the element type for typI. 1064 1065 -- Finally if Discard_Names is in effect for an enumeration type, then 1066 -- a special if expression is built that yields the space needed for the 1067 -- decimal representation of the largest pos value in the subtype. See 1068 -- code below for details. 1069 1070 procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is 1071 Loc : constant Source_Ptr := Sloc (N); 1072 Typ : constant Entity_Id := Etype (N); 1073 Pref : constant Node_Id := Prefix (N); 1074 Ptyp : constant Entity_Id := Etype (Pref); 1075 Rtyp : constant Entity_Id := Root_Type (Ptyp); 1076 Arglist : List_Id; 1077 Ttyp : Entity_Id; 1078 XX : RE_Id; 1079 YY : Entity_Id; 1080 1081 begin 1082 -- Types derived from Standard.Boolean 1083 1084 if Rtyp = Standard_Boolean then 1085 XX := RE_Width_Boolean; 1086 YY := Rtyp; 1087 1088 -- Types derived from Standard.Character 1089 1090 elsif Rtyp = Standard_Character then 1091 case Attr is 1092 when Normal => XX := RE_Width_Character; 1093 when Wide => XX := RE_Wide_Width_Character; 1094 when Wide_Wide => XX := RE_Wide_Wide_Width_Character; 1095 end case; 1096 1097 YY := Rtyp; 1098 1099 -- Types derived from Standard.Wide_Character 1100 1101 elsif Rtyp = Standard_Wide_Character then 1102 case Attr is 1103 when Normal => XX := RE_Width_Wide_Character; 1104 when Wide => XX := RE_Wide_Width_Wide_Character; 1105 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character; 1106 end case; 1107 1108 YY := Rtyp; 1109 1110 -- Types derived from Standard.Wide_Wide_Character 1111 1112 elsif Rtyp = Standard_Wide_Wide_Character then 1113 case Attr is 1114 when Normal => XX := RE_Width_Wide_Wide_Character; 1115 when Wide => XX := RE_Wide_Width_Wide_Wide_Character; 1116 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char; 1117 end case; 1118 1119 YY := Rtyp; 1120 1121 -- Signed integer types 1122 1123 elsif Is_Signed_Integer_Type (Rtyp) then 1124 XX := RE_Width_Long_Long_Integer; 1125 YY := Standard_Long_Long_Integer; 1126 1127 -- Modular integer types 1128 1129 elsif Is_Modular_Integer_Type (Rtyp) then 1130 XX := RE_Width_Long_Long_Unsigned; 1131 YY := RTE (RE_Long_Long_Unsigned); 1132 1133 -- Real types 1134 1135 elsif Is_Real_Type (Rtyp) then 1136 Rewrite (N, 1137 Make_If_Expression (Loc, 1138 Expressions => New_List ( 1139 1140 Make_Op_Gt (Loc, 1141 Left_Opnd => 1142 Make_Attribute_Reference (Loc, 1143 Prefix => New_Reference_To (Ptyp, Loc), 1144 Attribute_Name => Name_First), 1145 1146 Right_Opnd => 1147 Make_Attribute_Reference (Loc, 1148 Prefix => New_Reference_To (Ptyp, Loc), 1149 Attribute_Name => Name_Last)), 1150 1151 Make_Integer_Literal (Loc, 0), 1152 1153 Make_Attribute_Reference (Loc, 1154 Prefix => New_Reference_To (Base_Type (Ptyp), Loc), 1155 Attribute_Name => Name_Width)))); 1156 1157 Analyze_And_Resolve (N, Typ); 1158 return; 1159 1160 -- User defined enumeration types 1161 1162 else 1163 pragma Assert (Is_Enumeration_Type (Rtyp)); 1164 1165 -- Whenever pragma Discard_Names is in effect, the value we need 1166 -- is the value needed to accomodate the largest integer pos value 1167 -- in the range of the subtype + 1 for the space at the start. We 1168 -- build: 1169 1170 -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last) 1171 1172 -- and replace the expression by 1173 1174 -- (if Ptyp'Range_Length = 0 then 0 1175 -- else (if Tnn < 10 then 2 1176 -- else (if Tnn < 100 then 3 1177 -- ... 1178 -- else n)))... 1179 1180 -- where n is equal to Rtyp'Pos (Ptyp'Last) + 1 1181 1182 -- Note: The above processing is in accordance with the intent of 1183 -- the RM, which is that Width should be related to the impl-defined 1184 -- behavior of Image. It is not clear what this means if Image is 1185 -- not defined (as in the configurable run-time case for GNAT) and 1186 -- gives an error at compile time. 1187 1188 -- We choose in this case to just go ahead and implement Width the 1189 -- same way, returning what Image would have returned if it has been 1190 -- available in the configurable run-time library. 1191 1192 if Discard_Names (Rtyp) then 1193 declare 1194 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T'); 1195 Cexpr : Node_Id; 1196 P : Int; 1197 M : Int; 1198 K : Int; 1199 1200 begin 1201 Insert_Action (N, 1202 Make_Object_Declaration (Loc, 1203 Defining_Identifier => Tnn, 1204 Constant_Present => True, 1205 Object_Definition => 1206 New_Occurrence_Of (Standard_Integer, Loc), 1207 Expression => 1208 Make_Attribute_Reference (Loc, 1209 Prefix => New_Occurrence_Of (Rtyp, Loc), 1210 Attribute_Name => Name_Pos, 1211 Expressions => New_List ( 1212 Convert_To (Rtyp, 1213 Make_Attribute_Reference (Loc, 1214 Prefix => New_Occurrence_Of (Ptyp, Loc), 1215 Attribute_Name => Name_Last)))))); 1216 1217 -- OK, now we need to build the if expression. First get the 1218 -- value of M, the largest possible value needed. 1219 1220 P := UI_To_Int 1221 (Enumeration_Pos (Entity (Type_High_Bound (Rtyp)))); 1222 1223 K := 1; 1224 M := 1; 1225 while M < P loop 1226 M := M * 10; 1227 K := K + 1; 1228 end loop; 1229 1230 -- Build inner else 1231 1232 Cexpr := Make_Integer_Literal (Loc, K); 1233 1234 -- Wrap in inner if's until counted down to 2 1235 1236 while K > 2 loop 1237 M := M / 10; 1238 K := K - 1; 1239 1240 Cexpr := 1241 Make_If_Expression (Loc, 1242 Expressions => New_List ( 1243 Make_Op_Lt (Loc, 1244 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 1245 Right_Opnd => Make_Integer_Literal (Loc, M)), 1246 Make_Integer_Literal (Loc, K), 1247 Cexpr)); 1248 end loop; 1249 1250 -- Add initial comparison for null range and we are done, so 1251 -- rewrite the attribute occurrence with this expression. 1252 1253 Rewrite (N, 1254 Convert_To (Typ, 1255 Make_If_Expression (Loc, 1256 Expressions => New_List ( 1257 Make_Op_Eq (Loc, 1258 Left_Opnd => 1259 Make_Attribute_Reference (Loc, 1260 Prefix => New_Occurrence_Of (Ptyp, Loc), 1261 Attribute_Name => Name_Range_Length), 1262 Right_Opnd => Make_Integer_Literal (Loc, 0)), 1263 Make_Integer_Literal (Loc, 0), 1264 Cexpr)))); 1265 1266 Analyze_And_Resolve (N, Typ); 1267 return; 1268 end; 1269 end if; 1270 1271 -- Normal case, not Discard_Names 1272 1273 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); 1274 1275 case Attr is 1276 when Normal => 1277 if Ttyp = Standard_Integer_8 then 1278 XX := RE_Width_Enumeration_8; 1279 elsif Ttyp = Standard_Integer_16 then 1280 XX := RE_Width_Enumeration_16; 1281 else 1282 XX := RE_Width_Enumeration_32; 1283 end if; 1284 1285 when Wide => 1286 if Ttyp = Standard_Integer_8 then 1287 XX := RE_Wide_Width_Enumeration_8; 1288 elsif Ttyp = Standard_Integer_16 then 1289 XX := RE_Wide_Width_Enumeration_16; 1290 else 1291 XX := RE_Wide_Width_Enumeration_32; 1292 end if; 1293 1294 when Wide_Wide => 1295 if Ttyp = Standard_Integer_8 then 1296 XX := RE_Wide_Wide_Width_Enumeration_8; 1297 elsif Ttyp = Standard_Integer_16 then 1298 XX := RE_Wide_Wide_Width_Enumeration_16; 1299 else 1300 XX := RE_Wide_Wide_Width_Enumeration_32; 1301 end if; 1302 end case; 1303 1304 Arglist := 1305 New_List ( 1306 New_Occurrence_Of (Lit_Strings (Rtyp), Loc), 1307 1308 Make_Attribute_Reference (Loc, 1309 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), 1310 Attribute_Name => Name_Address), 1311 1312 Make_Attribute_Reference (Loc, 1313 Prefix => New_Reference_To (Ptyp, Loc), 1314 Attribute_Name => Name_Pos, 1315 1316 Expressions => New_List ( 1317 Make_Attribute_Reference (Loc, 1318 Prefix => New_Reference_To (Ptyp, Loc), 1319 Attribute_Name => Name_First))), 1320 1321 Make_Attribute_Reference (Loc, 1322 Prefix => New_Reference_To (Ptyp, Loc), 1323 Attribute_Name => Name_Pos, 1324 1325 Expressions => New_List ( 1326 Make_Attribute_Reference (Loc, 1327 Prefix => New_Reference_To (Ptyp, Loc), 1328 Attribute_Name => Name_Last)))); 1329 1330 Rewrite (N, 1331 Convert_To (Typ, 1332 Make_Function_Call (Loc, 1333 Name => New_Reference_To (RTE (XX), Loc), 1334 Parameter_Associations => Arglist))); 1335 1336 Analyze_And_Resolve (N, Typ); 1337 return; 1338 end if; 1339 1340 -- If we fall through XX and YY are set 1341 1342 Arglist := New_List ( 1343 Convert_To (YY, 1344 Make_Attribute_Reference (Loc, 1345 Prefix => New_Reference_To (Ptyp, Loc), 1346 Attribute_Name => Name_First)), 1347 1348 Convert_To (YY, 1349 Make_Attribute_Reference (Loc, 1350 Prefix => New_Reference_To (Ptyp, Loc), 1351 Attribute_Name => Name_Last))); 1352 1353 Rewrite (N, 1354 Convert_To (Typ, 1355 Make_Function_Call (Loc, 1356 Name => New_Reference_To (RTE (XX), Loc), 1357 Parameter_Associations => Arglist))); 1358 1359 Analyze_And_Resolve (N, Typ); 1360 end Expand_Width_Attribute; 1361 1362 ----------------------- 1363 -- Has_Decimal_Small -- 1364 ----------------------- 1365 1366 function Has_Decimal_Small (E : Entity_Id) return Boolean is 1367 begin 1368 return Is_Decimal_Fixed_Point_Type (E) 1369 or else 1370 (Is_Ordinary_Fixed_Point_Type (E) 1371 and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); 1372 end Has_Decimal_Small; 1373 1374end Exp_Imgv; 1375