DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software. 

top - download
Index: ┃ T V ┃

⟦35a757ae8⟧ TextFile

    Length: 7419 (0x1cfb)
    Types: TextFile
    Names: »V«

Derivation

└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
    └─ ⟦0c20f784e⟧ »DATA« 
        └─⟦1abbe589f⟧ 
            └─⟦059497ac5⟧ 
                └─⟦this⟧

TextFile

--/ if TeleGen2 and then Unix then
--// with Float_Text_Io;
--/ end if;

with Text_Io;  
with Unchecked_Deallocation;

with Xlbmt_Numeric_Types;

package Xlbt_Arithmetic is
------------------------------------------------------------------------------
-- X Library Arithmetic Types
--
-- Xlbt_Arithmetic - Differing sizes of arithmetic types and types constructed
--  from arithmetic types, e.g. arrays.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
--
--                  All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the name of Rational not be used in
-- advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- Rational disclaims all warranties with regard to this software, including
-- all implied warranties of merchantability and fitness, in no event shall
-- Rational be liable for any special, indirect or consequential damages or
-- any damages whatsoever resulting from loss of use, data or profits, whether
-- in an action of contract, negligence or other tortious action, arising out
-- of or in connection with the use or performance of this software.
------------------------------------------------------------------------------

--\f

----Scalar Types

    type S_Char  is new Xlbmt_Numeric_Types.Eight_Bits_Signed;  
    type S_Short is new Xlbmt_Numeric_Types.Sixteen_Bits_Signed;  
    type S_Long  is new Xlbmt_Numeric_Types.Thirty_Two_Bits_Signed;

    subtype S_Natural  is S_Long range 0 .. S_Long'Last;  
    subtype S_Positive is S_Long range 1 .. S_Long'Last;

    type U_Char  is new Xlbmt_Numeric_Types.Eight_Bits_Unsigned;  
    type U_Short is new Xlbmt_Numeric_Types.Sixteen_Bits_Unsigned;

--/ if TeleGen2_2d_Bug then
--//     subtype Telegen2_2d_Bug is Integer range 0 .. 255;
--/ end if;

    subtype U_Short_Positive is U_Short range 1 .. U_Short'Last;

----Unfortunately, a 32-bit unsigned type is not portable to most present-day
--  Ada implementations.  The LRM would require them to implemented at least
--  33-bit signed arithmetic (or 64-bit arithmetic) and most vendors do not
--  do that.  Xlib is thus forced to used 32-bit signed values where that is
--  not entirely appropriate.
--
--    type U_Long  is new Xlbmt_Numeric_Types.Thirty_Two_Bits_Unsigned;
--    type U_Long_Array  is array (S_Natural range <>) of U_Long;
--    type U_Long_List  is access U_Long_Array;
--    package U_Long_Io is new Text_Io.Integer_Io (U_Long);
--    None_U_Long_List  : constant U_Long_List  := null;
--    pragma Enable_Deallocation (U_Long_List);
--    procedure Free_U_Char_List is
--       new Unchecked_Deallocation (U_Long_Array, U_Long_List);

----I/O packages

    package S_Long_Io is new Text_Io.Integer_Io (S_Long);

--/ if TeleGen2 and then Unix then
--//     package Float_Io renames Float_Text_Io;
--/ else
    package Float_Io is new Text_Io.Float_Io (Float);
--/ end if;

----Signed Array Types

    type S_Char_Array  is array (S_Natural range <>) of S_Char;  
    type S_Short_Array is array (S_Natural range <>) of S_Short;  
    type S_Long_Array  is array (S_Natural range <>) of S_Long;

--/ if Pack then
--//     pragma Pack (S_Char_Array);
--//     pragma Pack (S_Short_Array);
--//     pragma Pack (S_Long_Array);
--/ end if;

    type S_Char_List  is access S_Char_Array;  
    type S_Short_List is access S_Short_Array;  
    type S_Long_List  is access S_Long_Array;

--/ if Enable_Deallocation then
    pragma Enable_Deallocation (S_Char_List);  
    pragma Enable_Deallocation (S_Short_List);  
    pragma Enable_Deallocation (S_Long_List);
--/ end if;

    None_S_Char_List  : constant S_Char_List  := null;  
    None_S_Short_List : constant S_Short_List := null;  
    None_S_Long_List  : constant S_Long_List  := null;

    procedure Free_S_Char_List  is  
       new Unchecked_Deallocation (S_Char_Array, S_Char_List);  
    procedure Free_S_Short_List is  
       new Unchecked_Deallocation (S_Short_Array, S_Short_List);  
    procedure Free_S_Long_List  is  
       new Unchecked_Deallocation (S_Long_Array, S_Long_List);

----Unsigned Array Types

    type U_Char_Array  is array (S_Natural range <>) of U_Char;  
    type U_Short_Array is array (S_Natural range <>) of U_Short;

--/ if Pack then
--//     pragma Pack (U_Char_Array);
--//     pragma Pack (U_Short_Array);
--/ end if;

    type U_Char_List  is access U_Char_Array;  
    type U_Short_List is access U_Short_Array;

--/ if Enable_Deallocation then
    pragma Enable_Deallocation (U_Char_List);  
    pragma Enable_Deallocation (U_Short_List);
--/ end if;

    None_U_Char_List  : constant U_Char_List  := null;  
    None_U_Short_List : constant U_Short_List := null;


    procedure Free_U_Char_List  is  
       new Unchecked_Deallocation (U_Char_Array, U_Char_List);  
    procedure Free_U_Short_List is  
       new Unchecked_Deallocation (U_Short_Array, U_Short_List);


--\f

--/ if TeleGen2_Derive_Bug then
--//
--// ------------------------------------------------------------------------------
--// -- TeleSoft's TeleGen2 68k Unix has a bug in it.  Derived types don't inherit
--// -- the functions of their base types.  Ack...  Fix this with this hack.
--// -- Duplicate lots of code.
--// ------------------------------------------------------------------------------
--//
--// ------------------------------------------------------------------------------
--// -- Perform bit-wise operations on signed 32-bit values.
--// ------------------------------------------------------------------------------
--//
--//     function "and" (A : S_Long; B : S_Long)  return S_Long;
--//     function "or"  (A : S_Long; B : S_Long)  return S_Long;
--//     function "xor" (A : S_Long; B : S_Long)  return S_Long;
--//     function "not" (A : S_Long)              return S_Long;
--//     function Shift (A : S_Long; B : Integer) return S_Long;
--//
--// ------------------------------------------------------------------------------
--// -- Perform bit-wise operations on unsigned 16-bit values.
--// ------------------------------------------------------------------------------
--//
--//     function "and" (A : U_Short; B : U_Short) return U_Short;
--//     function "or"  (A : U_Short; B : U_Short) return U_Short;
--//     function "xor" (A : U_Short; B : U_Short) return U_Short;
--//     function "not" (A : U_Short)              return U_Short;
--//     function Shift (A : U_Short; B : Integer) return U_Short;
--//
--// ------------------------------------------------------------------------------
--// -- Perform bit-wise operations on unsigned 8-bit values.
--// ------------------------------------------------------------------------------
--//
--//     function "and" (A : U_Char; B : U_Char)  return U_Char;
--//     function "or"  (A : U_Char; B : U_Char)  return U_Char;
--//     function "xor" (A : U_Char; B : U_Char)  return U_Char;
--//     function "not" (A : U_Char)              return U_Char;
--//     function Shift (A : U_Char; B : Integer) return U_Char;
--//
--/ end if;
end Xlbt_Arithmetic;