Fresh Fish 8/FreshFishVol8-CD1.bin/gnu/lib/gcc-lib/amigados/2.6.3/adainclude/a-textio.adb

Text File | 1994-11-30 | 21.5 KB | 856 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUNTIME COMPONENTS                          --
--                                                                          --
--                          A D A . T E X T _ I O                           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.23 $                             --
--                                                                          --
--           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
--                                                                          --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software  Foundation; either version 2, or (at your option) any --
-- later version.  The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
-- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
-- Library  General  Public  License for  more  details.  You  should  have --
-- received  a copy of the GNU  Library  General Public License  along with --
-- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Text_IO.Aux;
with System.Unsigned_Types;
package body Ada.Text_IO is

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Unimplemented (Message : String);
   --  Output message for unimplemented feature

   -------------------
   -- Unimplemented --
   -------------------

   procedure Unimplemented (Message : String) is
   begin
      Put (Message);
      Put_Line (" not implemented yet");
      raise Program_Error;
   end Unimplemented;

   ---------------------
   -- File Management --
   ---------------------

   procedure Create
     (File : in out File_Type;
      Mode : in File_Mode := Out_File;
      Name : in String := "";
      Form : in String := "")
   renames Text_IO.Aux.Create;

   procedure Open
     (File : in out File_Type;
      Mode : in File_Mode;
      Name : in String;
      Form : in String := "")
   renames Text_IO.Aux.Open;

   procedure Close  (File : in out File_Type) renames Text_IO.Aux.Close;
   procedure Delete (File : in out File_Type) renames Text_IO.Aux.Delete;

   procedure Reset
     (File : in out File_Type;
      Mode : in File_Mode)
   renames Text_IO.Aux.Reset;

   procedure Reset (File : in out File_Type) is
   begin
      Text_IO.Aux.Reset (File, Text_IO.Aux.Mode (File));
   end Reset;

   function Mode (File : in File_Type) return File_Mode
     renames Text_IO.Aux.Mode;

   function Name (File : in File_Type) return String renames Text_IO.Aux.Name;
   function Form (File : in File_Type) return String renames Text_IO.Aux.Form;

   function Is_Open (File : in File_Type) return Boolean
     renames Text_IO.Aux.Is_Open;

   procedure Set_Input  (File : in File_Type) renames Text_IO.Aux.Set_Input;
   procedure Set_Output (File : in File_Type) renames Text_IO.Aux.Set_Output;
   procedure Set_Error  (File : in File_Type) renames Text_IO.Aux.Set_Error;

   function Standard_Input return File_Type
     renames Text_IO.Aux.Standard_Input;

   function Standard_Output return File_Type
     renames Text_IO.Aux.Standard_Output;

   function Standard_Error return File_Type
     renames Text_IO.Aux.Standard_Error;

   function Current_Input  return File_Type renames Text_IO.Aux.Current_Input;
   function Current_Output return File_Type renames Text_IO.Aux.Current_Output;
   function Current_Error  return File_Type renames Text_IO.Aux.Current_Error;

   function Standard_Input return File_Access is
   begin
      return Text_IO.Aux.Standard_In'Access;
   end Standard_Input;

   function Standard_Output return File_Access is
   begin
      return Text_IO.Aux.Standard_Out'Access;
   end Standard_Output;

   function Standard_Error return File_Access is
   begin
      return Text_IO.Aux.Standard_Err'Access;
   end Standard_Error;

   function Current_Input  return File_Access is
   begin
      return Text_IO.Aux.Current_In'Access;
   end Current_Input;

   function Current_Output return File_Access is
   begin
      return Text_IO.Aux.Current_Out'Access;
   end Current_Output;

   function Current_Error  return File_Access is
   begin
      return Text_IO.Aux.Current_Err'Access;
   end Current_Error;

   --------------------
   -- Buffer control --
   --------------------

   procedure Flush (File : in out File_Type) is
   begin
      Unimplemented ("Flush");
      raise Program_Error;
   end Flush;

   procedure Flush is
   begin
      Unimplemented ("Flush");
      raise Program_Error;
   end Flush;

   --------------------------------------------
   -- Specification of line and page lengths --
   --------------------------------------------

   procedure Set_Line_Length (File : in File_Type; To : in Count)
     renames Text_IO.Aux.Set_Line_Length;

   procedure Set_Line_Length (To : in Count) is
   begin
      Text_IO.Aux.Set_Line_Length (Current_Output, To);
   end Set_Line_Length;

   function Line_Length (File : in File_Type) return Count
     renames Text_IO.Aux.Line_Length;

   function Line_Length return Count is
   begin
      return Text_IO.Aux.Line_Length (Current_Output);
   end Line_Length;

   procedure Set_Page_Length (File : in File_Type; To : in Count)
     renames Text_IO.Aux.Set_Page_Length;

   procedure Set_Page_Length (To : in Count) is
   begin
      Text_IO.Aux.Set_Page_Length (Current_Output, To);
   end Set_Page_Length;

   function Page_Length (File : in File_Type) return Count
     renames Text_IO.Aux.Page_Length;

   function Page_Length return Count is
   begin
      return Page_Length (Current_Output);
   end Page_Length;

   ------------------------------------
   -- Column, Line, and Page Control --
   ------------------------------------

   procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1)
     renames Text_IO.Aux.New_Line;

   procedure New_Line (Spacing : in Positive_Count := 1) is
   begin
      New_Line (Current_Output, Spacing);
   end New_Line;

   procedure Skip_Line
     (File    : in File_Type;
      Spacing : in Positive_Count := 1)
   renames Text_IO.Aux.Skip_Line;

   procedure Skip_Line (Spacing : in Positive_Count := 1) is
   begin
      Skip_Line (Current_Input, Spacing);
   end Skip_Line;

   function End_Of_Line (File : in File_Type) return Boolean
     renames Text_IO.Aux.End_Of_Line;

   function End_Of_Line return Boolean is
   begin
      return End_Of_Line (Current_Input);
   end End_Of_Line;

   procedure New_Page (File : in File_Type) renames Text_IO.Aux.New_Page;

   procedure New_Page is
   begin
      New_Page (Current_Output);
   end New_Page;

   procedure Skip_Page (File : in File_Type) renames Text_IO.Aux.Skip_Page;

   procedure Skip_Page is
   begin
      Skip_Page (Current_Input);
   end Skip_Page;

   function End_Of_Page (File : in File_Type) return Boolean
     renames Text_IO.Aux.End_Of_Page;

   function End_Of_Page return Boolean is
   begin
      return End_Of_Page (Current_Input);
   end End_Of_Page;

   function End_Of_File (File : in File_Type) return Boolean
     renames Text_IO.Aux.End_Of_File;

   function End_Of_File return Boolean is
   begin
      return End_Of_File (Current_Input);
   end End_Of_File;

   procedure Set_Col
     (File : in File_Type;
      To   : in Positive_Count)
   renames Text_IO.Aux.Set_Col;

   procedure Set_Col (To : in Positive_Count) is
   begin
      Set_Col (Current_Output, To);
   end Set_Col;

   procedure Set_Line
     (File : in File_Type;
      To   : in Positive_Count)
   renames Text_IO.Aux.Set_Line;

   procedure Set_Line (To : in Positive_Count) is
   begin
      Set_Line (Current_Output, To);
   end Set_Line;

   function Col (File : in File_Type) return Positive_Count
     renames Text_IO.Aux.Col;

   function Col return Positive_Count is
   begin
      return Col (Current_Output);
   end Col;

   function Line (File : in File_Type) return Positive_Count
     renames Text_IO.Aux.Line;

   function Line return Positive_Count is
   begin
      return Line (Current_Output);
   end Line;

   function Page (File : in File_Type) return Positive_Count
     renames Text_IO.Aux.Page;

   function Page return Positive_Count is
   begin
      return Page (Current_Output);
   end Page;

   -------------------------------
   --  Characters Input-Output  --
   -------------------------------

   procedure Get
     (File : in File_Type;
      Item : out Character)
   is
   begin
      Text_IO.Aux.The_File := File;
      Text_IO.Aux.Get (Item);
   end Get;


   procedure Get (Item : out Character) is
   begin
      Get (Current_Input, Item);
   end Get;

   procedure Put
     (File : in File_Type;
      Item : in Character)
   is
   begin
      Text_IO.Aux.The_File := File;
      Text_IO.Aux.Put (Item);
   end Put;

   procedure Put (Item : in Character) is
   begin
      Put (Current_Output, Item);
   end Put;

   procedure Look_Ahead
     (File        : in File_Type;
      Item        : out Character;
      End_Of_Line : out Boolean)
   is
   begin
      Unimplemented ("Look_Ahead");
      raise Program_Error;
   end Look_Ahead;

   procedure Look_Ahead
     (Item        : out Character;
      End_of_Line : out Boolean)
   is
   begin
      Unimplemented ("Look_Ahead");
      raise Program_Error;
   end Look_Ahead;

   procedure Get_Immediate
     (File : in File_Type;
      Item : out Character)
   is
   begin
      Unimplemented ("Get_Immediate");
      raise Program_Error;
   end Get_Immediate;

   procedure Get_Immediate (Item : out Character) is
   begin
      Unimplemented ("Get_Immediate");
      raise Program_Error;
   end Get_Immediate;

   procedure Get_Immediate
     (File      : in File_Type;
      Item      : out Character;
      Available : out Boolean)
   is
   begin
      Unimplemented ("Get_Immediate");
      raise Program_Error;
   end Get_Immediate;

   procedure Get_Immediate
     (Item      : out Character;
      Available : out Boolean)
   is
   begin
      Unimplemented ("Get_Immediate");
      raise Program_Error;
   end Get_Immediate;

   ---------------------------
   -- Strings Input-Output  --
   ---------------------------

   procedure Get
     (File : in File_Type;
      Item : out String)
   is
   begin
      Text_IO.Aux.The_File := File;
      Text_IO.Aux.Get (Item);
   end Get;

   procedure Get (Item : out String) is
   begin
      Get (Current_Input, Item);
   end Get;

   procedure Put
     (File : in File_Type;
      Item : in String)
   is
   begin
      Text_IO.Aux.The_File := File;
      Text_IO.Aux.Put (Item);
   end Put;

   procedure Put (Item : in String) is
   begin
      Put (Current_Output, Item);
   end Put;

   procedure Get_Line
     (File : in File_Type;
      Item : out String;
      Last : out Natural)
   renames Text_IO.Aux.Get_Line;

   procedure Get_Line
     (Item : out String;
      Last : out Natural)
   is
   begin
      Get_Line (Current_Input, Item, Last);
   end Get_Line;

   procedure Put_Line
     (File : in File_Type;
      Item : in String)
   renames Text_IO.Aux.Put_Line;

   procedure Put_Line (Item : in String) is
   begin
      Put_Line (Current_Output, Item);
   end Put_Line;

   -------------------------------------
   --  Input-Output of Integer Types  --
   -------------------------------------

   package body Integer_Io is
      subtype LLI is Long_Long_Integer;

      Num_First : LLI := LLI (Num'First);
      Num_Last  : LLI := LLI (Num'Last);

      procedure Get
        (File  : in File_Type;
         Item  : out Num;
         Width : in Field := 0)
      is
         X : Integer;

      begin
         if Num'Size > Integer'Size then
            Unimplemented ("Get on this type (Num too big)");
         end if;

         Text_IO.Aux.The_File := File;
         Text_IO.Aux.Get_Int (X, Width);

         if LLI (X) < Num_First or else LLI (X) > Num_Last then
            raise Data_Error;
         end if;

         Item := Num (X);
      end Get;

      procedure Get
        (Item  : out Num;
         Width : in Field := 0)
      is
      begin
         Get (Current_Input, Item, Width);
      end Get;

      procedure Put
        (File  : in File_Type;
         Item  : in Num;
         Width : in Field := Default_Width;
         Base  : in Number_Base := Default_Base)
      is
      begin
         Text_IO.Aux.The_File := File;

         if Num'Size > Integer'Size then
            Text_IO.Aux.Put_LLI (LLI (Item), Width, Base);
         else
            Text_IO.Aux.Put_Integer (Integer (Item), Width, Base);
         end if;
      end Put;

      procedure Put
        (Item  : in Num;
         Width : in Field := Default_Width;
         Base  : in Number_Base := Default_Base)
      is
      begin
         Put (Current_Output, Item, Width, Base);
      end Put;

      procedure Get
        (From : in String;
         Item : out Num;
         Last : out Positive)
      is
         Pos : Positive;
         X   : LLI;

      begin
         Text_IO.Aux.Get_LLI (From, X, Pos, Num'Size);
         if X < Num_First or else X > Num_Last then
            raise Data_Error;
         end if;

         Item := Num (X);
         Last := Pos;
      end Get;


      procedure Put
        (To   : out String;
         Item : in Num;
         Base : in Number_Base := Default_Base)
      is
      begin
         if Num'Size > Integer'Size then
            Text_IO.Aux.Put_LLI (To, LLI (Item), Base);
         else
            Text_IO.Aux.Put_Integer (To, Integer (Item), Base);
         end if;
      end Put;

   end Integer_Io;

   -------------------------------------
   --  Input-Output of Modular Types  --
   -------------------------------------

   package body Modular_IO is
      use System.Unsigned_Types;
      subtype LLU is Long_Long_Unsigned;

      Num_First : LLU := LLU (Num'First);
      Num_Last  : LLU := LLU (Num'Last);

      procedure Get
        (File  : in File_Type;
         Item  : out Num;
         Width : in Field := 0)
      is
      begin
         Unimplemented ("Modular Get");
      end Get;

      procedure Get
        (Item  : out Num;
         Width : in Field := 0)
      is
      begin
         Get (Current_Input, Item, Width);
      end Get;

      procedure Put
        (File  : in File_Type;
         Item  : in Num;
         Width : in Field := Default_Width;
         Base  : in Number_Base := Default_Base)
      is
      begin
         Text_IO.Aux.The_File := File;

         if Num'Size > Unsigned'Size then
            Text_IO.Aux.Put_LLU (LLU (Item), Width, Base);
         else
            Text_IO.Aux.Put_Unsigned (Unsigned (Item), Width, Base);
         end if;
      end Put;

      procedure Put
        (Item  : in Num;
         Width : in Field := Default_Width;
         Base  : in Number_Base := Default_Base)
      is
      begin
         Put (Current_Output, Item, Width, Base);
      end Put;

      procedure Get
        (From : in String;
         Item : out Num;
         Last : out Positive)
      is
         Pos  : Positive;
         X    : LLU;

      begin
         Text_IO.Aux.Get_LLU (From, X, Pos, Num'Size);

         if X < Num_First or else X > Num_Last then
            raise Data_Error;
         end if;

         Item := Num (X);
         Last := Pos;
      end Get;

      procedure Put
        (To   : out String;
         Item : in Num;
         Base : in Number_Base := Default_Base)
      is
      begin
         if Num'Size > Unsigned'Size then
            Text_IO.Aux.Put_LLU (To, LLU (Item), Base);
         else
            Text_IO.Aux.Put_Unsigned (To, Unsigned (Item), Base);
         end if;
      end Put;

   end Modular_IO;

   ---------------------------------
   -- Input-Output of Float Types --
   ---------------------------------

   package body Float_Io is

      Num_First : Aux.LLF := Aux.LLF (Num'First);
      Num_Last  : Aux.LLF := Aux.LLF (Num'Last);

      procedure Get
        (File : in File_Type;
         Item : out Num;
         Width : in Field := 0)
      is
         X : Aux.LLF;

      begin
         Text_IO.Aux.The_File := File;
         Text_IO.Aux.Get_Float (X, Width);

         if X < Num_First or else X > Num_Last then
            raise Data_Error;
         end if;

         Item := Num (X);
      end Get;

      procedure Get
        (Item : out Num;
         Width : in Field := 0)
      is
      begin
         Get (Current_Input, Item, Width);
      end Get;

      procedure Put
        (File : in File_Type;
         Item : in Num;
         Fore : in Field := Default_Fore;
         Aft  : in Field := Default_Aft;
         Exp  : in Field := Default_Exp)
      is
      begin
         Text_IO.Aux.The_File := File;
         Text_IO.Aux.Put_Float (Aux.LLF (Item), Fore, Aft, Exp);
      end Put;

      procedure Put
        (Item : in Num;
         Fore : in Field := Default_Fore;
         Aft  : in Field := Default_Aft;
         Exp : in Field := Default_Exp)
      is
      begin
         Put (Current_Output, Item, Fore, Aft, Exp);
      end Put;

      procedure Get
        (From : in String;
         Item : out Num;
         Last : out Positive)
      is
      begin
         Text_IO.Aux.Get_Float (From, Aux.LLF (Item), Last);
      end Get;

      procedure Put
        (To : out String;
         Item : in Num;
         Aft : in Field := Default_Aft;
         Exp : in Field := Default_Exp)
      is
      begin
         Text_IO.Aux.Put_Float (To, Aux.LLF (Item), Aft, Exp);
      end Put;

   end Float_Io;

   package body Fixed_Io is

      X : Aux.LLF;

      procedure Get
        (File  : in File_Type;
         Item  : out Num;
         Width : in Field := 0)
      is
      begin
         Text_IO.Aux.The_File := File;
         Text_IO.Aux.Get_Float (X, Width);
         --  ???
         --  if X < Aux.LLF (Num'First) or else X > Aux.LLF (Num'Last) then
         --     raise Data_Error;
         --  end if;
         Item := Num (X);
      end Get;

      procedure Get
        (Item  : out Num;
         Width : in Field := 0)
      is
      begin
         Get (Current_Input, Item, Width);
      end Get;

      procedure Put
        (File : in File_Type;
         Item : in Num;
         Fore : in Field := Default_Fore;
         Aft  : in Field := Default_Aft;
         Exp  : in Field := Default_Exp)
      is
      begin
         Text_IO.Aux.The_File := File;
         Text_IO.Aux.Put_Float (Aux.LLF (Item), Fore, Aft, Exp);
      end Put;

      procedure Put
        (Item : in Num;
         Fore : in Field := Default_Fore;
         Aft  : in Field := Default_Aft;
         Exp  : in Field := Default_Exp)
      is
      begin
         Put (Current_Output, Item, Fore, Aft, Exp);
      end Put;

      procedure Get
        (From : in String;
         Item : out Num; Last : out Positive)
      is
      begin
         Text_IO.Aux.Get_Float (From, X, Last);
         --  ???
         --  if X < Aux.LLF (Num'First) or else X > Aux.LLF (Num'Last) then
         --     raise Data_Error;
         --  end if;
         Item := Num (X);
      end Get;

      procedure Put
        (To   : out String;
         Item : in Num;
         Aft  : in Field := Default_Aft;
         Exp  : in Field := Default_Exp)
      is
      begin
         Text_IO.Aux.Put_Float (To, Aux.LLF (Item), Aft, Exp);
      end Put;

   end Fixed_Io;

   ---------------------------------------
   -- Input-Output of Enumeration Types --
   ---------------------------------------

   package body Enumeration_Io is

      --  S : String (1 .. Enum'Width);
      S : String (1 .. 255); -- ???

      procedure Get
        (File : in File_Type;
         Item : out Enum)
      is
         Len : Positive;

      begin
         Text_IO.Aux.The_File := File;
         Text_IO.Aux.Get_Enum (S, Len);

         for E in Enum'Range loop
            if Enum'Image (E) = S (1 .. Len) then
               Item := E;
               return;
            end if;
         end loop;
         raise Data_Error;
      end Get;

      procedure Get (Item : out Enum) is
      begin
         Get (Current_Input, Item);
      end Get;

      procedure Put
        (File  : in File_Type;
         Item  : in Enum;
         Width : in Field := Default_Width;
         Set   : in Type_Set := Default_Setting)
      is
      begin
         Text_IO.Aux.The_File := File;
         Text_IO.Aux.Put_Enum (Enum'Image (Item), Width, Set);
      end Put;

      procedure Put
        (Item  : in Enum;
         Width : in Field := Default_Width;
         Set   : in Type_Set := Default_Setting)
      is
      begin
         Put (Current_Output, Item, Width, Set);
      end Put;

      procedure Get
        (From : in String;
         Item : out Enum;
         Last : out Positive)
      is
         Len : Positive;

      begin
         Text_IO.Aux.Get_Enum (S, From, Len, Last);

         for E in Enum'Range loop
            if Enum'Image (E) = S (1 .. Len) then
               Item := E;
               return;
            end if;
         end loop;

         raise Data_Error;
      end Get;

      procedure Put
        (To   : out String;
         Item : in Enum;
         Set  : in Type_Set := Default_Setting)
      is
      begin
         Text_IO.Aux.Put_Enum (To, Enum'Image (Item), Set);
      end Put;

   end Enumeration_Io;

end Ada.Text_IO;