|
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 - downloadIndex: ┃ B T ┃
Length: 26390 (0x6716)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
--/ if R1000 then
with Unchecked_Conversions;
--/ elsif Cdf_Hpux then
--// with Unchecked_Conversion;
--/ elsif TeleGen2 and then Unix then
--// with System;
--/ end if;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
package body Xlbmp_Generic_Converters is
------------------------------------------------------------------------------
-- X Library Machine Types
--
-- Xlbmp_Generic_Converters - Machine/Compiler dependent conversions to/from
-- system data types.
------------------------------------------------------------------------------
-- 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.
------------------------------------------------------------------------------
--/ if TeleGen2 and then Unix then
--// procedure Xlbmt_Mem_Copy (To : System.Address;
--// From : System.Address;
--// Bytes : S_Long);
--// pragma Interface (Assembler, Xlbmt_Mem_Copy);
--// pragma Linkname (Xlbmt_Mem_Copy, "_Xlbmt_Mem_Copy");
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert a Discrete type.
------------------------------------------------------------------------------
--/ if R1000 then
procedure Convert_Discrete_To_Raw (Raw : out X_Raw_Data_Array;
Orig : Original) is
function To_Raw is
new Unchecked_Conversions.Convert_To_Byte_String (Original);
begin
Raw := To_Raw (Orig);
end Convert_Discrete_To_Raw;
--/ elsif TeleGen2 and then Unix then
--//
--// procedure Convert_Discrete_To_Raw (Raw : out X_Raw_Data_Array;
--// Orig : Original) is
--// begin
--//
--/ if DEBUG then
--// if Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Raw'Length > 0 then
--// if Original'Size < 32 then
--// declare
--// ----TeleGen2 places "small" things into "large" places on
--// -- the stack and 'Address gives you the address of the
--// -- place and not the address of the data!
--// type A_Record is
--// record
--// A : Original;
--// end record;
--// A : A_Record;
--// begin
--// A.A := Orig;
--// Xlbmt_Mem_Copy (Raw (Raw'First)'Address,
--// A.A'Address, Raw'Length);
--// end;
--// else
--// Xlbmt_Mem_Copy (Raw (Raw'First)'Address, Orig'Address,
--// Raw'Length);
--// end if;
--// end if;
--//
--// end Convert_Discrete_To_Raw;
--//
--/ else
--//
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_Discrete_To_Raw (Raw : out X_Raw_Data_Array;
--// Orig : Original) is
--// subtype Rdt is X_Raw_Data_Array (Raw'Range);
--// function To_Raw is new Unchecked_Conversion (Original, Rdt);
--// begin
--//
--/ if DEBUG then
--// if Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// Raw := To_Raw (Orig);
--//
--// end Convert_Discrete_To_Raw;
--//
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert a Private type.
------------------------------------------------------------------------------
--/ if R1000 then
procedure Convert_Private_To_Raw (Raw : out X_Raw_Data_Array;
Orig : Original) is
function To_Raw is
new Unchecked_Conversions.Convert_To_Byte_String (Original);
begin
Raw := To_Raw (Orig);
end Convert_Private_To_Raw;
--/ elsif TeleGen2 and then Unix then
--//
--// procedure Convert_Private_To_Raw (Raw : out X_Raw_Data_Array;
--// Orig : Original) is
--// begin
--//
--/ if DEBUG then
--// if Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Raw'Length > 0 then
--// Xlbmt_Mem_Copy (Raw (Raw'First)'Address, Orig'Address,
--// Raw'Length);
--// end if;
--//
--// end Convert_Private_To_Raw;
--//
--/ else
--//
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_Private_To_Raw (Raw : out X_Raw_Data_Array;
--// Orig : Original) is
--// subtype Rdt is X_Raw_Data_Array (Raw'Range);
--// function To_Raw is new Unchecked_Conversion (Original, Rdt);
--// begin
--//
--/ if DEBUG then
--// if Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// Raw := To_Raw (Orig);
--//
--// end Convert_Private_To_Raw;
--//
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert an Array type.
------------------------------------------------------------------------------
--/ if R1000 then
procedure Convert_Array_To_Raw (Raw : out X_Raw_Data_Array;
Orig : Original_Array) is
subtype Oat is Original_Array (Orig'Range);
Oad : Oat := Orig;
function To_Raw is
new Unchecked_Conversions.Convert_To_Byte_String (Oat);
begin
--/ if DEBUG then
if Orig'Length * Original'Size / X_Raw_Data'Size /= Raw'Length then
raise Constraint_Error;
end if;
--/ end if;
if Orig'Length > 0 then
Raw := To_Raw (Oad);
end if;
end Convert_Array_To_Raw;
--/ elsif TeleGen2 and then Unix then
--//
--// procedure Convert_Array_To_Raw (Raw : out X_Raw_Data_Array;
--// Orig : Original_Array) is
--// begin
--//
--/ if DEBUG then
--// if Orig'Length * Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Orig'Length > 0 then
--// Xlbmt_Mem_Copy (Raw (Raw'First)'Address,
--// Orig (Orig'First)'Address, Raw'Length);
--// end if;
--//
--// end Convert_Array_To_Raw;
--//
--/ else
--//
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_Array_To_Raw (Raw : out X_Raw_Data_Array;
--// Orig : Original_Array) is
--// subtype Rdt is X_Raw_Data_Array (Raw'Range);
--// subtype Oat is Original_Array (Orig'Range);
--// Oad : Oat := Orig;
--// function To_Raw is new Unchecked_Conversion (Oat, Rdt);
--// begin
--//
--/ if DEBUG then
--// if Orig'Length * Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// Raw := To_Raw (Oad);
--//
--// end Convert_Array_To_Raw;
--//
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert a 2-dimensional Array type.
------------------------------------------------------------------------------
--/ if Row_Major_Order then
--/ if R1000 then
procedure Convert_2d_Array_To_Raw (Raw : out X_Raw_Data_Array;
Orig : Original_Array) is
----Row_Major_Order, R1000
subtype Oat is Original_Array (Orig'Range (1), Orig'Range (2));
Oad : Oat := Orig;
function To_Raw is
new Unchecked_Conversions.Convert_To_Byte_String (Oat);
begin
--/ if DEBUG then
if Orig'Length (1) * Orig'Length (2) *
Original'Size / X_Raw_Data'Size /= Raw'Length then
raise Constraint_Error;
end if;
--/ end if;
if Raw'Length /= 0 then
Raw := To_Raw (Oad);
end if;
end Convert_2d_Array_To_Raw;
--/ elsif TeleGen2 and then Unix then
--//
--// procedure Convert_2d_Array_To_Raw (Raw : out X_Raw_Data_Array;
--// Orig : Original_Array) is
--// ----Row_Major_Order, not R1000
--// begin
--//
--/ if DEBUG then
--// if Orig'Length (1) * Orig'Length (2) *
--// Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Raw'Length /= 0 then
--// Xlbmt_Mem_Copy
--// (Raw (Raw'First)'Address,
--// Orig (Orig'First (1), Orig'First (2))'Address, Raw'Length);
--// end if;
--//
--// end Convert_2d_Array_To_Raw;
--//
--/ else
--//
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_2d_Array_To_Raw (Raw : out X_Raw_Data_Array;
--// Orig : Original_Array) is
--// ----Row_Major_Order, not R1000
--// subtype Rdt is X_Raw_Data_Array (Raw'Range);
--// subtype Oat is Original_Array (Orig'Range (1), Orig'Range (2));
--// Oad : Oat := Orig;
--// function To_Raw is new Unchecked_Conversion (Oat, Rdt);
--// begin
--//
--/ if DEBUG then
--// if Orig'Length (1) * Orig'Length (2) *
--// Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// Raw := To_Raw (Oad);
--//
--// end Convert_2d_Array_To_Raw;
--//
--/ end if;
--/ else
--//
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_2d_Array_To_Raw (Raw : out X_Raw_Data_Array;
--// Orig : Original_Array) is
--// ----Not Row_Major_Order
--// subtype Rdt is X_Raw_Data_Array (Raw'Range);
--// type Oatype2 is array (Index2 range <>, Index1 range <>) of Original;
--// subtype Oat2 is Oatype2 (Orig'Range (2), Orig'Range (1));
--// Oad : Oat2;
--// function To_Raw is new Unchecked_Conversion (Oat2, Rdt);
--// begin
--//
--/ if DEBUG then
--// if Orig'Length (1) * Orig'Length (2) *
--// Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// for I in Orig'Range (1) loop
--// for J in Orig'Range (2) loop
--// Oad (J, I) := Orig (I, J);
--// end loop;
--// end loop;
--// Raw := To_Raw (Oad);
--//
--// end Convert_2d_Array_To_Raw;
--//
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert to a Discrete type.
------------------------------------------------------------------------------
--/ if R1000 then
procedure Convert_Raw_To_Discrete
(Orig : out Original; Raw : X_Raw_Data_Array) is
function From_Raw is
new Unchecked_Conversions.Convert_From_Byte_String (Original);
begin
--/ if DEBUG then
if Original'Size / X_Raw_Data'Size /= Raw'Length then
raise Constraint_Error;
end if;
--/ end if;
Orig := From_Raw (Raw);
end Convert_Raw_To_Discrete;
--/ elsif TeleGen2 and then Unix then
--//
--// procedure Convert_Raw_To_Discrete (Orig : out Original;
--// Raw : X_Raw_Data_Array) is
--// begin
--//
--/ if DEBUG then
--// if Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Original'Size < 32 then
--// declare
--// ----TeleGen2 places "small" things into "large" places on
--// -- the stack and 'Address gives you the address of the
--// -- place and not the address of the data!
--// type A_Record is
--// record
--// A : Original;
--// end record;
--// A : A_Record;
--// begin
--// Xlbmt_Mem_Copy
--// (A.A'Address, Raw (Raw'First)'Address, Raw'Length);
--// Orig := A.A;
--// end;
--// else
--// Xlbmt_Mem_Copy (Orig'Address, Raw (Raw'First)'Address, Raw'Length);
--// end if;
--//
--// end Convert_Raw_To_Discrete;
--//
--/ else
--//
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_Raw_To_Discrete (Orig : out Original;
--// Raw : X_Raw_Data_Array) is
--// subtype Rdt is X_Raw_Data_Array (Raw'Range);
--// function From_Raw is new Unchecked_Conversion (Rdt, Original);
--// begin
--//
--/ if DEBUG then
--// if Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// Orig := From_Raw (Raw);
--//
--// end Convert_Raw_To_Discrete;
--//
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert to a Private type.
------------------------------------------------------------------------------
--/ if R1000 then
procedure Convert_Raw_To_Private (Orig : out Original;
Raw : X_Raw_Data_Array) is
function From_Raw is
new Unchecked_Conversions.Convert_From_Byte_String (Original);
begin
--/ if DEBUG then
if Original'Size / X_Raw_Data'Size /= Raw'Length then
raise Constraint_Error;
end if;
--/ end if;
Orig := From_Raw (Raw);
end Convert_Raw_To_Private;
--/ elsif TeleGen2 and then Unix then
--//
--// procedure Convert_Raw_To_Private (Orig : out Original;
--// Raw : X_Raw_Data_Array) is
--// begin
--//
--/ if DEBUG then
--// if Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Raw'Length > 0 then
--// Xlbmt_Mem_Copy (Orig'Address, Raw (Raw'First)'Address, Raw'Length);
--// end if;
--//
--// end Convert_Raw_To_Private;
--//
--/ else
--//
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_Raw_To_Private (Orig : out Original;
--// Raw : X_Raw_Data_Array) is
--// subtype Rdt is X_Raw_Data_Array (Raw'Range);
--// function From_Raw is new Unchecked_Conversion (Rdt, Original);
--// begin
--//
--/ if DEBUG then
--// if Original'Size / X_Raw_Data'Size /= Raw'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// Orig := From_Raw (Raw);
--//
--// end Convert_Raw_To_Private;
--//
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert to an Array type.
------------------------------------------------------------------------------
--/ if R1000 then
procedure Convert_Raw_To_Array (Orig : out Original_Array;
Raw : X_Raw_Data_Array) is
begin
----The lengths must correspond.
--/ if DEBUG then
if Raw'Length /= Orig'Length * Original'Size / X_Raw_Data'Size then
raise Constraint_Error;
end if;
--/ end if;
----If the length is non-zero then create a subtype with the correct indices
-- so that the R1000 architecture will store the index values in the subtype
-- descriptor and not in the data area. Then instantiate a new From_Raw
-- using that subtype. Then convert and return the result.
if Raw'Length > 0 then
declare
subtype Oat is Original_Array (Orig'Range);
function From_Raw is new Unchecked_Conversions.
Convert_From_Byte_String (Oat);
begin
Orig := From_Raw (Raw);
end;
end if;
end Convert_Raw_To_Array;
--/ elsif TeleGen2 and then Unix then
--//
--// procedure Convert_Raw_To_Array
--// (Orig : out Original_Array; Raw : X_Raw_Data_Array) is
--// begin
--//
--/ if DEBUG then
--// if Raw'Length /= Orig'Length * Original'Size / X_Raw_Data'Size then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Raw'Length > 0 then
--// Xlbmt_Mem_Copy (Orig (Orig'First)'Address,
--// Raw (Raw'First)'Address, Raw'Length);
--// end if;
--//
--// end Convert_Raw_To_Array;
--//
--/ else
--//
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_Raw_To_Array (Orig : out Original_Array;
--// Raw : X_Raw_Data_Array) is
--// begin
--//
--// ----The lengths must correspond
--//
--/ if DEBUG then
--// if Raw'Length /= Orig'Length * Original'Size / X_Raw_Data'Size then
--// raise Constraint_Error;
--// end if;
--/ end if;
--//
--// ----If the length is non-zero then create a subtype with the correct indices
--// -- so that the R1000 architecture will store the index values in the subtype
--// -- descriptor and not in the data area. Then instantiate a new From_Raw
--// -- using that subtype. Then convert and return the result.
--//
--// if Raw'Length > 0 then
--// declare
--// type Rdt is new X_Raw_Data_Array (Raw'Range);
--// type Oat is new Original_Array (Orig'Range);
--// function From_Raw is new Unchecked_Conversion (Rdt, Oat);
--// begin
--// Orig := Original_Array (From_Raw (Rdt (Raw)));
--// end;
--// end if;
--//
--// end Convert_Raw_To_Array;
--//
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert to a 2-dimensional Array type.
------------------------------------------------------------------------------
--/ if Row_Major_Order then
--/ if R1000 then
procedure Convert_Raw_To_2d_Array (Orig : out Original_Array;
Raw : X_Raw_Data_Array) is
begin
----The array lengths must correspond.
--/ if DEBUG then
if Raw'Length /= Orig'Length (1) * Orig'Length (2) *
Original'Size / X_Raw_Data'Size then
raise Constraint_Error;
end if;
--/ end if;
----If the length is non-zero then create a subtype with the correct indices
-- so that the R1000 architecture will store the index values in the subtype
-- descriptor and not in the data area. Then instantiate a new From_Raw
-- using that subtype. Then convert and return the result.
if Raw'Length > 0 then
declare
subtype Oat is Original_Array (Orig'Range (1), Orig'Range (2));
function From_Raw is new Unchecked_Conversions.
Convert_From_Byte_String (Oat);
begin
Orig := From_Raw (Raw);
end;
end if;
end Convert_Raw_To_2d_Array;
--/ elsif TeleGen2 and then Unix then
--//
--// procedure Convert_Raw_To_2d_Array
--// (Orig : out Original_Array; Raw : X_Raw_Data_Array) is
--// begin
--//
--/ if DEBUG then
--// if Raw'Length /= Orig'Length (1) * Orig'Length (2) *
--// Original'Size / X_Raw_Data'Size then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Raw'Length > 0 then
--// Xlbmt_Mem_Copy (Orig (Orig'First (1), Orig'First (2))'Address,
--// Raw (Raw'First)'Address, Raw'Length);
--// end if;
--//
--// end Convert_Raw_To_2d_Array;
--//
--/ else
--//
--// ----Row_Major_Order, Not R1000
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_Raw_To_2d_Array (Orig : out Original_Array;
--// Raw : X_Raw_Data_Array) is
--// begin
--//
--// ----Check size constraints.
--//
--/ if DEBUG then
--// if Raw'Length /= Orig'Length (1) * Orig'Length (2) *
--// Original'Size / X_Raw_Data'Size then
--// raise Constraint_Error;
--// end if;
--/ end if;
--//
--// ----If there is no data then just return.
--//
--// if Raw'Length = 0 then
--// return;
--//
--// ----If the length is non-zero then create a subtype with the correct indices
--// -- so that the R1000 architecture will store the index values in the subtype
--// -- descriptor and not in the data area. Then instantiate a new From_Raw
--// -- using that subtype. Then convert and return the result.
--//
--// else
--// declare
--// subtype Oat is Original_Array (Orig'Range (1), Orig'Range (2));
--// subtype Rdt is X_Raw_Data_Array (Raw'Range);
--// function From_Raw is new Unchecked_Conversion (Rdt, Oat);
--// begin
--// Orig := From_Raw (Raw);
--// end;
--// end if;
--//
--// end Convert_Raw_To_2d_Array;
--//
--/ end if;
--/ else
--//
--// ----Note: This is "generic" code for any Ada compiler;
--// -- it may not work for you. Do not modify this code. Copy it into
--// -- a new ELSE arm aimed at your particular taget. It *does* work for
--// -- some targets.
--//
--// procedure Convert_Raw_To_2d_Array (Orig : out Original_Array;
--// Raw : X_Raw_Data_Array) is
--// begin
--//
--// ----Check size constraints.
--//
--/ if DEBUG then
--// if Raw'Length /= Orig'Length (1) * Orig'Length (2) *
--// Original'Size / X_Raw_Data'Size then
--// raise Constraint_Error;
--// end if;
--/ end if;
--//
--// ----If there is no data then just return.
--//
--// if Raw'Length = 0 then
--// return;
--//
--// ----If the length is non-zero then create a subtype with the correct indices
--// -- so that the R1000 architecture will store the index values in the subtype
--// -- descriptor and not in the data area. Then instantiate a new From_Raw
--// -- using that subtype. Then convert and return the result.
--//
--// else
--// declare
--// subtype Rdt is X_Raw_Data_Array (1 .. Len);
--// type Oatype2 is
--// array (Index2 range <>, Index1 range <>) of Original;
--// subtype Oat2 is Oatype2 (Orig'Range (2), Orig'Range (1));
--// D2 : Oat2;
--// function From_Raw is new Unchecked_Conversion (Rdt, Oat2);
--// begin
--// D2 := From_Raw (Orig);
--// for I in D2'Range (1) loop
--// for J in D2'Range (2) loop
--// Orig (J, I) := D2 (I, J);
--// end loop;
--// end loop;
--// end;
--// end if;
--//
--// end Convert_Raw_To_2d_Array;
--//
--/ end if;
--\f
end Xlbmp_Generic_Converters;