|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 80474 (0x13a5a)
Types: TextFile
Names: »B«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦4c85d69e2⟧
└─⟦this⟧
-- The use of this system is subject to the software license terms and
-- conditions agreed upon between Rational and the Customer.
--
-- Copyright 1988 by Rational.
--
-- RESTRICTED RIGHTS LEGEND
--
-- Use, duplication, or disclosure by the Government is subject to
-- restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
-- Technical Data and Computer Software clause at 52.227-7013.
--
--
-- Rational
-- 3320 Scott Boulevard
-- Santa Clara, California 95054-3197
--
-- PROPRIETARY AND CONFIDENTIAL INFORMATION OF RATIONAL;
-- USE OR COPYING WITHOUT EXPRESS WRITTEN AUTHORIZATION
-- IS STRICTLY PROHIBITED. THIS MATERIAL IS PROTECTED AS
-- AN UNPUBLISHED WORK UNDER THE U.S. COPYRIGHT ACT OF
-- 1976. CREATED 1988. ALL RIGHTS RESERVED.
--
--
with Buffering;
with Device_Independent_Io;
with Io_Exceptions;
with Io_Exception_Flavors;
with Machine_Primitive_Operations;
with Primitive_Io;
with Semaphore;
with System;
with System_Types;
with Text_Io;
with Unchecked_Conversion;
pragma Elaborate (Device_Independent_Io);
package body Common_Text_Io is
package Iox renames Io_Exceptions;
package Iof renames Io_Exception_Flavors;
package Dio renames Device_Independent_Io;
--
subtype Byte is System_Types.Byte;
subtype Byte_String is System_Types.Byte_String;
subtype Long_Integer is System_Types.Long_Integer;
function "=" (L, R : Byte) return Boolean renames System_Types."=";
function To_Byte (C : Character) return Byte renames System_Types.To_Byte;
function To_Character (B : Byte) return Character
renames System_Types.To_Character;
-- ** function To_Byte_String (S : String) return Byte_String;
-- ** function To_String (Bs : Byte_String) return String;
function "=" (L, R : Dio.File_Mode) return Boolean renames Dio."=";
function "=" (L, R : Text_Io.File_Mode) return Boolean renames Text_Io."=";
function "=" (L, R : Buffering.Data_Buffer) return Boolean
renames Buffering."=";
function "=" (L, R : Text_Io.Count) return Boolean renames Text_Io."=";
function "+" (L, R : Text_Io.Count) return Text_Io.Count
renames Text_Io."+";
function "-" (L, R : Text_Io.Count) return Text_Io.Count
renames Text_Io."-";
function "=" (L, R : System.Address) return Boolean renames System."=";
Status_Error : exception renames Text_Io.Status_Error;
Mode_Error : exception renames Text_Io.Mode_Error;
Name_Error : exception renames Text_Io.Name_Error;
Use_Error : exception renames Text_Io.Use_Error;
Device_Error : exception renames Text_Io.Device_Error;
End_Error : exception renames Text_Io.End_Error;
Data_Error : exception renames Text_Io.Data_Error;
Layout_Error : exception renames Text_Io.Layout_Error;
--\f
type Terminator is (Eol, Eop, Eof);
Line_Terminator : constant Character := Ascii.Cr;
Page_Terminator : constant Character := Ascii.Ff;
Line_Term_Byte : constant Byte := To_Byte (Line_Terminator);
Page_Term_Byte : constant Byte := To_Byte (Page_Terminator);
Line_Terminator_Str : constant String (1 .. 1) := (1 => Line_Terminator);
Page_Terminator_Str : constant String (1 .. 2) :=
(1 => Page_Terminator, 2 => Line_Terminator);
Line_Terminator_Bs : constant Byte_String (1 .. 2) :=
(1 => To_Byte (Ascii.Cr), 2 => To_Byte (Ascii.Lf));
Page_Terminator_Bs : constant Byte_String (1 .. 1) :=
(1 => To_Byte (Page_Terminator));
--\f
-- Ada Text_Io has been carefully specified so that every file has at
-- least one page and every page has at least one line. This property
-- makes it possible to define a one-to-one correspondence between Text
-- files and Device_Independent_Io files. That is, every text file has
-- exactly one valid representation as a stream of bytes, and every
-- possible stream of bytes has exactly one interpretation as a text file.
-- The correspondence is this: every line is represented by the stream of
-- characters that comprise the line, followed by an ASCII LF. An
-- exception to this rule is that the last line of a page is terminated by
-- an ASCII FF instead of an LF. Finally, there is an exception to the
-- exception: the last line of the last page of a file is not terminated by
-- anything. File terminators have no explicit representation.
-- It is the task of Text_Io to hide all these exceptions from its clients.
-- When reading a file, Text_Io must supply an extra line terminator before
-- every page terminator that is actually in the file. Likewise, it must
-- supply an extra line, page, and file terminator at the very end of the
-- file. On output, it must omit these terminators.
-- All this simulation is not as messy as it sounds. For example, most of
-- the read calls are supposed to skip over the extra terminators that are
-- being simulated, so that the simulation requires less work than if the
-- terminators were actually present. However, users who wish to read or
-- write text files directly with Device-Independent I/O must be aware of
-- these conventions, or they will not get the expected results.
type Count_Repr is range 0 .. Count'Last + 2;
Unbounded_Repr : constant Count_Repr := Count_Repr'Last;
subtype Count_Limit is Count_Repr range 1 .. Unbounded_Repr;
subtype Extended_Count is Count_Repr range 1 .. Unbounded_Repr - 1;
-- The Ada LRM requires that Column, Line, and Page counts can overflow
-- without raising any exceptions unless their numerical value is
-- requested. This feature is implemented by storing the counts as
-- an Extended_Count, which has one more value at the high end than Count.
-- If the incrementing of a count raises an exception, the exception is
-- caught and the count is left at Extended_Count'LAST.
-- The limits on line lengths and page lengths are stored as the type
-- Count_Limit. This type has one additional value, Unbounded_Repr, which
-- is larger than any value ever stored for a count. This representation
-- slightly simplifies checking for end-of-line and end-of-page.
--\f
Default_Buffer_Size : constant := 400; -- bytes/characters
type Funny_Boolean is (True, False, Simulated_False);
type Input_State is
record
File : File_Type;
Line_Start : Integer;
Eob_Is_Eol : Boolean;
Line_Number : Extended_Count;
Page_Number : Extended_Count;
Eof_Encountered : Funny_Boolean;
end record;
type Access_Input_State is access Input_State;
-- Notes on Input_State:
-- File is a back pointer to the file that the Input_State belongs too.
-- Line_Start is the index within Buffer of the first character of the
-- current line. The column number of the next character to be read is
-- computed by Tail + 1 - Line_Start. If the start of the current
-- line is not in the buffer, Line_Start is an appropriate negative number
-- so that the formula will still work.
-- Eob_Is_Eol is true iff the buffer contains exactly one text line and
-- the last character in the buffer is a Line_Terminator.
-- Encountered_EOF indicates whether Device-Independent I/O has responded
-- to a read request with an End_Error. Since we need to keep track of
-- this event to properly simulate a line and page terminator at the end of
-- the file, we do not require Device-Independent I/O to raise End_Error
-- more than once on a file.
-- The literal parsers need one character of lookahead. Normally they can
-- "put back" a character by decrementing Next_To_Read. This technique
-- does not work for the simulated terminators at the end of a file. The
-- code Simulated_False allows for the simulated file terminator to be put
-- back without requiring Device_Independent_IO to support multiple
-- End_Errors. Clients who want to be fooled by this charade should test
-- if EOF_Encountered = True. Clients who want to know the truth should
-- test whether EOF_Encountered = False.
--\f
type Output_State is
record
File : File_Type;
Column_Number : Extended_Count;
Line_Number : Extended_Count;
Page_Number : Extended_Count;
Line_Length : Count_Limit;
Page_Length : Count_Limit;
Line_Terminated : Boolean;
end record;
type Access_Output_State is access Output_State;
-- Output to interactive files is not buffered. In the interactive case,
-- we always output a Line Terminator before each Page Terminator. The
-- Line_Terminated boolean is used by New_Page to determine if it needs to
-- output two terminators.
-- Conversely, noninteractive output is not buffered. In this case, every
-- page terminator represents a line terminator followed by a page
-- terminator. Thus, if the user outputs a line terminator followed by a
-- page terminator, that sequence is normalized to a page terminator.
-- The state needed to do this normalization is part of the buffer.
-- The buffer fields and the Line_Terminated bit could be part of a variant
-- record whose discriminant is Is_Interactive, that implementation would
-- be less efficient on the R1000.
--\f
package State_Handling is
procedure Initialize (File : File_Type; S : out Input_State);
procedure Initialize (File : File_Type; S : out Output_State);
-- The routines Get_Input_State and Get_Output_State are
-- called by every user-visible entry to Common_Text_Io
-- that requires a file argument to be open for a specific
-- mode. The routines check that the file has this state,
-- returning a pointer to the state if it is there, and
-- raising the appropriate exception if it is not. These
-- routines also acquire the file's lock, which must be
-- released with a call to Dio.Release.
function Get_Output_State (File : File_Type) return Access_Output_State;
function Get_Input_State (File : File_Type) return Access_Input_State;
-- The routine Get_File_State is called by routines that work
-- with files that are open for input or output. If the file
-- is not open, Status_Error is raised. Otherwise the mode
-- of the file, along with the corresponding Input_State or
-- Output_State is returned. The file is not locked.
procedure Get_File_State (File : File_Type;
Mode : out File_Mode;
In_State : out Access_Input_State;
Out_State : out Access_Output_State);
-- Allocate_State is called with a file that is open as far
-- as Dio is concerned, but has not Text_Io state. The file
-- is given an appropriate state, which is initialized, and
-- Dio is told about it.
procedure Allocate_State (File : File_Type; Mode : File_Mode);
procedure Free_State (File : File_Type);
procedure Free_State (File : File_Type; Mode : File_Mode);
-- ** Replaced due to cross-compiler problems
-- package Input_State_Ops is new Dio.Client_Specific
-- (Control_Block => Input_State,
-- Pointer => Access_Input_State);
procedure Iset (File : File_Type; Ais : Access_Input_State);
function Iget (File : File_Type) return Access_Input_State;
-- ** Replaced due to cross-compiler problem
-- package Output_State_Ops is new Dio.Client_Specific
-- (Control_Block => Output_State,
-- Pointer => Access_Output_State);
procedure Oset (File : File_Type; Aos : Access_Output_State);
function Oget (File : File_Type) return Access_Output_State;
private
pragma Suppress (Elaboration_Check, On => Initialize);
pragma Suppress (Elaboration_Check, On => Get_Output_State);
pragma Suppress (Elaboration_Check, On => Get_Input_State);
pragma Suppress (Elaboration_Check, On => Get_File_State);
pragma Suppress (Elaboration_Check, On => Allocate_State);
pragma Suppress (Elaboration_Check, On => Free_State);
pragma Suppress (Elaboration_Check, On => Iset);
pragma Suppress (Elaboration_Check, On => Iget);
pragma Suppress (Elaboration_Check, On => Oset);
pragma Suppress (Elaboration_Check, On => Oget);
end State_Handling;
--\f
-- This package manages the standard files for Text_Io.
package Standard_Files is
type Kind is (Input, Output, Error);
-- Does whatever necessary to open Standard_Input, Standard_Output,
-- and Standard_Error, and set Current_Input, Current_Output,
-- and Current_Error to their initial values.
procedure Initialize;
-- Used to set the "current" file.
procedure Set (K : Kind; F : File_Type);
-- Gets the value of the "current" file.
-- function Get (K : Kind) return File_Type;
-- Semantics bug won't allow suppress on Get, so change name
function Egt (K : Kind) return File_Type;
-- Gets the value of the original "standard" file.
function Std_Get (K : Kind) return File_Type;
-- When closing or deleting a file, it is necessary to check
-- whether that file has been set to Current_Input/_Output,
-- so that the relationship between the file variable and
-- the Current file can be maintained. This is done by
-- setting both the file and the Current file are set to
-- a special closed value.
procedure Check_If_Closing_Current (File : in out File_Type);
-- When creating, opening, or resetting a file, it is necessary
-- to check whether the file has been set to Current_Input/_Output,
-- and, if so, whether the new mode will be compatible. Mode_Error
-- will be raise if the new mode is incompatible.
procedure Check_If_Current_Compatible_Mode
(File : File_Type; New_Mode : File_Mode);
-- After creating or opening a file, it is necessary to check
-- whether the file has been set to Current_Input/_Output,
-- and, if so, to establish the association of the appropriate
-- current file to the new file descriptor.
procedure Check_If_Reassociating_Current
(Old_File : File_Type; New_File : File_Type);
private
pragma Suppress (Elaboration_Check, On => Initialize);
pragma Suppress (Elaboration_Check, On => Set);
--pragma Suppress (Elaboration_Check, On => Get); -- Semantics bug!
pragma Suppress (Elaboration_Check, On => Egt); -- Semantics bug!
pragma Suppress (Elaboration_Check, On => Std_Get);
end Standard_Files;
function Get_Current_Input
(Kind : Standard_Files.Kind := Standard_Files.Input)
return File_Type renames Standard_Files.Egt;
function Get_Current_Output
(Kind : Standard_Files.Kind := Standard_Files.Output)
return File_Type renames Standard_Files.Egt;
--\f
--Cio_Absorb_Output : Boolean := Primitive_Io.Global_Absorb_Output;
-- procedure Pput (S : in String;
-- Absorb_Output : Boolean :=
-- Primitive_Io.Global_Absorb_Output)
-- renames Primitive_Io.Put_Line;
procedure Set_Input (File : File_Type) is
begin
Standard_Files.Set (Standard_Files.Input, File);
end Set_Input;
procedure Set_Output (File : File_Type) is
begin
Standard_Files.Set (Standard_Files.Output, File);
end Set_Output;
procedure Set_Error (File : File_Type) is
begin
Standard_Files.Set (Standard_Files.Error, File);
end Set_Error;
function Standard_Input return File_Type is
begin
return Standard_Files.Std_Get (Standard_Files.Input);
end Standard_Input;
function Standard_Output return File_Type is
begin
return Standard_Files.Std_Get (Standard_Files.Output);
end Standard_Output;
function Standard_Error return File_Type is
begin
return Standard_Files.Std_Get (Standard_Files.Error);
end Standard_Error;
function Current_Input return File_Type is
begin
return Get_Current_Input;
end Current_Input;
function Current_Output return File_Type is
begin
return Get_Current_Output;
end Current_Output;
function Current_Error return File_Type is
begin
return Standard_Files.Egt (Standard_Files.Error);
end Current_Error;
--\f
function Convert (From : File_Mode) return Dio.File_Mode is
begin
case From is
when In_File =>
return Dio.In_File;
when Out_File =>
return Dio.Out_File;
end case;
end Convert;
-- Editorial : there really ought to be only one kind of file mode,
-- so that this nonsense is not necessary.
--\f
procedure Append (File : in out File_Type;
Name : String;
Form : String := "") is
Actual_Buffer_Size : Natural;
begin
begin
Dio.Acquire (File);
-- if Name /= "" then -- why not?
if Name'Length /= 0 then
Dio.Append (File, Dio.Out_File, Dio.Normal, Name, Form,
Default_Buffer_Size, Actual_Buffer_Size);
else
Dio.Append (File, Dio.Out_File, Dio.Temporary, "", Form,
Default_Buffer_Size, Actual_Buffer_Size);
end if;
exception
when Status_Error =>
-- As far as DIO is concerned, the file is open. See if the file
-- has been opened by Text_Io.
if Dio.Mode (File) = Dio.In_File then
Dio.Release (File);
raise Iof.Illegal_Operation_On_Infile;
end if;
if State_Handling.Oget (File) /= null then
Dio.Release (File);
raise Iof.Already_Open_Error;
end if;
when others =>
-- Name_Error, Device_Error, etc.
Dio.Release (File);
raise;
end;
State_Handling.Allocate_State (File, Out_File);
Dio.Release (File);
end Append;
--\f
procedure Save (File : File_Type) is
begin
Dio.Acquire (File);
Flush (File, Clear_Terminators => True);
Dio.Save (File);
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Save;
procedure Close (File : in out File_Type) is
Closed_File : File_Type := File;
begin
Dio.Acquire (File);
Flush (File, Clear_Terminators => True);
State_Handling.Free_State (File);
Standard_Files.Check_If_Closing_Current (File);
Dio.Close (Closed_File);
-- A successful close releases the file's lock
exception
when others =>
Dio.Release (Closed_File);
raise;
end Close;
procedure Delete (File : in out File_Type) is
Mode : File_Mode;
In_State : Access_Input_State;
Out_State : Access_Output_State;
Deleted_File : File_Type := File;
begin
Dio.Acquire (File);
-- The file state is not really needed. We call Get_File_State to make
-- sure an exception is raised if there is no state, only for
-- consistency with all the other visible entry points.
State_Handling.Get_File_State (File, Mode, In_State, Out_State);
State_Handling.Free_State (File);
Standard_Files.Check_If_Closing_Current (File);
Dio.Delete (Deleted_File);
-- Release isn't necessary: The file doesn't exist anymore!
exception
when others =>
Dio.Release (Deleted_File);
raise;
end Delete;
--\f
procedure Reset (File : in out File_Type;
Original_Mode : in File_Mode;
New_Mode : in File_Mode) is
Different_Mode : constant Boolean := Original_Mode /= New_Mode;
begin
if Different_Mode then
Standard_Files.Check_If_Current_Compatible_Mode (File, New_Mode);
end if;
Dio.Acquire (File);
-- Make sure there won't be a file open for output and input at
-- the same time
begin
if Different_Mode and New_Mode = Out_File then
declare
Oin, Oinout, Oout : Natural;
begin
Dio.Identical_Files (File, Oin, Oout, Oinout);
-- This file counts as 1 open for input
if Oin > 1 then
raise Iox.Use_Error;
end if;
end;
end if;
exception
when others =>
Dio.Release (File);
raise;
end;
-- Flush the file's buffer (if necessary) and do the actual reset,
-- then adjust the Text_Io state for the file
begin
Flush (File, Clear_Terminators => True);
Dio.Reset (File, Convert (New_Mode));
if Different_Mode then
State_Handling.Free_State (File, Original_Mode);
State_Handling.Allocate_State (File, New_Mode);
elsif New_Mode = In_File then
State_Handling.Initialize (File,
State_Handling.Iget (File).all);
else
State_Handling.Initialize (File,
State_Handling.Oget (File).all);
end if;
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end;
end Reset;
-----------------------------------------------------------------
-- Visible procedure RESET with explicit mode:
-----------------------------------------------------------------
procedure Reset (File : in out File_Type; Mode : File_Mode) is
begin
Reset (File,
Original_Mode => Common_Text_Io.Mode (File), -- checks for open
New_Mode => Mode);
end Reset;
-----------------------------------------------------------------
-- Visible procedure RESET to same mode:
-----------------------------------------------------------------
procedure Reset (File : in out File_Type) is
The_Mode : File_Mode := Mode (File); -- checks for open
begin
Reset (File, Original_Mode => The_Mode, New_Mode => The_Mode);
end Reset;
--\f
-----------------------------------------------------------------
-- Visible function MODE to return the mode of an open file:
-----------------------------------------------------------------
function Mode (File : File_Type) return File_Mode is
Result : File_Mode;
In_State : Access_Input_State;
Out_State : Access_Output_State;
begin
Dio.Acquire (File);
State_Handling.Get_File_State (File, Result, In_State, Out_State);
Dio.Release (File);
return Result;
exception
when others =>
Dio.Release (File);
raise;
end Mode;
-----------------------------------------------------------------
-- Visible function NAME to return the full name of the file:
-----------------------------------------------------------------
function Name (File : File_Type) return String is
Mode : File_Mode;
In_State : Access_Input_State;
Out_State : Access_Output_State;
begin
Dio.Acquire (File);
State_Handling.Get_File_State (File, Mode, In_State, Out_State);
-- The file state is not really needed. We call Get_File_State to make
-- sure an exception is raised if there is no state, only for
-- consistency with all the other visible entry points.
declare
Name : constant String := Dio.Name (File);
begin
Dio.Release (File);
return Name;
end;
exception
when others =>
Dio.Release (File);
raise;
end Name;
-----------------------------------------------------------------
-- Visible function FORM to return the FORM string of a file:
-----------------------------------------------------------------
function Form (File : File_Type) return String is
Mode : File_Mode;
In_State : Access_Input_State;
Out_State : Access_Output_State;
begin
Dio.Acquire (File);
State_Handling.Get_File_State (File, Mode, In_State, Out_State);
-- The file state is not really needed. We call Get_File_State to make
-- sure an exception is raised if there is no state, only for
-- consistency with all the other visible entry points.
declare
Form : constant String := Dio.Form (File);
begin
Dio.Release (File);
return Form;
end;
exception
when others =>
Dio.Release (File);
raise;
end Form;
--\f
function Is_Open (File : File_Type) return Boolean is
Mode : File_Mode;
In_State : Access_Input_State;
Out_State : Access_Output_State;
begin
State_Handling.Get_File_State (File, Mode, In_State, Out_State);
return True;
exception
when Status_Error =>
return False;
end Is_Open;
procedure Set_Line_Length (File : File_Type; To : Count) is
S : Output_State renames State_Handling.Get_Output_State (File).all;
begin
if To = Unbounded then
S.Line_Length := Unbounded_Repr;
else
S.Line_Length := Count_Limit (To);
end if;
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Set_Line_Length;
procedure Set_Line_Length (To : Count) is
begin
Set_Line_Length (Current_Output, To);
end Set_Line_Length;
procedure Set_Page_Length (File : File_Type; To : Count) is
S : Output_State renames State_Handling.Get_Output_State (File).all;
begin
if To = Unbounded then
S.Page_Length := Unbounded_Repr;
else
S.Page_Length := Count_Limit (To);
end if;
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Set_Page_Length;
procedure Set_Page_Length (To : Count) is
begin
Set_Page_Length (Current_Output, To);
end Set_Page_Length;
function Line_Length (File : File_Type) return Count is
S : Output_State renames State_Handling.Get_Output_State (File).all;
C : Count;
begin
if S.Line_Length = Unbounded_Repr then
C := Unbounded;
else
C := Count (S.Line_Length);
end if;
Dio.Release (File);
return C;
exception
when others =>
Dio.Release (File);
raise;
end Line_Length;
function Line_Length return Count is
begin
return Line_Length (Current_Output);
end Line_Length;
function Page_Length (File : File_Type) return Count is
S : Output_State renames State_Handling.Get_Output_State (File).all;
C : Count;
begin
if S.Page_Length = Unbounded_Repr then
C := Unbounded;
else
C := Count (S.Page_Length);
end if;
Dio.Release (File);
return C;
exception
when others =>
Dio.Release (File);
raise;
end Page_Length;
function Page_Length return Count is
begin
return Page_Length (Current_Output);
end Page_Length;
--\f
------------------------
--- Input routines ---
------------------------
procedure New_Line (S : in out Input_State) is
-- This routine should be called when the next character to be read
-- is the first character of a line, and the preceding character
-- is a line terminator.
begin
-- Set the Line_Start to the current position in the buffer,
-- and bump the Line_Number.
begin
-- The file must have a buffer when used for input
S.Line_Start := Dio.Get (S.File).Tail;
exception
when Constraint_Error =>
raise Use_Error;
end;
begin
S.Line_Number := S.Line_Number + 1; -- may overflow
exception
when Numeric_Error | Constraint_Error =>
null;
end;
end New_Line;
procedure New_Page (S : in out Input_State) is
-- This routine should be called when the next character to be read
-- is the first character of a line, and the preceding character
-- is a page terminator.
begin
-- Set the Line_Start to the current position in the buffer,
-- set the Line_Number to the first line on a page, and bump
-- the Page_Number.
begin
-- The file must have a buffer when used for input
S.Line_Start := Dio.Get (S.File).Tail;
exception
when Constraint_Error =>
raise Use_Error;
end;
S.Line_Number := 1;
begin
S.Page_Number := S.Page_Number + 1; -- may overflow
exception
when Numeric_Error | Constraint_Error =>
null;
end;
end New_Page;
--\f
-----------------------------------------------------------------
-- The procedure FILL_BUFFER which is the interface to
-- DEVICE_INDEPENDENT_IO for all COMMON_TEXT_IO input:
-----------------------------------------------------------------
-- All input from Device-Independent I/O to Text I/O goes through
-- Fill_Buffer. Fill_Buffer should be called when the file buffer
-- is empty. Fill_Buffer will return with at least one character in the
-- buffer or with S.EOF_Encountered /= False. In the latter case,
-- the buffer Head and Tail will be left unchanged so that the normal
-- test will cause another call into Fill_Buffer.
-- The mystical flag Undo_Eof controls what Fill_Buffer does when DIO
-- returns with an End_Error. The default action is to set EOF_Encountered
-- to True and call New_Page to final page terminator. If the client is
-- only interested in seeing if the end-of-file is out there without
-- having the New_Page invoked if it is there, he should use the Undo_Eof
-- flag. Note that client only has to worry about getting back
-- Simulated_False if he is using the Undo_Eof flag.
procedure Fill_Buffer (File : File_Type;
S : in out Input_State;
B : in out Buffering.Data_Buffer;
Undo_Eof : Boolean := False);
pragma Suppress (Elaboration_Check, On => Fill_Buffer);
function Has_No_Terminator (B : Buffering.Data_Buffer) return Boolean is
Data : Byte_String renames B.Buffer;
begin
for I in B.Tail .. B.Head loop
if Data (I) = Line_Term_Byte then
return False;
end if;
end loop;
return True;
end Has_No_Terminator;
-- This procedure fills the buffer if it is empty, raising End_Error
-- if there is no more data.
procedure Next_Buffer (File : File_Type;
S : in out Input_State;
B : in out Buffering.Data_Buffer;
Undo_Eof : Boolean := False) is
begin
-- if Buffering.Is_Empty (B) then
-- Pput ("Cti.Next_Buffer when buffer is empty");
-- else
-- Pput ("Cti.Next_Buffer when buffer is not empty");
-- end if;
if Buffering.Is_Empty (B) or else
(Has_No_Terminator (B) and then S.Eof_Encountered = False) then
Fill_Buffer (File, S, B, Undo_Eof);
if S.Eof_Encountered = True then
raise End_Error;
end if;
end if;
end Next_Buffer;
--\f
--------------------------------------------------------------------
-- Visible procedure GET returning character:
-- After skipping any line terminators and any page terminators,
-- reads the next character from the specified input file and
-- returns the value of this character in the out parameter Item.
-- The exception END_ERROR is raised if an attempt is made to skip
-- a file terminator. [RM 14.3.6 (1)]
--------------------------------------------------------------------
procedure Get (File : File_Type; Item : out Character) is
S : Input_State renames State_Handling.Get_Input_State (File).all;
B : Buffering.Data_Buffer := Dio.Get (File);
begin
-- if not Primitive_Io.Absorb_Output then
-- Pput ("Cti.Get(character) from " & Dio.Name (File));
-- end if;
loop
-- Pput ("Cti.Get(character) loop start");
Next_Buffer (File, S, B);
-- Pput ("Cti.Get(character) buffer has" &
-- Integer'Image (Buffering.Left (B)) & " characters remaining");
declare
C : Character := Buffering.Next (B);
begin
case C is
when Line_Terminator =>
-- Pput ("Cti.Get(character) have line terminator");
New_Line (S);
when Page_Terminator =>
-- Pput ("Cti.Get(character) have page terminator");
New_Page (S);
when others =>
--if not Primitive_Io.Absorb_Output then
-- if C in ' ' .. '~' then
-- Pput ("Cti.Get(character) have '" & C & ''');
-- else
-- Pput ("Cti.Get(character) have" &
-- Integer'Image (Character'Pos (C)));
-- end if;
Item := C;
Dio.Release (File);
return;
end case;
end;
end loop;
exception
when others =>
Dio.Release (File);
raise;
end Get;
--\f
--------------------------------------------------------------------
-- Visible procedure GET_ANY:
-- Similar to GET but does not interpret control characters as
-- terminators. [Not a routine in the RM]
--------------------------------------------------------------------
procedure Get_Any (File : File_Type; Item : out Character) is
S : Input_State renames State_Handling.Get_Input_State (File).all;
B : Buffering.Data_Buffer := Dio.Get (File);
begin
-- This function was put in as a hack to allow the Core Editor use use
-- Simple_Text_IO to read in its key definition tables, which have
-- control characters in the middle of lines.
-- It is not clear what it is supposed to do in all the weird boundary
-- cases.
Next_Buffer (File, S, B);
Item := Buffering.Next (B);
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Get_Any;
--\f
-----------------------------------------------------------------
-- Get all or part of a line. The intent is for each call to return
-- as many characters from the current line as possible, but
-- Last /= Item'Last doesn't imply End_Of_Line.
-----------------------------------------------------------------
procedure Get_A_Line (File : in File_Type;
S : in out Input_State;
Item : out String;
Last : out Natural;
Skip_Terminators : in Boolean;
End_Of_Line : out Boolean;
End_Of_Page : out Boolean;
End_Of_File : out Boolean);
pragma Suppress (Elaboration_Check, On => Get_A_Line);
--\f
--------------------------------------------------------------------
-- Visible procedure GET returning string:
-- Determines the length of the given string and attempts that
-- number of GET operations for successive characters of the string
-- (in particular, no operation is performed if the string is null).
-- [RM 14.3.6 (9)]
--------------------------------------------------------------------
procedure Get (File : File_Type; Item : out String) is
S : Input_State renames State_Handling.Get_Input_State (File).all;
B : Buffering.Data_Buffer := Dio.Get (File);
--
Item_First : Natural := Item'First;
Item_Last : constant Natural := Item'Last;
Item_Filled : Natural;
--
Eol, Eop, Eof : Boolean;
--
C : Character;
--
Ignore_Eol : Boolean := False;
begin
-- Definition implies that this operation can cross line and
-- page boundaries. It is undefined (by the RM) what happens
-- to Item if END_ERROR is raised before Item is filled; this
-- implementation will trash the first characters of Item.
-- if not Primitive_Io.Absorb_Output then
-- Pput ("Cti.Get(string) getting" & Integer'Image (Item'Length) &
-- " bytes");
-- end if;
-- Fill the Item in chunks of lines.
if Item'Length = 0 then
Dio.Release (File);
return;
end if;
loop
Get_A_Line (File, S, Item (Item_First .. Item_Last), Item_Filled,
Skip_Terminators => False,
End_Of_Line => Eol,
End_Of_Page => Eop,
End_Of_File => Eof);
if Item_Filled = Item_Last then
-- The string is filled, we're done.
-- Pput ("Cti.Get(string) have filled string");
Dio.Release (File);
return;
else
-- There is more to read to fill the string.
-- Skip the terminator that blocked us, and continue
-- with the next chunk.
-- Eof, Eop, and Eol are unreliable since Skip_Terminators
-- was False.
C := Buffering.Next (B);
-- ^ Can raise End_Error, which is fine
if C = Page_Terminator then
-- Pput ("Cti.Get(string) have EOP");
New_Page (S);
Ignore_Eol := True; -- since page terminators are FF & LF
elsif C = Line_Terminator then
-- Pput ("Cti.Get(string) have EOL");
if not Ignore_Eol then
New_Line (S);
else -- still need to set line start in order to get
-- correct column numbering
begin
S.Line_Start := Dio.Get (S.File).Tail;
exception
when Constraint_Error =>
raise Use_Error;
end;
end if;
Ignore_Eol := False;
else
-- if not Primitive_Io.Absorb_Output then
-- Pput ("Cti.Get(string) have '" & C &
-- "' as terminator ???");
-- end if;
raise Constraint_Error; -- ?? or programming_error eh?
-- Buffering.Throwback (B, 1);
end if;
Item_First := Item_Filled + 1;
end if;
end loop;
exception
when others =>
Dio.Release (File);
raise;
end Get;
--\f
--------------------------------------------------------------------
-- Visible procedure GET_LINE returns into a string and length.
--------------------------------------------------------------------
-- Replaces successive characters of the specified string by successive
-- characters read from the specified input file. Reading stops if the
-- end of line is met (*), in which case the procedure SKIP_LINE is then
-- called (in effect) with a spacing of one; reading also stops if the
-- end of the string is met. Characters not replaced are left undefined.
-- If characters are read, returns in LAST the index value such that
-- ITEM(LAST) is the last character replaced (the index of the first
-- character replaced is ITEM'FIRST). If no characters are read, returns
-- in LAST an index value that is one less than ITEM'FIRST. The exception
-- END_ERROR is raised if an attempt is made to skip a file terminator.
-- [RM 14.3.6 (13-15)]
-- (*) Except that AI-00050 provides that SKIP_LINE is only called
-- if the output string has not been exhausted and End_Of_Line is
-- true.
-- For a SPACING of one reads the line terminator and sets the current
-- column number to one. If the line terminator is not immediately
-- followed by a page terminator the current line number is incremented
-- by one. Otherwise, ifthe line terminator is immediately followed by
-- a page terminator then the page terminator is skipped, the current
-- page number is incremented by one, and the current line number is
-- set to one. [RM 14.3.4 (8)]
-- This procedure behaves as described above if Skip_Terminators is
-- True. If Skip_Terminators is false it will read up to a Line_Terminator
-- but not skip past it.
procedure Get_Line
(File : File_Type; Item : out String; Last : out Natural) is
S : Input_State renames State_Handling.Get_Input_State (File).all;
Eol, Eop, Eof : Boolean;
begin
Get_A_Line (File, S, Item, Last,
Skip_Terminators => True,
End_Of_Line => Eol,
End_Of_Page => Eop,
End_Of_File => Eof);
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Get_Line;
--\f
-----------------------------------------------------------------
-- Visible procedure GET_LINE returns string, length, and
-- indicators of terminators (not in TEXT_IO).
-----------------------------------------------------------------
procedure Get (File : File_Type;
Item : out String;
Last : out Natural;
End_Of_Line : out Boolean;
End_Of_Page : out Boolean;
End_Of_File : out Boolean) is
S : Input_State renames State_Handling.Get_Input_State (File).all;
begin
Get_A_Line (File, S, Item, Last,
Skip_Terminators => True,
End_Of_Line => End_Of_Line,
End_Of_Page => End_Of_Page,
End_Of_File => End_Of_File);
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Get;
-- \f
--------------------------------------------------------------------
-- Visible function GET_LINE returning string:
-- Similar to the RM procedure GET_LINE except returns its result
-- as a function.
--------------------------------------------------------------------
function Get_Line (File : File_Type) return String is
S : Input_State renames State_Handling.Get_Input_State (File).all;
-- This implementation is sort of sick, but probably isn't worth
-- too much effort to improve.
function Get_Line return String is
Result : String (1 .. 512);
Res_Len : Natural;
Eol, Eop, Eof : Boolean;
begin
Get_A_Line (File, S, Result, Res_Len,
Skip_Terminators => False,
End_Of_Line => Eol,
End_Of_Page => Eop,
End_Of_File => Eof);
if Eol then
-- Found an entire line, skip the terminators
New_Line (S);
return Result (1 .. Res_Len);
else
-- Didn't find the entire line yet, so put the pieces
-- together
return Result & Get_Line;
end if;
end Get_Line;
begin
declare
Result : constant String := Get_Line;
begin
Dio.Release (File);
return Result;
end;
exception
when others =>
Dio.Release (File);
raise;
end Get_Line;
--\f
--------------------------------------------------------------------
-- Advances to the N'th terminator in the file, where N = Spacing.
-- If Count_Lines, we count any terminator; otherwise we only count
-- page terminators.
--------------------------------------------------------------------
procedure Skip (File : File_Type;
S : in out Input_State;
Spacing : Positive_Count := 1;
Count_Lines : Boolean) is
B : Buffering.Data_Buffer := Dio.Get (File);
Space_Left : Positive_Count := Spacing;
C : Character;
begin
-- if not Primitive_Io.Absorb_Output then
-- if Count_Lines then
-- Pput ("Cti.Skip skipping" & Positive_Count'Image (Spacing) &
-- " lines");
-- else
-- Pput ("Cti.Skip skipping" & Positive_Count'Image (Spacing) &
-- " pages");
-- end if;
-- end if;
-- Get rid of the do-nothing case first
if Spacing = 0 then
return;
end if;
loop
if Buffering.Is_Empty (B) then
if S.Eof_Encountered = True then
-- See Get_Line for details on what is going on here.
raise End_Error;
end if;
Fill_Buffer (File, S, B);
if S.Eof_Encountered = True then
-- Page_Terminators are simulated at EOF, but
-- Line_Terminators aren't!
if (not Count_Lines) and Space_Left = 1 then
-- The final simulated terminator was the one we
-- were looking for. Just in the nick of time!
return;
else
-- There are not enough terminators in the file to
-- satisfy the request.
raise End_Error;
end if;
end if;
end if;
-- Do we have a known line terminator?
if S.Eob_Is_Eol then
-- Line-at-a-time case
declare
Have_Page : constant Boolean :=
Buffering.Peek_At_Last (B) = Page_Terminator;
begin
-- Eat up the rest of the line in one fell swoop
Buffering.Consume (B, Buffering.Left (B));
if Have_Page then
New_Page (S);
else
New_Line (S);
end if;
if Count_Lines then
if Space_Left = 1 then
return;
end if;
Space_Left := Space_Left - 1;
elsif Have_Page then
if Space_Left = 1 then
return;
end if;
Space_Left := Space_Left - 1;
end if;
end;
else
-- Character-at-a-time case
C := Buffering.Next (B);
case C is
when Line_Terminator =>
New_Line (S);
if Count_Lines then
if Space_Left = 1 then
return;
end if;
Space_Left := Space_Left - 1;
end if;
when Page_Terminator =>
-- Pput ("Cti.Skip - testing for Line_Terminator");
if Buffering.Is_Empty (B) then
Fill_Buffer (File, S, B, Undo_Eof => True);
if S.Eof_Encountered /= False then
S.Eof_Encountered := True;
end if;
end if;
if S.Eof_Encountered /= True and then
Buffering.Peek (B) = Line_Terminator then
Buffering.Consume (B);
-- Pput ("Cti.Skip - consumed Line_Terminator");
end if;
New_Page (S);
if Space_Left = 1 then
return;
end if;
Space_Left := Space_Left - 1;
when others =>
null;
end case;
end if;
end loop;
end Skip;
--\f
--------------------------------------------------------------------
-- Visible procedure SKIP_LINE:
-- For a SPACING of one: Reads and discards all characters until a
-- line terminator has been read, and then sets the current column
-- number to one. If the line terminator is not immediately
-- followed by a page terminator, the current line number is
-- incremented by one. Otherwise, if the line terminatoris
-- immediately followed by a page terminator, then the page
-- terminator is skipped, the current page number is incremented
-- by one, and the current line number is set to one. For a
-- SPACING greater than one, the above actions are performed
-- SPACING times. The exception END_ERROR is raised if an attempt
-- is made to read a file terminator. [RM 14.3.4 (8-10)]
--------------------------------------------------------------------
procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1) is
S : Input_State renames State_Handling.Get_Input_State (File).all;
begin
Skip (File, S, Spacing, Count_Lines => True);
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Skip_Line;
--------------------------------------------------------------------
-- Visible procedure SKIP_PAGE:
-- Reads and discards all characters and line terminators until a
-- page terminator has been read. Then adds one to the current
-- page number, and sets the current column and line numbers to one.
-- The exception END_ERROR is raised if an attempt is made to read
-- a file terminator.
-- [RM 14.3.4 (18-19)]
--------------------------------------------------------------------
procedure Skip_Page (File : File_Type) is
S : Input_State renames State_Handling.Get_Input_State (File).all;
begin
Skip (File, S, Count_Lines => False);
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Skip_Page;
--\f
function End_Of (File : File_Type; Level : Terminator) return Boolean is
-- Determine whether we are at end of (line, page, file), depending on
-- Level.
S : Input_State renames State_Handling.Get_Input_State (File).all;
B : Buffering.Data_Buffer := Dio.Get (File);
C : Character;
begin
-- This is a lookahead function. Unlike most functions, it does NOT
-- scan past terminators. Instead, it peeks ahead to see if there are
-- terminators out there.
-- if not Primitive_Io.Absorb_Output then
-- if Buffering.Is_Empty (B) then
-- Pput ("Cti.End_Of " & Terminator'Image (Level) &
-- " with empty buffer");
-- else
-- Pput ("Cti.End_Of " & Terminator'Image (Level) &
-- " with non-empty buffer");
-- end if;
-- end if;
if Buffering.Is_Empty (B) then
Fill_Buffer (File, S, B, Undo_Eof => True);
if S.Eof_Encountered /= False then
-- We are not letting ourselves be fooled by the
-- simulation requested by the Undo_Eof flag.
Dio.Release (File);
return True;
end if;
end if;
C := Buffering.Peek (B);
-- if not Primitive_Io.Absorb_Output then
-- Pput ("Cti.End_Of peeking at " & Character'Image (C));
-- end if;
case C is
when Line_Terminator =>
-- There is a special case of looking for EOF or EOP
-- at the End_Of_File, which requires a look-ahead for
-- EOF -- but only if we're at the end of a buffer.
if Level >= Eop and then B.Tail = B.Head then
-- Pput ("Cti.End_Of have special EOF or EOP condition");
Fill_Buffer (File, S, B, Undo_Eof => True);
declare
Result : constant Boolean := S.Eof_Encountered /= False;
begin
Dio.Release (File);
-- if not Primitive_Io.Absorb_Output then
-- Pput ("Cti.End_Of EOF or EOP = " &
-- Boolean'Image (Result));
-- end if;
return Result;
end;
else
Dio.Release (File);
-- if not Primitive_Io.Absorb_Output then
-- Pput ("Cti.End_Of returning " &
-- Boolean'Image (Level = Eol));
-- end if;
return Level = Eol;
end if;
-- Only return True if we are looking for end-of-line
when Page_Terminator =>
Dio.Release (File);
-- if not Primitive_Io.Absorb_Output then
-- Pput ("Cti.End_Of returning " &
-- Boolean'Image (Level <= Eop));
-- end if;
return Level <= Eop; -- or: Level /= Eof
-- A Page_Terminator is EOL as well as EOP
when others =>
Dio.Release (File);
-- Pput ("Cti.End_Of returning false");
return False;
end case;
exception
when others =>
Dio.Release (File);
raise;
end End_Of;
--\f
--------------------------------------------------------------------
-- Visible function END_OF_LINE:
-- Returns TRUE if a line terminator or a file terminator is next;
-- otherwise returns FALSE. [RM 14.3.4 (12)]
--------------------------------------------------------------------
function End_Of_Line (File : File_Type) return Boolean is
begin
return End_Of (File, Eol);
end End_Of_Line;
--------------------------------------------------------------------
-- Visible function END_OF_PAGE:
-- Returns TRUE if the combination of a line terminator and a page
-- terminator is next, or if a file terminator is next; otherwise
-- returns FALSE. [RM 14.3.4 (21)]
--------------------------------------------------------------------
function End_Of_Page (File : File_Type) return Boolean is
begin
return End_Of (File, Eop);
end End_Of_Page;
--------------------------------------------------------------------
-- Visible function END_OF_FILE:
-- Returns TRUE if a file terminator is next, or if the combination
-- of a line, a page, and a file terminator is next; otherwise
-- returns FALSE.
--------------------------------------------------------------------
function End_Of_File (File : File_Type) return Boolean is
begin
return End_Of (File, Eof);
end End_Of_File;
--\f
-- Next come all the input functions in which the file defaults to
-- Current_Input. All of these are implemented by calling the
-- corresponding routine, passing Current_Input as a parameter. It is hard
-- to do to much better than than this, because each of these routines must
-- check if Current_Output has been initialized, and open Standard_Input if
-- not. A program that uses Simple_Text_Io to read Current_Input will be
-- more efficient if it calls Current_Input once at the beginning, saves
-- the value in a variable, and then never uses the following routines.
-- It is annoying that we can't do this for him!
procedure Get (Item : out Character) is
begin
Get (Get_Current_Input, Item);
end Get;
procedure Get (Item : out String) is
begin
Get (Get_Current_Input, Item);
end Get;
procedure Get_Line (Item : out String; Last : out Natural) is
begin
Get_Line (Get_Current_Input, Item, Last);
end Get_Line;
function Get_Line return String is
begin
return Get_Line (Get_Current_Input);
end Get_Line;
procedure Skip_Line (Spacing : Positive_Count := 1) is
begin
Skip_Line (Get_Current_Input, Spacing);
end Skip_Line;
procedure Skip_Page is
begin
Skip_Page (Get_Current_Input);
end Skip_Page;
function End_Of_Line return Boolean is
begin
return End_Of_Line (Get_Current_Input);
end End_Of_Line;
function End_Of_Page return Boolean is
begin
return End_Of_Page (Get_Current_Input);
end End_Of_Page;
function End_Of_File return Boolean is
begin
return End_Of_File (Get_Current_Input);
end End_Of_File;
--\f
-----------------------
--- Output routines ---
-----------------------
package Buffering_Puts is
-- The following two Put procedures implement a small buffer between
-- Text IO and Device-Independent IO. There are two reasons for using
-- this buffer. First, if the user is doing character-at-a-time output,
-- we can avoid the overhead of calling Device-Independent I/O for every
-- character. Second, it allows us to normalize out redundant line and
-- page terminators.
-- These procedures do not keep track of column, line and page counts.
-- That is the responsibility of the next level up.
-- Semantics bug!
--procedure Put (F : File_Type; S : in out Output_State; Item : String);
procedure Upt (F : File_Type; S : in out Output_State; Item : String);
procedure Put_Line_Terminator (F : File_Type; S : in out Output_State);
procedure Put_Page_Terminator (F : File_Type; S : in out Output_State);
private
--pragma Suppress (Elaboration_Check, On => Put); -- Semantics bug!
pragma Suppress (Elaboration_Check, On => Upt); -- Semantics bug!
pragma Suppress (Elaboration_Check, On => Put_Line_Terminator);
pragma Suppress (Elaboration_Check, On => Put_Page_Terminator);
end Buffering_Puts;
package Formatting_Puts is
procedure Put_Unbroken
(F : File_Type; S : in out Output_State; Item : String);
procedure Put_Broken
(F : File_Type; S : in out Output_State; Item : String);
private
pragma Suppress (Elaboration_Check, On => Put_Unbroken);
pragma Suppress (Elaboration_Check, On => Put_Broken);
end Formatting_Puts;
use Buffering_Puts;
use Formatting_Puts;
--\f
-- The next level of procedures handles counts and terminators.
-- These are not user-visible routines; they assume that the file parameter
-- is open for output.
procedure New_Line (F : File_Type; S : in out Output_State) is
begin
-- No matter what happens, we will start a new line
S.Column_Number := 1;
-- We are buffering lines so that the page terminator can go
-- in front of the line terminator. Therefore, we always
-- end the line first.
Put_Line_Terminator (F, S);
-- See if a new page must be begun
if S.Line_Number >= S.Page_Length then
Put_Page_Terminator (F, S);
S.Line_Number := 1;
S.Page_Number := S.Page_Number + 1; -- may overflow
else
S.Line_Number := S.Line_Number + 1; -- may overflow
end if;
exception
when Numeric_Error | Constraint_Error =>
null;
end New_Line;
procedure New_Page (F : File_Type; S : in out Output_State) is
begin
Put_Page_Terminator (F, S);
S.Column_Number := 1;
S.Line_Number := 1;
S.Page_Number := S.Page_Number + 1; -- may overflow
exception
when Numeric_Error | Constraint_Error =>
null;
end New_Page;
--\f
procedure Set_Col (File : File_Type;
S : in out Input_State;
To : Positive_Count) is
C : Character;
Next_To_Read_Target : Integer;
B : Buffering.Data_Buffer := Dio.Get (File);
procedure Reset_Target is
-- For input files, the current column number is not stored; it is
-- computed from the buffer pointer and the variable S.Line_Start.
-- This routine computes the value that the buffer pointer must
-- have to equal the desired column number. This target must be
-- recomputed every time S.Line_Start changes: when we fill the
-- buffer or encounter a terminator.
begin
Next_To_Read_Target := S.Line_Start + Integer (To) - 1;
exception
when Numeric_Error =>
-- It is sufficent to set the target to be outside the buffer.
Next_To_Read_Target := 0;
end Reset_Target;
begin
Reset_Target;
-- This if statement implements the requirement from the LRM that if
-- the current column number equals the argument, then the call has no
-- effect. This is the only way we can return with a line terminator
-- as the next item to be read.
if B.Tail = Next_To_Read_Target then
return;
end if;
loop
-- Sliding the buffer could change Next_To_Read_Target
Next_Buffer (File, S, B);
Reset_Target; -- really needed here only if buffer slides
C := Buffering.Peek (B);
-- According to validation test CE3409D, it is not acceptable for
-- SET_COL to return with a line terminator as the next item to be
-- read, even if the line terminator has the desired column number.
-- Therefore we keep reading until we have read a real character
-- with the desired column number and then back up B.Tail
-- so that the next I/O call will get this character.
case C is
when Line_Terminator =>
Buffering.Consume (B, 1);
New_Line (S);
-- Reset_Target;
when Page_Terminator =>
Buffering.Consume (B, 1);
New_Page (S);
-- Reset_Target;
when others =>
exit when B.Tail = Next_To_Read_Target;
Buffering.Consume (B, 1);
end case;
end loop;
end Set_Col;
--\f
procedure Set_Col (F : File_Type; S : in out Output_State; To : Count) is
New_Number : constant Extended_Count := Extended_Count (To);
begin
-- Pput ("Cti.Set_Col output file To" & Count'Image (To) &
-- " where current column is" & Extended_Count'Image (S.Column_Number));
if New_Number > S.Line_Length then
raise Iof.Column_Error;
end if;
if New_Number < S.Column_Number then
-- Pput ("Cti.Set_Col to earlier column, doing New_Line");
New_Line (F, S);
-- Pput ("Cti.Set_Col Column_Number is now" &
-- Extended_Count'Image (S.Column_Number));
end if;
declare
Str : String (1 .. Integer (New_Number - S.Column_Number));
begin
-- Pput ("Cti.Set_Col dumping" & Integer'Image (Str'Length) & " blanks");
if Str'Length > 0 then
Machine_Primitive_Operations.Blank_Fill (Str, Str'Length);
end if;
Upt (F, S, Str);
end;
S.Column_Number := New_Number;
end Set_Col;
--\f
procedure Set_Line (File : File_Type;
S : in out Input_State;
To : Positive_Count) is
New_Line_Number : constant Extended_Count := Extended_Count (To);
begin
-- if not Primitive_Io.Absorb_Output then
-- Pput ("Cti.Set_Line for output file to" &
-- Extended_Count'Image (New_Line_Number) & " from" &
-- Extended_Count'Image (S.Line_Number));
-- end if;
while (S.Line_Number /= New_Line_Number) loop
-- if not Primitive_Io.Absorb_Output then
-- Pput ("Cti.Set_Line to" &
-- Extended_Count'Image (New_Line_Number) & " now at" &
-- Extended_Count'Image (S.Line_Number));
-- end if;
Skip (File, S, Count_Lines => True);
end loop;
-- The line we're currently at must exist (see CE3410E).
-- Thus we fill the buffer. This read-ahead is necessary.
declare
B : Buffering.Data_Buffer := Dio.Get (File);
begin
if Buffering.Is_Empty (B) then
-- And how can this be?
if S.Eof_Encountered = True then
raise End_Error;
end if;
Fill_Buffer (File, S, B, Undo_Eof => False);
if S.Eof_Encountered = True then
-- Hah! The line didn't exist after all.
raise End_Error;
end if;
end if;
end;
end Set_Line;
procedure Set_Line (F : File_Type; S : in out Output_State; To : Count) is
New_Number : constant Extended_Count := Extended_Count (To);
begin
if New_Number = S.Line_Number then
return;
end if;
if New_Number > S.Page_Length then
raise Iof.Illegal_Position_Error;
end if;
if New_Number < S.Line_Number then
New_Page (F, S);
end if;
-- Output an appropriate number of line terminators.
for I in 1 .. New_Number - S.Line_Number loop
Put_Line_Terminator (F, S);
end loop;
S.Column_Number := 1;
S.Line_Number := New_Number;
end Set_Line;
--\f
--------------------------------------------------------------------
-- User-visible output routines that take an explicit file parameter.
-- These routines all call Get_Output_State, which checks to see that
-- the file is open for output, raising the appropriate exception if
-- not Then lower-level routines are called to peform the requested
-- function(s).
--------------------------------------------------------------------
--------------------------------------------------------------------
-- Visible procedure PUT for writing a character:
-- If the line length of the specified output file is bounded (that
-- is, does not have the conventional value zero), and the current
-- column number exceeds it, has the effect of calling NEW_LINE with
-- a spacng of one. Then, or otherwise, outputs the given
-- character to the file. [RM 14.3.6 (6)]
--------------------------------------------------------------------
procedure Put (File : File_Type; Item : Character) is
S : Output_State renames State_Handling.Get_Output_State (File).all;
begin
Put_Unbroken (File, S, String'(1 => Item));
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Put;
--------------------------------------------------------------------
-- Visible procedure PUT for writing a string:
-- Determines the length of the given string and attempts that
-- number of PUT operations for successive characters of the string
-- (in particular, no operation is performed if the string is null).
-- [RM 14.3.6 (11)]
--------------------------------------------------------------------
procedure Put (File : File_Type; Item : String) is
S : Output_State renames State_Handling.Get_Output_State (File).all;
begin
Put_Broken (File, S, Item);
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Put;
--\f
--------------------------------------------------------------------
-- Visible procedure PUT_LINE for writing a string:
-- Calls the procedure PUT for the given string, and then the
-- procedure NEW_LINE with a spacing of one. [RM 14.3.6 (17)]
--------------------------------------------------------------------
procedure Put_Line (File : File_Type; Item : String) is
S : Output_State renames State_Handling.Get_Output_State (File).all;
begin
Put_Broken (File, S, Item);
New_Line (File, S);
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end Put_Line;
--\f
--------------------------------------------------------------------
-- Visible procedure NEW_LINE:
-- For a SPACING of one: Outputs a line terminator and sets the
-- current column number to one. Then increments the current line
-- number by one, except in the case that the current line number
-- is already greater than or equal to the maximum page length, for a
-- bounded page length; in that case a page terminator is output,
-- the current page number is incremented by one, and the current
-- line number is set to one. For a SPACING greater than one, the
-- above actions are performed SPACING times. [RM 14.3.4 (3-4)]
--------------------------------------------------------------------
procedure New_Line (File : File_Type; Spacing : Positive_Count := 1) is
S : Output_State renames State_Handling.Get_Output_State (File).all;
begin
for J in 1 .. Spacing loop
New_Line (File, S);
end loop;
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end New_Line;
--------------------------------------------------------------------
-- Visible procedure NEW_PAGE:
-- Outputs a line terminator if the current line is not terminated,
-- or if the current page is empty (that is, if the current column
-- and line numbers are both equal to one). Then outputs a page
-- terminator, which terminates the current page. Adds one to the
-- current page number and sets the current column and line numbers
-- to one. [RM 14.3.4 (15)]
--------------------------------------------------------------------
procedure New_Page (File : File_Type) is
S : Output_State renames State_Handling.Get_Output_State (File).all;
begin
New_Page (File, S);
Dio.Release (File);
exception
when others =>
Dio.Release (File);
raise;
end New_Page;
--\f
-- User-visible output procedures with file parameters that default to
-- Current_Output. Each simply calls the corresponding user-visible
-- procedure, passing it Current_Output. Since the current design insists
-- that any of these procedures can create Current_Output, it is hard to do
-- too much better than this.
procedure Put (Item : Character) is
begin
Put (Get_Current_Output, Item);
end Put;
procedure Put (Item : String) is
begin
Put (Get_Current_Output, Item);
end Put;
procedure Put_Line (Item : String) is
begin
Put_Line (Get_Current_Output, Item);
end Put_Line;
procedure New_Page is
begin
New_Page (Get_Current_Output);
end New_Page;
procedure New_Line (Spacing : Positive_Count := 1) is
begin
New_Line (Get_Current_Output, Spacing);
end New_Line;
--\f
-- The following routines work on files that are open for either input or
-- output. In each case, the routine Get_File_State is called, which
-- raises Status_Error if the file is not open, and returns its mode and
-- the appropriate state if it is. The routines then do different things,
-- depending on the mode.
-- The default file is Current_Output, so the default routines could simply
-- call Get_Output_State, but the lock isn't necessary, so just call
-- the corresponding visible routine with Current_Output.
procedure Set_Col (File : File_Type; To : Positive_Count) is
In_State : Access_Input_State;
Out_State : Access_Output_State;
Mode : File_Mode;
begin
State_Handling.Get_File_State (File, Mode, In_State, Out_State);
if Mode = In_File then
Set_Col (File, In_State.all, To);
else
Set_Col (File, Out_State.all, To);
end if;
end Set_Col;
procedure Set_Col (To : Positive_Count) is
begin
Set_Col (Get_Current_Output, To);
end Set_Col;
function Col (File : File_Type) return Positive_Count is
In_State : Access_Input_State;
Out_State : Access_Output_State;
Mode : File_Mode;
B : Buffering.Data_Buffer;
begin
State_Handling.Get_File_State (File, Mode, In_State, Out_State);
if Mode = In_File then
B := Dio.Get (File);
return Positive_Count (B.Tail + 1 - In_State.Line_Start);
else
return Positive_Count (Out_State.Column_Number);
end if;
exception
when Constraint_Error | Numeric_Error =>
raise Iof.Column_Error;
end Col;
function Col return Positive_Count is
begin
return Col (Get_Current_Output);
end Col;
--\f
procedure Set_Line (File : File_Type; To : Positive_Count) is
In_State : Access_Input_State;
Out_State : Access_Output_State;
Mode : File_Mode;
begin
State_Handling.Get_File_State (File, Mode, In_State, Out_State);
if Mode = In_File then
Set_Line (File, In_State.all, To);
else
Set_Line (File, Out_State.all, To);
end if;
end Set_Line;
procedure Set_Line (To : Positive_Count) is
begin
Set_Line (Get_Current_Output, To);
end Set_Line;
function Line (File : File_Type) return Positive_Count is
In_State : Access_Input_State;
Out_State : Access_Output_State;
Mode : File_Mode;
begin
State_Handling.Get_File_State (File, Mode, In_State, Out_State);
if Mode = Out_File then
return Positive_Count (Out_State.Line_Number);
else
return Positive_Count (In_State.Line_Number);
end if;
exception
when Constraint_Error | Numeric_Error =>
raise Iof.Illegal_Position_Error;
end Line;
function Line return Positive_Count is
begin
return Line (Get_Current_Output);
end Line;
--\f
function Page (File : File_Type) return Positive_Count is
In_State : Access_Input_State;
Out_State : Access_Output_State;
Mode : File_Mode;
begin
State_Handling.Get_File_State (File, Mode, In_State, Out_State);
if Mode = Out_File then
return Positive_Count (Out_State.Page_Number);
else
return Positive_Count (In_State.Page_Number);
end if;
exception
when Constraint_Error | Numeric_Error =>
raise Iof.Illegal_Position_Error;
end Page;
function Page return Positive_Count is
begin
return Page (Get_Current_Output);
end Page;
-- \f
-----------------------------------------------------------------
procedure Create (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String := "";
Form : String := "") is separate;
procedure Open (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String;
Form : String := "") is separate;
-- This procedure is called when a file is closed, reset, or saved.
-- If the file is an output file then the partial output buffer is
-- flushed immediately. For some implementations (e.g., VMS) this
-- will force a line terminator at the end of the buffer.
procedure Flush (File : File_Type;
Clear_Terminators : Boolean := True) is separate;
procedure Fill_Buffer (File : File_Type;
S : in out Input_State;
B : in out Buffering.Data_Buffer;
Undo_Eof : Boolean := False) is separate;
procedure Get_A_Line (File : in File_Type;
S : in out Input_State;
Item : out String;
Last : out Natural;
Skip_Terminators : in Boolean;
End_Of_Line : out Boolean;
End_Of_Page : out Boolean;
End_Of_File : out Boolean) is separate;
package body State_Handling is separate;
package body Buffering_Puts is separate;
package body Formatting_Puts is separate;
package body Enumeration_Io is separate;
package body Standard_Files is separate;
package body Enum_Io is separate;
package body Integer_Io is separate;
package body Float_Io is separate;
-----------------------------------------------------------------
begin
-- COMMON_TEXT_IO elaboration:
-- Remember to initialize the standard files here.
Standard_Files.Initialize;
end Common_Text_Io;