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