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-2004 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Casing; use Casing; 29with Checks; use Checks; 30with Einfo; use Einfo; 31with Exp_Util; use Exp_Util; 32with Namet; use Namet; 33with Nmake; use Nmake; 34with Nlists; use Nlists; 35with Opt; use Opt; 36with Rtsfind; use Rtsfind; 37with Sem_Res; use Sem_Res; 38with Sinfo; use Sinfo; 39with Snames; use Snames; 40with Stand; use Stand; 41with Stringt; use Stringt; 42with Tbuild; use Tbuild; 43with Ttypes; use Ttypes; 44with Uintp; use Uintp; 45 46package body Exp_Imgv is 47 48 ------------------------------------ 49 -- Build_Enumeration_Image_Tables -- 50 ------------------------------------ 51 52 procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is 53 Loc : constant Source_Ptr := Sloc (E); 54 Str : String_Id; 55 Ind : List_Id; 56 Lit : Entity_Id; 57 Nlit : Nat; 58 Len : Nat; 59 Estr : Entity_Id; 60 Eind : Entity_Id; 61 Ityp : Node_Id; 62 63 begin 64 -- Nothing to do for other than a root enumeration type 65 66 if E /= Root_Type (E) then 67 return; 68 69 -- Nothing to do if pragma Discard_Names applies 70 71 elsif Discard_Names (E) then 72 return; 73 end if; 74 75 -- Otherwise tables need constructing 76 77 Start_String; 78 Ind := New_List; 79 Lit := First_Literal (E); 80 Len := 1; 81 Nlit := 0; 82 83 loop 84 Append_To (Ind, 85 Make_Integer_Literal (Loc, UI_From_Int (Len))); 86 87 exit when No (Lit); 88 Nlit := Nlit + 1; 89 90 Get_Unqualified_Decoded_Name_String (Chars (Lit)); 91 92 if Name_Buffer (1) /= ''' then 93 Set_Casing (All_Upper_Case); 94 end if; 95 96 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 97 Len := Len + Int (Name_Len); 98 Next_Literal (Lit); 99 end loop; 100 101 if Len < Int (2 ** (8 - 1)) then 102 Ityp := Standard_Integer_8; 103 elsif Len < Int (2 ** (16 - 1)) then 104 Ityp := Standard_Integer_16; 105 else 106 Ityp := Standard_Integer_32; 107 end if; 108 109 Str := End_String; 110 111 Estr := 112 Make_Defining_Identifier (Loc, 113 Chars => New_External_Name (Chars (E), 'S')); 114 115 Eind := 116 Make_Defining_Identifier (Loc, 117 Chars => New_External_Name (Chars (E), 'N')); 118 119 Set_Lit_Strings (E, Estr); 120 Set_Lit_Indexes (E, Eind); 121 122 Insert_Actions (N, 123 New_List ( 124 Make_Object_Declaration (Loc, 125 Defining_Identifier => Estr, 126 Constant_Present => True, 127 Object_Definition => 128 New_Occurrence_Of (Standard_String, Loc), 129 Expression => 130 Make_String_Literal (Loc, 131 Strval => Str)), 132 133 Make_Object_Declaration (Loc, 134 Defining_Identifier => Eind, 135 Constant_Present => True, 136 137 Object_Definition => 138 Make_Constrained_Array_Definition (Loc, 139 Discrete_Subtype_Definitions => New_List ( 140 Make_Range (Loc, 141 Low_Bound => Make_Integer_Literal (Loc, 0), 142 High_Bound => Make_Integer_Literal (Loc, Nlit))), 143 Component_Definition => 144 Make_Component_Definition (Loc, 145 Aliased_Present => False, 146 Subtype_Indication => New_Occurrence_Of (Ityp, Loc))), 147 148 Expression => 149 Make_Aggregate (Loc, 150 Expressions => Ind))), 151 Suppress => All_Checks); 152 153 end Build_Enumeration_Image_Tables; 154 155 ---------------------------- 156 -- Expand_Image_Attribute -- 157 ---------------------------- 158 159 -- For all non-enumeration types, and for enumeration types declared 160 -- in packages Standard or System, typ'Image (Val) expands into: 161 162 -- Image_xx (tp (Expr) [, pm]) 163 164 -- The name xx and type conversion tp (Expr) (called tv below) depend on 165 -- the root type of Expr. The argument pm is an extra type dependent 166 -- parameter only used in some cases as follows: 167 168 -- For types whose root type is Character 169 -- xx = Character 170 -- tv = Character (Expr) 171 172 -- For types whose root type is Boolean 173 -- xx = Boolean 174 -- tv = Boolean (Expr) 175 176 -- For signed integer types with size <= Integer'Size 177 -- xx = Integer 178 -- tv = Integer (Expr) 179 180 -- For other signed integer types 181 -- xx = Long_Long_Integer 182 -- tv = Long_Long_Integer (Expr) 183 184 -- For modular types with modulus <= System.Unsigned_Types.Unsigned 185 -- xx = Unsigned 186 -- tv = System.Unsigned_Types.Unsigned (Expr) 187 188 -- For other modular integer types 189 -- xx = Long_Long_Unsigned 190 -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr) 191 192 -- For types whose root type is Wide_Character 193 -- xx = Wide_Character 194 -- tv = Wide_Character (Expr) 195 -- pm = Wide_Character_Encoding_Method 196 197 -- For floating-point types 198 -- xx = Floating_Point 199 -- tv = Long_Long_Float (Expr) 200 -- pm = typ'Digits 201 202 -- For ordinary fixed-point types 203 -- xx = Ordinary_Fixed_Point 204 -- tv = Long_Long_Float (Expr) 205 -- pm = typ'Aft 206 207 -- For decimal fixed-point types with size = Integer'Size 208 -- xx = Decimal 209 -- tv = Integer (Expr) 210 -- pm = typ'Scale 211 212 -- For decimal fixed-point types with size > Integer'Size 213 -- xx = Long_Long_Decimal 214 -- tv = Long_Long_Integer (Expr) 215 -- pm = typ'Scale 216 217 -- Note: for the decimal fixed-point type cases, the conversion is 218 -- done literally without scaling (i.e. the actual expression that 219 -- is generated is Image_xx (tp?(Expr) [, pm]) 220 221 -- For enumeration types other than those declared packages Standard 222 -- or System, typ'Image (X) expands into: 223 224 -- Image_Enumeration_NN (typ'Pos (X), typS, typI'Address) 225 226 -- where typS and typI are the entities constructed as described in 227 -- the spec for the procedure Build_Enumeration_Image_Tables and NN 228 -- is 32/16/8 depending on the element type of Lit_Indexes. 229 230 procedure Expand_Image_Attribute (N : Node_Id) is 231 Loc : constant Source_Ptr := Sloc (N); 232 Exprs : constant List_Id := Expressions (N); 233 Pref : constant Node_Id := Prefix (N); 234 Ptyp : constant Entity_Id := Entity (Pref); 235 Rtyp : constant Entity_Id := Root_Type (Ptyp); 236 Expr : constant Node_Id := Relocate_Node (First (Exprs)); 237 Imid : RE_Id; 238 Tent : Entity_Id; 239 Arglist : List_Id; 240 Func : RE_Id; 241 Ttyp : Entity_Id; 242 Func_Ent : Entity_Id; 243 244 begin 245 if Rtyp = Standard_Boolean then 246 Imid := RE_Image_Boolean; 247 Tent := Rtyp; 248 249 elsif Rtyp = Standard_Character then 250 Imid := RE_Image_Character; 251 Tent := Rtyp; 252 253 elsif Rtyp = Standard_Wide_Character then 254 Imid := RE_Image_Wide_Character; 255 Tent := Rtyp; 256 257 elsif Is_Signed_Integer_Type (Rtyp) then 258 if Esize (Rtyp) <= Esize (Standard_Integer) then 259 Imid := RE_Image_Integer; 260 Tent := Standard_Integer; 261 else 262 Imid := RE_Image_Long_Long_Integer; 263 Tent := Standard_Long_Long_Integer; 264 end if; 265 266 elsif Is_Modular_Integer_Type (Rtyp) then 267 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then 268 Imid := RE_Image_Unsigned; 269 Tent := RTE (RE_Unsigned); 270 else 271 Imid := RE_Image_Long_Long_Unsigned; 272 Tent := RTE (RE_Long_Long_Unsigned); 273 end if; 274 275 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then 276 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 277 Imid := RE_Image_Decimal; 278 Tent := Standard_Integer; 279 else 280 Imid := RE_Image_Long_Long_Decimal; 281 Tent := Standard_Long_Long_Integer; 282 end if; 283 284 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then 285 Imid := RE_Image_Ordinary_Fixed_Point; 286 Tent := Standard_Long_Long_Float; 287 288 elsif Is_Floating_Point_Type (Rtyp) then 289 Imid := RE_Image_Floating_Point; 290 Tent := Standard_Long_Long_Float; 291 292 -- Only other possibility is user defined enumeration type 293 294 else 295 if Discard_Names (First_Subtype (Ptyp)) 296 or else No (Lit_Strings (Root_Type (Ptyp))) 297 then 298 -- When pragma Discard_Names applies to the first subtype, 299 -- then build (Pref'Pos)'Img. 300 301 Rewrite (N, 302 Make_Attribute_Reference (Loc, 303 Prefix => 304 Make_Attribute_Reference (Loc, 305 Prefix => Pref, 306 Attribute_Name => Name_Pos, 307 Expressions => New_List (Expr)), 308 Attribute_Name => 309 Name_Img)); 310 Analyze_And_Resolve (N, Standard_String); 311 312 else 313 -- Here we get the Image of an enumeration type 314 315 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); 316 317 if Ttyp = Standard_Integer_8 then 318 Func := RE_Image_Enumeration_8; 319 elsif Ttyp = Standard_Integer_16 then 320 Func := RE_Image_Enumeration_16; 321 else 322 Func := RE_Image_Enumeration_32; 323 end if; 324 325 -- Apply a validity check, since it is a bit drastic to 326 -- get a completely junk image value for an invalid value. 327 328 if not Expr_Known_Valid (Expr) then 329 Insert_Valid_Check (Expr); 330 end if; 331 332 Rewrite (N, 333 Make_Function_Call (Loc, 334 Name => New_Occurrence_Of (RTE (Func), Loc), 335 Parameter_Associations => New_List ( 336 Make_Attribute_Reference (Loc, 337 Attribute_Name => Name_Pos, 338 Prefix => New_Occurrence_Of (Ptyp, Loc), 339 Expressions => New_List (Expr)), 340 New_Occurrence_Of (Lit_Strings (Rtyp), Loc), 341 Make_Attribute_Reference (Loc, 342 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), 343 Attribute_Name => Name_Address)))); 344 345 Analyze_And_Resolve (N, Standard_String); 346 end if; 347 348 return; 349 end if; 350 351 -- If we fall through, we have one of the cases that is handled by 352 -- calling one of the System.Img_xx routines and Imid is set to the 353 -- RE_Id for the function to be called. 354 355 Func_Ent := RTE (Imid); 356 357 -- If the function entity is empty, that means we have a case in 358 -- no run time mode where the operation is not allowed, and an 359 -- appropriate diagnostic has already been issued. 360 361 if No (Func_Ent) then 362 return; 363 end if; 364 365 -- Otherwise prepare arguments for run-time call 366 367 Arglist := New_List (Convert_To (Tent, Relocate_Node (Expr))); 368 369 -- For floating-point types, append Digits argument 370 371 if Is_Floating_Point_Type (Rtyp) then 372 Append_To (Arglist, 373 Make_Attribute_Reference (Loc, 374 Prefix => New_Reference_To (Ptyp, Loc), 375 Attribute_Name => Name_Digits)); 376 377 -- For ordinary fixed-point types, append Aft parameter 378 379 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then 380 Append_To (Arglist, 381 Make_Attribute_Reference (Loc, 382 Prefix => New_Reference_To (Ptyp, Loc), 383 Attribute_Name => Name_Aft)); 384 385 -- For wide character, append encoding method 386 387 elsif Rtyp = Standard_Wide_Character then 388 Append_To (Arglist, 389 Make_Integer_Literal (Loc, 390 Intval => Int (Wide_Character_Encoding_Method))); 391 392 -- For decimal, append Scale and also set to do literal conversion 393 394 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then 395 Append_To (Arglist, 396 Make_Attribute_Reference (Loc, 397 Prefix => New_Reference_To (Ptyp, Loc), 398 Attribute_Name => Name_Scale)); 399 400 Set_Conversion_OK (First (Arglist)); 401 Set_Etype (First (Arglist), Tent); 402 end if; 403 404 Rewrite (N, 405 Make_Function_Call (Loc, 406 Name => New_Reference_To (Func_Ent, Loc), 407 Parameter_Associations => Arglist)); 408 409 Analyze_And_Resolve (N, Standard_String); 410 end Expand_Image_Attribute; 411 412 ---------------------------- 413 -- Expand_Value_Attribute -- 414 ---------------------------- 415 416 -- For scalar types derived from Boolean, Character and integer types 417 -- in package Standard, typ'Value (X) expands into: 418 419 -- btyp (Value_xx (X)) 420 421 -- where btyp is he base type of the prefix, and 422 423 -- For types whose root type is Character 424 -- xx = Character 425 426 -- For types whose root type is Boolean 427 -- xx = Boolean 428 429 -- For signed integer types with size <= Integer'Size 430 -- xx = Integer 431 432 -- For other signed integer types 433 -- xx = Long_Long_Integer 434 435 -- For modular types with modulus <= System.Unsigned_Types.Unsigned 436 -- xx = Unsigned 437 438 -- For other modular integer types 439 -- xx = Long_Long_Unsigned 440 441 -- For floating-point types and ordinary fixed-point types 442 -- xx = Real 443 444 -- For types derived from Wide_Character, typ'Value (X) expands into 445 446 -- Value_Wide_Character (X, Wide_Character_Encoding_Method) 447 448 -- For decimal types with size <= Integer'Size, typ'Value (X) 449 -- expands into 450 451 -- btyp?(Value_Decimal (X, typ'Scale)); 452 453 -- For all other decimal types, typ'Value (X) expands into 454 455 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale)) 456 457 -- For enumeration types other than those derived from types Boolean, 458 -- Character, and Wide_Character in Standard, typ'Value (X) expands to: 459 460 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) 461 462 -- where typS and typI and the Lit_Strings and Lit_Indexes entities 463 -- from T's root type entitym and Num is Enum'Pos (Enum'Last). The 464 -- Value_Enumeration_NN function will search the tables looking for 465 -- X and return the position number in the table if found which is 466 -- used to provide the result of 'Value (using Enum'Val). If the 467 -- value is not found Constraint_Error is raised. The suffix _NN 468 -- depends on the element type of typI. 469 470 procedure Expand_Value_Attribute (N : Node_Id) is 471 Loc : constant Source_Ptr := Sloc (N); 472 Typ : constant Entity_Id := Etype (N); 473 Btyp : constant Entity_Id := Base_Type (Typ); 474 Rtyp : constant Entity_Id := Root_Type (Typ); 475 Exprs : constant List_Id := Expressions (N); 476 Vid : RE_Id; 477 Args : List_Id; 478 Func : RE_Id; 479 Ttyp : Entity_Id; 480 481 begin 482 Args := Exprs; 483 484 if Rtyp = Standard_Character then 485 Vid := RE_Value_Character; 486 487 elsif Rtyp = Standard_Boolean then 488 Vid := RE_Value_Boolean; 489 490 elsif Rtyp = Standard_Wide_Character then 491 Vid := RE_Value_Wide_Character; 492 Append_To (Args, 493 Make_Integer_Literal (Loc, 494 Intval => Int (Wide_Character_Encoding_Method))); 495 496 elsif Rtyp = Base_Type (Standard_Short_Short_Integer) 497 or else Rtyp = Base_Type (Standard_Short_Integer) 498 or else Rtyp = Base_Type (Standard_Integer) 499 then 500 Vid := RE_Value_Integer; 501 502 elsif Is_Signed_Integer_Type (Rtyp) then 503 Vid := RE_Value_Long_Long_Integer; 504 505 elsif Is_Modular_Integer_Type (Rtyp) then 506 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then 507 Vid := RE_Value_Unsigned; 508 else 509 Vid := RE_Value_Long_Long_Unsigned; 510 end if; 511 512 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then 513 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 514 Vid := RE_Value_Decimal; 515 else 516 Vid := RE_Value_Long_Long_Decimal; 517 end if; 518 519 Append_To (Args, 520 Make_Attribute_Reference (Loc, 521 Prefix => New_Reference_To (Typ, Loc), 522 Attribute_Name => Name_Scale)); 523 524 Rewrite (N, 525 OK_Convert_To (Btyp, 526 Make_Function_Call (Loc, 527 Name => New_Reference_To (RTE (Vid), Loc), 528 Parameter_Associations => Args))); 529 530 Set_Etype (N, Btyp); 531 Analyze_And_Resolve (N, Btyp); 532 return; 533 534 elsif Is_Real_Type (Rtyp) then 535 Vid := RE_Value_Real; 536 537 -- Only other possibility is user defined enumeration type 538 539 else 540 pragma Assert (Is_Enumeration_Type (Rtyp)); 541 542 -- Case of pragma Discard_Names, transform the Value 543 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args)) 544 545 if Discard_Names (First_Subtype (Typ)) 546 or else No (Lit_Strings (Rtyp)) 547 then 548 Rewrite (N, 549 Make_Attribute_Reference (Loc, 550 Prefix => New_Reference_To (Btyp, Loc), 551 Attribute_Name => Name_Val, 552 Expressions => New_List ( 553 Make_Attribute_Reference (Loc, 554 Prefix => 555 New_Occurrence_Of (Standard_Long_Long_Integer, Loc), 556 Attribute_Name => Name_Value, 557 Expressions => Args)))); 558 559 Analyze_And_Resolve (N, Btyp); 560 561 -- Here for normal case where we have enumeration tables, this 562 -- is where we build 563 564 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) 565 566 else 567 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); 568 569 if Ttyp = Standard_Integer_8 then 570 Func := RE_Value_Enumeration_8; 571 elsif Ttyp = Standard_Integer_16 then 572 Func := RE_Value_Enumeration_16; 573 else 574 Func := RE_Value_Enumeration_32; 575 end if; 576 577 Prepend_To (Args, 578 Make_Attribute_Reference (Loc, 579 Prefix => New_Occurrence_Of (Rtyp, Loc), 580 Attribute_Name => Name_Pos, 581 Expressions => New_List ( 582 Make_Attribute_Reference (Loc, 583 Prefix => New_Occurrence_Of (Rtyp, Loc), 584 Attribute_Name => Name_Last)))); 585 586 Prepend_To (Args, 587 Make_Attribute_Reference (Loc, 588 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), 589 Attribute_Name => Name_Address)); 590 591 Prepend_To (Args, 592 New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); 593 594 Rewrite (N, 595 Make_Attribute_Reference (Loc, 596 Prefix => New_Reference_To (Typ, Loc), 597 Attribute_Name => Name_Val, 598 Expressions => New_List ( 599 Make_Function_Call (Loc, 600 Name => 601 New_Reference_To (RTE (Func), Loc), 602 Parameter_Associations => Args)))); 603 604 Analyze_And_Resolve (N, Btyp); 605 end if; 606 607 return; 608 end if; 609 610 -- Fall through for all cases except user defined enumeration type 611 -- and decimal types, with Vid set to the Id of the entity for the 612 -- Value routine and Args set to the list of parameters for the call. 613 614 Rewrite (N, 615 Convert_To (Btyp, 616 Make_Function_Call (Loc, 617 Name => New_Reference_To (RTE (Vid), Loc), 618 Parameter_Associations => Args))); 619 620 Analyze_And_Resolve (N, Btyp); 621 end Expand_Value_Attribute; 622 623 ---------------------------- 624 -- Expand_Width_Attribute -- 625 ---------------------------- 626 627 -- The processing here also handles the case of Wide_Width. With the 628 -- exceptions noted, the processing is identical 629 630 -- For scalar types derived from Boolean, character and integer types 631 -- in package Standard. Note that the Width attribute is computed at 632 -- compile time for all cases except those involving non-static sub- 633 -- types. For such subtypes, typ'Width and typ'Wide_Width expands into: 634 635 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last))) 636 637 -- where 638 639 -- For types whose root type is Character 640 -- xx = Width_Character (Wide_Width_Character for Wide_Width case) 641 -- yy = Character 642 643 -- For types whose root type is Boolean 644 -- xx = Width_Boolean 645 -- yy = Boolean 646 647 -- For signed integer types 648 -- xx = Width_Long_Long_Integer 649 -- yy = Long_Long_Integer 650 651 -- For modular integer types 652 -- xx = Width_Long_Long_Unsigned 653 -- yy = Long_Long_Unsigned 654 655 -- For types derived from Wide_Character, typ'Width expands into 656 657 -- Result_Type (Width_Wide_Character ( 658 -- Wide_Character (typ'First), 659 -- Wide_Character (typ'Last), 660 -- Wide_Character_Encoding_Method); 661 662 -- and typ'Wide_Width expands into: 663 664 -- Result_Type (Wide_Width_Wide_Character ( 665 -- Wide_Character (typ'First), 666 -- Wide_Character (typ'Last)); 667 668 -- For real types, typ'Width and typ'Wide_Width expand into 669 670 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if 671 672 -- where btyp is the base type. This looks recursive but it isn't 673 -- because the base type is always static, and hence the expression 674 -- in the else is reduced to an integer literal. 675 676 -- For user defined enumeration types, typ'Width expands into 677 678 -- Result_Type (Width_Enumeration_NN 679 -- (typS, 680 -- typI'Address, 681 -- typ'Pos (typ'First), 682 -- typ'Pos (Typ'Last))); 683 684 -- and typ'Wide_Width expands into: 685 686 -- Result_Type (Wide_Width_Enumeration_NN 687 -- (typS, 688 -- typI, 689 -- typ'Pos (typ'First), 690 -- typ'Pos (Typ'Last)) 691 -- Wide_Character_Encoding_Method); 692 693 -- where typS and typI are the enumeration image strings and 694 -- indexes table, as described in Build_Enumeration_Image_Tables. 695 -- NN is 8/16/32 for depending on the element type for typI. 696 697 procedure Expand_Width_Attribute (N : Node_Id; Wide : Boolean) is 698 Loc : constant Source_Ptr := Sloc (N); 699 Typ : constant Entity_Id := Etype (N); 700 Pref : constant Node_Id := Prefix (N); 701 Ptyp : constant Entity_Id := Etype (Pref); 702 Rtyp : constant Entity_Id := Root_Type (Ptyp); 703 XX : RE_Id; 704 YY : Entity_Id; 705 Arglist : List_Id; 706 Ttyp : Entity_Id; 707 708 begin 709 -- Types derived from Standard.Boolean 710 711 if Rtyp = Standard_Boolean then 712 XX := RE_Width_Boolean; 713 YY := Rtyp; 714 715 -- Types derived from Standard.Character 716 717 elsif Rtyp = Standard_Character then 718 if not Wide then 719 XX := RE_Width_Character; 720 else 721 XX := RE_Wide_Width_Character; 722 end if; 723 724 YY := Rtyp; 725 726 -- Types derived from Standard.Wide_Character 727 728 elsif Rtyp = Standard_Wide_Character then 729 if not Wide then 730 XX := RE_Width_Wide_Character; 731 else 732 XX := RE_Wide_Width_Wide_Character; 733 end if; 734 735 YY := Rtyp; 736 737 -- Signed integer types 738 739 elsif Is_Signed_Integer_Type (Rtyp) then 740 XX := RE_Width_Long_Long_Integer; 741 YY := Standard_Long_Long_Integer; 742 743 -- Modular integer types 744 745 elsif Is_Modular_Integer_Type (Rtyp) then 746 XX := RE_Width_Long_Long_Unsigned; 747 YY := RTE (RE_Long_Long_Unsigned); 748 749 -- Real types 750 751 elsif Is_Real_Type (Rtyp) then 752 753 Rewrite (N, 754 Make_Conditional_Expression (Loc, 755 Expressions => New_List ( 756 757 Make_Op_Gt (Loc, 758 Left_Opnd => 759 Make_Attribute_Reference (Loc, 760 Prefix => New_Reference_To (Ptyp, Loc), 761 Attribute_Name => Name_First), 762 763 Right_Opnd => 764 Make_Attribute_Reference (Loc, 765 Prefix => New_Reference_To (Ptyp, Loc), 766 Attribute_Name => Name_Last)), 767 768 Make_Integer_Literal (Loc, 0), 769 770 Make_Attribute_Reference (Loc, 771 Prefix => New_Reference_To (Base_Type (Ptyp), Loc), 772 Attribute_Name => Name_Width)))); 773 774 Analyze_And_Resolve (N, Typ); 775 return; 776 777 -- User defined enumeration types 778 779 else 780 pragma Assert (Is_Enumeration_Type (Rtyp)); 781 782 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); 783 784 if not Wide then 785 if Ttyp = Standard_Integer_8 then 786 XX := RE_Width_Enumeration_8; 787 elsif Ttyp = Standard_Integer_16 then 788 XX := RE_Width_Enumeration_16; 789 else 790 XX := RE_Width_Enumeration_32; 791 end if; 792 793 else 794 if Ttyp = Standard_Integer_8 then 795 XX := RE_Wide_Width_Enumeration_8; 796 elsif Ttyp = Standard_Integer_16 then 797 XX := RE_Wide_Width_Enumeration_16; 798 else 799 XX := RE_Wide_Width_Enumeration_32; 800 end if; 801 end if; 802 803 Arglist := 804 New_List ( 805 New_Occurrence_Of (Lit_Strings (Rtyp), Loc), 806 807 Make_Attribute_Reference (Loc, 808 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), 809 Attribute_Name => Name_Address), 810 811 Make_Attribute_Reference (Loc, 812 Prefix => New_Reference_To (Ptyp, Loc), 813 Attribute_Name => Name_Pos, 814 815 Expressions => New_List ( 816 Make_Attribute_Reference (Loc, 817 Prefix => New_Reference_To (Ptyp, Loc), 818 Attribute_Name => Name_First))), 819 820 Make_Attribute_Reference (Loc, 821 Prefix => New_Reference_To (Ptyp, Loc), 822 Attribute_Name => Name_Pos, 823 824 Expressions => New_List ( 825 Make_Attribute_Reference (Loc, 826 Prefix => New_Reference_To (Ptyp, Loc), 827 Attribute_Name => Name_Last)))); 828 829 -- For enumeration'Wide_Width, add encoding method parameter 830 831 if Wide then 832 Append_To (Arglist, 833 Make_Integer_Literal (Loc, 834 Intval => Int (Wide_Character_Encoding_Method))); 835 end if; 836 837 Rewrite (N, 838 Convert_To (Typ, 839 Make_Function_Call (Loc, 840 Name => New_Reference_To (RTE (XX), Loc), 841 Parameter_Associations => Arglist))); 842 843 Analyze_And_Resolve (N, Typ); 844 return; 845 end if; 846 847 -- If we fall through XX and YY are set 848 849 Arglist := New_List ( 850 Convert_To (YY, 851 Make_Attribute_Reference (Loc, 852 Prefix => New_Reference_To (Ptyp, Loc), 853 Attribute_Name => Name_First)), 854 855 Convert_To (YY, 856 Make_Attribute_Reference (Loc, 857 Prefix => New_Reference_To (Ptyp, Loc), 858 Attribute_Name => Name_Last))); 859 860 -- For Wide_Character'Width, add encoding method parameter 861 862 if Rtyp = Standard_Wide_Character and then Wide then 863 Append_To (Arglist, 864 Make_Integer_Literal (Loc, 865 Intval => Int (Wide_Character_Encoding_Method))); 866 end if; 867 868 Rewrite (N, 869 Convert_To (Typ, 870 Make_Function_Call (Loc, 871 Name => New_Reference_To (RTE (XX), Loc), 872 Parameter_Associations => Arglist))); 873 874 Analyze_And_Resolve (N, Typ); 875 end Expand_Width_Attribute; 876 877end Exp_Imgv; 878