DataMuseum.dk

top - download

    Length: 15632 (0x3d10)
    Types: TextFile
    Names: »B«

└─⟦149519bd4⟧ Bits:30000546 8mm tape, Rational 1000, !projects 93-07-13
    └─ ⟦124ff5788⟧ »DATA« 
        └─⟦this⟧ 
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
    └─ ⟦6f12a12be⟧ »DATA« 
        └─⟦this⟧ 

TextFile

WITH Interchange_Float;
WITH Pragma_Assert;

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);
   Junk : Boolean := Pragma_Assert.Check (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.Check (Fraction >= 0.0);
--      PRAGMA Assert (Fraction < 1.0);
      Pragma_Assert.Check (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;