|
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: 19456 (0x4c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, procedure Rm_060, seg_005621
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Test_Io;
with Rm_Test_Utilities;
with Xlbt_Display3;
use Xlbt_Display3;
with Xlbt_Rm3;
use Xlbt_Rm3;
with Xlbt_String;
use Xlbt_String;
with Xlbp_Rm;
use Xlbp_Rm;
procedure Rm_060 is
------------------------------------------------------------------------------
-- Tests for Xlbp_Rm - Precedence order tests.
------------------------------------------------------------------------------
-- *****************************************************************************
-- * Date - /Name/ Comment
-- *
-- * 29-OCT-90 - /DRK/ Created.
-- * 19-NOV-90 - /GEB/ New RM error returns.
-- *****************************************************************************
---------------
-- Utilities --
---------------
procedure Check (Condition : Boolean; Message : String; Section : String) is
-- Check a condition. If it doesn't hold, print error messages.
begin
if not Condition then
Test_Io.Put_Line (Message);
Test_Io.Put_Error ("Section " & Section & " test failed.");
end if;
end Check;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Check (Error : X_Rm_Status; Section : String) is
-- Check that no errors were reported.
begin
Check (Error = Rm_Successful, "RM error", Section);
end Check;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Add (Db : in out X_Rm_Database;
Line : X_String;
Section : String) is
-- Add an entry to a database.
Error : X_Rm_Status;
begin
Test_Io.Put_Line ("Adding """ & To_String (Line) & '"');
X_Rm_Add_Resource (Db, Line, Error);
Check (Error, Section);
end Add;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Get (Db : X_Rm_Database;
Names : X_String;
Classes : X_String;
Expect : X_String := "";
Section : String) is
-- Lookup an entry in the database.
Rep : X_Rm_Representation;
Val : X_Rm_Value;
begin
Test_Io.Putx ("(""" & Names & """, """ & Classes & """) => ");
X_Rm_Get_Resource (Db, Names, Classes, Rep, Val);
Test_Io.Put_Line (Rm_Test_Utilities.Image (Val));
if (Expect = "") then
Check (Val = None_X_Rm_Value, "Expected: no entry", Section);
else
Check (Val /= None_X_Rm_Value and then
Val.Kind = Is_X_String_Pointer and then
Val.V_X_String_Pointer.all = Expect,
"Expected: """ & To_String (Expect) & '"', Section);
end if;
end Get;
----------------------------------------------------------------------
-------------------------
-- Major test sections --
-------------------------
procedure Test_Rule_1 is
Section : constant String := "Rule_1";
Db : X_Rm_Database := None_X_Rm_Database;
begin
Test_Io.Section (Section & ": " &
"The attribute of the name and class must match.");
Add (Db, "rule_1.foo: true", Section);
Get (Db, ".rule_1.bar", ".Rule_1.Bar", "", Section);
Free_X_Rm_Database (Db);
Test_Io.New_Line;
exception
when others =>
Check (False, "Unhandled exception", Section);
raise;
end Test_Rule_1;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Test_Rule_2 is
Section : constant String := "Rule_2";
Db : X_Rm_Database := None_X_Rm_Database;
begin
Test_Io.Section (Section & ": " &
"Tight bindings override loose bindings.");
Add (Db, "rule_2.-2-: tight", Section);
Add (Db, "rule_2*-2-: loose", Section);
Add (Db, "*-2-: very_loose", Section);
Get (Db, "rule_2.-2-", "Rule_2.-2-", "tight", Section);
Free_X_Rm_Database (Db);
Test_Io.New_Line;
exception
when others =>
Check (False, "Unhandled exception", Section);
raise;
end Test_Rule_2;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Test_Rule_3 is
Section : constant String := "Rule_3";
Db : X_Rm_Database := None_X_Rm_Database;
begin
Test_Io.Section (Section & ": " & "Names override classes.");
Add (Db, "*rule_3.foo: name", Section);
Add (Db, "*Rule_3.Foo: class", Section);
Get (Db, "rule_3.foo", "Rule_3.Foo", "name", Section);
Free_X_Rm_Database (Db);
Test_Io.New_Line;
exception
when others =>
Check (False, "Unhandled exception", Section);
raise;
end Test_Rule_3;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Test_Rule_4 is
Section : constant String := "Rule_4";
Db : X_Rm_Database := None_X_Rm_Database;
begin
Test_Io.Section (Section & ": " &
"Explicit attributes override implicit ones.");
Add (Db, "rule_4*foo*bar: qualified", Section);
Add (Db, "rule_4*bar: unqualified", Section);
Get (Db, "rule_4.foo.bar", "Rule_4.Foo.Bar", "qualified", Section);
Free_X_Rm_Database (Db);
Test_Io.New_Line;
exception
when others =>
Check (False, "Unhandled exception", Section);
raise;
end Test_Rule_4;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Test_Rule_5 is
Section : constant String := "Rule_5";
Db : X_Rm_Database := None_X_Rm_Database;
begin
Test_Io.Section (Section & ": " &
"Left components override right components.");
Add (Db, "*foo*rule_5: foo", Section);
Add (Db, "*bar*rule_5: bar", Section);
Get (Db, ".foo.bar.rule_5", "Foo.Bar.Rule_5", "foo", Section);
Free_X_Rm_Database (Db);
Test_Io.New_Line;
exception
when others =>
Check (False, "Unhandled exception", Section);
raise;
end Test_Rule_5;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Test_Rule_6 is
Section : constant String := "Rule_6";
Db : X_Rm_Database := None_X_Rm_Database;
begin
Test_Io.Section (Section & ": " &
"Tight binding is implicit for the first component.");
Add (Db, "rule_6: foo", Section);
Add (Db, "*rule_6: bar", Section);
Get (Db, ".rule_6", ".Rule_6", "foo", Section);
Free_X_Rm_Database (Db);
Test_Io.New_Line;
exception
when others =>
Check (False, "Unhandled exception", Section);
raise;
end Test_Rule_6;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Test_Mixed_Attributes is
Section : constant String := "Mixed_Attributes";
Db : X_Rm_Database := None_X_Rm_Database;
begin
Test_Io.Section (Section & ": " & "Names and classes may be mixed.");
Add (Db, "xmh*bg: red", Section);
Add (Db, "*cmd.font: 8x13", Section);
Add (Db, "*cmd.bg: blue", Section);
Add (Db, "*Cmd.Fg: green", Section);
Add (Db, "xmh.toc*Cmd.aFg: black", Section);
Get (Db, ".xmh.toc.msgf.incl.aFg",
".Xmh.VPaned.Box.Cmd.Fg", "black", Section);
Free_X_Rm_Database (Db);
Test_Io.New_Line;
exception
when others =>
Check (False, "Unhandled exception", Section);
raise;
end Test_Mixed_Attributes;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Test_Precedence is
Section : constant String := "Precedence";
Db : X_Rm_Database := None_X_Rm_Database;
begin
Test_Io.Section (Section & ": " &
"The lowest numbered rule wins conflicts.");
-- Rule 1 vs. everything.
-- We'll take this for granted.
-- Rule 2 vs. 3.
Add (Db, ".a.B: Rule 2 vs. 3", Section);
Add (Db, "*a.b: Rule 3 vs. 2", Section);
Get (Db, ".a.b", ".A.B", "Rule 2 vs. 3", Section);
Test_Io.New_Line;
-- Rule 2 vs. 4.
Free_X_Rm_Database (Db);
Add (Db, ".a*c: Rule 2 vs. 4", Section);
Add (Db, "*a.b.c: Rule 4 vs. 2", Section);
Get (Db, ".a.b.c", ".A.B.C", "Rule 2 vs. 4", Section);
Test_Io.New_Line;
-- Rule 2 vs. 5.
Free_X_Rm_Database (Db);
Add (Db, ".a*c*d: Rule 2 vs. 5", Section);
Add (Db, "*a*b*d: Rule 5 vs. 2", Section);
Get (Db, ".a.b.c.d", ".A.B.C.D", "Rule 2 vs. 5", Section);
Test_Io.New_Line;
-- Rule 2 vs. 6.
-- How can this be tested? Rule 6 is a really a parsing rule,
-- not a precedence rule.
-- Rule 3 vs. 4.
Free_X_Rm_Database (Db);
Add (Db, "a*c: Rule 3 vs. 4", Section);
Add (Db, "A.B.C: Rule 4 vs. 3", Section);
Get (Db, ".a.b.c", ".A.B.C", "Rule 3 vs. 4", Section);
Test_Io.New_Line;
-- Rule 3 vs. 5.
Free_X_Rm_Database (Db);
Add (Db, "a*c*d: Rule 3 vs. 5", Section);
Add (Db, "A*b*d: Rule 5 vs. 3", Section);
Get (Db, ".a.b.c.d", ".A.B.C.D", "Rule 3 vs. 5", Section);
Test_Io.New_Line;
-- Rule 3 vs. 6: see 2 vs. 3 above.
-- Rule 4 vs. 5.
Free_X_Rm_Database (Db);
Add (Db, "a*c*d: Rule 4 vs. 5", Section);
Add (Db, "*b*d: Rule 5 vs. 4", Section);
Get (Db, ".a.b.c.d", ".A.B.C.D", "Rule 4 vs. 5", Section);
Test_Io.New_Line;
-- Rule 4 vs. 6: see 2 vs. 4 above.
-- Rule 5 vs. 6: see 2 vs. 5 above.
Free_X_Rm_Database (Db);
exception
when others =>
Check (False, "Unhandled exception", Section);
raise;
end Test_Precedence;
begin
-- Simple rule tests
Test_Rule_1;
Test_Rule_2;
Test_Rule_3;
Test_Rule_4;
Test_Rule_5;
Test_Rule_6;
-- Slightly more complex tests
Test_Mixed_Attributes;
Test_Precedence;
end Rm_060;
nblk1=12
nid=0
hdr6=24
[0x00] rec0=22 rec1=00 rec2=01 rec3=008
[0x01] rec0=1a rec1=00 rec2=02 rec3=094
[0x02] rec0=19 rec1=00 rec2=03 rec3=04e
[0x03] rec0=1e rec1=00 rec2=04 rec3=014
[0x04] rec0=00 rec1=00 rec2=12 rec3=01c
[0x05] rec0=1a rec1=00 rec2=05 rec3=06c
[0x06] rec0=00 rec1=00 rec2=11 rec3=00e
[0x07] rec0=1e rec1=00 rec2=06 rec3=000
[0x08] rec0=01 rec1=00 rec2=10 rec3=00e
[0x09] rec0=1b rec1=00 rec2=07 rec3=02a
[0x0a] rec0=00 rec1=00 rec2=0f rec3=01c
[0x0b] rec0=1a rec1=00 rec2=08 rec3=044
[0x0c] rec0=00 rec1=00 rec2=0e rec3=00e
[0x0d] rec0=1c rec1=00 rec2=09 rec3=004
[0x0e] rec0=00 rec1=00 rec2=0d rec3=00e
[0x0f] rec0=19 rec1=00 rec2=0a rec3=046
[0x10] rec0=1f rec1=00 rec2=0b rec3=030
[0x11] rec0=0d rec1=00 rec2=0c rec3=000
tail 0x21500a36e81978d2dd169 0x42a00088462063203