1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E T _ T A R G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2013-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 Debug; use Debug; 27with Get_Targ; use Get_Targ; 28with Opt; use Opt; 29with Output; use Output; 30 31with System; use System; 32with System.OS_Lib; use System.OS_Lib; 33 34with Unchecked_Conversion; 35 36package body Set_Targ is 37 38 -------------------------------------------------------- 39 -- Data Used to Read/Write Target Dependent Info File -- 40 -------------------------------------------------------- 41 42 -- Table of string names written to file 43 44 subtype Str is String; 45 46 S_Bits_BE : constant Str := "Bits_BE"; 47 S_Bits_Per_Unit : constant Str := "Bits_Per_Unit"; 48 S_Bits_Per_Word : constant Str := "Bits_Per_Word"; 49 S_Bytes_BE : constant Str := "Bytes_BE"; 50 S_Char_Size : constant Str := "Char_Size"; 51 S_Double_Float_Alignment : constant Str := "Double_Float_Alignment"; 52 S_Double_Scalar_Alignment : constant Str := "Double_Scalar_Alignment"; 53 S_Double_Size : constant Str := "Double_Size"; 54 S_Float_Size : constant Str := "Float_Size"; 55 S_Float_Words_BE : constant Str := "Float_Words_BE"; 56 S_Int_Size : constant Str := "Int_Size"; 57 S_Long_Double_Size : constant Str := "Long_Double_Size"; 58 S_Long_Long_Long_Size : constant Str := "Long_Long_Long_Size"; 59 S_Long_Long_Size : constant Str := "Long_Long_Size"; 60 S_Long_Size : constant Str := "Long_Size"; 61 S_Maximum_Alignment : constant Str := "Maximum_Alignment"; 62 S_Max_Unaligned_Field : constant Str := "Max_Unaligned_Field"; 63 S_Pointer_Size : constant Str := "Pointer_Size"; 64 S_Short_Enums : constant Str := "Short_Enums"; 65 S_Short_Size : constant Str := "Short_Size"; 66 S_Strict_Alignment : constant Str := "Strict_Alignment"; 67 S_System_Allocator_Alignment : constant Str := "System_Allocator_Alignment"; 68 S_Wchar_T_Size : constant Str := "Wchar_T_Size"; 69 S_Words_BE : constant Str := "Words_BE"; 70 71 -- Table of names 72 73 type AStr is access all String; 74 75 DTN : constant array (Nat range <>) of AStr := ( 76 S_Bits_BE 'Unrestricted_Access, 77 S_Bits_Per_Unit 'Unrestricted_Access, 78 S_Bits_Per_Word 'Unrestricted_Access, 79 S_Bytes_BE 'Unrestricted_Access, 80 S_Char_Size 'Unrestricted_Access, 81 S_Double_Float_Alignment 'Unrestricted_Access, 82 S_Double_Scalar_Alignment 'Unrestricted_Access, 83 S_Double_Size 'Unrestricted_Access, 84 S_Float_Size 'Unrestricted_Access, 85 S_Float_Words_BE 'Unrestricted_Access, 86 S_Int_Size 'Unrestricted_Access, 87 S_Long_Double_Size 'Unrestricted_Access, 88 S_Long_Long_Long_Size 'Unrestricted_Access, 89 S_Long_Long_Size 'Unrestricted_Access, 90 S_Long_Size 'Unrestricted_Access, 91 S_Maximum_Alignment 'Unrestricted_Access, 92 S_Max_Unaligned_Field 'Unrestricted_Access, 93 S_Pointer_Size 'Unrestricted_Access, 94 S_Short_Enums 'Unrestricted_Access, 95 S_Short_Size 'Unrestricted_Access, 96 S_Strict_Alignment 'Unrestricted_Access, 97 S_System_Allocator_Alignment 'Unrestricted_Access, 98 S_Wchar_T_Size 'Unrestricted_Access, 99 S_Words_BE 'Unrestricted_Access); 100 101 -- Table of corresponding value pointers 102 103 DTV : constant array (Nat range <>) of System.Address := ( 104 Bits_BE 'Address, 105 Bits_Per_Unit 'Address, 106 Bits_Per_Word 'Address, 107 Bytes_BE 'Address, 108 Char_Size 'Address, 109 Double_Float_Alignment 'Address, 110 Double_Scalar_Alignment 'Address, 111 Double_Size 'Address, 112 Float_Size 'Address, 113 Float_Words_BE 'Address, 114 Int_Size 'Address, 115 Long_Double_Size 'Address, 116 Long_Long_Long_Size 'Address, 117 Long_Long_Size 'Address, 118 Long_Size 'Address, 119 Maximum_Alignment 'Address, 120 Max_Unaligned_Field 'Address, 121 Pointer_Size 'Address, 122 Short_Enums 'Address, 123 Short_Size 'Address, 124 Strict_Alignment 'Address, 125 System_Allocator_Alignment 'Address, 126 Wchar_T_Size 'Address, 127 Words_BE 'Address); 128 129 DTR : array (Nat range DTV'Range) of Boolean := (others => False); 130 -- Table of flags used to validate that all values are present in file 131 132 ----------------------- 133 -- Local Subprograms -- 134 ----------------------- 135 136 procedure Read_Target_Dependent_Values (File_Name : String); 137 -- Read target dependent values from File_Name, and set the target 138 -- dependent values (global variables) declared in this package. 139 140 procedure Fail (E : String); 141 pragma No_Return (Fail); 142 -- Terminate program with fatal error message passed as parameter 143 144 procedure Register_Float_Type 145 (Name : C_String; 146 Digs : Natural; 147 Complex : Boolean; 148 Count : Natural; 149 Float_Rep : Float_Rep_Kind; 150 Precision : Positive; 151 Size : Positive; 152 Alignment : Natural); 153 pragma Convention (C, Register_Float_Type); 154 -- Call back to allow the back end to register available types. This call 155 -- back makes entries in the FPT_Mode_Table for any floating point types 156 -- reported by the back end. Name is the name of the type as a normal 157 -- format Null-terminated string. Digs is the number of digits, where 0 158 -- means it is not a fpt type (ignored during registration). Complex is 159 -- non-zero if the type has real and imaginary parts (also ignored during 160 -- registration). Count is the number of elements in a vector type (zero = 161 -- not a vector, registration ignores vectors). Float_Rep shows the kind of 162 -- floating-point type, and Precision, Size and Alignment are the precision 163 -- size and alignment in bits. 164 -- 165 -- The only types that are actually registered have Digs non-zero, Complex 166 -- zero (false), and Count zero (not a vector). The Long_Double_Index 167 -- variable below is updated to indicate the index at which a "long double" 168 -- type can be found if it gets registered at all. 169 170 Long_Double_Index : Integer := -1; 171 -- Once all the floating point types have been registered, the index in 172 -- FPT_Mode_Table at which "long double" can be found, if anywhere. A 173 -- negative value means that no "long double" has been registered. This 174 -- is useful to know whether we have a "long double" available at all and 175 -- get at it's characteristics without having to search the FPT_Mode_Table 176 -- when we need to decide which C type should be used as the basis for 177 -- Long_Long_Float in Ada. 178 179 function FPT_Mode_Index_For (Name : String) return Natural; 180 -- Return the index in FPT_Mode_Table that designates the entry 181 -- corresponding to the C type named Name. Raise Program_Error if 182 -- there is no such entry. 183 184 function FPT_Mode_Index_For (T : S_Float_Types) return Natural; 185 -- Return the index in FPT_Mode_Table that designates the entry for 186 -- a back-end type suitable as a basis to construct the standard Ada 187 -- floating point type identified by T. 188 189 ---------------- 190 -- C_Type_For -- 191 ---------------- 192 193 function C_Type_For (T : S_Float_Types) return String is 194 195 -- ??? For now, we don't have a good way to tell the widest float 196 -- type with hardware support. Basically, GCC knows the size of that 197 -- type, but on x86-64 there often are two or three 128-bit types, 198 -- one double extended that has 18 decimal digits, a 128-bit quad 199 -- precision type with 33 digits and possibly a 128-bit decimal float 200 -- type with 34 digits. As a workaround, we define Long_Long_Float as 201 -- C's "long double" if that type exists and has at most 18 digits, 202 -- or otherwise the same as Long_Float. 203 204 Max_HW_Digs : constant := 18; 205 -- Maximum hardware digits supported 206 207 begin 208 case T is 209 when S_Float 210 | S_Short_Float 211 => 212 return "float"; 213 214 when S_Long_Float => 215 return "double"; 216 217 when S_Long_Long_Float => 218 if Long_Double_Index >= 0 219 and then FPT_Mode_Table (Long_Double_Index).DIGS <= Max_HW_Digs 220 then 221 return "long double"; 222 else 223 return "double"; 224 end if; 225 end case; 226 end C_Type_For; 227 228 ---------- 229 -- Fail -- 230 ---------- 231 232 procedure Fail (E : String) is 233 E_Fatal : constant := 4; 234 -- Code for fatal error 235 236 begin 237 Write_Str (E); 238 Write_Eol; 239 OS_Exit (E_Fatal); 240 end Fail; 241 242 ------------------------ 243 -- FPT_Mode_Index_For -- 244 ------------------------ 245 246 function FPT_Mode_Index_For (Name : String) return Natural is 247 begin 248 for J in FPT_Mode_Table'First .. Num_FPT_Modes loop 249 if FPT_Mode_Table (J).NAME.all = Name then 250 return J; 251 end if; 252 end loop; 253 254 raise Program_Error; 255 end FPT_Mode_Index_For; 256 257 function FPT_Mode_Index_For (T : S_Float_Types) return Natural is 258 begin 259 return FPT_Mode_Index_For (C_Type_For (T)); 260 end FPT_Mode_Index_For; 261 262 ------------------------- 263 -- Register_Float_Type -- 264 ------------------------- 265 266 procedure Register_Float_Type 267 (Name : C_String; 268 Digs : Natural; 269 Complex : Boolean; 270 Count : Natural; 271 Float_Rep : Float_Rep_Kind; 272 Precision : Positive; 273 Size : Positive; 274 Alignment : Natural) 275 is 276 T : String (1 .. Name'Length); 277 Last : Natural := 0; 278 279 procedure Dump; 280 -- Dump information given by the back end for the type to register 281 282 ---------- 283 -- Dump -- 284 ---------- 285 286 procedure Dump is 287 begin 288 Write_Str ("type " & T (1 .. Last) & " is "); 289 290 if Count > 0 then 291 Write_Str ("array (1 .. "); 292 Write_Int (Int (Count)); 293 294 if Complex then 295 Write_Str (", 1 .. 2"); 296 end if; 297 298 Write_Str (") of "); 299 300 elsif Complex then 301 Write_Str ("array (1 .. 2) of "); 302 end if; 303 304 if Digs > 0 then 305 Write_Str ("digits "); 306 Write_Int (Int (Digs)); 307 Write_Line (";"); 308 309 Write_Str ("pragma Float_Representation ("); 310 311 case Float_Rep is 312 when AAMP => Write_Str ("AAMP"); 313 when IEEE_Binary => Write_Str ("IEEE"); 314 end case; 315 316 Write_Line (", " & T (1 .. Last) & ");"); 317 318 else 319 Write_Str ("mod 2**"); 320 Write_Int (Int (Precision / Positive'Max (1, Count))); 321 Write_Line (";"); 322 end if; 323 324 if Precision = Size then 325 Write_Str ("for " & T (1 .. Last) & "'Size use "); 326 Write_Int (Int (Size)); 327 Write_Line (";"); 328 329 else 330 Write_Str ("for " & T (1 .. Last) & "'Value_Size use "); 331 Write_Int (Int (Precision)); 332 Write_Line (";"); 333 334 Write_Str ("for " & T (1 .. Last) & "'Object_Size use "); 335 Write_Int (Int (Size)); 336 Write_Line (";"); 337 end if; 338 339 Write_Str ("for " & T (1 .. Last) & "'Alignment use "); 340 Write_Int (Int (Alignment / 8)); 341 Write_Line (";"); 342 Write_Eol; 343 end Dump; 344 345 -- Start of processing for Register_Float_Type 346 347 begin 348 -- Acquire name 349 350 for J in T'Range loop 351 T (J) := Name (Name'First + J - 1); 352 353 if T (J) = ASCII.NUL then 354 Last := J - 1; 355 exit; 356 end if; 357 end loop; 358 359 -- Dump info if debug flag set 360 361 if Debug_Flag_Dot_B then 362 Dump; 363 end if; 364 365 -- Acquire entry if non-vector non-complex fpt type (digits non-zero) 366 367 if Digs > 0 and then not Complex and then Count = 0 then 368 369 declare 370 This_Name : constant String := T (1 .. Last); 371 begin 372 Num_FPT_Modes := Num_FPT_Modes + 1; 373 FPT_Mode_Table (Num_FPT_Modes) := 374 (NAME => new String'(This_Name), 375 DIGS => Digs, 376 FLOAT_REP => Float_Rep, 377 PRECISION => Precision, 378 SIZE => Size, 379 ALIGNMENT => Alignment); 380 381 if Long_Double_Index < 0 and then This_Name = "long double" then 382 Long_Double_Index := Num_FPT_Modes; 383 end if; 384 end; 385 end if; 386 end Register_Float_Type; 387 388 ----------------------------------- 389 -- Write_Target_Dependent_Values -- 390 ----------------------------------- 391 392 -- We do this at the System.Os_Lib level, since we have to do the read at 393 -- that level anyway, so it is easier and more consistent to follow the 394 -- same path for the write. 395 396 procedure Write_Target_Dependent_Values is 397 Fdesc : File_Descriptor; 398 OK : Boolean; 399 400 Buffer : String (1 .. 80); 401 Buflen : Natural; 402 -- Buffer used to build line one of file 403 404 type ANat is access all Natural; 405 -- Pointer to Nat or Pos value (it is harmless to treat Pos values and 406 -- Nat values as Natural via Unchecked_Conversion). 407 408 function To_ANat is new Unchecked_Conversion (Address, ANat); 409 410 procedure AddC (C : Character); 411 -- Add one character to buffer 412 413 procedure AddN (N : Natural); 414 -- Add representation of integer N to Buffer, updating Buflen. N 415 -- must be less than 1000, and output is 3 characters with leading 416 -- spaces as needed. 417 418 procedure Write_Line; 419 -- Output contents of Buffer (1 .. Buflen) followed by a New_Line, 420 -- and set Buflen back to zero, ready to write next line. 421 422 ---------- 423 -- AddC -- 424 ---------- 425 426 procedure AddC (C : Character) is 427 begin 428 Buflen := Buflen + 1; 429 Buffer (Buflen) := C; 430 end AddC; 431 432 ---------- 433 -- AddN -- 434 ---------- 435 436 procedure AddN (N : Natural) is 437 begin 438 if N > 999 then 439 raise Program_Error; 440 end if; 441 442 if N > 99 then 443 AddC (Character'Val (48 + N / 100)); 444 else 445 AddC (' '); 446 end if; 447 448 if N > 9 then 449 AddC (Character'Val (48 + N / 10 mod 10)); 450 else 451 AddC (' '); 452 end if; 453 454 AddC (Character'Val (48 + N mod 10)); 455 end AddN; 456 457 ---------------- 458 -- Write_Line -- 459 ---------------- 460 461 procedure Write_Line is 462 begin 463 AddC (ASCII.LF); 464 465 if Buflen /= Write (Fdesc, Buffer'Address, Buflen) then 466 Delete_File (Target_Dependent_Info_Write_Name.all, OK); 467 Fail ("disk full writing file " 468 & Target_Dependent_Info_Write_Name.all); 469 end if; 470 471 Buflen := 0; 472 end Write_Line; 473 474 -- Start of processing for Write_Target_Dependent_Values 475 476 begin 477 Fdesc := 478 Create_File (Target_Dependent_Info_Write_Name.all, Text); 479 480 if Fdesc = Invalid_FD then 481 Fail ("cannot create file " & Target_Dependent_Info_Write_Name.all); 482 end if; 483 484 -- Loop through values 485 486 for J in DTN'Range loop 487 488 -- Output name 489 490 Buflen := DTN (J)'Length; 491 Buffer (1 .. Buflen) := DTN (J).all; 492 493 -- Line up values 494 495 while Buflen < 26 loop 496 AddC (' '); 497 end loop; 498 499 AddC (' '); 500 AddC (' '); 501 502 -- Output value and write line 503 504 AddN (To_ANat (DTV (J)).all); 505 Write_Line; 506 end loop; 507 508 -- Blank line to separate sections 509 510 Write_Line; 511 512 -- Write lines for registered FPT types 513 514 for J in 1 .. Num_FPT_Modes loop 515 declare 516 E : FPT_Mode_Entry renames FPT_Mode_Table (J); 517 begin 518 Buflen := E.NAME'Last; 519 Buffer (1 .. Buflen) := E.NAME.all; 520 521 -- Pad out to line up values 522 523 while Buflen < 11 loop 524 AddC (' '); 525 end loop; 526 527 AddC (' '); 528 AddC (' '); 529 530 AddN (E.DIGS); 531 AddC (' '); 532 AddC (' '); 533 534 case E.FLOAT_REP is 535 when AAMP => AddC ('A'); 536 when IEEE_Binary => AddC ('I'); 537 end case; 538 539 AddC (' '); 540 541 AddN (E.PRECISION); 542 AddC (' '); 543 544 AddN (E.ALIGNMENT); 545 Write_Line; 546 end; 547 end loop; 548 549 -- Close file 550 551 Close (Fdesc, OK); 552 553 if not OK then 554 Fail ("disk full writing file " 555 & Target_Dependent_Info_Write_Name.all); 556 end if; 557 end Write_Target_Dependent_Values; 558 559 ---------------------------------- 560 -- Read_Target_Dependent_Values -- 561 ---------------------------------- 562 563 procedure Read_Target_Dependent_Values (File_Name : String) is 564 File_Desc : File_Descriptor; 565 N : Natural; 566 567 type ANat is access all Natural; 568 -- Pointer to Nat or Pos value (it is harmless to treat Pos values 569 -- as Nat via Unchecked_Conversion). 570 571 function To_ANat is new Unchecked_Conversion (Address, ANat); 572 573 VP : ANat; 574 575 Buffer : String (1 .. 2000); 576 Buflen : Natural; 577 -- File information and length (2000 easily enough) 578 579 Nam_Buf : String (1 .. 40); 580 Nam_Len : Natural; 581 582 procedure Check_Spaces; 583 -- Checks that we have one or more spaces and skips them 584 585 procedure FailN (S : String); 586 pragma No_Return (FailN); 587 -- Calls Fail adding " name in file xxx", where name is the currently 588 -- gathered name in Nam_Buf, surrounded by quotes, and xxx is the 589 -- name of the file. 590 591 procedure Get_Name; 592 -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls 593 -- Skip_Spaces to skip any following spaces. Note that the name is 594 -- terminated by a sequence of at least two spaces. 595 596 function Get_Nat return Natural; 597 -- N on entry points to decimal integer, scan out decimal integer 598 -- and return it, leaving N pointing to following space or LF. 599 600 procedure Skip_Spaces; 601 -- Skip past spaces 602 603 ------------------ 604 -- Check_Spaces -- 605 ------------------ 606 607 procedure Check_Spaces is 608 begin 609 if N > Buflen or else Buffer (N) /= ' ' then 610 FailN ("missing space for"); 611 end if; 612 613 Skip_Spaces; 614 return; 615 end Check_Spaces; 616 617 ----------- 618 -- FailN -- 619 ----------- 620 621 procedure FailN (S : String) is 622 begin 623 Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file " 624 & File_Name); 625 end FailN; 626 627 -------------- 628 -- Get_Name -- 629 -------------- 630 631 procedure Get_Name is 632 begin 633 Nam_Len := 0; 634 635 -- Scan out name and put it in Nam_Buf 636 637 loop 638 if N > Buflen or else Buffer (N) = ASCII.LF then 639 FailN ("incorrectly formatted line for"); 640 end if; 641 642 -- Name is terminated by two blanks 643 644 exit when N < Buflen and then Buffer (N .. N + 1) = " "; 645 646 Nam_Len := Nam_Len + 1; 647 648 if Nam_Len > Nam_Buf'Last then 649 Fail ("name too long"); 650 end if; 651 652 Nam_Buf (Nam_Len) := Buffer (N); 653 N := N + 1; 654 end loop; 655 656 Check_Spaces; 657 end Get_Name; 658 659 ------------- 660 -- Get_Nat -- 661 ------------- 662 663 function Get_Nat return Natural is 664 Result : Natural := 0; 665 666 begin 667 loop 668 if N > Buflen 669 or else Buffer (N) not in '0' .. '9' 670 or else Result > 999 671 then 672 FailN ("bad value for"); 673 end if; 674 675 Result := Result * 10 + (Character'Pos (Buffer (N)) - 48); 676 N := N + 1; 677 678 exit when N <= Buflen 679 and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' '); 680 end loop; 681 682 return Result; 683 end Get_Nat; 684 685 ----------------- 686 -- Skip_Spaces -- 687 ----------------- 688 689 procedure Skip_Spaces is 690 begin 691 while N <= Buflen and Buffer (N) = ' ' loop 692 N := N + 1; 693 end loop; 694 end Skip_Spaces; 695 696 -- Start of processing for Read_Target_Dependent_Values 697 698 begin 699 File_Desc := Open_Read (File_Name, Text); 700 701 if File_Desc = Invalid_FD then 702 Fail ("cannot read file " & File_Name); 703 end if; 704 705 Buflen := Read (File_Desc, Buffer'Address, Buffer'Length); 706 707 Close (File_Desc); 708 709 if Buflen = Buffer'Length then 710 Fail ("file is too long: " & File_Name); 711 end if; 712 713 -- Scan through file for properly formatted entries in first section 714 715 N := 1; 716 while N <= Buflen and then Buffer (N) /= ASCII.LF loop 717 Get_Name; 718 719 -- Validate name and get corresponding value pointer 720 721 VP := null; 722 723 for J in DTN'Range loop 724 if DTN (J).all = Nam_Buf (1 .. Nam_Len) then 725 VP := To_ANat (DTV (J)); 726 DTR (J) := True; 727 exit; 728 end if; 729 end loop; 730 731 if VP = null then 732 FailN ("unrecognized name"); 733 end if; 734 735 -- Scan out value 736 737 VP.all := Get_Nat; 738 739 if N > Buflen or else Buffer (N) /= ASCII.LF then 740 FailN ("misformatted line for"); 741 end if; 742 743 N := N + 1; -- skip LF 744 end loop; 745 746 -- Fall through this loop when all lines in first section read. 747 -- Check that values have been supplied for all entries. 748 749 for J in DTR'Range loop 750 if not DTR (J) then 751 -- Make an exception for Long_Long_Long_Size??? 752 753 if DTN (J) = S_Long_Long_Long_Size'Unrestricted_Access then 754 Long_Long_Long_Size := Long_Long_Size; 755 756 else 757 Fail ("missing entry for " & DTN (J).all & " in file " 758 & File_Name); 759 end if; 760 end if; 761 end loop; 762 763 -- Now acquire FPT entries 764 765 if N >= Buflen then 766 Fail ("missing entries for FPT modes in file " & File_Name); 767 end if; 768 769 if Buffer (N) = ASCII.LF then 770 N := N + 1; 771 else 772 Fail ("missing blank line in file " & File_Name); 773 end if; 774 775 Num_FPT_Modes := 0; 776 while N <= Buflen loop 777 Get_Name; 778 779 Num_FPT_Modes := Num_FPT_Modes + 1; 780 781 declare 782 E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes); 783 784 begin 785 E.NAME := new String'(Nam_Buf (1 .. Nam_Len)); 786 787 if Long_Double_Index < 0 and then E.NAME.all = "long double" then 788 Long_Double_Index := Num_FPT_Modes; 789 end if; 790 791 E.DIGS := Get_Nat; 792 Check_Spaces; 793 794 case Buffer (N) is 795 when 'I' => 796 E.FLOAT_REP := IEEE_Binary; 797 798 when 'A' => 799 E.FLOAT_REP := AAMP; 800 801 when others => 802 FailN ("bad float rep field for"); 803 end case; 804 805 N := N + 1; 806 Check_Spaces; 807 808 E.PRECISION := Get_Nat; 809 Check_Spaces; 810 811 E.ALIGNMENT := Get_Nat; 812 813 if Buffer (N) /= ASCII.LF then 814 FailN ("junk at end of line for"); 815 end if; 816 817 -- ??? We do not read E.SIZE, see Write_Target_Dependent_Values 818 819 E.SIZE := 820 (E.PRECISION + E.ALIGNMENT - 1) / E.ALIGNMENT * E.ALIGNMENT; 821 822 N := N + 1; 823 end; 824 end loop; 825 end Read_Target_Dependent_Values; 826 827-- Package Initialization, set target dependent values. This must be done 828-- early on, before we start accessing various compiler packages, since 829-- these values are used all over the place. 830 831begin 832 -- First step: see if the -gnateT switch is present. As we have noted, 833 -- this has to be done very early, so cannot depend on the normal circuit 834 -- for reading switches and setting switches in Opt. The following code 835 -- will set Opt.Target_Dependent_Info_Read_Name if the switch -gnateT=name 836 -- is present in the options string. 837 838 declare 839 type Arg_Array is array (Nat) of Big_String_Ptr; 840 type Arg_Array_Ptr is access Arg_Array; 841 -- Types to access compiler arguments 842 843 save_argc : Nat; 844 pragma Import (C, save_argc); 845 -- Saved value of argc (number of arguments), imported from misc.c 846 847 save_argv : Arg_Array_Ptr; 848 pragma Import (C, save_argv); 849 -- Saved value of argv (argument pointers), imported from misc.c 850 851 gnat_argc : Nat; 852 gnat_argv : Arg_Array_Ptr; 853 pragma Import (C, gnat_argc); 854 pragma Import (C, gnat_argv); 855 -- If save_argv is not set, default to gnat_argc/argv 856 857 argc : Nat; 858 argv : Arg_Array_Ptr; 859 860 function Len_Arg (Arg : Big_String_Ptr) return Nat; 861 -- Determine length of argument Arg (a nul terminated C string). 862 863 ------------- 864 -- Len_Arg -- 865 ------------- 866 867 function Len_Arg (Arg : Big_String_Ptr) return Nat is 868 begin 869 for J in 1 .. Nat'Last loop 870 if Arg (Natural (J)) = ASCII.NUL then 871 return J - 1; 872 end if; 873 end loop; 874 875 raise Program_Error; 876 end Len_Arg; 877 878 begin 879 if save_argv /= null then 880 argv := save_argv; 881 argc := save_argc; 882 else 883 -- Case of a non gcc compiler, e.g. gnat2why or gnat2scil 884 argv := gnat_argv; 885 argc := gnat_argc; 886 end if; 887 888 -- Loop through arguments looking for -gnateT, also look for -gnatd.b 889 890 for Arg in 1 .. argc - 1 loop 891 declare 892 Argv_Ptr : constant Big_String_Ptr := argv (Arg); 893 Argv_Len : constant Nat := Len_Arg (Argv_Ptr); 894 895 begin 896 if Argv_Len > 8 897 and then Argv_Ptr (1 .. 8) = "-gnateT=" 898 then 899 Opt.Target_Dependent_Info_Read_Name := 900 new String'(Argv_Ptr (9 .. Natural (Argv_Len))); 901 902 elsif Argv_Len >= 8 903 and then Argv_Ptr (1 .. 8) = "-gnatd.b" 904 then 905 Debug_Flag_Dot_B := True; 906 end if; 907 end; 908 end loop; 909 end; 910 911 -- Case of reading the target dependent values from file 912 913 -- This is bit more complex than might be expected, because it has to be 914 -- done very early. All kinds of packages depend on these values, and we 915 -- can't wait till the normal processing of reading command line switches 916 -- etc to read the file. We do this at the System.OS_Lib level since it is 917 -- too early to be using Osint directly. 918 919 if Opt.Target_Dependent_Info_Read_Name /= null then 920 Read_Target_Dependent_Values (Target_Dependent_Info_Read_Name.all); 921 else 922 -- If the back-end comes with a target config file, then use it 923 -- to set the values 924 925 declare 926 Back_End_Config_File : constant String_Ptr := 927 Get_Back_End_Config_File; 928 begin 929 if Back_End_Config_File /= null then 930 pragma Gnat_Annotate 931 (CodePeer, Intentional, "test always false", 932 "some variant body will return non null"); 933 Read_Target_Dependent_Values (Back_End_Config_File.all); 934 935 -- Otherwise we get all values from the back end directly 936 937 else 938 Bits_BE := Get_Bits_BE; 939 Bits_Per_Unit := Get_Bits_Per_Unit; 940 Bits_Per_Word := Get_Bits_Per_Word; 941 Bytes_BE := Get_Bytes_BE; 942 Char_Size := Get_Char_Size; 943 Double_Float_Alignment := Get_Double_Float_Alignment; 944 Double_Scalar_Alignment := Get_Double_Scalar_Alignment; 945 Float_Words_BE := Get_Float_Words_BE; 946 Int_Size := Get_Int_Size; 947 Long_Long_Long_Size := Get_Long_Long_Long_Size; 948 Long_Long_Size := Get_Long_Long_Size; 949 Long_Size := Get_Long_Size; 950 Maximum_Alignment := Get_Maximum_Alignment; 951 Max_Unaligned_Field := Get_Max_Unaligned_Field; 952 Pointer_Size := Get_Pointer_Size; 953 Short_Enums := Get_Short_Enums; 954 Short_Size := Get_Short_Size; 955 Strict_Alignment := Get_Strict_Alignment; 956 System_Allocator_Alignment := Get_System_Allocator_Alignment; 957 Wchar_T_Size := Get_Wchar_T_Size; 958 Words_BE := Get_Words_BE; 959 960 -- Let the back-end register its floating point types and compute 961 -- the sizes of our standard types from there: 962 963 Num_FPT_Modes := 0; 964 Register_Back_End_Types (Register_Float_Type'Access); 965 966 declare 967 T : FPT_Mode_Entry renames 968 FPT_Mode_Table (FPT_Mode_Index_For (S_Float)); 969 begin 970 Float_Size := Pos (T.SIZE); 971 end; 972 973 declare 974 T : FPT_Mode_Entry renames 975 FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Float)); 976 begin 977 Double_Size := Pos (T.SIZE); 978 end; 979 980 declare 981 T : FPT_Mode_Entry renames 982 FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Long_Float)); 983 begin 984 Long_Double_Size := Pos (T.SIZE); 985 end; 986 987 end if; 988 end; 989 end if; 990end Set_Targ; 991