| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E T _ T A R G -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2013-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Debug; use Debug; |
| with Get_Targ; use Get_Targ; |
| with Opt; use Opt; |
| with Output; use Output; |
| |
| with System; use System; |
| with System.OS_Lib; use System.OS_Lib; |
| |
| with Ada.Unchecked_Conversion; |
| |
| package body Set_Targ is |
| |
| -------------------------------------------------------- |
| -- Data Used to Read/Write Target Dependent Info File -- |
| -------------------------------------------------------- |
| |
| -- Table of string names written to file |
| |
| subtype Str is String; |
| |
| S_Bits_BE : constant Str := "Bits_BE"; |
| S_Bits_Per_Unit : constant Str := "Bits_Per_Unit"; |
| S_Bits_Per_Word : constant Str := "Bits_Per_Word"; |
| S_Bytes_BE : constant Str := "Bytes_BE"; |
| S_Char_Size : constant Str := "Char_Size"; |
| S_Double_Float_Alignment : constant Str := "Double_Float_Alignment"; |
| S_Double_Scalar_Alignment : constant Str := "Double_Scalar_Alignment"; |
| S_Double_Size : constant Str := "Double_Size"; |
| S_Float_Size : constant Str := "Float_Size"; |
| S_Float_Words_BE : constant Str := "Float_Words_BE"; |
| S_Int_Size : constant Str := "Int_Size"; |
| S_Long_Double_Size : constant Str := "Long_Double_Size"; |
| S_Long_Long_Long_Size : constant Str := "Long_Long_Long_Size"; |
| S_Long_Long_Size : constant Str := "Long_Long_Size"; |
| S_Long_Size : constant Str := "Long_Size"; |
| S_Maximum_Alignment : constant Str := "Maximum_Alignment"; |
| S_Max_Unaligned_Field : constant Str := "Max_Unaligned_Field"; |
| S_Pointer_Size : constant Str := "Pointer_Size"; |
| S_Short_Enums : constant Str := "Short_Enums"; |
| S_Short_Size : constant Str := "Short_Size"; |
| S_Strict_Alignment : constant Str := "Strict_Alignment"; |
| S_System_Allocator_Alignment : constant Str := "System_Allocator_Alignment"; |
| S_Wchar_T_Size : constant Str := "Wchar_T_Size"; |
| S_Words_BE : constant Str := "Words_BE"; |
| |
| -- Table of names |
| |
| type AStr is access all String; |
| |
| DTN : constant array (Nat range <>) of AStr := ( |
| S_Bits_BE 'Unrestricted_Access, |
| S_Bits_Per_Unit 'Unrestricted_Access, |
| S_Bits_Per_Word 'Unrestricted_Access, |
| S_Bytes_BE 'Unrestricted_Access, |
| S_Char_Size 'Unrestricted_Access, |
| S_Double_Float_Alignment 'Unrestricted_Access, |
| S_Double_Scalar_Alignment 'Unrestricted_Access, |
| S_Double_Size 'Unrestricted_Access, |
| S_Float_Size 'Unrestricted_Access, |
| S_Float_Words_BE 'Unrestricted_Access, |
| S_Int_Size 'Unrestricted_Access, |
| S_Long_Double_Size 'Unrestricted_Access, |
| S_Long_Long_Long_Size 'Unrestricted_Access, |
| S_Long_Long_Size 'Unrestricted_Access, |
| S_Long_Size 'Unrestricted_Access, |
| S_Maximum_Alignment 'Unrestricted_Access, |
| S_Max_Unaligned_Field 'Unrestricted_Access, |
| S_Pointer_Size 'Unrestricted_Access, |
| S_Short_Enums 'Unrestricted_Access, |
| S_Short_Size 'Unrestricted_Access, |
| S_Strict_Alignment 'Unrestricted_Access, |
| S_System_Allocator_Alignment 'Unrestricted_Access, |
| S_Wchar_T_Size 'Unrestricted_Access, |
| S_Words_BE 'Unrestricted_Access); |
| |
| -- Table of corresponding value pointers |
| |
| DTV : constant array (Nat range <>) of System.Address := ( |
| Bits_BE 'Address, |
| Bits_Per_Unit 'Address, |
| Bits_Per_Word 'Address, |
| Bytes_BE 'Address, |
| Char_Size 'Address, |
| Double_Float_Alignment 'Address, |
| Double_Scalar_Alignment 'Address, |
| Double_Size 'Address, |
| Float_Size 'Address, |
| Float_Words_BE 'Address, |
| Int_Size 'Address, |
| Long_Double_Size 'Address, |
| Long_Long_Long_Size 'Address, |
| Long_Long_Size 'Address, |
| Long_Size 'Address, |
| Maximum_Alignment 'Address, |
| Max_Unaligned_Field 'Address, |
| Pointer_Size 'Address, |
| Short_Enums 'Address, |
| Short_Size 'Address, |
| Strict_Alignment 'Address, |
| System_Allocator_Alignment 'Address, |
| Wchar_T_Size 'Address, |
| Words_BE 'Address); |
| |
| DTR : array (Nat range DTV'Range) of Boolean := (others => False); |
| -- Table of flags used to validate that all values are present in file |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Read_Target_Dependent_Values (File_Name : String); |
| -- Read target dependent values from File_Name, and set the target |
| -- dependent values (global variables) declared in this package. |
| |
| procedure Fail (E : String); |
| pragma No_Return (Fail); |
| -- Terminate program with fatal error message passed as parameter |
| |
| procedure Register_Float_Type |
| (Name : C_String; |
| Digs : Natural; |
| Complex : Boolean; |
| Count : Natural; |
| Float_Rep : Float_Rep_Kind; |
| Precision : Positive; |
| Size : Positive; |
| Alignment : Natural); |
| pragma Convention (C, Register_Float_Type); |
| -- Call back to allow the back end to register available types. This call |
| -- back makes entries in the FPT_Mode_Table for any floating point types |
| -- reported by the back end. Name is the name of the type as a normal |
| -- format Null-terminated string. Digs is the number of digits, where 0 |
| -- means it is not a fpt type (ignored during registration). Complex is |
| -- non-zero if the type has real and imaginary parts (also ignored during |
| -- registration). Count is the number of elements in a vector type (zero = |
| -- not a vector, registration ignores vectors). Float_Rep shows the kind of |
| -- floating-point type, and Precision, Size and Alignment are the precision |
| -- size and alignment in bits. |
| -- |
| -- The only types that are actually registered have Digs non-zero, Complex |
| -- zero (false), and Count zero (not a vector). The Long_Double_Index |
| -- variable below is updated to indicate the index at which a "long double" |
| -- type can be found if it gets registered at all. |
| |
| Long_Double_Index : Integer := -1; |
| -- Once all the floating point types have been registered, the index in |
| -- FPT_Mode_Table at which "long double" can be found, if anywhere. A |
| -- negative value means that no "long double" has been registered. This |
| -- is useful to know whether we have a "long double" available at all and |
| -- get at it's characteristics without having to search the FPT_Mode_Table |
| -- when we need to decide which C type should be used as the basis for |
| -- Long_Long_Float in Ada. |
| |
| function FPT_Mode_Index_For (Name : String) return Natural; |
| -- Return the index in FPT_Mode_Table that designates the entry |
| -- corresponding to the C type named Name. Raise Program_Error if |
| -- there is no such entry. |
| |
| function FPT_Mode_Index_For (T : S_Float_Types) return Natural; |
| -- Return the index in FPT_Mode_Table that designates the entry for |
| -- a back-end type suitable as a basis to construct the standard Ada |
| -- floating point type identified by T. |
| |
| ---------------- |
| -- C_Type_For -- |
| ---------------- |
| |
| function C_Type_For (T : S_Float_Types) return String is |
| |
| -- ??? For now, we don't have a good way to tell the widest float |
| -- type with hardware support. Basically, GCC knows the size of that |
| -- type, but on x86-64 there often are two or three 128-bit types, |
| -- one double extended that has 18 decimal digits, a 128-bit quad |
| -- precision type with 33 digits and possibly a 128-bit decimal float |
| -- type with 34 digits. As a workaround, we define Long_Long_Float as |
| -- C's "long double" if that type exists and has at most 18 digits, |
| -- or otherwise the same as Long_Float. |
| |
| Max_HW_Digs : constant := 18; |
| -- Maximum hardware digits supported |
| |
| begin |
| case T is |
| when S_Float |
| | S_Short_Float |
| => |
| return "float"; |
| |
| when S_Long_Float => |
| return "double"; |
| |
| when S_Long_Long_Float => |
| if Long_Double_Index >= 0 |
| and then FPT_Mode_Table (Long_Double_Index).DIGS <= Max_HW_Digs |
| then |
| return "long double"; |
| else |
| return "double"; |
| end if; |
| end case; |
| end C_Type_For; |
| |
| ---------- |
| -- Fail -- |
| ---------- |
| |
| procedure Fail (E : String) is |
| E_Fatal : constant := 4; |
| -- Code for fatal error |
| |
| begin |
| Write_Str (E); |
| Write_Eol; |
| OS_Exit (E_Fatal); |
| end Fail; |
| |
| ------------------------ |
| -- FPT_Mode_Index_For -- |
| ------------------------ |
| |
| function FPT_Mode_Index_For (Name : String) return Natural is |
| begin |
| for J in FPT_Mode_Table'First .. Num_FPT_Modes loop |
| if FPT_Mode_Table (J).NAME.all = Name then |
| return J; |
| end if; |
| end loop; |
| |
| raise Program_Error; |
| end FPT_Mode_Index_For; |
| |
| function FPT_Mode_Index_For (T : S_Float_Types) return Natural is |
| begin |
| return FPT_Mode_Index_For (C_Type_For (T)); |
| end FPT_Mode_Index_For; |
| |
| ------------------------- |
| -- Register_Float_Type -- |
| ------------------------- |
| |
| procedure Register_Float_Type |
| (Name : C_String; |
| Digs : Natural; |
| Complex : Boolean; |
| Count : Natural; |
| Float_Rep : Float_Rep_Kind; |
| Precision : Positive; |
| Size : Positive; |
| Alignment : Natural) |
| is |
| T : String (1 .. Name'Length); |
| Last : Natural := 0; |
| |
| procedure Dump; |
| -- Dump information given by the back end for the type to register |
| |
| ---------- |
| -- Dump -- |
| ---------- |
| |
| procedure Dump is |
| begin |
| Write_Str ("type " & T (1 .. Last) & " is "); |
| |
| if Count > 0 then |
| Write_Str ("array (1 .. "); |
| Write_Int (Int (Count)); |
| |
| if Complex then |
| Write_Str (", 1 .. 2"); |
| end if; |
| |
| Write_Str (") of "); |
| |
| elsif Complex then |
| Write_Str ("array (1 .. 2) of "); |
| end if; |
| |
| if Digs > 0 then |
| Write_Str ("digits "); |
| Write_Int (Int (Digs)); |
| Write_Line (";"); |
| |
| Write_Str ("pragma Float_Representation ("); |
| |
| case Float_Rep is |
| when IEEE_Binary => Write_Str ("IEEE"); |
| end case; |
| |
| Write_Line (", " & T (1 .. Last) & ");"); |
| |
| else |
| Write_Str ("mod 2**"); |
| Write_Int (Int (Precision / Positive'Max (1, Count))); |
| Write_Line (";"); |
| end if; |
| |
| if Precision = Size then |
| Write_Str ("for " & T (1 .. Last) & "'Size use "); |
| Write_Int (Int (Size)); |
| Write_Line (";"); |
| |
| else |
| Write_Str ("for " & T (1 .. Last) & "'Value_Size use "); |
| Write_Int (Int (Precision)); |
| Write_Line (";"); |
| |
| Write_Str ("for " & T (1 .. Last) & "'Object_Size use "); |
| Write_Int (Int (Size)); |
| Write_Line (";"); |
| end if; |
| |
| Write_Str ("for " & T (1 .. Last) & "'Alignment use "); |
| Write_Int (Int (Alignment / 8)); |
| Write_Line (";"); |
| Write_Eol; |
| end Dump; |
| |
| -- Start of processing for Register_Float_Type |
| |
| begin |
| -- Acquire name |
| |
| for J in T'Range loop |
| T (J) := Name (Name'First + J - 1); |
| |
| if T (J) = ASCII.NUL then |
| Last := J - 1; |
| exit; |
| end if; |
| end loop; |
| |
| -- Dump info if debug flag set |
| |
| if Debug_Flag_Dot_B then |
| Dump; |
| end if; |
| |
| -- Acquire entry if non-vector non-complex fpt type (digits non-zero) |
| |
| if Digs > 0 and then not Complex and then Count = 0 then |
| |
| declare |
| This_Name : constant String := T (1 .. Last); |
| begin |
| Num_FPT_Modes := Num_FPT_Modes + 1; |
| FPT_Mode_Table (Num_FPT_Modes) := |
| (NAME => new String'(This_Name), |
| DIGS => Digs, |
| FLOAT_REP => Float_Rep, |
| PRECISION => Precision, |
| SIZE => Size, |
| ALIGNMENT => Alignment); |
| |
| if Long_Double_Index < 0 and then This_Name = "long double" then |
| Long_Double_Index := Num_FPT_Modes; |
| end if; |
| end; |
| end if; |
| end Register_Float_Type; |
| |
| ----------------------------------- |
| -- Write_Target_Dependent_Values -- |
| ----------------------------------- |
| |
| -- We do this at the System.Os_Lib level, since we have to do the read at |
| -- that level anyway, so it is easier and more consistent to follow the |
| -- same path for the write. |
| |
| procedure Write_Target_Dependent_Values is |
| Fdesc : File_Descriptor; |
| OK : Boolean; |
| |
| Buffer : String (1 .. 80); |
| Buflen : Natural; |
| -- Buffer used to build line one of file |
| |
| type ANat is access all Natural; |
| -- Pointer to Nat or Pos value (it is harmless to treat Pos values and |
| -- Nat values as Natural via Unchecked_Conversion). |
| |
| function To_ANat is new Ada.Unchecked_Conversion (Address, ANat); |
| |
| procedure AddC (C : Character); |
| -- Add one character to buffer |
| |
| procedure AddN (N : Natural); |
| -- Add representation of integer N to Buffer, updating Buflen. N |
| -- must be less than 1000, and output is 3 characters with leading |
| -- spaces as needed. |
| |
| procedure Write_Line; |
| -- Output contents of Buffer (1 .. Buflen) followed by a New_Line, |
| -- and set Buflen back to zero, ready to write next line. |
| |
| ---------- |
| -- AddC -- |
| ---------- |
| |
| procedure AddC (C : Character) is |
| begin |
| Buflen := Buflen + 1; |
| Buffer (Buflen) := C; |
| end AddC; |
| |
| ---------- |
| -- AddN -- |
| ---------- |
| |
| procedure AddN (N : Natural) is |
| begin |
| if N > 999 then |
| raise Program_Error; |
| end if; |
| |
| if N > 99 then |
| AddC (Character'Val (48 + N / 100)); |
| else |
| AddC (' '); |
| end if; |
| |
| if N > 9 then |
| AddC (Character'Val (48 + N / 10 mod 10)); |
| else |
| AddC (' '); |
| end if; |
| |
| AddC (Character'Val (48 + N mod 10)); |
| end AddN; |
| |
| ---------------- |
| -- Write_Line -- |
| ---------------- |
| |
| procedure Write_Line is |
| begin |
| AddC (ASCII.LF); |
| |
| if Buflen /= Write (Fdesc, Buffer'Address, Buflen) then |
| Delete_File (Target_Dependent_Info_Write_Name.all, OK); |
| Fail ("disk full writing file " |
| & Target_Dependent_Info_Write_Name.all); |
| end if; |
| |
| Buflen := 0; |
| end Write_Line; |
| |
| -- Start of processing for Write_Target_Dependent_Values |
| |
| begin |
| Fdesc := |
| Create_File (Target_Dependent_Info_Write_Name.all, Text); |
| |
| if Fdesc = Invalid_FD then |
| Fail ("cannot create file " & Target_Dependent_Info_Write_Name.all); |
| end if; |
| |
| -- Loop through values |
| |
| for J in DTN'Range loop |
| |
| -- Output name |
| |
| Buflen := DTN (J)'Length; |
| Buffer (1 .. Buflen) := DTN (J).all; |
| |
| -- Line up values |
| |
| while Buflen < 26 loop |
| AddC (' '); |
| end loop; |
| |
| AddC (' '); |
| AddC (' '); |
| |
| -- Output value and write line |
| |
| AddN (To_ANat (DTV (J)).all); |
| Write_Line; |
| end loop; |
| |
| -- Blank line to separate sections |
| |
| Write_Line; |
| |
| -- Write lines for registered FPT types |
| |
| for J in 1 .. Num_FPT_Modes loop |
| declare |
| E : FPT_Mode_Entry renames FPT_Mode_Table (J); |
| begin |
| Buflen := E.NAME'Last; |
| Buffer (1 .. Buflen) := E.NAME.all; |
| |
| -- Pad out to line up values |
| |
| while Buflen < 11 loop |
| AddC (' '); |
| end loop; |
| |
| AddC (' '); |
| AddC (' '); |
| |
| AddN (E.DIGS); |
| AddC (' '); |
| AddC (' '); |
| |
| case E.FLOAT_REP is |
| when IEEE_Binary => AddC ('I'); |
| end case; |
| |
| AddC (' '); |
| |
| AddN (E.PRECISION); |
| AddC (' '); |
| |
| AddN (E.ALIGNMENT); |
| Write_Line; |
| end; |
| end loop; |
| |
| -- Close file |
| |
| Close (Fdesc, OK); |
| |
| if not OK then |
| Fail ("disk full writing file " |
| & Target_Dependent_Info_Write_Name.all); |
| end if; |
| end Write_Target_Dependent_Values; |
| |
| ---------------------------------- |
| -- Read_Target_Dependent_Values -- |
| ---------------------------------- |
| |
| procedure Read_Target_Dependent_Values (File_Name : String) is |
| File_Desc : File_Descriptor; |
| N : Natural; |
| |
| type ANat is access all Natural; |
| -- Pointer to Nat or Pos value (it is harmless to treat Pos values |
| -- as Nat via Unchecked_Conversion). |
| |
| function To_ANat is new Ada.Unchecked_Conversion (Address, ANat); |
| |
| VP : ANat; |
| |
| Buffer : String (1 .. 2000); |
| Buflen : Natural; |
| -- File information and length (2000 easily enough) |
| |
| Nam_Buf : String (1 .. 40); |
| Nam_Len : Natural; |
| |
| procedure Check_Spaces; |
| -- Checks that we have one or more spaces and skips them |
| |
| procedure FailN (S : String); |
| pragma No_Return (FailN); |
| -- Calls Fail adding " name in file xxx", where name is the currently |
| -- gathered name in Nam_Buf, surrounded by quotes, and xxx is the |
| -- name of the file. |
| |
| procedure Get_Name; |
| -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls |
| -- Skip_Spaces to skip any following spaces. Note that the name is |
| -- terminated by a sequence of at least two spaces. |
| |
| function Get_Nat return Natural; |
| -- N on entry points to decimal integer, scan out decimal integer |
| -- and return it, leaving N pointing to following space or LF. |
| |
| procedure Skip_Spaces; |
| -- Skip past spaces |
| |
| ------------------ |
| -- Check_Spaces -- |
| ------------------ |
| |
| procedure Check_Spaces is |
| begin |
| if N > Buflen or else Buffer (N) /= ' ' then |
| FailN ("missing space for"); |
| end if; |
| |
| Skip_Spaces; |
| return; |
| end Check_Spaces; |
| |
| ----------- |
| -- FailN -- |
| ----------- |
| |
| procedure FailN (S : String) is |
| begin |
| Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file " |
| & File_Name); |
| end FailN; |
| |
| -------------- |
| -- Get_Name -- |
| -------------- |
| |
| procedure Get_Name is |
| begin |
| Nam_Len := 0; |
| |
| -- Scan out name and put it in Nam_Buf |
| |
| loop |
| if N > Buflen or else Buffer (N) = ASCII.LF then |
| FailN ("incorrectly formatted line for"); |
| end if; |
| |
| -- Name is terminated by two blanks |
| |
| exit when N < Buflen and then Buffer (N .. N + 1) = " "; |
| |
| Nam_Len := Nam_Len + 1; |
| |
| if Nam_Len > Nam_Buf'Last then |
| Fail ("name too long"); |
| end if; |
| |
| Nam_Buf (Nam_Len) := Buffer (N); |
| N := N + 1; |
| end loop; |
| |
| Check_Spaces; |
| end Get_Name; |
| |
| ------------- |
| -- Get_Nat -- |
| ------------- |
| |
| function Get_Nat return Natural is |
| Result : Natural := 0; |
| |
| begin |
| loop |
| if N > Buflen |
| or else Buffer (N) not in '0' .. '9' |
| or else Result > 999 |
| then |
| FailN ("bad value for"); |
| end if; |
| |
| Result := Result * 10 + (Character'Pos (Buffer (N)) - 48); |
| N := N + 1; |
| |
| exit when N <= Buflen |
| and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' '); |
| end loop; |
| |
| return Result; |
| end Get_Nat; |
| |
| ----------------- |
| -- Skip_Spaces -- |
| ----------------- |
| |
| procedure Skip_Spaces is |
| begin |
| while N <= Buflen and Buffer (N) = ' ' loop |
| N := N + 1; |
| end loop; |
| end Skip_Spaces; |
| |
| -- Start of processing for Read_Target_Dependent_Values |
| |
| begin |
| File_Desc := Open_Read (File_Name, Text); |
| |
| if File_Desc = Invalid_FD then |
| Fail ("cannot read file " & File_Name); |
| end if; |
| |
| Buflen := Read (File_Desc, Buffer'Address, Buffer'Length); |
| |
| Close (File_Desc); |
| |
| if Buflen = Buffer'Length then |
| Fail ("file is too long: " & File_Name); |
| end if; |
| |
| -- Scan through file for properly formatted entries in first section |
| |
| N := 1; |
| while N <= Buflen and then Buffer (N) /= ASCII.LF loop |
| Get_Name; |
| |
| -- Validate name and get corresponding value pointer |
| |
| VP := null; |
| |
| for J in DTN'Range loop |
| if DTN (J).all = Nam_Buf (1 .. Nam_Len) then |
| VP := To_ANat (DTV (J)); |
| DTR (J) := True; |
| exit; |
| end if; |
| end loop; |
| |
| if VP = null then |
| FailN ("unrecognized name"); |
| end if; |
| |
| -- Scan out value |
| |
| VP.all := Get_Nat; |
| |
| if N > Buflen or else Buffer (N) /= ASCII.LF then |
| FailN ("misformatted line for"); |
| end if; |
| |
| N := N + 1; -- skip LF |
| end loop; |
| |
| -- Fall through this loop when all lines in first section read. |
| -- Check that values have been supplied for all entries. |
| |
| for J in DTR'Range loop |
| if not DTR (J) then |
| -- Make an exception for Long_Long_Long_Size??? |
| |
| if DTN (J) = S_Long_Long_Long_Size'Unrestricted_Access then |
| Long_Long_Long_Size := Long_Long_Size; |
| |
| else |
| Fail ("missing entry for " & DTN (J).all & " in file " |
| & File_Name); |
| end if; |
| end if; |
| end loop; |
| |
| -- Now acquire FPT entries |
| |
| if N >= Buflen then |
| Fail ("missing entries for FPT modes in file " & File_Name); |
| end if; |
| |
| if Buffer (N) = ASCII.LF then |
| N := N + 1; |
| else |
| Fail ("missing blank line in file " & File_Name); |
| end if; |
| |
| Num_FPT_Modes := 0; |
| while N <= Buflen loop |
| Get_Name; |
| |
| Num_FPT_Modes := Num_FPT_Modes + 1; |
| |
| declare |
| E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes); |
| |
| begin |
| E.NAME := new String'(Nam_Buf (1 .. Nam_Len)); |
| |
| if Long_Double_Index < 0 and then E.NAME.all = "long double" then |
| Long_Double_Index := Num_FPT_Modes; |
| end if; |
| |
| E.DIGS := Get_Nat; |
| Check_Spaces; |
| |
| case Buffer (N) is |
| when 'I' => |
| E.FLOAT_REP := IEEE_Binary; |
| |
| when others => |
| FailN ("bad float rep field for"); |
| end case; |
| |
| N := N + 1; |
| Check_Spaces; |
| |
| E.PRECISION := Get_Nat; |
| Check_Spaces; |
| |
| E.ALIGNMENT := Get_Nat; |
| |
| if Buffer (N) /= ASCII.LF then |
| FailN ("junk at end of line for"); |
| end if; |
| |
| -- ??? We do not read E.SIZE, see Write_Target_Dependent_Values |
| |
| E.SIZE := |
| (E.PRECISION + E.ALIGNMENT - 1) / E.ALIGNMENT * E.ALIGNMENT; |
| |
| N := N + 1; |
| end; |
| end loop; |
| end Read_Target_Dependent_Values; |
| |
| -- Package Initialization, set target dependent values. This must be done |
| -- early on, before we start accessing various compiler packages, since |
| -- these values are used all over the place. |
| |
| begin |
| -- First step: see if the -gnateT switch is present. As we have noted, |
| -- this has to be done very early, so cannot depend on the normal circuit |
| -- for reading switches and setting switches in Opt. The following code |
| -- will set Opt.Target_Dependent_Info_Read_Name if the switch -gnateT=name |
| -- is present in the options string. |
| |
| declare |
| type Arg_Array is array (Nat) of Big_String_Ptr; |
| type Arg_Array_Ptr is access Arg_Array; |
| -- Types to access compiler arguments |
| |
| save_argc : Nat; |
| pragma Import (C, save_argc); |
| -- Saved value of argc (number of arguments), imported from misc.c |
| |
| save_argv : Arg_Array_Ptr; |
| pragma Import (C, save_argv); |
| -- Saved value of argv (argument pointers), imported from misc.c |
| |
| gnat_argc : Nat; |
| gnat_argv : Arg_Array_Ptr; |
| pragma Import (C, gnat_argc); |
| pragma Import (C, gnat_argv); |
| -- If save_argv is not set, default to gnat_argc/argv |
| |
| argc : Nat; |
| argv : Arg_Array_Ptr; |
| |
| function Len_Arg (Arg : Big_String_Ptr) return Nat; |
| -- Determine length of argument Arg (a nul terminated C string). |
| |
| ------------- |
| -- Len_Arg -- |
| ------------- |
| |
| function Len_Arg (Arg : Big_String_Ptr) return Nat is |
| begin |
| for J in 1 .. Nat'Last loop |
| if Arg (Natural (J)) = ASCII.NUL then |
| return J - 1; |
| end if; |
| end loop; |
| |
| raise Program_Error; |
| end Len_Arg; |
| |
| begin |
| if save_argv /= null then |
| argv := save_argv; |
| argc := save_argc; |
| else |
| -- Case of a non-GCC compiler, e.g. gnat2why or gnat2scil |
| argv := gnat_argv; |
| argc := gnat_argc; |
| end if; |
| |
| -- Loop through arguments looking for -gnateT, also look for -gnatd.b |
| |
| for Arg in 1 .. argc - 1 loop |
| declare |
| Argv_Ptr : constant Big_String_Ptr := argv (Arg); |
| Argv_Len : constant Nat := Len_Arg (Argv_Ptr); |
| |
| begin |
| if Argv_Len > 8 |
| and then Argv_Ptr (1 .. 8) = "-gnateT=" |
| then |
| Opt.Target_Dependent_Info_Read_Name := |
| new String'(Argv_Ptr (9 .. Natural (Argv_Len))); |
| |
| elsif Argv_Len >= 8 |
| and then Argv_Ptr (1 .. 8) = "-gnatd.b" |
| then |
| Debug_Flag_Dot_B := True; |
| end if; |
| end; |
| end loop; |
| end; |
| |
| -- Case of reading the target dependent values from file |
| |
| -- This is bit more complex than might be expected, because it has to be |
| -- done very early. All kinds of packages depend on these values, and we |
| -- can't wait till the normal processing of reading command line switches |
| -- etc to read the file. We do this at the System.OS_Lib level since it is |
| -- too early to be using Osint directly. |
| |
| if Opt.Target_Dependent_Info_Read_Name /= null then |
| Read_Target_Dependent_Values (Target_Dependent_Info_Read_Name.all); |
| else |
| -- If the back-end comes with a target config file, then use it |
| -- to set the values |
| |
| declare |
| Back_End_Config_File : constant String_Ptr := |
| Get_Back_End_Config_File; |
| begin |
| if Back_End_Config_File /= null then |
| pragma Gnat_Annotate |
| (CodePeer, Intentional, "test always false", |
| "some variant body will return non null"); |
| Read_Target_Dependent_Values (Back_End_Config_File.all); |
| |
| -- Otherwise we get all values from the back end directly |
| |
| else |
| Bits_BE := Get_Bits_BE; |
| Bits_Per_Unit := Get_Bits_Per_Unit; |
| Bits_Per_Word := Get_Bits_Per_Word; |
| Bytes_BE := Get_Bytes_BE; |
| Char_Size := Get_Char_Size; |
| Double_Float_Alignment := Get_Double_Float_Alignment; |
| Double_Scalar_Alignment := Get_Double_Scalar_Alignment; |
| Float_Words_BE := Get_Float_Words_BE; |
| Int_Size := Get_Int_Size; |
| Long_Long_Long_Size := Get_Long_Long_Long_Size; |
| Long_Long_Size := Get_Long_Long_Size; |
| Long_Size := Get_Long_Size; |
| Maximum_Alignment := Get_Maximum_Alignment; |
| Max_Unaligned_Field := Get_Max_Unaligned_Field; |
| Pointer_Size := Get_Pointer_Size; |
| Short_Enums := Get_Short_Enums; |
| Short_Size := Get_Short_Size; |
| Strict_Alignment := Get_Strict_Alignment; |
| System_Allocator_Alignment := Get_System_Allocator_Alignment; |
| Wchar_T_Size := Get_Wchar_T_Size; |
| Words_BE := Get_Words_BE; |
| |
| -- Let the back-end register its floating point types and compute |
| -- the sizes of our standard types from there: |
| |
| Num_FPT_Modes := 0; |
| Register_Back_End_Types (Register_Float_Type'Access); |
| |
| declare |
| T : FPT_Mode_Entry renames |
| FPT_Mode_Table (FPT_Mode_Index_For (S_Float)); |
| begin |
| Float_Size := Pos (T.SIZE); |
| end; |
| |
| declare |
| T : FPT_Mode_Entry renames |
| FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Float)); |
| begin |
| Double_Size := Pos (T.SIZE); |
| end; |
| |
| declare |
| T : FPT_Mode_Entry renames |
| FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Long_Float)); |
| begin |
| Long_Double_Size := Pos (T.SIZE); |
| end; |
| |
| end if; |
| end; |
| end if; |
| end Set_Targ; |
