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