home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Geek Gadgets 1
/
ADE-1.bin
/
ade-dist
/
gnat-2.06-src.tgz
/
tar.out
/
fsf
/
gnat
/
ada
/
a-tiwtio.adb
< prev
next >
Wrap
Text File
|
1996-09-28
|
29KB
|
1,095 lines
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . T E X T _ I O . W I D E _ T E X T _ I O --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (c) 1992,1993,1994,1995 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.Streams; use Ada.Streams;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System;
with System.File_IO;
with System.WCh_Cnv; use System.WCh_Cnv;
with System.WCh_Con; use System.WCh_Con;
with Unchecked_Conversion;
with Unchecked_Deallocation;
pragma Elaborate_All (System.File_IO);
-- Needed because of calls to Chain_File in package body elaboration
package body Ada.Text_IO.Wide_Text_IO is
package FIO renames System.File_IO;
package TIO renames Ada.Text_IO;
subtype AP is FCB.AFCB_Ptr;
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
-----------------------
-- Local Subprograms --
-----------------------
function Get_Wide_Char
(C : Character;
File : File_Type)
return Wide_Character;
-- This function is shared by Get and Get_Immediate to extract a wide
-- character value from the given File. The first byte has already been
-- read and is passed in C. The wide character value is returned as the
-- result, and the file pointer is bumped past the character.
-------------------
-- AFCB_Allocate --
-------------------
function AFCB_Allocate
(Control_Block : Wide_Text_AFCB)
return FCB.AFCB_Ptr
is
begin
return new Wide_Text_AFCB;
end AFCB_Allocate;
----------------
-- AFCB_Close --
----------------
procedure AFCB_Close (File : access Wide_Text_AFCB) is
begin
-- If the file being closed is one of the current files, then close
-- the corresponding current file. It is not clear that this action
-- is required (RM A.10.3(23)) but it seems reasonable, and besides
-- ACVC test CE3208A expects this behavior).
if File = Current_In then
Current_In := null;
elsif File = Current_Out then
Current_Out := null;
elsif File = Current_Err then
Current_Err := null;
end if;
-- Output line terminator if needed, but page terminator is implied
if File.Mode /= FCB.In_File and then File.Col /= 1 then
New_Line (File);
end if;
end AFCB_Close;
---------------
-- AFCB_Free --
---------------
procedure AFCB_Free (File : access Wide_Text_AFCB) is
type FCB_Ptr is access all Wide_Text_AFCB;
FT : FCB_Ptr := File;
procedure Free is new
Unchecked_Deallocation (Wide_Text_AFCB, FCB_Ptr);
begin
Free (FT);
end AFCB_Free;
-----------
-- Close --
-----------
procedure Close (File : in out File_Type) is
begin
FIO.Close (AP (File));
end Close;
---------
-- Col --
---------
-- Note: we assume that it is impossible in practice for the column
-- to exceed the value of Count'Last, i.e. no check is required for
-- overflow raising layout error.
function Col (File : in File_Type) return Positive_Count is
begin
return Positive_Count (TIO.Col (TIO.File_Type (File)));
end Col;
function Col return Positive_Count is
begin
return Col (Current_Out);
end Col;
------------
-- Create --
------------
procedure Create
(File : in out File_Type;
Mode : in File_Mode := Out_File;
Name : in String := "";
Form : in String := "")
is
File_Control_Block : Wide_Text_AFCB;
begin
FIO.Open (File_Ptr => AP (File),
Dummy_FCB => File_Control_Block,
Mode => To_FCB (Mode),
Name => Name,
Form => Form,
Amethod => 'W',
Creat => True,
Text => True);
Setup (File);
end Create;
-------------------
-- Current_Error --
-------------------
function Current_Error return File_Type is
begin
return Current_Err;
end Current_Error;
function Current_Error return File_Access is
begin
return Current_Err'Access;
end Current_Error;
-------------------
-- Current_Input --
-------------------
function Current_Input return File_Type is
begin
return Current_In;
end Current_Input;
function Current_Input return File_Access is
begin
return Current_In'Access;
end Current_Input;
--------------------
-- Current_Output --
--------------------
function Current_Output return File_Type is
begin
return Current_Out;
end Current_Output;
function Current_Output return File_Access is
begin
return Current_Out'Access;
end Current_Output;
------------
-- Delete --
------------
procedure Delete (File : in out File_Type) is
begin
FIO.Delete (AP (File));
end Delete;
-----------------
-- End_Of_File --
-----------------
function End_Of_File (File : in File_Type) return Boolean is
begin
return TIO.End_Of_File (TIO.File_Type (File));
end End_Of_File;
function End_Of_File return Boolean is
begin
return TIO.End_Of_File (TIO.File_Type (Current_In));
end End_Of_File;
-----------------
-- End_Of_Line --
-----------------
function End_Of_Line (File : in File_Type) return Boolean is
begin
FIO.Check_Read_Status (AP (File));
if File.Before_Wide_Character then
return False;
else
return TIO.End_Of_Line (TIO.File_Type (File));
end if;
end End_Of_Line;
function End_Of_Line return Boolean is
begin
return End_Of_Line (Current_In);
end End_Of_Line;
-----------------
-- End_Of_Page --
-----------------
function End_Of_Page (File : in File_Type) return Boolean is
begin
FIO.Check_Read_Status (AP (File));
if File.Before_Wide_Character then
return False;
else
return TIO.End_Of_Page (TIO.File_Type (File));
end if;
end End_Of_Page;
function End_Of_Page return Boolean is
begin
return End_Of_Page (Current_In);
end End_Of_Page;
-----------
-- Flush --
-----------
procedure Flush (File : in out File_Type) is
begin
FIO.Flush (AP (File));
end Flush;
procedure Flush is
begin
Flush (Current_Out);
end Flush;
----------
-- Form --
----------
function Form (File : in File_Type) return String is
begin
return FIO.Form (AP (File));
end Form;
---------
-- Get --
---------
procedure Get
(File : in File_Type;
Item : out Wide_Character)
is
C : Character;
begin
FIO.Check_Read_Status (AP (File));
if File.Before_Wide_Character then
File.Before_Wide_Character := False;
Item := File.Saved_Wide_Character;
else
TIO.Get (TIO.File_Type (File), C);
Item := Get_Wide_Char (C, File);
end if;
end Get;
procedure Get (Item : out Wide_Character) is
begin
Get (Current_In, Item);
end Get;
procedure Get
(File : in File_Type;
Item : out Wide_String)
is
begin
for J in Item'Range loop
Get (File, Item (J));
end loop;
end Get;
procedure Get (Item : out Wide_String) is
begin
Get (Current_In, Item);
end Get;
-------------------
-- Get_Immediate --
-------------------
-- More work required here ???
procedure Get_Immediate
(File : in File_Type;
Item : out Wide_Character)
is
ch : int;
begin
FIO.Check_Read_Status (AP (File));
if File.Before_Wide_Character then
File.Before_Wide_Character := False;
Item := File.Saved_Wide_Character;
elsif File.Before_LM then
File.Before_LM := False;
File.Before_LM_PM := False;
Item := Wide_Character'Val (LM);
else
ch := Getc (TIO.File_Type (File));
if ch = EOF then
raise End_Error;
else
Item := Get_Wide_Char (Character'Val (ch), File);
end if;
end if;
end Get_Immediate;
procedure Get_Immediate
(Item : out Wide_Character)
is
begin
Get_Immediate (Current_In, Item);
end Get_Immediate;
procedure Get_Immediate
(File : in File_Type;
Item : out Wide_Character;
Available : out Boolean)
is
ch : int;
begin
FIO.Check_Read_Status (AP (File));
Available := True;
if File.Before_Wide_Character then
File.Before_Wide_Character := False;
Item := File.Saved_Wide_Character;
elsif File.Before_LM then
File.Before_LM := False;
File.Before_LM_PM := False;
Item := Wide_Character'Val (LM);
else
ch := Getc (TIO.File_Type (File));
if ch = EOF then
raise End_Error;
else
Item := Get_Wide_Char (Character'Val (ch), File);
end if;
end if;
end Get_Immediate;
procedure Get_Immediate
(Item : out Wide_Character;
Available : out Boolean)
is
begin
Get_Immediate (Current_In, Item, Available);
end Get_Immediate;
--------------
-- Get_Line --
--------------
procedure Get_Line
(File : in File_Type;
Item : out Wide_String;
Last : out Natural)
is
begin
FIO.Check_Read_Status (AP (File));
Last := Item'First - 1;
-- Immediate exit for null string, this is a case in which we do not
-- need to test for end of file and we do not skip a line mark under
-- any circumstances.
if Last >= Item'Last then
return;
end if;
-- Here we have at least one character, if we are immediately before
-- a line mark, then we will just skip past it storing no characters.
if File.Before_LM then
File.Before_LM := False;
File.Before_LM_PM := False;
-- Otherwise we need to read some characters
else
-- If we are at the end of file now, it means we are trying to
-- skip a file terminator and we raise End_Error (RM A.10.7(20))
if Nextc (TIO.File_Type (File)) = EOF then
raise End_Error;
end if;
-- Loop through characters in string
loop
-- Exit the loop if read is terminated by encountering line mark
-- Note that the use of Skip_Line here ensures we properly deal
-- with setting the page and line numbers.
if End_Of_Line (File) then
Skip_Line (File);
return;
end if;
-- Otherwise store the character, note that we know that ch is
-- something other than LM or EOF. It could possibly be a page
-- mark if there is a stray page mark in the middle of a line,
-- but this is not an official page mark in any case, since
-- official page marks can only follow a line mark. The whole
-- page business is pretty much nonsense anyway, so we do not
-- want to waste time trying to make sense out of non-standard
-- page marks in the file! This means that the behavior of
-- Get_Line is different from repeated Get of a character, but
-- that's too bad. We only promise that page numbers etc make
-- sense if the file is formatted in a standard manner.
-- Note: we do not adjust the column number because it is quicker
-- to adjust it once at the end of the operation than incrementing
-- it each time around the loop.
Last := Last + 1;
Get (File, Item (Last));
-- All done if the string is full, this is the case in which
-- we do not skip the following line mark. We need to adjust
-- the column number in this case.
if Last = Item'Last then
File.Col := File.Col + TIO.Count (Item'Length);
return;
end if;
-- Exit from the loop if we are at the end of file. This happens
-- if we have a last line that is not terminated with a line mark.
-- In this case we consider that there is an implied line mark;
-- this is a non-standard file, but we will treat it nicely.
exit when Nextc (TIO.File_Type (File)) = EOF;
end loop;
end if;
end Get_Line;
procedure Get_Line
(Item : out Wide_String;
Last : out Natural)
is
begin
Get_Line (Current_In, Item, Last);
end Get_Line;
-------------------
-- Get_Wide_Char --
-------------------
function Get_Wide_Char
(C : Character;
File : File_Type)
return Wide_Character
is
function In_Char return Character;
-- Function used to obtain additional characters it the wide character
-- sequence is more than one character long.
function In_Char return Character is
ch : constant Integer := Getc (TIO.File_Type (File));
begin
if ch = EOF then
raise End_Error;
else
return Character'Val (ch);
end if;
end In_Char;
function WC_In is new Char_Sequence_To_Wide_Char (In_Char);
begin
return WC_In (C, File.WC_Method);
end Get_Wide_Char;
-------------
-- Is_Open --
-------------
function Is_Open (File : in File_Type) return Boolean is
begin
return FIO.Is_Open (AP (File));
end Is_Open;
----------
-- Line --
----------
-- Note: we assume that it is impossible in practice for the line
-- to exceed the value of Count'Last, i.e. no check is required for
-- overflow raising layout error.
function Line (File : in File_Type) return Positive_Count is
begin
return Positive_Count (TIO.Line (TIO.File_Type (File)));
end Line;
function Line return Positive_Count is
begin
return Line (Current_Out);
end Line;
-----------------
-- Line_Length --
-----------------
function Line_Length (File : in File_Type) return Count is
begin
return Count (TIO.Line_Length (TIO.File_Type (File)));
end Line_Length;
function Line_Length return Count is
begin
return Line_Length (Current_Out);
end Line_Length;
----------------
-- Look_Ahead --
----------------
procedure Look_Ahead
(File : in File_Type;
Item : out Wide_Character;
End_Of_Line : out Boolean)
is
ch : int;
WC : Wide_Character;
-- Start of processing for Look_Ahead
begin
FIO.Check_Read_Status (AP (File));
-- If we are logically before a line mark, we can return immediately
if File.Before_LM then
End_Of_Line := True;
Item := Wide_Character'Val (0);
-- If we are before a wide character, just return it (this happens
-- if there are two calls to Look_Ahead in a row).
elsif File.Before_Wide_Character then
End_Of_Line := False;
Item := File.Saved_Wide_Character;
-- otherwise we must read a character from the input stream
else
ch := Getc (TIO.File_Type (File));
if ch = LM
or else ch = EOF
or else (ch = EOF and then File.Is_Regular_File)
then
End_Of_Line := True;
Ungetc (ch, TIO.File_Type (File));
Item := Wide_Character'Val (0);
-- If the character is in the range 16#0000# to 16#007F# it stands
-- for itself and occupies a single byte, so we can unget it with
-- no difficulty.
elsif ch <= 16#0080# then
End_Of_Line := False;
Ungetc (ch, TIO.File_Type (File));
Item := Wide_Character'Val (ch);
-- For a character above this range, we read the character, using
-- the Get_Wide_Char routine. It may well occupy more than one byte
-- so we can't put it back with ungetc. Instead we save it in the
-- control block, setting a flag that everyone interested in reading
-- characters must test before reading the stream.
else
Item := Get_Wide_Char (Character'Val (ch), File);
End_Of_Line := False;
File.Saved_Wide_Character := Item;
File.Before_Wide_Character := True;
end if;
end if;
end Look_Ahead;
procedure Look_Ahead
(Item : out Wide_Character;
End_Of_Line : out Boolean)
is
begin
Look_Ahead (Standard_In, Item, End_Of_Line);
end Look_Ahead;
----------
-- Mode --
----------
function Mode (File : in File_Type) return File_Mode is
begin
return To_TIO (FIO.Mode (AP (File)));
end Mode;
----------
-- Name --
----------
function Name (File : in File_Type) return String is
begin
return FIO.Name (AP (File));
end Name;
--------------
-- New_Line --
--------------
procedure New_Line
(File : in File_Type;
Spacing : in Positive_Count := 1)
is
begin
TIO.New_Line (TIO.File_Type (File), TIO.Positive_Count (Spacing));
end New_Line;
procedure New_Line (Spacing : in Positive_Count := 1) is
begin
New_Line (Current_Out, Spacing);
end New_Line;
--------------
-- New_Page --
--------------
procedure New_Page (File : in File_Type) is
begin
TIO.New_Page (TIO.File_Type (File));
end New_Page;
procedure New_Page is
begin
New_Page (Current_Out);
end New_Page;
----------
-- Open --
----------
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
Name : in String;
Form : in String := "")
is
File_Control_Block : Wide_Text_AFCB;
begin
FIO.Open (File_Ptr => AP (File),
Dummy_FCB => File_Control_Block,
Mode => To_FCB (Mode),
Name => Name,
Form => Form,
Amethod => 'T',
Creat => False,
Text => True);
Setup (File);
end Open;
----------
-- Page --
----------
-- Note: we assume that it is impossible in practice for the page
-- to exceed the value of Count'Last, i.e. no check is required for
-- overflow raising layout error.
function Page (File : in File_Type) return Positive_Count is
begin
return Positive_Count (TIO.Page (TIO.File_Type (File)));
end Page;
function Page return Positive_Count is
begin
return Page (Current_Out);
end Page;
-----------------
-- Page_Length --
-----------------
function Page_Length (File : in File_Type) return Count is
begin
return Count (TIO.Page_Length (TIO.File_Type (File)));
end Page_Length;
function Page_Length return Count is
begin
return Page_Length (Current_Out);
end Page_Length;
---------
-- Put --
---------
procedure Put
(File : in File_Type;
Item : in Wide_Character)
is
procedure Out_Char (C : Character);
-- Procedure to output one character of a wide character sequence
procedure Out_Char (C : Character) is
begin
Putc (Character'Pos (C), TIO.File_Type (File));
end Out_Char;
procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char);
begin
WC_Out (Item, File.WC_Method);
File.Col := File.Col + 1;
end Put;
procedure Put (Item : in Wide_Character) is
begin
Put (Current_Out, Item);
end Put;
---------
-- Put --
---------
procedure Put
(File : in File_Type;
Item : in Wide_String)
is
begin
for J in Item'Range loop
Put (File, Item (J));
end loop;
end Put;
procedure Put (Item : in Wide_String) is
begin
Put (Current_Out, Item);
end Put;
--------------
-- Put_Line --
--------------
procedure Put_Line
(File : in File_Type;
Item : in Wide_String)
is
begin
Put (File, Item);
New_Line (File);
end Put_Line;
procedure Put_Line (Item : in Wide_String) is
begin
Put (Current_Out, Item);
New_Line (Current_Out);
end Put_Line;
-----------
-- Reset --
-----------
procedure Reset
(File : in out File_Type;
Mode : in File_Mode)
is
function To_TIO_Mode is
new Unchecked_Conversion (File_Mode, TIO.File_Mode);
begin
TIO.Reset (TIO.File_Type (File), To_TIO_Mode (Mode));
File.Before_Wide_Character := False;
end Reset;
procedure Reset (File : in out File_Type) is
begin
TIO.Reset (TIO.File_Type (File));
File.Before_Wide_Character := False;
end Reset;
-------------
-- Set_Col --
-------------
procedure Set_Col
(File : in File_Type;
To : in Positive_Count)
is
begin
TIO.Set_Col (TIO.File_Type (File), TIO.Positive_Count (To));
end Set_Col;
procedure Set_Col (To : in Positive_Count) is
begin
Set_Col (Current_Out, To);
end Set_Col;
---------------
-- Set_Error --
---------------
procedure Set_Error (File : in File_Type) is
begin
FIO.Check_Write_Status (AP (File));
Current_Err := File;
end Set_Error;
---------------
-- Set_Input --
---------------
procedure Set_Input (File : in File_Type) is
begin
FIO.Check_Read_Status (AP (File));
Current_In := File;
end Set_Input;
--------------
-- Set_Line --
--------------
procedure Set_Line
(File : in File_Type;
To : in Positive_Count)
is
begin
TIO.Set_Line (TIO.File_Type (File), TIO.Positive_Count (To));
File.Before_Wide_Character := False;
end Set_Line;
procedure Set_Line (To : in Positive_Count) is
begin
Set_Line (Current_Out, To);
end Set_Line;
---------------------
-- Set_Line_Length --
---------------------
procedure Set_Line_Length (File : in File_Type; To : in Count) is
begin
TIO.Set_Line_Length (TIO.File_Type (File), TIO.Count (To));
end Set_Line_Length;
procedure Set_Line_Length (To : in Count) is
begin
Set_Line_Length (Current_Out, To);
end Set_Line_Length;
----------------
-- Set_Output --
----------------
procedure Set_Output (File : in File_Type) is
begin
FIO.Check_Write_Status (AP (File));
Current_Out := File;
end Set_Output;
---------------------
-- Set_Page_Length --
---------------------
procedure Set_Page_Length (File : in File_Type; To : in Count) is
begin
TIO.Set_Page_Length (TIO.File_Type (File), TIO.Count (To));
end Set_Page_Length;
procedure Set_Page_Length (To : in Count) is
begin
Set_Page_Length (Current_Out, To);
end Set_Page_Length;
-----------
-- Setup --
-----------
procedure Setup (File : File_Type) is
Start, Stop : Natural;
begin
FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop);
if Start = 0 then
null;
elsif Start /= Stop then
raise Use_Error;
else
for J in WC_Encoding_Method loop
if File.Form (Start) = WC_Encoding_Letters (J) then
File.WC_Method := J;
return;
end if;
end loop;
raise Use_Error;
end if;
end Setup;
---------------
-- Skip_Line --
---------------
procedure Skip_Line
(File : in File_Type;
Spacing : in Positive_Count := 1)
is
begin
TIO.Skip_Line (TIO.File_Type (File), TIO.Positive_Count (Spacing));
File.Before_Wide_Character := False;
end Skip_Line;
procedure Skip_Line (Spacing : in Positive_Count := 1) is
begin
Skip_Line (Current_In, Spacing);
end Skip_Line;
---------------
-- Skip_Page --
---------------
procedure Skip_Page (File : in File_Type) is
begin
TIO.Skip_Page (TIO.File_Type (File));
File.Before_Wide_Character := False;
end Skip_Page;
procedure Skip_Page is
begin
Skip_Page (Current_In);
end Skip_Page;
--------------------
-- Standard_Error --
--------------------
function Standard_Error return File_Type is
begin
return Standard_Err;
end Standard_Error;
function Standard_Error return File_Access is
begin
return Standard_Err'Access;
end Standard_Error;
--------------------
-- Standard_Input --
--------------------
function Standard_Input return File_Type is
begin
return Standard_In;
end Standard_Input;
function Standard_Input return File_Access is
begin
return Standard_In'Access;
end Standard_Input;
---------------------
-- Standard_Output --
---------------------
function Standard_Output return File_Type is
begin
return Standard_Out;
end Standard_Output;
function Standard_Output return File_Access is
begin
return Standard_Out'Access;
end Standard_Output;
begin
-------------------------------
-- Initialize Standard Files --
-------------------------------
-- Note: the names in these files are bogus, and probably it would be
-- better for these files to have no names, but the ACVC test insist!
-- We use names that are bound to fail in open etc.
Standard_In.Stream := stdin;
Standard_In.Name := new String'("*stdin");
Standard_In.Form := Null_Str'Access;
Standard_In.Mode := FCB.In_File;
Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0;
Standard_In.Is_Temporary_File := False;
Standard_In.Is_System_File := True;
Standard_In.Is_Text_File := True;
Standard_In.Access_Method := 'W';
Standard_Out.Stream := stdout;
Standard_Out.Name := new String'("*stdout");
Standard_Out.Form := Null_Str'Access;
Standard_Out.Mode := FCB.Out_File;
Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0;
Standard_Out.Is_Temporary_File := False;
Standard_Out.Is_System_File := True;
Standard_Out.Is_Text_File := True;
Standard_Out.Access_Method := 'W';
Standard_Err.Stream := stderr;
Standard_Err.Name := new String'("*stderr");
Standard_Err.Form := Null_Str'Access;
Standard_Err.Mode := FCB.Out_File;
Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0;
Standard_Err.Is_Temporary_File := False;
Standard_Err.Is_System_File := True;
Standard_Err.Is_Text_File := True;
Standard_Err.Access_Method := 'W';
FIO.Chain_File (AP (Standard_In));
FIO.Chain_File (AP (Standard_Out));
FIO.Chain_File (AP (Standard_Err));
end Ada.Text_IO.Wide_Text_IO;