|
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: 20100 (0x4e84)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
--/ if TeleGen2 and then Unix then
--// with System;
--/ else
with Unchecked_Conversion;
--/ end if;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
package body Xlbp_U_Char_Generics is
------------------------------------------------------------------------------
-- X Library Machine Conversions
--
-- Xlbp_U_Char_Generics - Machine/Compiler dependent conversions to/from
-- system data types.
------------------------------------------------------------------------------
-- Copyright 1990 - 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 TeleGen2 and then Unix then
--//
--// procedure Convert_Discrete_To_Uca (Uca : out U_Char_Array;
--// Orig : Original) is
--// begin
--//
--/ if DEBUG then
--// if Original'Size / U_Char'Size /= Uca'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Uca'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 (Uca (Uca'First)'Address,
--// A.A'Address, Uca'Length);
--// end;
--// else
--// Xlbmt_Mem_Copy (Uca (Uca'First)'Address, Orig'Address,
--// Uca'Length);
--// end if;
--// end if;
--//
--// end Convert_Discrete_To_Uca;
--//
--/ 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_Uca (Uca : out U_Char_Array;
Orig : Original) is
subtype Rdt is U_Char_Array (Uca'Range);
function To_Uca is new Unchecked_Conversion (Original, Rdt);
begin
--/ if DEBUG then
if Original'Size / U_Char'Size /= Uca'Length then
raise Constraint_Error;
end if;
--/ end if;
Uca := To_Uca (Orig);
end Convert_Discrete_To_Uca;
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert a Private type.
------------------------------------------------------------------------------
--/ if TeleGen2 and then Unix then
--//
--// procedure Convert_Private_To_Uca (Uca : out U_Char_Array;
--// Orig : Original) is
--// begin
--//
--/ if DEBUG then
--// if Original'Size / U_Char'Size /= Uca'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Uca'Length > 0 then
--// Xlbmt_Mem_Copy (Uca (Uca'First)'Address, Orig'Address, Uca'Length);
--// end if;
--//
--// end Convert_Private_To_Uca;
--//
--/ 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_Uca (Uca : out U_Char_Array;
Orig : Original) is
subtype Rdt is U_Char_Array (Uca'Range);
function To_Uca is new Unchecked_Conversion (Original, Rdt);
begin
--/ if DEBUG then
if Original'Size / U_Char'Size /= Uca'Length then
raise Constraint_Error;
end if;
--/ end if;
Uca := To_Uca (Orig);
end Convert_Private_To_Uca;
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert an Array type.
------------------------------------------------------------------------------
--/ if TeleGen2 and then Unix then
--//
--// procedure Convert_Array_To_Uca (Uca : out U_Char_Array;
--// Orig : Original_Array) is
--// begin
--//
--/ if DEBUG then
--// if Orig'Length * Original'Size / U_Char'Size /= Uca'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Uca'Length > 0 then
--// Xlbmt_Mem_Copy (Uca (Uca'First)'Address,
--// Orig (Orig'First)'Address, Uca'Length);
--// end if;
--//
--// end Convert_Array_To_Uca;
--//
--/ 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_Uca (Uca : out U_Char_Array;
Orig : Original_Array) is
subtype Rdt is U_Char_Array (Uca'Range);
subtype Oat is Original_Array (Orig'Range);
Oad : Oat := Orig;
function To_Uca is new Unchecked_Conversion (Oat, Rdt);
begin
--/ if DEBUG then
if Orig'Length * Original'Size / U_Char'Size /= Uca'Length then
raise Constraint_Error;
end if;
--/ end if;
Uca := To_Uca (Oad);
end Convert_Array_To_Uca;
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert a 2-dimensional Array type.
------------------------------------------------------------------------------
--/ if Row_Major_Order then
--/ if TeleGen2 and then Unix then
--//
--// procedure Convert_2d_Array_To_Uca (Uca : out U_Char_Array;
--// Orig : Original_Array) is
--// begin
--//
--/ if DEBUG then
--// if Orig'Length (1) * Orig'Length (2) * Original'Size / U_Char'Size /=
--// Uca'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Uca'Length > 0 then
--// Xlbmt_Mem_Copy
--// (Uca (Uca'First)'Address,
--// Orig (Orig'First (1), Orig'First (2))'Address, Uca'Length);
--// end if;
--// end Convert_2d_Array_To_Uca;
--//
--/ 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_Uca (Uca : out U_Char_Array;
Orig : Original_Array) is
subtype Rdt is U_Char_Array (Uca'Range);
subtype Oat is Original_Array (Orig'Range (1), Orig'Range (2));
Oad : Oat := Orig;
function To_Uca is new Unchecked_Conversion (Oat, Rdt);
begin
--/ if DEBUG then
if Orig'Length (1) * Orig'Length (2) * Original'Size / U_Char'Size /=
Uca'Length then
raise Constraint_Error;
end if;
--/ end if;
Uca := To_Uca (Oad);
end Convert_2d_Array_To_Uca;
--/ 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_Uca (Uca : out U_Char_Array;
--// Orig : Original_Array) is
--// ----Not Row_Major_Order
--// subtype Rdt is U_Char_Array (Uca'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_Uca is new Unchecked_Conversion (Oat2, Rdt);
--// begin
--//
--/ if DEBUG then
--// if Orig'Length (1) * Orig'Length (2) * Original'Size / U_Char'Size /=
--// Uca'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;
--// Uca := To_Uca (Oad);
--//
--// end Convert_2d_Array_To_Uca;
--//
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert to a Discrete type.
------------------------------------------------------------------------------
--/ if TeleGen2 and then Unix then
--//
--// procedure Convert_Uca_To_Discrete (Orig : out Original;
--// Uca : U_Char_Array) is
--// begin
--//
--/ if DEBUG then
--// if Original'Size / U_Char'Size /= Uca'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, Uca (Uca'First)'Address, Uca'Length);
--// Orig := A.A;
--// end;
--// elsif Uca'Length > 0 then
--// Xlbmt_Mem_Copy (Orig'Address, Uca (Uca'First)'Address, Uca'Length);
--// end if;
--//
--// end Convert_Uca_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_Uca_To_Discrete (Orig : out Original;
Uca : U_Char_Array) is
subtype Rdt is U_Char_Array (Uca'Range);
Rda : Rdt := Uca;
function From_Uca is new Unchecked_Conversion (Rdt, Original);
begin
--/ if DEBUG then
if Original'Size / U_Char'Size /= Uca'Length then
raise Constraint_Error;
end if;
--/ end if;
Orig := From_Uca (Rda);
end Convert_Uca_To_Discrete;
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert to a Private type.
------------------------------------------------------------------------------
--/ if TeleGen2 and then Unix then
--//
--// procedure Convert_Uca_To_Private (Orig : out Original;
--// Uca : U_Char_Array) is
--// begin
--//
--/ if DEBUG then
--// if Original'Size / U_Char'Size /= Uca'Length then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Uca'Length > 0 then
--// Xlbmt_Mem_Copy (Orig'Address, Uca (Uca'First)'Address, Uca'Length);
--// end if;
--//
--// end Convert_Uca_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_Uca_To_Private (Orig : out Original;
Uca : U_Char_Array) is
subtype Rdt is U_Char_Array (Uca'Range);
Rda : Rdt := Uca;
function From_Uca is new Unchecked_Conversion (Rdt, Original);
begin
--/ if DEBUG then
if Original'Size / U_Char'Size /= Uca'Length then
raise Constraint_Error;
end if;
--/ end if;
Orig := From_Uca (Rda);
end Convert_Uca_To_Private;
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert to an Array type.
------------------------------------------------------------------------------
--/ if TeleGen2 and then Unix then
--//
--// procedure Convert_Uca_To_Array (Orig : out Original_Array;
--// Uca : U_Char_Array) is
--// begin
--//
--/ if DEBUG then
--// if Uca'Length /= Orig'Length * Original'Size / U_Char'Size then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Uca'Length > 0 then
--// Xlbmt_Mem_Copy (Orig (Orig'First)'Address,
--// Uca (Uca'First)'Address, Uca'Length);
--// end if;
--//
--// end Convert_Uca_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_Uca_To_Array (Orig : out Original_Array;
Uca : U_Char_Array) is
begin
----The array lengths must correspond.
--/ if DEBUG then
if Uca'Length /= Orig'Length * Original'Size / U_Char'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_Uca
-- using that subtype. Then convert and return the result.
if Orig'Length > 0 then
declare
subtype Rdt is U_Char_Array (Uca'Range);
subtype Oat is Original_Array (Orig'Range);
Rda : Rdt := Uca;
function From_Uca is new Unchecked_Conversion (Rdt, Oat);
begin
Orig := From_Uca (Rda);
end;
end if;
end Convert_Uca_To_Array;
--/ end if;
--\f
------------------------------------------------------------------------------
-- Convert to a 2-dimensional Array type.
------------------------------------------------------------------------------
--/ if Row_Major_Order then
--/ if TeleGen2 and then Unix then
--//
--// procedure Convert_Uca_To_2d_Array (Orig : out Original_Array;
--// Uca : U_Char_Array) is
--// begin
--//
--/ if DEBUG then
--// if Uca'Length /= Orig'Length (1) * Orig'Length (2) *
--// Original'Size / U_Char'Size then
--// raise Constraint_Error;
--// end if;
--/ end if;
--// if Uca'Length > 0 then
--// Xlbmt_Mem_Copy (Orig (Orig'First (1), Orig'First (2))'Address,
--// Uca (Uca'First)'Address, Uca'Length);
--// end if;
--//
--// end Convert_Uca_To_2d_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_Uca_To_2d_Array (Orig : out Original_Array;
Uca : U_Char_Array) is
begin
----The array lengths must correspond.
--/ if DEBUG then
if Uca'Length /= Orig'Length (1) * Orig'Length (2) *
Original'Size / U_Char'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_Uca
-- using that subtype. Then convert and return the result.
if Uca'Length /= 0 then
declare
subtype Rdt is U_Char_Array (Uca'Range);
subtype Oat is Original_Array (Orig'Range (1), Orig'Range (2));
Rda : Rdt := Uca;
function From_Uca is new Unchecked_Conversion (Rdt, Oat);
begin
Orig := From_Uca (Rda);
end;
end if;
end Convert_Uca_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_Uca_To_2d_Array (Orig : out Original_Array;
--// Uca : U_Char_Array) is
--// begin
--//
--// ----The array lengths must correspond.
--//
--/ if DEBUG then
--// if Uca'Length /= Orig'Length (1) * Orig'Length (2) *
--// Original'Size / U_Char'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_Uca
--// -- using that subtype. Then convert and return the result.
--//
--// if Uca'Length /= 0 then
--// declare
--// subtype Rdt is U_Char_Array (Uca'Range);
--// type Oatype2 is
--// array (Index2 range <>, Index1 range <>) of Original;
--// subtype Oat2 is Oattype2 (Orig'Range (2), Orig'Range (1));
--// D2 : Oat2;
--// function From_Uca is new Unchecked_Conversion (Rdt, Oat2);
--// begin
--// D2 := From_Uca (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_Uca_To_2d_Array;
--//
--/ end if;
--\f
end Xlbp_U_Char_Generics;