1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- A 4 G . D D A _ A U X -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1999-2015, AdaCore -- 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 Asis; 27with Asis.Data_Decomposition; 28 29use type Asis.Data_Decomposition.Portable_Value; 30 31with Atree; use Atree; 32with Einfo; use Einfo; 33with Sem_Aux; use Sem_Aux; 34with Sinfo; use Sinfo; 35with Snames; use Snames; 36with Nlists; use Nlists; 37with System; use System; 38 39with Unchecked_Conversion; 40 41package body A4G.DDA_Aux is 42 43 pragma Warnings (Off, Default_Bit_Order); 44 -- This pragma is needed to suppress warnings (generated in -gnatwa mode) 45 -- for the conditions like 46 -- 47 -- if Default_Bit_Order = High_Order_First then 48 -- 49 -- Conditions like this includes two constants, so they are always True (or 50 -- always False), but the value of Default_Bit_Order is different on 51 -- different platforms 52 53 ------------------------------------------- 54 -- Renamed Entities in Imported Packages -- 55 ------------------------------------------- 56 57 -- These are simply renamed to avoid the need for qualification 58 59 subtype ASIS_Integer is Asis.ASIS_Integer; 60 subtype ASIS_Natural is Asis.ASIS_Natural; 61 subtype ASIS_Positive is Asis.ASIS_Positive; 62 63 subtype Portable_Value is Asis.Data_Decomposition.Portable_Value; 64 subtype Portable_Positive is Asis.Data_Decomposition.Portable_Positive; 65 subtype Portable_Data is Asis.Data_Decomposition.Portable_Data; 66 67 subtype Dimension_Indexes is Asis.Data_Decomposition.Dimension_Indexes; 68 69 subtype Discrim_List is Repinfo.Discrim_List; 70 71 ------------------------ 72 -- Local Declarations -- 73 ------------------------ 74 75 SU : constant := 8; 76 -- Size of storage unit, basically we assume this throughout, but we 77 -- still try to use this symbolic value everywhere, both for clarity 78 -- and to assist anyone undertaking the (rather large) task of dealing 79 -- with non-byte addressable machines. 80 81 type Bit is range 0 .. 1; 82 for Bit'Size use 1; 83 84 type Bit_String is array (0 .. ASIS_Natural'Last - 1) of Bit; 85 pragma Pack (Bit_String); 86 -- Type used for interpreting Portable_Data values as bit strings 87 88 type Bit_String_Ptr is access all Bit_String; 89 -- The actual access is via a bit string pointer, obtained by the 90 -- use of unchecked conversion on the portable data value. 91 92 function To_Bit_String_Ptr is 93 new Unchecked_Conversion (Address, Bit_String_Ptr); 94 95 ----------------------- 96 -- Local Subprograms -- 97 ----------------------- 98 99 function Check (U : Node_Ref_Or_Val) return Uint; 100 -- This function checks if the given value is a constant, and if so 101 -- returns it, otherwise the exception Variable_Rep_Info is raised. 102 103 function Check (U : Node_Ref_Or_Val) return ASIS_Natural; 104 -- Like above function, but value is returned as ASIS_Natural. The 105 -- exception Invalid_Data is raised if the value is not in the range 106 -- of this type. 107 108 function Check_And_Eval 109 (U : Node_Ref_Or_Val; 110 Discs : Discrim_List) 111 return Uint; 112 -- This function checks if the given value is a constant, or is a value 113 -- that depends on the discriminants of its containing record. In the 114 -- former case, the value is returned, in the latter case, the list of 115 -- discriminants is used to evaluate the value. If U is No_Uint on 116 -- entry, then the exception Variable_Rep_Info is raised. 117 118 function Check_And_Eval 119 (U : Node_Ref_Or_Val; 120 Discs : Discrim_List) 121 return ASIS_Natural; 122 -- Like above function, but value is returned as ASIS_Natural. The 123 -- exception Invalid_Data is raised if the value is not in the range 124 -- of this type. 125 126 function Extract_Field 127 (Data : Portable_Data; 128 Start : ASIS_Natural; 129 Len : ASIS_Natural; 130 Typ : Entity_Id) 131 return Portable_Data; 132 -- Given a portable data value, Data, takes the bit slice starting at 133 -- offset Start, with length Len bits and returns a Portable_Value that 134 -- is interpretable as a value of the given type Typ. In the case of 135 -- a scalar value, the result will be 1,2,4, or 8 bytes long with proper 136 -- sign or zero extension as required. 137 138 function Set_Field 139 (Data : Portable_Data; 140 Start : ASIS_Natural; 141 Len : ASIS_Natural; 142 Typ : Entity_Id; 143 Val : Portable_Data) 144 return Portable_Data; 145 -- Given a portable data value, sets the bit slice in this value to 146 -- contain the value corresponding to the value given in Val. The value 147 -- returned is the resulting Portable_Data value, extended if necessary 148 -- to be long enough to accomodate the slice, and with the new value 149 -- set in place. 150 151 procedure Set_Field 152 (Data : in out Portable_Data; 153 Start : ASIS_Natural; 154 Len : ASIS_Natural; 155 Typ : Entity_Id; 156 Val : Portable_Data); 157 -- This is similar in effect, except that the assignment is done in place 158 -- to the supplied Data value, which must be long enough to accomodate the 159 -- given slice (if it is not, then the Invalid_Data exception is raised. 160 161 ------------------------ 162 -- Build_Discrim_List -- 163 ------------------------ 164 165 function Build_Discrim_List 166 (Rec : Entity_Id; 167 Data : Portable_Data) 168 return Discrim_List 169 is 170 begin 171 if Is_Record_Type (Rec) and then Has_Discriminants (Rec) then 172 declare 173 D : Entity_Id; 174 Dis : Discrim_List (1 .. Number_Discriminants (Rec)); 175 176 begin 177 D := First_Discriminant (Rec); 178 for J in Dis'Range loop 179 Dis (J) := Extract_Discriminant (Data, D); 180 D := Next_Discriminant (D); 181 end loop; 182 183 return Dis; 184 end; 185 186 else 187 return Null_Discrims; 188 end if; 189 end Build_Discrim_List; 190 191 ----------- 192 -- Check -- 193 ----------- 194 195 function Check (U : Node_Ref_Or_Val) return Uint is 196 begin 197 if U = No_Uint or else U < 0 then 198 raise Variable_Rep_Info; 199 else 200 return U; 201 end if; 202 end Check; 203 204 function Check (U : Node_Ref_Or_Val) return ASIS_Natural is 205 begin 206 if U = No_Uint or else U < 0 then 207 raise Variable_Rep_Info; 208 209 elsif not UI_Is_In_Aint_Range (U) then 210 raise Invalid_Data; 211 212 else 213 return UI_To_Aint (U); 214 end if; 215 end Check; 216 217 -------------------- 218 -- Check_And_Eval -- 219 -------------------- 220 221 function Check_And_Eval 222 (U : Node_Ref_Or_Val; 223 Discs : Discrim_List) 224 return Uint 225 is 226 begin 227 if U = No_Uint then 228 raise Variable_Rep_Info; 229 else 230 return Rep_Value (U, Discs); 231 end if; 232 end Check_And_Eval; 233 234 function Check_And_Eval 235 (U : Node_Ref_Or_Val; 236 Discs : Discrim_List) 237 return ASIS_Natural 238 is 239 V : Uint; 240 241 begin 242 if U = No_Uint then 243 raise Variable_Rep_Info; 244 245 else 246 V := Rep_Value (U, Discs); 247 248 if not UI_Is_In_Aint_Range (V) then 249 raise Invalid_Data; 250 else 251 return UI_To_Aint (V); 252 end if; 253 end if; 254 end Check_And_Eval; 255 256 ----------------------- 257 -- Component_Present -- 258 ----------------------- 259 260 function Component_Present 261 (Comp : Entity_Id; 262 Discs : Discrim_List) 263 return Boolean 264 is 265 Decl : constant Node_Id := Declaration_Node (Comp); 266 Var : Node_Id; 267 268 function Variant_Present (V : Node_Id) return Boolean; 269 -- Given the N_Variant node and using Discs as the global object 270 -- representing the discriminant list, determines if the given 271 -- variant is present for the given list of discriminant values. 272 -- This includes checking the existance of enclosing variants in case 273 -- if V is a nesed variant, or checking the presence of other 274 -- variants in case if V is 'when OTHERS' variant 275 276 function Variant_Present (V : Node_Id) return Boolean is 277 278 Next_Var : Node_Id; 279 -- Needed to iterate throurg the preceding variants in the 280 -- same variant part 281 282 Result : Boolean := True; 283 284 function Enclosing_Variant (V : Node_Id) return Node_Id; 285 -- Implements Sinfo.Enclosing_Variant, which because of some 286 -- unknown reeason always returns Empty ??? 287 288 function Enclosing_Variant (V : Node_Id) return Node_Id is 289 Result : Node_Id := Empty; 290 begin 291 Result := Parent (Parent (Parent (V))); 292 293 if Nkind (Result) /= N_Variant then 294 Result := Empty; 295 end if; 296 297 return Result; 298 end Enclosing_Variant; 299 300 begin 301 302 if No (V) then 303 -- To stop the recursion in case of nested variants 304 return True; 305 306 else 307 308 Next_Var := First_Non_Pragma (List_Containing (V)); 309 310 while Next_Var /= V loop 311 312 -- Checking that all the preceding variants (if any) do not 313 -- present 314 315 if Rep_Value (Present_Expr (Next_Var), Discs) /= Uint_0 then 316 Result := False; 317 exit; 318 end if; 319 320 Next_Var := Next_Non_Pragma (Next_Var); 321 end loop; 322 323 if Result then 324 -- Checking that the given variant presents "locally" 325 Result := Rep_Value (Present_Expr (V), Discs) /= Uint_0; 326 end if; 327 328 return Result and then Variant_Present (Enclosing_Variant (V)); 329 330 end if; 331 end Variant_Present; 332 333 begin 334 -- If not a component, assume must be present 335 336 if Nkind (Decl) /= N_Component_Declaration then 337 return True; 338 339 -- If not in variant part, assume must be present 340 341 else 342 Var := Parent (Parent (Decl)); 343 344 if Nkind (Var) /= N_Variant then 345 return True; 346 347 -- Otherwise evaluate to see if present 348 349 else 350 return Variant_Present (Var); 351 end if; 352 end if; 353 end Component_Present; 354 355 ------------------------- 356 -- Decode_Scalar_Value -- 357 ------------------------- 358 359 function Decode_Scalar_Value 360 (Typ : Entity_Id; 361 Data : Portable_Data) 362 return Uint 363 is 364 U : Uint; 365 Neg : Boolean; 366 367 begin 368 U := Uint_0; 369 370 -- Determine if input value is negative 371 372 if Is_Unsigned_Type (Typ) or else Has_Biased_Representation (Typ) then 373 Neg := False; 374 375 elsif Default_Bit_Order = High_Order_First then 376 Neg := Data (Data'First) >= 16#80#; 377 else 378 Neg := Data (Data'Last) >= 16#80#; 379 end if; 380 381 -- Negative values of a signed type 382 383 if Neg then 384 385 if Default_Bit_Order = Low_Order_First then 386 for J in reverse Data'Range loop 387 U := U * 256 + Int ((not Data (J))); 388 end loop; 389 390 else 391 for J in Data'Range loop 392 U := U * 256 + Int ((not Data (J))); 393 end loop; 394 end if; 395 396 return -(U + 1); 397 398 -- Non-negative values 399 400 else 401 if Default_Bit_Order = Low_Order_First then 402 for J in reverse Data'Range loop 403 404 U := U * 256 + Int (Data (J)); 405 end loop; 406 407 else 408 for J in Data'Range loop 409 U := U * 256 + Int (Data (J)); 410 end loop; 411 end if; 412 413 -- Remove bias if biased type 414 415 if Has_Biased_Representation (Typ) then 416 return U + Eval_Scalar_Node 417 (Type_Low_Bound (First_Subtype (Typ))); 418 else 419 return U; 420 end if; 421 end if; 422 end Decode_Scalar_Value; 423 424 ------------------------- 425 -- Encode_Scalar_Value -- 426 ------------------------- 427 428 function Encode_Scalar_Value 429 (Typ : Entity_Id; 430 Val : ASIS_Integer) 431 return Portable_Data 432 is 433 begin 434 return Encode_Scalar_Value (Typ, UI_From_Aint (Val)); 435 end Encode_Scalar_Value; 436 437 function Encode_Scalar_Value 438 (Typ : Entity_Id; 439 Val : Uint) 440 return Portable_Data 441 is 442 V : Uint := Val; 443 L : Portable_Positive; 444 445 Lo : constant Uint := 446 Eval_Scalar_Node (Type_Low_Bound (Base_Type (Typ))); 447 448 Hi : constant Uint := 449 Eval_Scalar_Node (Type_High_Bound (Base_Type (Typ))); 450 451 Enum_Lit : Entity_Id; 452 Match_Found : Boolean := False; 453 454 begin 455 -- If we have an enumeration type that has a representation 456 -- specification, Val corresponds to the value defined by this 457 -- specification, but we need a positional number here 458 459 if Ekind (Typ) = E_Enumeration_Type 460 and then 461 Has_Enumeration_Rep_Clause (Typ) 462 then 463 Enum_Lit := First_Literal (Typ); 464 465 while Present (Enum_Lit) loop 466 if V = Enumeration_Rep (Enum_Lit) then 467 V := Enumeration_Pos (Enum_Lit); 468 Match_Found := True; 469 exit; 470 end if; 471 472 Enum_Lit := Next (Enum_Lit); 473 end loop; 474 475 if not Match_Found then 476 raise Invalid_Data; 477 end if; 478 end if; 479 480 if V < Lo or else V > Hi then 481 raise Invalid_Data; 482 end if; 483 484 V := Val; 485 486 -- If biased type, then introduce bias 487 488 if Has_Biased_Representation (Typ) then 489 V := V - Eval_Scalar_Node (Type_Low_Bound (First_Subtype (Typ))); 490 end if; 491 492 -- Negative values (type must be signed). In these cases we adjust 493 -- to get the corresponding unsigned value (which will look to be 494 -- appropriately sign extended when it is stored in the output) 495 496 if V < 0 then 497 if V >= -(Uint_2 ** 7) then 498 V := Uint_2 ** 8 + V; 499 L := 1; 500 501 elsif V >= -(Uint_2 ** 15) then 502 V := Uint_2 ** 16 + V; 503 L := 2; 504 505 elsif V >= -(Uint_2 ** 31) then 506 V := Uint_2 ** 32 + V; 507 L := 4; 508 509 elsif V >= -(Uint_2 ** 63) then 510 V := Uint_2 ** 64 + V; 511 L := 8; 512 513 else 514 raise Invalid_Data; 515 end if; 516 517 -- Non-negative values of unsigned types 518 519 elsif Is_Unsigned_Type (Typ) 520 or else Has_Biased_Representation (Typ) 521 then 522 if V < Uint_2 ** 8 then 523 L := 1; 524 525 elsif V < Uint_2 ** 16 then 526 L := 2; 527 528 elsif V < Uint_2 ** 32 then 529 L := 4; 530 531 elsif V < Uint_2 ** 64 then 532 L := 8; 533 534 else 535 raise Invalid_Data; 536 end if; 537 538 -- Non-negative values of signed types 539 540 else 541 if V < Uint_2 ** 7 then 542 L := 1; 543 544 elsif V < Uint_2 ** 15 then 545 L := 2; 546 547 elsif V < Uint_2 ** 31 then 548 L := 4; 549 550 elsif V < Uint_2 ** 63 then 551 L := 8; 552 553 else 554 raise Invalid_Data; 555 end if; 556 557 end if; 558 559 declare 560 Data : Portable_Data (1 .. L); 561 562 begin 563 if Default_Bit_Order = High_Order_First then 564 for J in reverse Data'Range loop 565 Data (J) := Portable_Value (UI_To_Int (V mod 256)); 566 V := V / 256; 567 end loop; 568 569 else 570 for J in Data'Range loop 571 Data (J) := Portable_Value (UI_To_Int (V mod 256)); 572 V := V / 256; 573 end loop; 574 end if; 575 576 return Data; 577 end; 578 end Encode_Scalar_Value; 579 580 ---------------------- 581 -- Eval_Scalar_Node -- 582 ---------------------- 583 584 function Eval_Scalar_Node 585 (N : Node_Id; 586 Discs : Discrim_List := Null_Discrims) 587 return Uint 588 is 589 Dnum : Uint; 590 Ent : Entity_Id; 591 592 begin 593 -- Case of discriminant reference 594 595 if Nkind (N) = N_Identifier 596 and then Ekind (Entity (N)) = E_Discriminant 597 then 598 Dnum := Discriminant_Number (Entity (N)); 599 600 if Dnum > Discs'Last then 601 raise Constraint_Error; 602 else 603 return Discs (UI_To_Int (Dnum)); 604 end if; 605 606 -- Case of static expression, note that we cannot use Expr_Value 607 -- here, since we cannot afford to drag in all of Sem_Eval. 608 609 elsif Is_Static_Expression (N) then 610 611 -- Identifier case 612 613 if Nkind (N) = N_Identifier then 614 Ent := Entity (N); 615 616 -- Enumeration literal, we need the Pos value 617 618 if Ekind (Ent) = E_Enumeration_Literal then 619 return Enumeration_Pos (Ent); 620 621 -- A user defined static constant 622 623 else 624 return Eval_Scalar_Node (Constant_Value (Ent), Discs); 625 end if; 626 627 -- Integer literal 628 629 elsif Nkind (N) = N_Integer_Literal then 630 return Intval (N); 631 632 -- Only other possibility is a character literal 633 634 else 635 Ent := Entity (N); 636 637 -- Since Character literals of type Standard.Character don't 638 -- have any defining character literals built for them, they 639 -- do not have their Entity set, so just use their Char 640 -- code. Otherwise for user-defined character literals use 641 -- their Pos value as usual. 642 643 if No (Ent) then 644 return Char_Literal_Value (N); 645 646 -- Enumeration literal other than a character literal defined in 647 -- Standard, we need the Pos value 648 649 elsif Ekind (Ent) = E_Enumeration_Literal then 650 return Enumeration_Pos (Ent); 651 652 -- A user defined static constant 653 654 else 655 return Eval_Scalar_Node (Constant_Value (Ent), Discs); 656 657 -- ??? There is at least one more case which can not handled 658 -- properly yet: N is a reference to a component of a static 659 -- record object 660 661 end if; 662 663 end if; 664 665 -- If not static expression, or discriminant, cannot get bounds 666 667 else 668 raise Variable_Rep_Info; 669 end if; 670 end Eval_Scalar_Node; 671 672 ----------------------------- 673 -- Extract_Array_Component -- 674 ----------------------------- 675 676 function Extract_Array_Component 677 (Typ : Entity_Id; 678 Data : Portable_Data; 679 Subs : Dimension_Indexes; 680 Discs : Discrim_List := Null_Discrims) 681 return Portable_Data 682 is 683 N : constant ASIS_Natural := Linear_Index (Typ, Subs, Discs); 684 S : constant ASIS_Natural := UI_To_Aint (Get_Component_Size (Typ)); 685 F : constant ASIS_Natural := N * S; 686 687 begin 688 return Extract_Field (Data, F, S, Component_Type (Typ)); 689 end Extract_Array_Component; 690 691 ------------------- 692 -- Extract_Field -- 693 ------------------- 694 695 function Extract_Field 696 (Data : Portable_Data; 697 Start : ASIS_Natural; 698 Len : ASIS_Natural; 699 Typ : Entity_Id) 700 return Portable_Data 701 is 702 P : constant Bit_String_Ptr := To_Bit_String_Ptr (Data'Address); 703 RL : ASIS_Natural; 704 L : ASIS_Natural; 705 706 Uns : constant Boolean := Is_Unsigned_Type (Typ) 707 or else Has_Biased_Representation (Typ); 708 709 begin 710 -- Here for non-scalar case, in this case, we simply build a 711 -- portable data value that is the right length, rounded up to 712 -- the next byte as needed, and then copy the bits to the target 713 -- padding at the end with zero bits. 714 715 if not Is_Scalar_Type (Typ) then 716 declare 717 Res : aliased Portable_Data (1 .. (Len + (SU - 1)) / SU); 718 RP : constant Bit_String_Ptr := To_Bit_String_Ptr (Res'Address); 719 720 begin 721 RP (0 .. Len - 1) := P (Start .. Start + Len - 1); 722 RP (Len .. Res'Length * SU - 1) := (others => 0); 723 return Res; 724 end; 725 726 -- For scalar types, things are more complex, since we have to deal 727 -- with proper endian handling and proper sign/zero extension. 728 729 else 730 -- First job is to find length of result 731 732 L := Len; 733 734 if L <= 8 then 735 RL := 1; 736 737 elsif L <= 16 then 738 RL := 2; 739 740 elsif L <= 32 then 741 RL := 4; 742 743 else 744 RL := 8; 745 746 -- Deal with case where there are unused bits 747 748 if L > 64 then 749 L := 64; 750 end if; 751 end if; 752 753 declare 754 Res : aliased Portable_Data (1 .. RL); 755 RP : constant Bit_String_Ptr := To_Bit_String_Ptr (Res'Address); 756 Ptr : ASIS_Integer; 757 SX : Bit; 758 759 begin 760 -- Big-endian case. In this case we fill the result from right 761 -- to left, since we want the result right justified, and then 762 -- zero/sign fill on the left (i.e. at low numbered bits). 763 764 if Default_Bit_Order = High_Order_First then 765 Ptr := RL * SU - 1; 766 767 for J in reverse Start .. Start + Len - 1 loop 768 RP (Ptr) := P (J); 769 Ptr := Ptr - 1; 770 end loop; 771 772 if Uns then 773 SX := 0; 774 else 775 SX := P (Start); 776 end if; 777 778 for J in reverse 0 .. Ptr loop 779 RP (J) := SX; 780 end loop; 781 782 -- Little-endian case. In this case, we fill the result from 783 -- the left to right, since we want the result left justified, 784 -- and then zero/sign on the right (i.e. at high numbered bits) 785 786 else 787 Ptr := 0; 788 789 for J in Start .. Start + Len - 1 loop 790 RP (Ptr) := P (J); 791 Ptr := Ptr + 1; 792 end loop; 793 794 if Uns then 795 SX := 0; 796 else 797 SX := P (Start + Len - 1); 798 end if; 799 800 for J in Ptr .. RL * SU - 1 loop 801 RP (J) := SX; 802 end loop; 803 end if; 804 805 return Res; 806 end; 807 end if; 808 end Extract_Field; 809 810 ------------------------------ 811 -- Extract_Record_Component -- 812 ------------------------------ 813 814 function Extract_Record_Component 815 (Data : Portable_Data; 816 Comp : Entity_Id; 817 Discs : Discrim_List := Null_Discrims) 818 return Portable_Data 819 is 820 begin 821 if Component_Present (Comp, Discs) then 822 return 823 Extract_Field 824 (Data => Data, 825 Start => Check_And_Eval (Component_Bit_Offset (Comp), Discs), 826 Len => Check_And_Eval (Esize (Comp), Discs), 827 Typ => Etype (Comp)); 828 829 else 830 raise No_Component; 831 end if; 832 end Extract_Record_Component; 833 834 -------------------------- 835 -- Extract_Discriminant -- 836 -------------------------- 837 838 function Extract_Discriminant 839 (Data : Portable_Data; 840 Disc : Entity_Id) 841 return Uint 842 is 843 begin 844 return 845 Decode_Scalar_Value 846 (Etype (Disc), 847 Extract_Field 848 (Data => Data, 849 Start => Check (Component_Bit_Offset (Disc)), 850 Len => Check (Esize (Disc)), 851 Typ => Etype (Disc))); 852 end Extract_Discriminant; 853 854 ------------------------------ 855 -- Get_Component_Bit_Offset -- 856 ------------------------------ 857 858 function Get_Component_Bit_Offset 859 (Comp : Entity_Id; 860 Discs : Discrim_List := Null_Discrims) 861 return Uint 862 is 863 begin 864 if Component_Present (Comp, Discs) then 865 return Check_And_Eval (Component_Bit_Offset (Comp), Discs); 866 else 867 raise No_Component; 868 end if; 869 end Get_Component_Bit_Offset; 870 871 ------------------------ 872 -- Get_Component_Size -- 873 ------------------------ 874 875 function Get_Component_Size (Typ : Entity_Id) return Uint is 876 begin 877 return Check (Component_Size (Typ)); 878 end Get_Component_Size; 879 880 --------------- 881 -- Get_Esize -- 882 --------------- 883 884 function Get_Esize 885 (Comp : Entity_Id; 886 Discs : Discrim_List := Null_Discrims) 887 return Uint 888 is 889 begin 890 if Component_Present (Comp, Discs) then 891 return Check_And_Eval (Esize (Comp), Discs); 892 else 893 raise No_Component; 894 end if; 895 end Get_Esize; 896 897 ---------------- 898 -- Get_Length -- 899 ---------------- 900 901 function Get_Length 902 (Typ : Entity_Id; 903 Sub : ASIS_Positive; 904 Discs : Discrim_List := Null_Discrims) 905 return ASIS_Natural 906 is 907 N : Node_Id; 908 T : Entity_Id; 909 L : Node_Id; 910 U : Node_Id; 911 912 begin 913 N := First_Index (Typ); 914 for J in 1 .. Sub - 1 loop 915 N := Next_Index (N); 916 end loop; 917 918 T := Etype (N); 919 920 L := Type_Low_Bound (T); 921 922 U := Type_High_Bound (T); 923 924 return 925 UI_To_Aint 926 (UI_Max (0, Eval_Scalar_Node (U, Discs) 927 - Eval_Scalar_Node (L, Discs) 928 + 1)); 929 end Get_Length; 930 931 ------------------ 932 -- Linear_Index -- 933 ------------------ 934 935 function Linear_Index 936 (Typ : Entity_Id; 937 Subs : Dimension_Indexes; 938 Discs : Discrim_List := Null_Discrims) 939 return ASIS_Natural 940 is 941 Indx : ASIS_Natural; 942 Len : ASIS_Positive; 943 944 begin 945 Indx := 0; 946 947 -- For the normal case, we are row major 948 949 if Convention (Typ) /= Convention_Fortran then 950 for J in Subs'Range loop 951 Len := Get_Length (Typ, J, Discs); 952 953 if Subs (J) > Len then 954 raise No_Component; 955 else 956 Indx := Indx * Len + Subs (J) - 1; 957 end if; 958 end loop; 959 960 -- For Fortran, we are column major 961 962 else 963 for J in reverse Subs'Range loop 964 Len := Get_Length (Typ, J, Discs); 965 966 if Subs (J) > Len then 967 raise No_Component; 968 else 969 Indx := Indx * Len + Subs (J) - 1; 970 end if; 971 end loop; 972 end if; 973 974 return Indx; 975 end Linear_Index; 976 977 ------------------------- 978 -- Set_Array_Component -- 979 ------------------------- 980 981 function Set_Array_Component 982 (Typ : Entity_Id; 983 Data : Portable_Data; 984 Subs : Dimension_Indexes; 985 Val : Portable_Data; 986 Discs : Discrim_List := Null_Discrims) 987 return Portable_Data 988 is 989 N : constant ASIS_Natural := Linear_Index (Typ, Subs, Discs); 990 S : constant ASIS_Natural := UI_To_Aint (Get_Component_Size (Typ)); 991 F : constant ASIS_Natural := N * S; 992 993 begin 994 return Set_Field (Data, F, S, Component_Type (Typ), Val); 995 end Set_Array_Component; 996 997 procedure Set_Array_Component 998 (Typ : Entity_Id; 999 Data : in out Portable_Data; 1000 Subs : Dimension_Indexes; 1001 Val : Portable_Data; 1002 Discs : Discrim_List := Null_Discrims) 1003 is 1004 N : constant ASIS_Natural := Linear_Index (Typ, Subs, Discs); 1005 S : constant ASIS_Natural := UI_To_Aint (Get_Component_Size (Typ)); 1006 F : constant ASIS_Natural := N * S; 1007 1008 begin 1009 Set_Field (Data, F, S, Component_Type (Typ), Val); 1010 end Set_Array_Component; 1011 1012 ---------------------- 1013 -- Set_Discriminant -- 1014 ---------------------- 1015 1016 function Set_Discriminant 1017 (Data : Portable_Data; 1018 Disc : Entity_Id; 1019 Val : Uint) 1020 return Portable_Data 1021 is 1022 F : constant ASIS_Natural := Check (Component_Bit_Offset (Disc)); 1023 S : constant ASIS_Natural := Check (Esize (Disc)); 1024 T : constant Entity_Id := Etype (Disc); 1025 1026 begin 1027 return Set_Field (Data, F, S, T, Encode_Scalar_Value (T, Val)); 1028 end Set_Discriminant; 1029 1030 procedure Set_Discriminant 1031 (Data : in out Portable_Data; 1032 Disc : Entity_Id; 1033 Val : Uint) 1034 is 1035 F : constant ASIS_Natural := Check (Component_Bit_Offset (Disc)); 1036 S : constant ASIS_Natural := Check (Esize (Disc)); 1037 T : constant Entity_Id := Etype (Disc); 1038 1039 begin 1040 Set_Field (Data, F, S, T, Encode_Scalar_Value (T, Val)); 1041 end Set_Discriminant; 1042 1043 function Set_Discriminant 1044 (Data : Portable_Data; 1045 Disc : Entity_Id; 1046 Val : ASIS_Integer) 1047 return Portable_Data 1048 is 1049 F : constant ASIS_Natural := Check (Component_Bit_Offset (Disc)); 1050 S : constant ASIS_Natural := Check (Esize (Disc)); 1051 T : constant Entity_Id := Etype (Disc); 1052 1053 begin 1054 return Set_Field (Data, F, S, T, Encode_Scalar_Value (T, Val)); 1055 end Set_Discriminant; 1056 1057 procedure Set_Discriminant 1058 (Data : in out Portable_Data; 1059 Disc : Entity_Id; 1060 Val : ASIS_Integer) 1061 is 1062 F : constant ASIS_Natural := Check (Component_Bit_Offset (Disc)); 1063 S : constant ASIS_Natural := Check (Esize (Disc)); 1064 T : constant Entity_Id := Etype (Disc); 1065 1066 begin 1067 Set_Field (Data, F, S, T, Encode_Scalar_Value (T, Val)); 1068 end Set_Discriminant; 1069 1070 --------------- 1071 -- Set_Field -- 1072 --------------- 1073 1074 function Set_Field 1075 (Data : Portable_Data; 1076 Start : ASIS_Natural; 1077 Len : ASIS_Natural; 1078 Typ : Entity_Id; 1079 Val : Portable_Data) 1080 return Portable_Data 1081 is 1082 Req_Bytes : constant ASIS_Natural := (Start + Len + (SU - 1)) / SU; 1083 1084 begin 1085 if Data'Length >= Req_Bytes then 1086 declare 1087 Result : Portable_Data := Data; 1088 1089 begin 1090 Set_Field (Result, Start, Len, Typ, Val); 1091 return Result; 1092 end; 1093 1094 -- Extension of the value is needed 1095 1096 else 1097 declare 1098 Result : Portable_Data (1 .. Req_Bytes); 1099 1100 begin 1101 Result (1 .. Data'Length) := Data; 1102 1103 for J in Data'Length + 1 .. Result'Length loop 1104 Result (J) := 0; 1105 end loop; 1106 1107 Set_Field (Result, Start, Len, Typ, Val); 1108 return Result; 1109 end; 1110 end if; 1111 end Set_Field; 1112 1113 procedure Set_Field 1114 (Data : in out Portable_Data; 1115 Start : ASIS_Natural; 1116 Len : ASIS_Natural; 1117 Typ : Entity_Id; 1118 Val : Portable_Data) 1119 is 1120 Req_Bytes : constant ASIS_Natural := (Start + Len + (SU - 1)) / SU; 1121 Val_Bits : constant ASIS_Natural := Val'Length * SU; 1122 Min_Size : constant ASIS_Natural := ASIS_Natural'Min (Len, Val_Bits); 1123 1124 D : constant Bit_String_Ptr := To_Bit_String_Ptr (Data'Address); 1125 V : constant Bit_String_Ptr := To_Bit_String_Ptr (Val'Address); 1126 1127 SX : Bit; 1128 -- 0 or 1 for zero or sign extension 1129 1130 Uns : constant Boolean := Is_Unsigned_Type (Typ) 1131 or else Has_Biased_Representation (Typ); 1132 1133 begin 1134 -- Error if length of data not sufficient to accomodate new field 1135 1136 if Data'Length < Req_Bytes then 1137 raise Constraint_Error; 1138 end if; 1139 1140 -- Case of non-scalar type, in this case, we simply copy the data 1141 -- from the start of Val into place in the target, filling in only 1142 -- those bits corresponding to the actual field in the target. 1143 1144 if not Is_Scalar_Type (Typ) then 1145 1146 -- Error if supplied value is too short 1147 1148 if Val_Bits < Len then 1149 raise Invalid_Data; 1150 end if; 1151 1152 -- Otherwise copy in the required bits. Note that we do not 1153 -- check uncopied bits of the original field in this case. 1154 1155 for J in 0 .. Len - 1 loop 1156 D (J + Start) := V (J); 1157 end loop; 1158 1159 return; 1160 1161 -- For a scalar type, things are more complicated, since we need 1162 -- to store the right set of bits, and then zero or sign extend. 1163 -- We also need to check that the value being stored is not too 1164 -- large, i.e. any unstored bits are zero or sign bits as required. 1165 1166 -- For the little endian case, we store bits from the left end, 1167 -- low numbered bit first, i.e. low order bit first) 1168 1169 elsif Default_Bit_Order = Low_Order_First then 1170 1171 pragma Warnings (On, Default_Bit_Order); 1172 1173 for J in 0 .. Min_Size - 1 loop 1174 D (J + Start) := V (J); 1175 end loop; 1176 1177 -- Find proper extension bit 1178 1179 if Uns or else V (Min_Size - 1) = 0 then 1180 SX := 0; 1181 else 1182 SX := 1; 1183 end if; 1184 1185 -- If unstored bits, they must all be sign/zero extension bits 1186 1187 if Len < Val_Bits then 1188 for J in Len .. Val_Bits - 1 loop 1189 if V (J) /= SX then 1190 raise Invalid_Data; 1191 end if; 1192 end loop; 1193 1194 -- Otherwise, store sign/zero extension bits in rest of target 1195 1196 else -- Len >= Val_Bits 1197 for J in Val_Bits .. Len - 1 loop 1198 D (J + Start) := SX; 1199 end loop; 1200 end if; 1201 1202 return; 1203 1204 -- For the little endian case, we store bits from the right end, 1205 -- high numbered bit first, i.e. low order bit first) 1206 1207 else -- Default_Bit_Order = High_Order_First then 1208 1209 for J in 0 .. Min_Size - 1 loop 1210 D (Start + Len - 1 - J) := V (Val_Bits - 1 - J); 1211 end loop; 1212 1213 -- Find proper extension bit 1214 1215 if Uns or else V (Val_Bits - Min_Size) = 0 then 1216 SX := 0; 1217 else 1218 SX := 1; 1219 end if; 1220 1221 -- If unstored bits, they must all be sign/zero extension bits 1222 1223 if Len < Val_Bits then 1224 for J in Len .. Val_Bits - 1 loop 1225 if V (Val_Bits - 1 - J) /= SX then 1226 raise Invalid_Data; 1227 end if; 1228 end loop; 1229 1230 -- Otherwise, store sign/zero extension bits in rest of target 1231 1232 else -- Len >= Val_Bits 1233 for J in Val_Bits .. Len - 1 loop 1234 D (Start + Len - 1 - J) := SX; 1235 end loop; 1236 end if; 1237 1238 return; 1239 end if; 1240 end Set_Field; 1241 1242 -------------------------- 1243 -- Set_Record_Component -- 1244 -------------------------- 1245 1246 function Set_Record_Component 1247 (Data : Portable_Data; 1248 Comp : Entity_Id; 1249 Val : Portable_Data; 1250 Discs : Discrim_List := Null_Discrims) 1251 return Portable_Data 1252 is 1253 F : constant ASIS_Natural := 1254 Check_And_Eval (Component_Bit_Offset (Comp), Discs); 1255 1256 S : constant ASIS_Natural := Check_And_Eval (Esize (Comp), Discs); 1257 1258 begin 1259 if Component_Present (Comp, Discs) then 1260 return Set_Field (Data, F, S, Etype (Comp), Val); 1261 else 1262 raise No_Component; 1263 end if; 1264 end Set_Record_Component; 1265 1266 procedure Set_Record_Component 1267 (Data : in out Portable_Data; 1268 Comp : Entity_Id; 1269 Val : Portable_Data; 1270 Discs : Discrim_List := Null_Discrims) 1271 is 1272 F : constant ASIS_Natural := 1273 Check_And_Eval (Component_Bit_Offset (Comp), Discs); 1274 1275 S : constant ASIS_Natural := Check_And_Eval (Esize (Comp), Discs); 1276 1277 begin 1278 if Component_Present (Comp, Discs) then 1279 Set_Field (Data, F, S, Etype (Comp), Val); 1280 else 1281 raise No_Component; 1282 end if; 1283 end Set_Record_Component; 1284 1285 ------------------ 1286 -- UI_From_Aint -- 1287 ------------------ 1288 1289 -- Due to the somewhat unfortunate choice of ASIS_Integer to be Integer 1290 -- rather than Int, there is no very simple way of doing this accurately. 1291 -- In fact, on all targets so far Integer and Int are the same type so 1292 -- we can simply assume that this test is OK. 1293 1294 -- The following static assertions verify this assumption: 1295 1296-- Assert_1 : constant := 1 / Boolean'Pos 1297-- (Int'Pos (Int'First) = ASIS_Integer'Pos (ASIS_Integer'First)); 1298 1299-- Assert_2 : constant := 1 / Boolean'Pos 1300-- (Int'Pos (Int'Last) = ASIS_Integer'Pos (ASIS_Integer'Last)); 1301 1302 function UI_From_Aint (A : ASIS_Integer) return Uint is 1303 begin 1304 return UI_From_Int (Int (A)); 1305 end UI_From_Aint; 1306 1307 ------------------------- 1308 -- UI_Is_In_Aint_Range -- 1309 ------------------------- 1310 1311 -- See comment and assertions for UI_From_Aint which also apply here 1312 1313 function UI_Is_In_Aint_Range (U : Uint) return Boolean is 1314 begin 1315 return UI_Is_In_Int_Range (U); 1316 end UI_Is_In_Aint_Range; 1317 1318 ---------------- 1319 -- UI_To_Aint -- 1320 ---------------- 1321 1322 function UI_To_Aint (U : Uint) return ASIS_Integer is 1323 begin 1324 if UI_Is_In_Aint_Range (U) then 1325 return ASIS_Integer (UI_To_Int (U)); 1326 else 1327 raise Invalid_Data; 1328 end if; 1329 end UI_To_Aint; 1330 1331end A4G.DDA_Aux; 1332