Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             L I B . U T I L                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, 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_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;