|
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: 16565 (0x40b5)
Types: TextFile
Names: »B«
└─⟦bad92a95e⟧ Bits:30000535 8mm tape, Rational 1000, RPC 1_0_2
└─⟦bb34fe6e2⟧ »DATA«
└─⟦15d8b76c6⟧
└─⟦this⟧
with Interchange_Float;
package body Interchange is
subtype Padding_Type is Byte_String (1 .. 1);
Padding : constant Padding_Type := (others => 0);
Radix : constant Long_Integer := Long_Integer (Byte'Last) + 1;
subtype Signed_Byte_Range is Long_Integer
range -(Radix / 2) .. (Radix / 2) - 1;
Scale_A : constant Standard.Natural
:= Interchange_Defs.Duration_Magnitude;
Scale_B : constant Standard.Natural := (10 ** 9) / Scale_A;
pragma Assert (Scale_A * Scale_B = 10 ** 9);
Half_Scale_B : constant Standard.Natural := Scale_B / 2;
Half_Scale_A : constant Standard.Duration :=
(Standard.Duration'Delta * Scale_A) / 2;
function Convert (X : Standard.Duration) return Interchange.Duration is
Seconds : Interchange.Integer;
Fraction : Standard.Duration;
Nanoseconds : Standard.Natural;
begin
Seconds := Interchange.Integer (X);
Fraction := X - Standard.Duration (Seconds);
if Fraction < 0.0 then
Seconds := Seconds - 1;
Fraction := X - Standard.Duration (Seconds);
end if;
pragma Assert (Fraction >= 0.0);
pragma Assert (Fraction < 1.0);
Nanoseconds := Standard.Natural (Fraction * Scale_A) * Scale_B;
if Nanoseconds > Standard.Natural
(Interchange.Nanosecond_Count'Last) then
-- duration'delta < 10 ** -9
Seconds := Seconds + 1;
Nanoseconds := 0;
end if;
return Interchange.Duration'
(Seconds, Interchange.Nanosecond_Count (Nanoseconds));
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Convert;
function Convert (X : Interchange.Duration) return Standard.Duration is
Fraction : Standard.Duration;
begin
Fraction :=
Standard.Duration
((Standard.Natural (X.Nanoseconds) + Half_Scale_B) / Scale_B);
-- Adding Half_Scale_B before dividing by Scale_B has the effect of
-- rounding to the NEAREST Integer, rather than the next smallest.
Fraction := (Fraction + Half_Scale_A) / Scale_A;
-- The Ada LRM does not specify how rounding is done when dividing
-- a Duration (fixed-point) by an Integer. The R1000 rounds DOWN.
-- Adding Half_Scale_A before dividing by Scale_A has the effect of
-- rounding to the NEAREST Duration, rather than the next smallest.
return Standard.Duration (X.Seconds) + Fraction;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Convert;
function Convert (X : Calendar.Time) return Interchange.Time is
Seconds : Calendar.Day_Duration;
Y : Time;
begin
Calendar.Split (X, Calendar.Year_Number (Y.Year),
Calendar.Month_Number (Y.Month),
Calendar.Day_Number (Y.Day), Seconds);
Y.Seconds := Convert (Seconds);
return Y;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Convert;
function Convert (X : Interchange.Time) return Calendar.Time is
begin
return Calendar.Time_Of
(Calendar.Year_Number (X.Year),
Calendar.Month_Number (X.Month),
Calendar.Day_Number (X.Day), Convert (X.Seconds));
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Convert;
package body Operations is
procedure Put (Into : Stream_Id;
Data : Long_Integer;
Bytes : Interchange.Natural) is
Data_Copy : Long_Integer := Data;
Data_Byte : Byte_String (1 .. Standard.Natural (Bytes));
Temp : Long_Integer;
begin
if Bytes <= 0 then
if Data /= 0 then
raise Interchange.Constraint_Error;
end if;
else
for I in reverse 2 .. Data_Byte'Last loop
Temp := Data_Copy mod Radix;
Data_Byte (I) := Byte (Temp);
Data_Copy := (Data_Copy - Temp) / Radix;
end loop;
Data_Byte (1) := Byte (Signed_Byte_Range (Data_Copy) mod Radix);
Put (Into, Data_Byte);
end if;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Put;
procedure Get (From : Stream_Id;
Data : out Long_Integer;
Bytes : Interchange.Natural) is
Data_Byte : Byte_String (1 .. Standard.Natural (Bytes));
Data_Copy : Long_Integer;
begin
if Bytes <= 0 then
Data := 0;
else
Get (From, Data_Byte);
Data_Copy := Long_Integer (Data_Byte (1));
if Data_Copy > Signed_Byte_Range'Last then
Data_Copy := Data_Copy - Radix;
end if;
for I in 2 .. Data_Byte'Last loop
Data_Copy := (Data_Copy * Radix) +
Long_Integer (Data_Byte (I));
end loop;
Data := Data_Copy;
end if;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get;
procedure Put (Into : Stream_Id; Data : Interchange.Short_Integer) is
begin
Put (Into, Long_Integer (Data), 2);
end Put;
procedure Get (From : Stream_Id;
Data : out Interchange.Short_Integer) is
begin
Get (From, Long_Integer (Data), 2);
end Get;
procedure Put (Into : Stream_Id; Data : Interchange.Integer) is
begin
Put (Into, Long_Integer (Data), 4);
end Put;
procedure Get (From : Stream_Id; Data : out Interchange.Integer) is
begin
Get (From, Long_Integer (Data), 4);
end Get;
procedure Put (Into : Stream_Id; Data : Long_Integer) is
Data_Copy : Long_Integer := Data;
Bytes : Interchange.Natural;
begin
if Data_Copy = 0 then
Bytes := 0;
else
Bytes := 1;
while not (Data_Copy in Signed_Byte_Range) loop
Bytes := Bytes + 1;
Data_Copy := Data_Copy / Radix;
end loop;
end if;
Put (Into, Bytes);
Put (Into, Data, Bytes);
if Bytes mod 2 /= 0 then
Put (Into, Padding);
end if;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Put;
procedure Get (From : Stream_Id; Data : out Interchange.Long_Integer) is
Bytes : Interchange.Natural; -- JMK 7/14/86
Padding : Padding_Type;
begin
Get (From, Bytes);
Get (From, Data, Bytes);
if Bytes mod 2 /= 0 then
Get (From, Padding);
end if;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get;
procedure Put (Into : Stream_Id; Data : Interchange.Float) is
begin
Put (Into, Byte_String (Interchange_Float.Convert
(Interchange_Defs.Float (Data))));
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Put;
procedure Put (Into : Stream_Id; Data : Interchange.Long_Float) is
begin
Put (Into, Byte_String (Interchange_Float.Convert
(Interchange_Defs.Long_Float (Data))));
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Put;
procedure Get (From : Stream_Id; Data : out Interchange.Float) is
Bytes : Byte_String (1 .. Interchange_Float.Float'Length);
begin
Get (From, Bytes);
Data := Interchange.Float (Interchange_Float.Convert
(Interchange_Float.Float (Bytes)));
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get;
procedure Get (From : Stream_Id; Data : out Interchange.Long_Float) is
Bytes : Byte_String (1 .. Interchange_Float.Long_Float'Length);
begin
Get (From, Bytes);
Data := Interchange.Long_Float
(Interchange_Float.Convert
(Interchange_Float.Long_Float (Bytes)));
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get;
procedure Put (Into : Stream_Id; Data : Interchange.Duration) is
begin
Put (Into, Data.Seconds);
Put (Into, Data.Nanoseconds);
end Put;
procedure Get (From : Stream_Id; Data : out Interchange.Duration) is
begin
Get (From, Data.Seconds);
Get (From, Data.Nanoseconds);
end Get;
procedure Put (Into : Stream_Id; Data : Interchange.Time) is
begin
Put (Into, Data.Year);
Put (Into, Data.Month);
Put (Into, Data.Day);
Put (Into, Data.Seconds);
end Put;
procedure Get (From : Stream_Id; Data : out Interchange.Time) is
begin
Get (From, Data.Year);
Get (From, Data.Month);
Get (From, Data.Day);
Get (From, Data.Seconds);
end Get;
procedure Put (Into : Stream_Id; Data : Standard.Boolean) is
begin
if Data then
Put (Into, Interchange.Short_Natural (1));
else
Put (Into, Interchange.Short_Natural (0));
end if;
end Put;
procedure Get (From : Stream_Id; Data : out Standard.Boolean) is
Temp : Interchange.Short_Natural;
begin
Get (From, Temp);
Data := (Temp /= 0);
end Get;
procedure Put (Into : Stream_Id; Data : Standard.Character) is
begin
Put (Into, Interchange.Short_Natural
(Standard.Character'Pos (Data)));
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Put;
procedure Get (From : Stream_Id; Data : out Standard.Character) is
Temp : Interchange.Short_Natural;
begin
Get (From, Temp);
Data := Standard.Character'Val (Temp);
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get;
procedure Put_Byte_String (Into : Stream_Id;
Data : Interchange.Byte_String) is
begin
Put (Into, Interchange.Natural (Data'Length));
Put (Into, Data);
if Data'Length mod 2 /= 0 then
Put (Into, Padding);
end if;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Put_Byte_String;
function Get_Byte_String (From : Stream_Id)
return Interchange.Byte_String is
Length : Interchange.Natural;
Padding : Padding_Type;
begin
Get (From, Length);
declare
Answer : Interchange.Byte_String
(1 .. Standard.Natural (Length));
begin
Get (From, Answer);
if Answer'Length mod 2 /= 0 then
Get (From, Padding);
end if;
return Answer;
end;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get_Byte_String;
procedure Put_String (Into : Stream_Id; Data : Standard.String) is
Bytes : Interchange.Byte_String (Data'First .. Data'Last);
begin
for I in Data'Range loop
Bytes (I) := Interchange.Byte (Character'Pos (Data (I)));
end loop;
Put_Byte_String (Into, Bytes);
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Put_String;
function Get_String (From : Stream_Id) return Standard.String is
Bytes : constant Interchange.Byte_String := Get_Byte_String (From);
Answer : Standard.String (Bytes'First .. Bytes'Last);
begin
for I in Answer'Range loop
Answer (I) := Standard.Character'Val (Bytes (I));
end loop;
return Answer;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get_String;
procedure Put (Into : Stream_Id; Data : Interchange.Byte) is
begin
Put (Into, Interchange.Short_Natural (Data));
end Put;
procedure Get (From : Stream_Id; Data : out Interchange.Byte) is
begin
Get (From, Interchange.Short_Integer (Data));
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get;
package body Discrete is
procedure Put (Into : Stream_Id; Data : Discrete_Type) is
begin
Put (Into, Interchange.Short_Natural
(Discrete_Type'Pos (Data)));
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Put;
procedure Get (From : Stream_Id; Data : out Discrete_Type) is
Pos : Interchange.Short_Natural;
begin
Get (From, Pos);
Data := Discrete_Type'Val (Pos);
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get;
end Discrete;
package body Vector is
procedure Put (Into : Stream_Id; Data : Vector_Type) is
begin
Put (Into, Interchange.Natural (Data'Length));
for I in Data'Range loop
Put (Into, Data (I));
end loop;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Put;
function Get (From : Stream_Id) return Vector_Type is
Length : Interchange.Natural;
begin
Get (From, Length);
declare
Data : Vector_Type
(Index_Type'First ..
Index_Type'Val
(Index_Type'Pos (Index_Type'First) +
Length - 1));
begin
for I in Data'Range loop
Get (From, Data (I));
end loop;
return Data;
end;
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Get;
end Vector;
end Operations;
end Interchange;