diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/lib-util.adb')
| -rw-r--r-- | gcc-4.9/gcc/ada/lib-util.adb | 337 |
1 files changed, 337 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/lib-util.adb b/gcc-4.9/gcc/ada/lib-util.adb new file mode 100644 index 000000000..ae6e204c2 --- /dev/null +++ b/gcc-4.9/gcc/ada/lib-util.adb @@ -0,0 +1,337 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2013, 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 Hostparm; +with Osint.C; use Osint.C; +with Stringt; use Stringt; + +package body Lib.Util is + + Max_Line : constant Natural := 2 * Hostparm.Max_Name_Length + 64; + Max_Buffer : constant Natural := 1000 * Max_Line; + + Info_Buffer : String (1 .. Max_Buffer); + -- Info_Buffer used to prepare lines of library output + + Info_Buffer_Len : Natural := 0; + -- Number of characters stored in Info_Buffer + + Info_Buffer_Col : Natural := 1; + -- Column number of next character to be written. + -- Can be different from Info_Buffer_Len + 1 because of tab characters + -- written by Write_Info_Tab. + + procedure Write_Info_Hex_Byte (J : Natural); + -- Place two hex digits representing the value J (which is in the range + -- 0-255) in Info_Buffer, incrementing Info_Buffer_Len by 2. The digits + -- are output using lower case letters. + + --------------------- + -- Write_Info_Char -- + --------------------- + + procedure Write_Info_Char (C : Character) is + begin + Info_Buffer_Len := Info_Buffer_Len + 1; + Info_Buffer (Info_Buffer_Len) := C; + Info_Buffer_Col := Info_Buffer_Col + 1; + end Write_Info_Char; + + -------------------------- + -- Write_Info_Char_Code -- + -------------------------- + + procedure Write_Info_Char_Code (Code : Char_Code) is + begin + -- 00 .. 7F + + if Code <= 16#7F# then + Write_Info_Char (Character'Val (Code)); + + -- 80 .. FF + + elsif Code <= 16#FF# then + Write_Info_Char ('U'); + Write_Info_Hex_Byte (Natural (Code)); + + -- 0100 .. FFFF + + else + Write_Info_Char ('W'); + Write_Info_Hex_Byte (Natural (Code / 256)); + Write_Info_Hex_Byte (Natural (Code mod 256)); + end if; + end Write_Info_Char_Code; + + -------------------- + -- Write_Info_Col -- + -------------------- + + function Write_Info_Col return Positive is + begin + return Info_Buffer_Col; + end Write_Info_Col; + + -------------------- + -- Write_Info_EOL -- + -------------------- + + procedure Write_Info_EOL is + begin + if Hostparm.OpenVMS + or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer + then + Write_Info_Terminate; + else + -- Delete any trailing blanks + + while Info_Buffer_Len > 0 + and then Info_Buffer (Info_Buffer_Len) = ' ' + loop + Info_Buffer_Len := Info_Buffer_Len - 1; + end loop; + + Info_Buffer_Len := Info_Buffer_Len + 1; + Info_Buffer (Info_Buffer_Len) := ASCII.LF; + Info_Buffer_Col := 1; + end if; + end Write_Info_EOL; + + ------------------------- + -- Write_Info_Hex_Byte -- + ------------------------- + + procedure Write_Info_Hex_Byte (J : Natural) is + Hexd : constant array (0 .. 15) of Character := "0123456789abcdef"; + begin + Write_Info_Char (Hexd (J / 16)); + Write_Info_Char (Hexd (J mod 16)); + end Write_Info_Hex_Byte; + + ------------------------- + -- Write_Info_Initiate -- + ------------------------- + + procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char; + + -------------------- + -- Write_Info_Int -- + -------------------- + + procedure Write_Info_Int (N : Int) is + begin + if N >= 0 then + Write_Info_Nat (N); + + -- Negative numbers, use Write_Info_Uint to avoid problems with largest + -- negative number. + + else + Write_Info_Uint (UI_From_Int (N)); + end if; + end Write_Info_Int; + + --------------------- + -- Write_Info_Name -- + --------------------- + + procedure Write_Info_Name (Name : Name_Id) is + begin + Get_Name_String (Name); + Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) := + Name_Buffer (1 .. Name_Len); + Info_Buffer_Len := Info_Buffer_Len + Name_Len; + Info_Buffer_Col := Info_Buffer_Col + Name_Len; + end Write_Info_Name; + + procedure Write_Info_Name (Name : File_Name_Type) is + begin + Write_Info_Name (Name_Id (Name)); + end Write_Info_Name; + + procedure Write_Info_Name (Name : Unit_Name_Type) is + begin + Write_Info_Name (Name_Id (Name)); + end Write_Info_Name; + + ----------------------------------- + -- Write_Info_Name_May_Be_Quoted -- + ----------------------------------- + + procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type) is + Quoted : Boolean := False; + Cur : Positive; + + begin + Get_Name_String (Name); + + -- The file/path name is quoted only if it includes spaces + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = ' ' then + Quoted := True; + exit; + end if; + end loop; + + -- Deal with quoting string if needed + + if Quoted then + Insert_Str_In_Name_Buffer ("""", 1); + Add_Char_To_Name_Buffer ('"'); + + -- Any character '"' is doubled + + Cur := 2; + while Cur < Name_Len loop + if Name_Buffer (Cur) = '"' then + Insert_Str_In_Name_Buffer ("""", Cur); + Cur := Cur + 2; + else + Cur := Cur + 1; + end if; + end loop; + end if; + + Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) := + Name_Buffer (1 .. Name_Len); + Info_Buffer_Len := Info_Buffer_Len + Name_Len; + Info_Buffer_Col := Info_Buffer_Col + Name_Len; + end Write_Info_Name_May_Be_Quoted; + + -------------------- + -- Write_Info_Nat -- + -------------------- + + procedure Write_Info_Nat (N : Nat) is + begin + if N > 9 then + Write_Info_Nat (N / 10); + end if; + + Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0'))); + end Write_Info_Nat; + + --------------------- + -- Write_Info_Slit -- + --------------------- + + procedure Write_Info_Slit (S : String_Id) is + C : Character; + + begin + Write_Info_Str (""""); + + for J in 1 .. String_Length (S) loop + C := Get_Character (Get_String_Char (S, J)); + + if C in Character'Val (16#20#) .. Character'Val (16#7E#) + and then C /= '{' + then + Write_Info_Char (C); + + if C = '"' then + Write_Info_Char (C); + end if; + + else + Write_Info_Char ('{'); + Write_Info_Hex_Byte (Character'Pos (C)); + Write_Info_Char ('}'); + end if; + end loop; + + Write_Info_Char ('"'); + end Write_Info_Slit; + + -------------------- + -- Write_Info_Str -- + -------------------- + + procedure Write_Info_Str (Val : String) is + begin + Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length) + := Val; + Info_Buffer_Len := Info_Buffer_Len + Val'Length; + Info_Buffer_Col := Info_Buffer_Col + Val'Length; + end Write_Info_Str; + + -------------------- + -- Write_Info_Tab -- + -------------------- + + procedure Write_Info_Tab (Col : Positive) is + Next_Tab : Positive; + + begin + if Col <= Info_Buffer_Col then + Write_Info_Str (" "); + else + loop + Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1; + exit when Col < Next_Tab; + Write_Info_Char (ASCII.HT); + Info_Buffer_Col := Next_Tab; + end loop; + + while Info_Buffer_Col < Col loop + Write_Info_Char (' '); + end loop; + end if; + end Write_Info_Tab; + + -------------------------- + -- Write_Info_Terminate -- + -------------------------- + + procedure Write_Info_Terminate is + begin + -- Delete any trailing blanks + + while Info_Buffer_Len > 0 + and then Info_Buffer (Info_Buffer_Len) = ' ' + loop + Info_Buffer_Len := Info_Buffer_Len - 1; + end loop; + + -- Write_Library_Info adds the EOL + + Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len)); + + Info_Buffer_Len := 0; + Info_Buffer_Col := 1; + end Write_Info_Terminate; + + --------------------- + -- Write_Info_Uint -- + --------------------- + + procedure Write_Info_Uint (N : Uint) is + begin + UI_Image (N, Decimal); + Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length)); + end Write_Info_Uint; + +end Lib.Util; |