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-2021, 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 IEEE_Binary => Write_Str ("IEEE"); 313 end case; 314 315 Write_Line (", " & T (1 .. Last) & ");"); 316 317 else 318 Write_Str ("mod 2**"); 319 Write_Int (Int (Precision / Positive'Max (1, Count))); 320 Write_Line (";"); 321 end if; 322 323 if Precision = Size then 324 Write_Str ("for " & T (1 .. Last) & "'Size use "); 325 Write_Int (Int (Size)); 326 Write_Line (";"); 327 328 else 329 Write_Str ("for " & T (1 .. Last) & "'Value_Size use "); 330 Write_Int (Int (Precision)); 331 Write_Line (";"); 332 333 Write_Str ("for " & T (1 .. Last) & "'Object_Size use "); 334 Write_Int (Int (Size)); 335 Write_Line (";"); 336 end if; 337 338 Write_Str ("for " & T (1 .. Last) & "'Alignment use "); 339 Write_Int (Int (Alignment / 8)); 340 Write_Line (";"); 341 Write_Eol; 342 end Dump; 343 344 -- Start of processing for Register_Float_Type 345 346 begin 347 -- Acquire name 348 349 for J in T'Range loop 350 T (J) := Name (Name'First + J - 1); 351 352 if T (J) = ASCII.NUL then 353 Last := J - 1; 354 exit; 355 end if; 356 end loop; 357 358 -- Dump info if debug flag set 359 360 if Debug_Flag_Dot_B then 361 Dump; 362 end if; 363 364 -- Acquire entry if non-vector non-complex fpt type (digits non-zero) 365 366 if Digs > 0 and then not Complex and then Count = 0 then 367 368 declare 369 This_Name : constant String := T (1 .. Last); 370 begin 371 Num_FPT_Modes := Num_FPT_Modes + 1; 372 FPT_Mode_Table (Num_FPT_Modes) := 373 (NAME => new String'(This_Name), 374 DIGS => Digs, 375 FLOAT_REP => Float_Rep, 376 PRECISION => Precision, 377 SIZE => Size, 378 ALIGNMENT => Alignment); 379 380 if Long_Double_Index < 0 and then This_Name = "long double" then 381 Long_Double_Index := Num_FPT_Modes; 382 end if; 383 end; 384 end if; 385 end Register_Float_Type; 386 387 ----------------------------------- 388 -- Write_Target_Dependent_Values -- 389 ----------------------------------- 390 391 -- We do this at the System.Os_Lib level, since we have to do the read at 392 -- that level anyway, so it is easier and more consistent to follow the 393 -- same path for the write. 394 395 procedure Write_Target_Dependent_Values is 396 Fdesc : File_Descriptor; 397 OK : Boolean; 398 399 Buffer : String (1 .. 80); 400 Buflen : Natural; 401 -- Buffer used to build line one of file 402 403 type ANat is access all Natural; 404 -- Pointer to Nat or Pos value (it is harmless to treat Pos values and 405 -- Nat values as Natural via Unchecked_Conversion). 406 407 function To_ANat is new Unchecked_Conversion (Address, ANat); 408 409 procedure AddC (C : Character); 410 -- Add one character to buffer 411 412 procedure AddN (N : Natural); 413 -- Add representation of integer N to Buffer, updating Buflen. N 414 -- must be less than 1000, and output is 3 characters with leading 415 -- spaces as needed. 416 417 procedure Write_Line; 418 -- Output contents of Buffer (1 .. Buflen) followed by a New_Line, 419 -- and set Buflen back to zero, ready to write next line. 420 421 ---------- 422 -- AddC -- 423 ---------- 424 425 procedure AddC (C : Character) is 426 begin 427 Buflen := Buflen + 1; 428 Buffer (Buflen) := C; 429 end AddC; 430 431 ---------- 432 -- AddN -- 433 ---------- 434 435 procedure AddN (N : Natural) is 436 begin 437 if N > 999 then 438 raise Program_Error; 439 end if; 440 441 if N > 99 then 442 AddC (Character'Val (48 + N / 100)); 443 else 444 AddC (' '); 445 end if; 446 447 if N > 9 then 448 AddC (Character'Val (48 + N / 10 mod 10)); 449 else 450 AddC (' '); 451 end if; 452 453 AddC (Character'Val (48 + N mod 10)); 454 end AddN; 455 456 ---------------- 457 -- Write_Line -- 458 ---------------- 459 460 procedure Write_Line is 461 begin 462 AddC (ASCII.LF); 463 464 if Buflen /= Write (Fdesc, Buffer'Address, Buflen) then 465 Delete_File (Target_Dependent_Info_Write_Name.all, OK); 466 Fail ("disk full writing file " 467 & Target_Dependent_Info_Write_Name.all); 468 end if; 469 470 Buflen := 0; 471 end Write_Line; 472 473 -- Start of processing for Write_Target_Dependent_Values 474 475 begin 476 Fdesc := 477 Create_File (Target_Dependent_Info_Write_Name.all, Text); 478 479 if Fdesc = Invalid_FD then 480 Fail ("cannot create file " & Target_Dependent_Info_Write_Name.all); 481 end if; 482 483 -- Loop through values 484 485 for J in DTN'Range loop 486 487 -- Output name 488 489 Buflen := DTN (J)'Length; 490 Buffer (1 .. Buflen) := DTN (J).all; 491 492 -- Line up values 493 494 while Buflen < 26 loop 495 AddC (' '); 496 end loop; 497 498 AddC (' '); 499 AddC (' '); 500 501 -- Output value and write line 502 503 AddN (To_ANat (DTV (J)).all); 504 Write_Line; 505 end loop; 506 507 -- Blank line to separate sections 508 509 Write_Line; 510 511 -- Write lines for registered FPT types 512 513 for J in 1 .. Num_FPT_Modes loop 514 declare 515 E : FPT_Mode_Entry renames FPT_Mode_Table (J); 516 begin 517 Buflen := E.NAME'Last; 518 Buffer (1 .. Buflen) := E.NAME.all; 519 520 -- Pad out to line up values 521 522 while Buflen < 11 loop 523 AddC (' '); 524 end loop; 525 526 AddC (' '); 527 AddC (' '); 528 529 AddN (E.DIGS); 530 AddC (' '); 531 AddC (' '); 532 533 case E.FLOAT_REP is 534 when IEEE_Binary => AddC ('I'); 535 end case; 536 537 AddC (' '); 538 539 AddN (E.PRECISION); 540 AddC (' '); 541 542 AddN (E.ALIGNMENT); 543 Write_Line; 544 end; 545 end loop; 546 547 -- Close file 548 549 Close (Fdesc, OK); 550 551 if not OK then 552 Fail ("disk full writing file " 553 & Target_Dependent_Info_Write_Name.all); 554 end if; 555 end Write_Target_Dependent_Values; 556 557 ---------------------------------- 558 -- Read_Target_Dependent_Values -- 559 ---------------------------------- 560 561 procedure Read_Target_Dependent_Values (File_Name : String) is 562 File_Desc : File_Descriptor; 563 N : Natural; 564 565 type ANat is access all Natural; 566 -- Pointer to Nat or Pos value (it is harmless to treat Pos values 567 -- as Nat via Unchecked_Conversion). 568 569 function To_ANat is new Unchecked_Conversion (Address, ANat); 570 571 VP : ANat; 572 573 Buffer : String (1 .. 2000); 574 Buflen : Natural; 575 -- File information and length (2000 easily enough) 576 577 Nam_Buf : String (1 .. 40); 578 Nam_Len : Natural; 579 580 procedure Check_Spaces; 581 -- Checks that we have one or more spaces and skips them 582 583 procedure FailN (S : String); 584 pragma No_Return (FailN); 585 -- Calls Fail adding " name in file xxx", where name is the currently 586 -- gathered name in Nam_Buf, surrounded by quotes, and xxx is the 587 -- name of the file. 588 589 procedure Get_Name; 590 -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls 591 -- Skip_Spaces to skip any following spaces. Note that the name is 592 -- terminated by a sequence of at least two spaces. 593 594 function Get_Nat return Natural; 595 -- N on entry points to decimal integer, scan out decimal integer 596 -- and return it, leaving N pointing to following space or LF. 597 598 procedure Skip_Spaces; 599 -- Skip past spaces 600 601 ------------------ 602 -- Check_Spaces -- 603 ------------------ 604 605 procedure Check_Spaces is 606 begin 607 if N > Buflen or else Buffer (N) /= ' ' then 608 FailN ("missing space for"); 609 end if; 610 611 Skip_Spaces; 612 return; 613 end Check_Spaces; 614 615 ----------- 616 -- FailN -- 617 ----------- 618 619 procedure FailN (S : String) is 620 begin 621 Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file " 622 & File_Name); 623 end FailN; 624 625 -------------- 626 -- Get_Name -- 627 -------------- 628 629 procedure Get_Name is 630 begin 631 Nam_Len := 0; 632 633 -- Scan out name and put it in Nam_Buf 634 635 loop 636 if N > Buflen or else Buffer (N) = ASCII.LF then 637 FailN ("incorrectly formatted line for"); 638 end if; 639 640 -- Name is terminated by two blanks 641 642 exit when N < Buflen and then Buffer (N .. N + 1) = " "; 643 644 Nam_Len := Nam_Len + 1; 645 646 if Nam_Len > Nam_Buf'Last then 647 Fail ("name too long"); 648 end if; 649 650 Nam_Buf (Nam_Len) := Buffer (N); 651 N := N + 1; 652 end loop; 653 654 Check_Spaces; 655 end Get_Name; 656 657 ------------- 658 -- Get_Nat -- 659 ------------- 660 661 function Get_Nat return Natural is 662 Result : Natural := 0; 663 664 begin 665 loop 666 if N > Buflen 667 or else Buffer (N) not in '0' .. '9' 668 or else Result > 999 669 then 670 FailN ("bad value for"); 671 end if; 672 673 Result := Result * 10 + (Character'Pos (Buffer (N)) - 48); 674 N := N + 1; 675 676 exit when N <= Buflen 677 and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' '); 678 end loop; 679 680 return Result; 681 end Get_Nat; 682 683 ----------------- 684 -- Skip_Spaces -- 685 ----------------- 686 687 procedure Skip_Spaces is 688 begin 689 while N <= Buflen and Buffer (N) = ' ' loop 690 N := N + 1; 691 end loop; 692 end Skip_Spaces; 693 694 -- Start of processing for Read_Target_Dependent_Values 695 696 begin 697 File_Desc := Open_Read (File_Name, Text); 698 699 if File_Desc = Invalid_FD then 700 Fail ("cannot read file " & File_Name); 701 end if; 702 703 Buflen := Read (File_Desc, Buffer'Address, Buffer'Length); 704 705 Close (File_Desc); 706 707 if Buflen = Buffer'Length then 708 Fail ("file is too long: " & File_Name); 709 end if; 710 711 -- Scan through file for properly formatted entries in first section 712 713 N := 1; 714 while N <= Buflen and then Buffer (N) /= ASCII.LF loop 715 Get_Name; 716 717 -- Validate name and get corresponding value pointer 718 719 VP := null; 720 721 for J in DTN'Range loop 722 if DTN (J).all = Nam_Buf (1 .. Nam_Len) then 723 VP := To_ANat (DTV (J)); 724 DTR (J) := True; 725 exit; 726 end if; 727 end loop; 728 729 if VP = null then 730 FailN ("unrecognized name"); 731 end if; 732 733 -- Scan out value 734 735 VP.all := Get_Nat; 736 737 if N > Buflen or else Buffer (N) /= ASCII.LF then 738 FailN ("misformatted line for"); 739 end if; 740 741 N := N + 1; -- skip LF 742 end loop; 743 744 -- Fall through this loop when all lines in first section read. 745 -- Check that values have been supplied for all entries. 746 747 for J in DTR'Range loop 748 if not DTR (J) then 749 -- Make an exception for Long_Long_Long_Size??? 750 751 if DTN (J) = S_Long_Long_Long_Size'Unrestricted_Access then 752 Long_Long_Long_Size := Long_Long_Size; 753 754 else 755 Fail ("missing entry for " & DTN (J).all & " in file " 756 & File_Name); 757 end if; 758 end if; 759 end loop; 760 761 -- Now acquire FPT entries 762 763 if N >= Buflen then 764 Fail ("missing entries for FPT modes in file " & File_Name); 765 end if; 766 767 if Buffer (N) = ASCII.LF then 768 N := N + 1; 769 else 770 Fail ("missing blank line in file " & File_Name); 771 end if; 772 773 Num_FPT_Modes := 0; 774 while N <= Buflen loop 775 Get_Name; 776 777 Num_FPT_Modes := Num_FPT_Modes + 1; 778 779 declare 780 E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes); 781 782 begin 783 E.NAME := new String'(Nam_Buf (1 .. Nam_Len)); 784 785 if Long_Double_Index < 0 and then E.NAME.all = "long double" then 786 Long_Double_Index := Num_FPT_Modes; 787 end if; 788 789 E.DIGS := Get_Nat; 790 Check_Spaces; 791 792 case Buffer (N) is 793 when 'I' => 794 E.FLOAT_REP := IEEE_Binary; 795 796 when others => 797 FailN ("bad float rep field for"); 798 end case; 799 800 N := N + 1; 801 Check_Spaces; 802 803 E.PRECISION := Get_Nat; 804 Check_Spaces; 805 806 E.ALIGNMENT := Get_Nat; 807 808 if Buffer (N) /= ASCII.LF then 809 FailN ("junk at end of line for"); 810 end if; 811 812 -- ??? We do not read E.SIZE, see Write_Target_Dependent_Values 813 814 E.SIZE := 815 (E.PRECISION + E.ALIGNMENT - 1) / E.ALIGNMENT * E.ALIGNMENT; 816 817 N := N + 1; 818 end; 819 end loop; 820 end Read_Target_Dependent_Values; 821 822-- Package Initialization, set target dependent values. This must be done 823-- early on, before we start accessing various compiler packages, since 824-- these values are used all over the place. 825 826begin 827 -- First step: see if the -gnateT switch is present. As we have noted, 828 -- this has to be done very early, so cannot depend on the normal circuit 829 -- for reading switches and setting switches in Opt. The following code 830 -- will set Opt.Target_Dependent_Info_Read_Name if the switch -gnateT=name 831 -- is present in the options string. 832 833 declare 834 type Arg_Array is array (Nat) of Big_String_Ptr; 835 type Arg_Array_Ptr is access Arg_Array; 836 -- Types to access compiler arguments 837 838 save_argc : Nat; 839 pragma Import (C, save_argc); 840 -- Saved value of argc (number of arguments), imported from misc.c 841 842 save_argv : Arg_Array_Ptr; 843 pragma Import (C, save_argv); 844 -- Saved value of argv (argument pointers), imported from misc.c 845 846 gnat_argc : Nat; 847 gnat_argv : Arg_Array_Ptr; 848 pragma Import (C, gnat_argc); 849 pragma Import (C, gnat_argv); 850 -- If save_argv is not set, default to gnat_argc/argv 851 852 argc : Nat; 853 argv : Arg_Array_Ptr; 854 855 function Len_Arg (Arg : Big_String_Ptr) return Nat; 856 -- Determine length of argument Arg (a nul terminated C string). 857 858 ------------- 859 -- Len_Arg -- 860 ------------- 861 862 function Len_Arg (Arg : Big_String_Ptr) return Nat is 863 begin 864 for J in 1 .. Nat'Last loop 865 if Arg (Natural (J)) = ASCII.NUL then 866 return J - 1; 867 end if; 868 end loop; 869 870 raise Program_Error; 871 end Len_Arg; 872 873 begin 874 if save_argv /= null then 875 argv := save_argv; 876 argc := save_argc; 877 else 878 -- Case of a non-GCC compiler, e.g. gnat2why or gnat2scil 879 argv := gnat_argv; 880 argc := gnat_argc; 881 end if; 882 883 -- Loop through arguments looking for -gnateT, also look for -gnatd.b 884 885 for Arg in 1 .. argc - 1 loop 886 declare 887 Argv_Ptr : constant Big_String_Ptr := argv (Arg); 888 Argv_Len : constant Nat := Len_Arg (Argv_Ptr); 889 890 begin 891 if Argv_Len > 8 892 and then Argv_Ptr (1 .. 8) = "-gnateT=" 893 then 894 Opt.Target_Dependent_Info_Read_Name := 895 new String'(Argv_Ptr (9 .. Natural (Argv_Len))); 896 897 elsif Argv_Len >= 8 898 and then Argv_Ptr (1 .. 8) = "-gnatd.b" 899 then 900 Debug_Flag_Dot_B := True; 901 end if; 902 end; 903 end loop; 904 end; 905 906 -- Case of reading the target dependent values from file 907 908 -- This is bit more complex than might be expected, because it has to be 909 -- done very early. All kinds of packages depend on these values, and we 910 -- can't wait till the normal processing of reading command line switches 911 -- etc to read the file. We do this at the System.OS_Lib level since it is 912 -- too early to be using Osint directly. 913 914 if Opt.Target_Dependent_Info_Read_Name /= null then 915 Read_Target_Dependent_Values (Target_Dependent_Info_Read_Name.all); 916 else 917 -- If the back-end comes with a target config file, then use it 918 -- to set the values 919 920 declare 921 Back_End_Config_File : constant String_Ptr := 922 Get_Back_End_Config_File; 923 begin 924 if Back_End_Config_File /= null then 925 pragma Gnat_Annotate 926 (CodePeer, Intentional, "test always false", 927 "some variant body will return non null"); 928 Read_Target_Dependent_Values (Back_End_Config_File.all); 929 930 -- Otherwise we get all values from the back end directly 931 932 else 933 Bits_BE := Get_Bits_BE; 934 Bits_Per_Unit := Get_Bits_Per_Unit; 935 Bits_Per_Word := Get_Bits_Per_Word; 936 Bytes_BE := Get_Bytes_BE; 937 Char_Size := Get_Char_Size; 938 Double_Float_Alignment := Get_Double_Float_Alignment; 939 Double_Scalar_Alignment := Get_Double_Scalar_Alignment; 940 Float_Words_BE := Get_Float_Words_BE; 941 Int_Size := Get_Int_Size; 942 Long_Long_Long_Size := Get_Long_Long_Long_Size; 943 Long_Long_Size := Get_Long_Long_Size; 944 Long_Size := Get_Long_Size; 945 Maximum_Alignment := Get_Maximum_Alignment; 946 Max_Unaligned_Field := Get_Max_Unaligned_Field; 947 Pointer_Size := Get_Pointer_Size; 948 Short_Enums := Get_Short_Enums; 949 Short_Size := Get_Short_Size; 950 Strict_Alignment := Get_Strict_Alignment; 951 System_Allocator_Alignment := Get_System_Allocator_Alignment; 952 Wchar_T_Size := Get_Wchar_T_Size; 953 Words_BE := Get_Words_BE; 954 955 -- Let the back-end register its floating point types and compute 956 -- the sizes of our standard types from there: 957 958 Num_FPT_Modes := 0; 959 Register_Back_End_Types (Register_Float_Type'Access); 960 961 declare 962 T : FPT_Mode_Entry renames 963 FPT_Mode_Table (FPT_Mode_Index_For (S_Float)); 964 begin 965 Float_Size := Pos (T.SIZE); 966 end; 967 968 declare 969 T : FPT_Mode_Entry renames 970 FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Float)); 971 begin 972 Double_Size := Pos (T.SIZE); 973 end; 974 975 declare 976 T : FPT_Mode_Entry renames 977 FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Long_Float)); 978 begin 979 Long_Double_Size := Pos (T.SIZE); 980 end; 981 982 end if; 983 end; 984 end if; 985end Set_Targ; 986