|
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: 15386 (0x3c1a)
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 Literal_Parser;
with Numeric_Literals;
separate (Common_Text_Io)
package body Float_Io is
-- Dio_Absorb_Output : constant Boolean := Primitive_Io.Global_Absorb_Output;
-- procedure Pput (S : in String; Absorb_Output : Boolean := Dio_Absorb_Output)
-- renames Primitive_Io.Put_Line;
-- Must be large enough to hold the longest floating point literal
-- formatted by Image. Should be large enough to hold most floating
-- point literals to be input by user.
Default_Numeric_Literal_Max_Length : constant := 35;
-----------------------------------------------------------------
-- Visible procedure GET a FLOAT from a FILE:
-- This procedure implements the semantics of RM 14.3.8 (8-11),
-- except only on type Standard.Float. One hopes that Standard.
-- Float is the highest precision floating point type of the
-- machine.
-----------------------------------------------------------------
procedure Get (File : in File_Type; Item : out Float; Width : in Field) is
S : Input_State renames State_Handling.Get_Input_State (File).all;
B : Buffering.Data_Buffer := Dio.Get (File);
Numeric_Literal_Max_Length : Natural :=
Default_Numeric_Literal_Max_Length;
Status : Literal_Parser.Parse_Status;
Last_Of_Source : Natural;
function "=" (Left, Right : in Literal_Parser.Parse_Status)
return Boolean renames Literal_Parser."=";
begin
-- Pput ("Cti.Float_Io.Get (file)");
-- If Width = 0 then the syntax of the input determines how
-- many characters are read, that is, read until you can't
-- add the character to a numeric literal. If Width > 0 then
-- exactly that many characters or until end-of-line, whichever
-- comes first must be read and must be a valid numeric literal.
if Width = 0 then
-- Pput ("Cti.Float_Io.Get Width = 0");
<<Force_Reparse>> null;
declare
Result : Numeric_Literals.Numeric_Literal
(Max_Length => Numeric_Literal_Max_Length);
begin
loop
-- if S.Eof_Encountered = False then
-- Fill_Buffer (File, S, B, Undo_Eof => True);
-- end if;
--
Next_Buffer (File, S, B);
-- ^ Can raise End_Error here
declare
N : constant Natural := B.Head - B.Tail + 1;
S : String (1 .. N);
begin
-- Too bad we seem to need a copy here!!
if N > 0 then
Machine_Primitive_Operations.Move_Bytes
(B.Buffer (B.Tail .. B.Max_Length), S, N);
end if;
Literal_Parser.Parse_Numeric_Literal
(Source => S,
Integral => False,
Result => Result,
Status => Status,
Last_Of_Source => Last_Of_Source);
-- Pput
-- ("Cti.Float_Io.Get Parse_Numeric_Literal status = " &
-- Literal_Parser.Parse_Status'Image (Status));
exception
when Constraint_Error | Numeric_Error =>
-- Pput
-- ("Cti.Float_Io.Get Parse_Numeric_Literal raised CE or NE");
Status := Literal_Parser.Syntax_Error;
when others =>
-- Eh?
-- Pput
-- ("Cti.Float_Io.Get Parse_Numeric_Literal raised some exception");
Status := Literal_Parser.Syntax_Error;
end;
-- Check to see if a valid but unusually long numeric
-- literal was read from the current buffer. If so,
-- then we need to reallocate the Numeric_Literal and
-- try to parse it again.
if Status = Literal_Parser.Numeric_Literal_Too_Short then
Numeric_Literal_Max_Length := Result.L;
goto Force_Reparse;
end if;
-- Since we're in a copy of the source, the following line
-- won't work anymore:
-- Buffering.Consume (B, Last - B.Tail + 1);
Buffering.Consume (B, Last_Of_Source);
exit when Status /= Literal_Parser.Empty_Field;
-- Here we may have to skip a terminator next
if not Buffering.Is_Empty (B) then
declare
C : Character := Buffering.Peek (B);
begin
if C = Line_Terminator then
-- Pput
-- ("Cti.Float_Io.Get(file) skipping line terminator");
Buffering.Consume (B, 1);
New_Line (S);
elsif C = Page_Terminator then
-- Pput
-- ("Cti.Float_Io.Get(file) skipping page terminator");
Buffering.Consume (B, 1);
if not Buffering.Is_Empty (B) then
C := Buffering.Peek (B);
if C = Line_Terminator then
Buffering.Consume (B, 1);
end if;
end if;
New_Page (S);
else
-- and if it isn't a terminator ?????????
--Pput ("Cti.Float_Io.Get(file) have " &
-- Character'Image (C) &
-- " as separator, which is invalid");
raise Data_Error;
end if;
end;
end if;
end loop;
case Status is
when Literal_Parser.Ok =>
begin
-- Pput ("Cti.Float_Io.Get have Item = '" &
-- Result.V (1 .. Result.L) & ''');
Item := Value (Result.V (1 .. Result.L));
exception
when Constraint_Error | Numeric_Error =>
-- Pput
-- ("Cti.Float_Io.Get raised CE or NE getting Value of Item");
raise Iof.Input_Value_Error;
end;
when Literal_Parser.Empty_Field =>
-- How can this happen?
raise Data_Error;
when Literal_Parser.Syntax_Error =>
raise Iof.Input_Syntax_Error;
when Literal_Parser.Numeric_Literal_Too_Short =>
Numeric_Literal_Max_Length := Result.L;
goto Force_Reparse;
end case;
end;
else
-- Pput ("Cti.Float_Io.Get have Width =" & Field'Image (Width));
declare
Result : Numeric_Literals.Numeric_Literal (Max_Length => Width);
Buffer : String (1 .. Width);
Buffer_Filled : Natural;
Eol, Eop, Eof : Boolean;
begin
Get_A_Line (File, S, Buffer, Buffer_Filled,
False, -- don't skip terminators
Eol, Eop, Eof);
-- ^ Can raise End_Error
Literal_Parser.Parse_Numeric_Literal
(Source => Buffer (1 .. Buffer_Filled),
Integral => False,
Result => Result,
Status => Status,
Last_Of_Source => Last_Of_Source);
-- Pput ("Cti.Float_Io.Get Parse_Numeric_Literal status = " &
-- Literal_Parser.Parse_Status'Image (Status));
case Status is
-- If we get this far, we will only return a value or raise
-- Data_Error, as per the Ada LRM.
when Literal_Parser.Ok =>
-- Pput ("Cti.Float_Io.Get(file) Ok");
-- Make sure the entire value was read. Any trailing
-- junk, including spaces, causes Data_Error.
if Last_Of_Source /= Buffer_Filled then
-- Pput
-- ("Cti.Float_Io.Get(file) except didn't ready everything");
raise Iof.Input_Syntax_Error;
end if;
begin
-- Pput ("Cti.Float_Io.Get have Item = '" &
-- Result.V (1 .. Result.L) & ''');
Item := Value (Result.V (1 .. Result.L));
exception
when Constraint_Error | Numeric_Error =>
-- Pput
-- ("Cti.Float_Io.Get(file) Value raised exception");
raise Iof.Input_Value_Error;
end;
when Literal_Parser.Empty_Field =>
-- Pput ("Cti.Float_Io.Get(file) Empty Field 2");
raise Iof.Input_Syntax_Error;
when Literal_Parser.Syntax_Error =>
-- Pput ("Cti.Float_Io.Get(file) Syntax Error 2");
raise Iof.Input_Syntax_Error;
when Literal_Parser.Numeric_Literal_Too_Short =>
-- Pput ("Cti.Float_Io.Get(file) Too short?");
-- Can't really happen!
raise Data_Error;
end case;
end;
end if;
Dio.Release (File);
exception
when others =>
-- Pput ("Cti.Get (file) raised some exception");
Dio.Release (File);
raise;
end Get;
procedure Put (File : in File_Type;
Item : in Float;
Fore : in Field;
Aft : in Field;
Exp : in Field) is
S : Output_State renames State_Handling.Get_Output_State (File).all;
R : String (1 .. Default_Numeric_Literal_Max_Length + Fore + Aft + Exp);
Rl : Natural;
begin
-- Pput ("Cti.Put (file)");
Image (Item, Fore, Aft, Exp, R, Rl);
-- Pput ("Cti.Put has image '" & R (1 .. Rl) & ''');
Put_Unbroken (File, S, R (1 .. Rl));
Dio.Release (File);
exception
when others =>
-- Pput ("Cti.Put raised some exception");
Dio.Release (File);
raise;
end Put;
-----------------------------------------------------------------
-- Visible procedure GET a FLOAT from a STRING:
-- This procedure reads a Float from a string, as described in
-- RM 14.3.8 (17-19), except that it always reads a Float. One
-- hopes that Float is the highest-precision floating point type
-- on the machine.
-----------------------------------------------------------------
procedure Get (From : in String; Item : out Float; Last : out Positive) is
Result : Numeric_Literals.Numeric_Literal (Max_Length => From'Length);
Status : Literal_Parser.Parse_Status;
Last_Of_Source : Natural;
begin
-- Pput ("Cti.Get (string) '" & From & ''');
Literal_Parser.Parse_Numeric_Literal (Source => From,
Integral => False,
Result => Result,
Status => Status,
Last_Of_Source => Last_Of_Source);
case Status is
when Literal_Parser.Ok =>
begin
-- Pput ("Cti.Get (string) have Item = '" &
-- Result.V (1 .. Result.L) & ''');
Item := Value (Result.V (1 .. Result.L));
exception
when Constraint_Error | Numeric_Error =>
-- Pput ("Cti.Get (string) value raised C.E. or N.E.");
raise Iof.Input_Value_Error;
end;
Last := Last_Of_Source;
return;
when Literal_Parser.Empty_Field =>
-- Pput ("Cti.Get (string) have Empty_Field");
raise End_Error;
when Literal_Parser.Syntax_Error =>
-- Pput ("Cti.Get (string) have Syntax_Error");
raise Iof.Input_Syntax_Error;
when Literal_Parser.Numeric_Literal_Too_Short =>
-- Can't happen
-- Pput ("Cti.Get (string) have Num Lit Too Short");
raise Data_Error;
end case;
end Get;
procedure Put (To : out String;
Item : in Float;
Aft : in Field;
Exp : in Field) is
R : String (1 .. Default_Numeric_Literal_Max_Length + Aft + Exp);
Rl : Natural;
To_Last : constant Natural := To'Last;
begin
Image (Item, 0, Aft, Exp, R, Rl);
if Rl > To'Length then
raise Iof.Item_Length_Error;
end if;
declare
Bf_Length : constant Natural := To'Length - Rl;
begin
if Bf_Length > 0 then
Machine_Primitive_Operations.Blank_Fill (To, Bf_Length);
end if;
To (To'First + Bf_Length .. To_Last) := R (1 .. Rl);
end;
end Put;
end Float_Io;