|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 12288 (0x3000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, generic, procedure Rm_020, seg_00560f
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Test_Io;
use Test_Io;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Rm3;
use Xlbt_Rm3;
with Xlbt_String;
use Xlbt_String;
with Xlbp_Rm_Name;
use Xlbp_Rm_Name;
with Xlbit_Library3;
use Xlbit_Library3;
with Xlbmp_Debugger;
procedure Rm_020 is
------------------------------------------------------------------------------
-- Tests for Xlbp_Rm_Name.
------------------------------------------------------------------------------
-- 07/05/90 GEB | Created.
------------------------------------------------------------------------------
function Class_Id (C : X_Rm_Class) return S_Long is
begin
return C.Id;
end Class_Id;
function Name_Id (N : X_Rm_Name) return S_Long is
begin
return N.Id;
end Name_Id;
function Representation_Id (R : X_Rm_Representation) return S_Long is
begin
return R.Id;
end Representation_Id;
generic
What : String;
type Quark is private;
None : Quark;
type Quark_Array is array (S_Natural range <>) of Quark;
with function To_Quark (Name : X_String;
Validate : Boolean) return Quark;
with function To_String (Q : Quark) return X_String;
with procedure To_Ql (List : X_String; Ql : out Quark_Array);
with procedure To_Bql (List : X_String;
Bl : out X_Rm_Binding_Array;
Ql : out Quark_Array);
with function Unique return Quark;
with function To_Id (Q : Quark) return S_Long;
procedure Test_One_Type;
procedure Test_One_Type is
Quark1 : Quark;
Quark_List : Quark_Array (1 .. 10);
Bind_List : X_Rm_Binding_Array (1 .. 10);
procedure Qts (Name : X_String) is
------------------------------------------------------------------------------
-- Name - Specifies the name to use for the test
--
-- Called to turn a name into a Quark and then the Quark back into a string.
-- Print out the results so we can have a log of what happens.
------------------------------------------------------------------------------
begin
Quark1 := To_Quark (Name, False);
Put ("Named " & What & " ");
Putx ('"' & Name & '"');
Put (' ');
Set_Col (31);
Put (To_Id (Quark1));
Put (" => ");
Putx ('"' & To_String (Quark1) & '"');
New_Line;
end Qts;
procedure Qtl (List : X_String) is
------------------------------------------------------------------------------
-- List - Specifies a name/Quarks-list to use
--
-- Called to turn a list of names into a list of Quarks. We print out the
-- list and the resultant list so that we have a log of what happens.
------------------------------------------------------------------------------
begin
Put (What & "-List := ");
Putx ('"' & List & '"');
New_Line;
To_Ql (List, Quark_List);
Put ("Result =>");
New_Line;
for I in Quark_List'Range loop
if Quark_List (I) = None then
exit;
end if;
Put (" ");
Put (I);
Put (' ');
Putx ('"' & To_String (Quark_List (I)) & '"');
New_Line;
end loop;
New_Line;
end Qtl;
procedure Qtbl (List : X_String) is
------------------------------------------------------------------------------
-- List - Specifies a name/Quark-list to use
--
-- Called to turn a list of names into a list of Quarks. We print out the
-- list and the resultant list so that we have a log of what happens.
------------------------------------------------------------------------------
begin
Put (What & "-List := ");
Putx ('"' & List & '"');
New_Line;
To_Bql (List, Bind_List, Quark_List);
Put ("Result =>");
New_Line;
for I in Quark_List'Range loop
if Quark_List (I) = None then
exit;
end if;
Put (" ");
Put (I);
Put (' ');
Put (X_Rm_Binding'Image (Bind_List (I)));
Put (' ');
Putx ('"' & To_String (Quark_List (I)) & '"');
New_Line;
end loop;
New_Line;
end Qtbl;
begin
----Call X_Rm_Unique_Quark a few times and make sure that each one results
-- in a new value.
Section ("Unique_" & What);
for I in 1 .. 5 loop
Quark1 := Unique;
Put ("Unique " & What & " ");
Put (To_Id (Quark1));
Put (" => ");
Putx ('"' & To_String (Quark1) & '"');
New_Line;
end loop;
----See if we can turn strings into Quark and back again.
Section ("To/From_String");
Qts ("QOne");
Qts ("RTwo");
Qts ("SThree");
Qts ("TFour");
Qts ("UAnd-A-Long-String");
Qts ("VSomething_Else");
Qts ("Wsomething_else");
----See if we can turn those same strings into the same Quark all over again.
Section ("To/From_Old_String");
Qts ("QOne");
Qts ("RTwo");
Qts ("SThree");
Qts ("TFour");
Qts ("UAnd-A-Long-String");
Qts ("VSomething_Else");
Qts ("Wsomething_else");
----See if we can successfully parse some Quark lists.
Section ("Simple " & What & " lists");
Qtl ("QOne");
Qtl ("RTwo.");
Qtl ("SThree.TFour");
Qtl ("TFour.SThree.QOne.RTwo.VSomething_Else");
Qtl ("UA.UB.UC.UD.UE.UF.UG");
----Try those same lists a Binding-Quark lists
Section ("Tight " & What & "/Binding lists");
Qtbl ("QOne");
Qtbl ("RTwo.");
Qtbl ("SThree.TFour");
Qtbl ("TFour.SThree.QOne.RTwo.VSomething_Else");
Qtbl ("UA.UB.UC.UD.UE.UF.UG");
----Try those same lists a Binding-Quark lists and add some different bindings
Section ("Mixed " & What & "/Binding lists");
Qtbl ("QOne");
Qtbl ("*QOne");
Qtbl (".QOne");
Qtbl ("RTwo.");
Qtbl ("RTwo*");
Qtbl ("SThree.TFour");
Qtbl ("SThree*TFour");
Qtbl ("TFour.SThree.QOne.RTwo.VSomething_Else");
Qtbl ("*TFour.SThree*QOne.RTwo*VSomething_Else");
Qtbl ("UA*UB*UC*UD.UE.UF.UG");
end Test_One_Type;
procedure Class_Test is
new Test_One_Type
(What => "Class",
Quark => X_Rm_Class,
None => None_X_Rm_Class,
Quark_Array => X_Rm_Class_Array,
To_Quark => X_Rm_String_To_Class,
To_String => X_Rm_Class_To_String,
To_Ql => X_Rm_String_To_Class_List,
To_Bql => X_Rm_String_To_Binding_Class_List,
Unique => X_Rm_Unique_Class,
To_Id => Class_Id);
procedure Name_Test is
new Test_One_Type
(What => "Name",
Quark => X_Rm_Name,
None => None_X_Rm_Name,
Quark_Array => X_Rm_Name_Array,
To_Quark => X_Rm_String_To_Name,
To_String => X_Rm_Name_To_String,
To_Ql => X_Rm_String_To_Name_List,
To_Bql => X_Rm_String_To_Binding_Name_List,
Unique => X_Rm_Unique_Name,
To_Id => Name_Id);
procedure Representation_Test is
new Test_One_Type
(What => "Representation",
Quark => X_Rm_Representation,
None => None_X_Rm_Representation,
Quark_Array => X_Rm_Representation_Array,
To_Quark => X_Rm_String_To_Representation,
To_String => X_Rm_Representation_To_String,
To_Ql => X_Rm_String_To_Representation_List,
To_Bql => X_Rm_String_To_Binding_Representation_List,
Unique => X_Rm_Unique_Representation,
To_Id => Representation_Id);
begin
----Set up for debugging.
Xlbmp_Debugger.Register_Debugging_Imagers;
-- Empty the quark map in case we're run after Rm_010.
declare
Quark_Map : X_Rm_Quark_Map.Map;
begin
X_Lib.Seize_Quark_Map (Quark_Map);
X_Rm_Quark_Map.New_Map (Quark_Map);
X_Lib.Release_Quark_Map (Quark_Map);
end;
X_Lib.Set_Next_Quark (Quark => (Id => 2000));
-- Force testing to begin with a known state.
-- Applications that do this are committing
-- suicide.
----Perform tests.
Class_Test;
Name_Test;
Representation_Test;
end Rm_020;
nblk1=b
nid=0
hdr6=16
[0x00] rec0=2a rec1=00 rec2=01 rec3=008
[0x01] rec0=16 rec1=00 rec2=02 rec3=02c
[0x02] rec0=01 rec1=00 rec2=0b rec3=060
[0x03] rec0=19 rec1=00 rec2=03 rec3=06e
[0x04] rec0=1d rec1=00 rec2=04 rec3=00e
[0x05] rec0=1d rec1=00 rec2=05 rec3=026
[0x06] rec0=22 rec1=00 rec2=06 rec3=01e
[0x07] rec0=1d rec1=00 rec2=07 rec3=01c
[0x08] rec0=18 rec1=00 rec2=08 rec3=068
[0x09] rec0=18 rec1=00 rec2=09 rec3=004
[0x0a] rec0=17 rec1=00 rec2=0a rec3=001
tail 0x21500a35681978d16c9d7 0x42a00088462063203