diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/set_targ.adb')
| -rwxr-xr-x | gcc-4.9/gcc/ada/set_targ.adb | 863 |
1 files changed, 863 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/set_targ.adb b/gcc-4.9/gcc/ada/set_targ.adb new file mode 100755 index 000000000..d6268c823 --- /dev/null +++ b/gcc-4.9/gcc/ada/set_targ.adb @@ -0,0 +1,863 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E T _ T A R G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2014, 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 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_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_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_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 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. + -- + -- So to summarize, the only types that are actually registered have Digs + -- non-zero, Complex zero (false), and Count zero (not a vector). + + ---------- + -- 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; + + ------------------------- + -- 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"); + + when VAX_Native => + case Digs is + when 6 => + Write_Str ("VAXF"); + + when 9 => + Write_Str ("VAXD"); + + when 15 => + Write_Str ("VAXG"); + + when others => + Write_Str ("VAX_"); + Write_Int (Int (Digs)); + end case; + + when AAMP => Write_Str ("AAMP"); + 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 + Num_FPT_Modes := Num_FPT_Modes + 1; + FPT_Mode_Table (Num_FPT_Modes) := + (NAME => new String'(T (1 .. Last)), + DIGS => Digs, + FLOAT_REP => Float_Rep, + PRECISION => Precision, + SIZE => Size, + ALIGNMENT => Alignment); + 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 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'Address, 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'Address, 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'); + when VAX_Native => + AddC ('V'); + when AAMP => + AddC ('A'); + 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; + +-- 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 can not 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; + + -- If the switch is not set, we get all values from the back end + + if Opt.Target_Dependent_Info_Read_Name = null then + + -- Set values by direct calls to the back end + + 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; + Double_Size := Get_Double_Size; + Float_Size := Get_Float_Size; + Float_Words_BE := Get_Float_Words_BE; + Int_Size := Get_Int_Size; + Long_Double_Size := Get_Long_Double_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; + + -- Register floating-point types from the back end + + Register_Back_End_Types (Register_Float_Type'Access); + + -- 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. + + else + Read_Target_Dependent_Values : declare + 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 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); + -- 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 " + & Target_Dependent_Info_Read_Name.all); + 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 (Target_Dependent_Info_Read_Name.all, Text); + + if File_Desc = Invalid_FD then + Fail ("cannot read file " & Target_Dependent_Info_Read_Name.all); + end if; + + Buflen := Read (File_Desc, Buffer'Address, Buffer'Length); + + if Buflen = Buffer'Length then + Fail ("file is too long: " & Target_Dependent_Info_Read_Name.all); + 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 + Fail ("missing entry for " & DTN (J).all & " in file " + & Target_Dependent_Info_Read_Name.all); + end if; + end loop; + + -- Now acquire FPT entries + + if N >= Buflen then + Fail ("missing entries for FPT modes in file " + & Target_Dependent_Info_Read_Name.all); + end if; + + if Buffer (N) = ASCII.LF then + N := N + 1; + else + Fail ("missing blank line in file " + & Target_Dependent_Info_Read_Name.all); + 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)); + + E.DIGS := Get_Nat; + Check_Spaces; + + case Buffer (N) is + when 'I' => + E.FLOAT_REP := IEEE_Binary; + when 'V' => + E.FLOAT_REP := VAX_Native; + when 'A' => + E.FLOAT_REP := AAMP; + 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; + end if; +end Set_Targ; |