|
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: 14336 (0x3800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, procedure Rm_050, seg_00561b
└─⟦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 Trap_Error_Reports;
with Rm_Test_Utilities;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Display3;
use Xlbt_Display3;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Rm3;
use Xlbt_Rm3;
with Xlbt_String;
use Xlbt_String;
with Xlbp_Rm;
use Xlbp_Rm;
with Xlbp_Rm_Name;
use Xlbp_Rm_Name;
with Xlbp_Rm_Quark;
use Xlbp_Rm_Quark;
procedure Rm_050 is
------------------------------------------------------------------------------
-- Tests for Xlbp_Rm - Get/Put resource tests.
------------------------------------------------------------------------------
-- ****************************************************************************
-- * Date - /Name/ Comment
-- *
-- * 5-JUL-90 - /GEB/ Created.
-- * 8-NOV-90 - /DRK/ Reorganized, added Quoting_Tests.
-- * 19-NOV-90 - /GEB/ New RM error returns.
-- ****************************************************************************
-----------------------------------
-- Local variables and constants --
-----------------------------------
Rep_String : constant X_Rm_Representation :=
X_Rm_String_To_Representation ("Rep_String");
Rep_S_Long : constant X_Rm_Representation :=
X_Rm_String_To_Representation ("Rep_S_Long");
Rep_Boolean : constant X_Rm_Representation :=
X_Rm_String_To_Representation ("Rep_Boolean");
Rep_U_Char_Array : constant X_Rm_Representation :=
X_Rm_String_To_Representation ("Rep_U_Char_Array");
Rep_Universal : constant X_Rm_Representation :=
X_Rm_String_To_Representation ("Rep_Universal");
Name_One : constant X_Rm_Name := X_Rm_String_To_Name ("one");
Name_Two : constant X_Rm_Name := X_Rm_String_To_Name ("two");
Name_Three : constant X_Rm_Name := X_Rm_String_To_Name ("three");
Name_Four : constant X_Rm_Name := X_Rm_String_To_Name ("four");
Class_One : constant X_Rm_Class := X_Rm_String_To_Class ("One");
Quark_One : constant X_Rm_Quark := X_Rm_String_To_Quark ("ONE");
----------------------------------------------------------------------
---------------------
-- Local utilities --
---------------------
procedure Check (Condition : Boolean;
Failure_Msg : String;
Success_Msg : String := "") is
begin
if not Condition then
if not Trap_Error_Reports.Expect_Error_Report then
Test_Io.Put_Error (Failure_Msg);
end if;
elsif Success_Msg /= "" then
Test_Io.Put_Line (Success_Msg);
end if;
end Check;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Check (Error : X_Rm_Status) is
begin
Check (Error = Rm_Successful, "RM error");
end Check;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Try (Db : in out X_Rm_Database;
Line : X_String;
Probe : X_String;
Expect : X_String := "";
Erroneous : Boolean := False) is
Error : X_Rm_Status;
Rep : X_Rm_Representation;
Val : X_Rm_Value;
begin
Trap_Error_Reports.Expect_Error_Report := Erroneous;
Trap_Error_Reports.Error_Reported := False;
-- Insert this resource.
Test_Io.Put_Line ("Resource """ & To_String (Line) & '"');
X_Rm_Add_Resource (Db, Line, Error);
Check (Error);
-- Retrieve it.
Test_Io.Putx (" """ & Probe & """ => ");
X_Rm_Get_Resource (Db, Probe, Probe, Rep, Val);
Test_Io.Put_Line (Rm_Test_Utilities.Image (Val));
-- Compare results.
if (Expect = "") then
Check (Val = None_X_Rm_Value, "Expected: no value");
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) & '"');
end if;
Check (Trap_Error_Reports.Error_Reported = Erroneous,
"Error reporting inconsistency: expect error = " &
Boolean'Image (Erroneous));
end Try;
----------------------------------------------------------------------
--------------------------
-- Major test sections. --
--------------------------
procedure Create_Delete_Tests is
Db : X_Rm_Database;
begin
Test_Io.Section ("Creation/Deletion");
-- Can we even create and delete empty databases?
Db := X_New_Rm_Database;
Free_X_Rm_Database (Db);
Check (Db = None_X_Rm_Database,
"Free_X_Rm_Database didn't return null.");
-- Put in a few strings and delete it.
Db := X_New_Rm_Database;
X_Rm_Put_String_Resource
(Db, (0 => 'a', 1 => 'b', 2 => 'c'), "abc value");
X_Rm_Put_String_Resource
(Db, (2 => 'd', 3 => 'e', 4 => 'f'), "def value");
X_Rm_Put_String_Resource (Db, "a.b.c", "a.b.c value");
X_Rm_Put_String_Resource (Db, "ab*c", "ab*c value");
Free_X_Rm_Database (Db);
Check (Db = None_X_Rm_Database,
"Free_X_Rm_Database didn't return null.");
end Create_Delete_Tests;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Smoke_Tests is
Db : X_Rm_Database;
begin
-- Call each of the Put interfaces once. Simple smoke test.
Test_Io.Section ("Put smoke tests.");
Db := X_New_Rm_Database;
X_Rm_Put_Resource (Db, (2 => X_Rm_Bind_Loosely),
X_Rm_Name_Array'(0 => Name_One),
Rep_S_Long, (Is_S_Long, 1));
X_Rm_Put_Resource (Db, (0 .. 1 => X_Rm_Bind_Tightly),
X_Rm_Class_Array'(2 .. 3 => Class_One),
Rep_S_Long, (Is_S_Long, 1));
X_Rm_Put_Resource (Db, (1 .. 3 => X_Rm_Bind_Loosely),
X_Rm_Quark_Array'(1 .. 3 => Quark_One),
Rep_S_Long, (Is_S_Long, 1));
X_Rm_Put_String_Resource
(Db, (0 => X_Rm_Bind_Tightly), (2 => Name_Two), "2");
X_Rm_Put_Resource (Db, "three", "Random", (Is_S_Long, 3));
X_Rm_Put_String_Resource (Db, "*four", "4");
-- Call each of the Put interfaces once. Simple smoke test.
Test_Io.Section ("Get smoke tests.");
declare
Rep : X_Rm_Representation;
Val : X_Rm_Value;
begin
X_Rm_Get_Resource (Database => Db,
Names => "some.names",
Classes => "Some.Classes",
Representation => Rep,
Value => Val);
X_Rm_Get_Resource
(Database => Db,
Names => X_Rm_Name_Array'(0 => Name_One, 1 => None_X_Rm_Name),
Classes => X_Rm_Class_Array'
(2 => Class_One, 3 => None_X_Rm_Class),
Representation => Rep,
Value => Val);
end;
Free_X_Rm_Database (Db);
Check (Db = None_X_Rm_Database,
"Free_X_Rm_Database didn't return null.");
end Smoke_Tests;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Quoting_Tests is
Db : X_Rm_Database
Old : X_Procedure_Variable;
begin
Test_Io.Section ("Put quoting tests");
Db := X_New_Rm_Database;
Trap_Error_Reports.Catch_Error_Reports (Old);
-- Try various "normal" cases.
Try (Db, "normal: a", "normal", "a");
Try (Db, "octal: \142", "octal", "b");
Try (Db, "newline: \n", "newline", (1 => Lf));
Try (Db, "nl.lf: \n" & Lf, "nl.lf", (1 => Lf));
Try (Db, "backslash: \\", "backslash", "\");
Try (Db, "long: \1234", "long", "S4");
-- Try some error cases
Try (Db, "unknown: \?", "unknown", "?", True);
Try (Db, "short: \0", "short", "0", True);
Try (Db, "bignum: \530", "bignum", "X", True);
-- Make sure we parse lines correctly.
Try (Db, "wrapped: a\" & Lf & "b", "wrapped", "ab");
Try (Db, "clipped: c\", "clipped", "c");
Trap_Error_Reports.Propagate_Error_Reports (Old);
Free_X_Rm_Database (Db);
Check (Db = None_X_Rm_Database,
"Free_X_Rm_Database didn't return null.");
end Quoting_Tests;
begin
Create_Delete_Tests;
Smoke_Tests;
Quoting_Tests;
end Rm_050;
nblk1=d
nid=0
hdr6=1a
[0x00] rec0=24 rec1=00 rec2=01 rec3=000
[0x01] rec0=15 rec1=00 rec2=02 rec3=00a
[0x02] rec0=00 rec1=00 rec2=0d rec3=032
[0x03] rec0=1d rec1=00 rec2=03 rec3=056
[0x04] rec0=19 rec1=00 rec2=04 rec3=03e
[0x05] rec0=01 rec1=00 rec2=0c rec3=00e
[0x06] rec0=1a rec1=00 rec2=05 rec3=01c
[0x07] rec0=18 rec1=00 rec2=06 rec3=010
[0x08] rec0=12 rec1=00 rec2=07 rec3=036
[0x09] rec0=17 rec1=00 rec2=08 rec3=036
[0x0a] rec0=00 rec1=00 rec2=0b rec3=002
[0x0b] rec0=19 rec1=00 rec2=09 rec3=006
[0x0c] rec0=0a rec1=00 rec2=0a rec3=000
tail 0x21500a36681978d24f617 0x42a00088462063203