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: ┃ B T

⟦9af5acdef⟧ TextFile

    Length: 20100 (0x4e84)
    Types: TextFile
    Names: »B«

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 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;