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