|
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: I T
Length: 15626 (0x3d0a)
Types: TextFile
Names: »INTERCHANGE_BODY«
└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
└─⟦5cb1d1d7f⟧ »DATA«
└─⟦3b1ee7bd8⟧
└─⟦this⟧
with Interchange_Float;
package body Interchange is
Radix : constant Long_Integer := Long_Integer (Byte'Last) + 1;
subtype Signed_Byte_Range is Long_Integer
range -(Radix / 2) .. (Radix / 2) - 1;
Scale : constant Standard.Integer := Interchange_Defs.Duration_Magnitude;
Unscale : constant Standard.Integer := (10 ** 9) / Scale;
pragma Assert (Scale = (10 ** 9) / Unscale);
subtype Padding_Type is Byte_String (1 .. 1);
Padding : constant Padding_Type := (others => 0);
function Convert (X : Standard.Duration) return Interchange.Duration is
Seconds : Interchange.Integer;
Nanoseconds : Interchange.Nanosecond_Count;
Temp : Standard.Integer;
Temp1 : Standard.Duration;
begin
Seconds := Interchange.Integer (X);
if (X - Standard.Duration (Seconds)) < 0.0 then
Seconds := Seconds - 1;
end if;
pragma Assert ((X - Standard.Duration (Seconds)) >= 0.0);
pragma Assert ((X - Standard.Duration (Seconds)) < 1.0);
Temp1 := (X - Standard.Duration (Seconds)) * Scale;
Temp := Standard.Integer (Temp1);
Temp := Temp * Unscale;
Nanoseconds := Interchange.Nanosecond_Count (Temp);
if Nanoseconds >= 10 ** 9 then
-- duration'delta < 10 ** -9
Seconds := Seconds + 1;
Nanoseconds := 0;
end if;
return Interchange.Duration'(Seconds, Nanoseconds);
exception
when Standard.Constraint_Error | Standard.Numeric_Error =>
raise Interchange.Constraint_Error;
end Convert;
function Convert (X : Interchange.Duration) return Standard.Duration is
begin
return Standard.Duration (X.Seconds) +
(Standard.Duration
(Standard.Integer (X.Nanoseconds) / Unscale) / Scale);
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 : Interchange_Float.Float;
begin
Get (From, Byte_String (Bytes));
Data := Interchange.Float (Interchange_Float.Convert (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 : Interchange_Float.Long_Float;
begin
Get (From, Byte_String (Bytes));
Data := Interchange.Long_Float (Interchange_Float.Convert (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;