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