-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions; use Ada.Exceptions;
with Ada.Streams; use Ada.Streams;
with Interfaces.C_Streams; use Interfaces.C_Streams;
-with System;
with System.CRTL;
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;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
pragma Elaborate_All (System.File_IO);
-- Needed because of calls to Chain_File in package body elaboration
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);
+ function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode);
+ function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode);
use type FCB.File_Mode;
use type System.CRTL.size_t;
-- done in Get_Immediate mode (i.e. without waiting for a line return).
procedure Set_WCEM (File : in out File_Type);
- -- Called by Open and Create to set the wide character encoding method
- -- for the file, processing a WCEM form parameter if one is present.
- -- File is IN OUT because it may be closed in case of an error.
+ -- Called by Open and Create to set the wide character encoding method for
+ -- the file, processing a WCEM form parameter if one is present. File is
+ -- IN OUT because it may be closed in case of an error.
-------------------
-- AFCB_Allocate --
-- AFCB_Close --
----------------
- procedure AFCB_Close (File : access Wide_Text_AFCB) is
+ procedure AFCB_Close (File : not null 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
-- AFCB_Free --
---------------
- procedure AFCB_Free (File : access Wide_Text_AFCB) is
+ procedure AFCB_Free (File : not null access Wide_Text_AFCB) is
type FCB_Ptr is access all Wide_Text_AFCB;
FT : FCB_Ptr := FCB_Ptr (File);
- procedure Free is new Unchecked_Deallocation (Wide_Text_AFCB, FCB_Ptr);
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Wide_Text_AFCB, FCB_Ptr);
begin
Free (FT);
procedure Close (File : in out File_Type) is
begin
- FIO.Close (AP (File));
+ FIO.Close (AP (File)'Unrestricted_Access);
end Close;
---------
Amethod => 'W',
Creat => True,
Text => True);
+
+ File.Self := File;
Set_WCEM (File);
end Create;
function Current_Error return File_Access is
begin
- return Current_Err'Access;
+ return Current_Err.Self'Access;
end Current_Error;
-------------------
function Current_Input return File_Access is
begin
- return Current_In'Access;
+ return Current_In.Self'Access;
end Current_Input;
--------------------
function Current_Output return File_Access is
begin
- return Current_Out'Access;
+ return Current_Out.Self'Access;
end Current_Output;
------------
procedure Delete (File : in out File_Type) is
begin
- FIO.Delete (AP (File));
+ FIO.Delete (AP (File)'Unrestricted_Access);
end Delete;
-----------------
return False;
elsif File.Before_LM then
-
if File.Before_LM_PM then
return Nextc (File) = EOF;
end if;
File.Before_Wide_Character := False;
Item := File.Saved_Wide_Character;
+ -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same???
+
else
Get_Character (File, C);
Item := Get_Wide_Char (C, File);
Item := Wide_Character'Val (LM);
else
+ -- Shouldn't we use getc_immediate_nowait here, like Text_IO???
+
ch := Getc_Immed (File);
if ch = EOF then
end if;
end In_Char;
- -- Start of processing for In_Char
+ -- Start of processing for Get_Wide_Char
begin
+ FIO.Check_Read_Status (AP (File));
return WC_In (C, File.WC_Method);
end Get_Wide_Char;
-- Start of processing for Get_Wide_Char_Immed
begin
+ FIO.Check_Read_Status (AP (File));
return WC_In (C, File.WC_Method);
end Get_Wide_Char_Immed;
End_Of_Line := True;
Item := Wide_Character'Val (0);
- -- If we are before a wide character, just return it (this happens
+ -- If we are before a wide character, just return it (this can happen
-- if there are two calls to Look_Ahead in a row).
elsif File.Before_Wide_Character then
Ungetc (ch, 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
+ -- Case where character obtained does not represent the start of an
+ -- encoded sequence so it stands for itself and we can unget it with
-- no difficulty.
- elsif ch <= 16#0080# then
+ elsif not Is_Start_Of_Encoding
+ (Character'Val (ch), File.WC_Method)
+ then
End_Of_Line := False;
Ungetc (ch, 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
+ -- For the start of an encoding, we read the character using the
+ -- Get_Wide_Char routine. It will 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
Amethod => 'W',
Creat => False,
Text => True);
+
+ File.Self := File;
Set_WCEM (File);
end Open;
-- Procedure to output one character of a wide character sequence
procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char);
+
--------------
-- Out_Char --
--------------
-- Start of processing for Put
begin
+ FIO.Check_Write_Status (AP (File));
WC_Out (Item, File.WC_Method);
File.Col := File.Col + 1;
end Put;
end if;
Terminate_Line (File);
- FIO.Reset (AP (File), To_FCB (Mode));
+ FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode));
File.Page := 1;
File.Line := 1;
File.Col := 1;
procedure Reset (File : in out File_Type) is
begin
Terminate_Line (File);
- FIO.Reset (AP (File));
+ FIO.Reset (AP (File)'Unrestricted_Access);
File.Page := 1;
File.Line := 1;
File.Col := 1;
if Start = 0 then
File.WC_Method := WCEM_Brackets;
- elsif Start /= 0 then
+ else
if Stop = Start then
for J in WC_Encoding_Letters'Range loop
if File.Form (Start) = WC_Encoding_Letters (J) then
end if;
Close (File);
- Raise_Exception (Use_Error'Identity, "invalid WCEM form parameter");
+ raise Use_Error with "invalid WCEM form parameter";
end if;
end Set_WCEM;
-- up for such files, so we assume an implicit LM in this case.
loop
- exit when ch = LM or ch = EOF;
+ exit when ch = LM or else ch = EOF;
ch := Getc (File);
end loop;
end if;
Ungetc (ch, File);
end if;
end if;
-
end loop;
File.Before_Wide_Character := False;
(File : in out Wide_Text_AFCB;
Item : Stream_Element_Array)
is
+ pragma Warnings (Off, File);
+ -- Because in this implementation we don't need IN OUT, we only read
+
Siz : constant size_t := Item'Length;
begin
-- a null character in the runtime, here the null characters are added
-- just to have a correct filename length.
- Err_Name : aliased String := "*stderr" & ASCII.Nul;
- In_Name : aliased String := "*stdin" & ASCII.Nul;
- Out_Name : aliased String := "*stdout" & ASCII.Nul;
+ Err_Name : aliased String := "*stderr" & ASCII.NUL;
+ In_Name : aliased String := "*stdin" & ASCII.NUL;
+ Out_Name : aliased String := "*stdout" & ASCII.NUL;
begin
-------------------------------
Standard_Err.Is_System_File := True;
Standard_Err.Is_Text_File := True;
Standard_Err.Access_Method := 'T';
+ Standard_Err.Self := Standard_Err;
Standard_Err.WC_Method := Default_WCEM;
- Standard_In.Stream := stdin;
- Standard_In.Name := In_Name'Access;
- Standard_In.Form := Null_Str'Unrestricted_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 := 'T';
- Standard_In.WC_Method := Default_WCEM;
+ Standard_In.Stream := stdin;
+ Standard_In.Name := In_Name'Access;
+ Standard_In.Form := Null_Str'Unrestricted_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 := 'T';
+ Standard_In.Self := Standard_In;
+ Standard_In.WC_Method := Default_WCEM;
Standard_Out.Stream := stdout;
Standard_Out.Name := Out_Name'Access;
Standard_Out.Is_System_File := True;
Standard_Out.Is_Text_File := True;
Standard_Out.Access_Method := 'T';
+ Standard_Out.Self := Standard_Out;
Standard_Out.WC_Method := Default_WCEM;
FIO.Chain_File (AP (Standard_In));
OSDN Git Service
