|
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: 18432 (0x4800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Table_Formatter, seg_00eb0f
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Table_Sort_Generic;
package body Table_Formatter is
Intercolumn_Spacing : constant := 2;
subtype Column_Index is Natural range 1 .. Number_Of_Columns;
type Width_List is array (Column_Index) of Natural;
type A_String is access String;
type An_Item (Subitem_Length : Natural);
type Access_Item is access An_Item;
type An_Item (Subitem_Length : Natural) is
record
Subitem : String (1 .. Subitem_Length);
Next : Access_Item;
end record;
type Item_List is array (Column_Index) of Access_Item;
type Line;
type Access_Line is access Line;
type Access_Line_Array is array (Integer range <>) of Access_Line;
Current_Line : Access_Line;
type Line is
record
Values : Item_List;
Width : Width_List := (others => 0);
Next : Access_Line := Current_Line;
end record;
Current_Column : Column_Index := Column_Index'Last;
In_Subitem : Boolean := False;
Max_Width : Width_List := (others => 0);
Headers : array (Column_Index) of A_String;
Header_Column : Natural := 0;
Column_Format : array (Column_Index) of Adjust;
function Max (Left, Right : Integer) return Integer is
begin
if Left >= Right then
return Left;
else
return Right;
end if;
end Max;
procedure Insert (S : String) is
-- Put the String into the current row/column, appending it if
-- there is already something there.
Cell : Access_Item renames Current_Line.Values (Current_Column);
Width : Natural renames Current_Line.Width (Current_Column);
Max : Natural renames Max_Width (Current_Column);
begin
if Cell = null then
Width := S'Length;
else
Width := Width + Subitem_Separator'Length + S'Length;
end if;
if Width > Max then
Max := Width;
end if;
Cell := new An_Item'(S'Length, S, Cell);
end Insert;
procedure Item (S : String) is
-- Begin a new cell, put S there, and mark the cell closed by
-- setting In_Subitem to be false.
begin
if Current_Column = Column_Index'Last then
Current_Line := new Line;
Current_Column := Column_Index'First;
else
Current_Column := Current_Column + 1;
end if;
Insert (S);
In_Subitem := False;
end Item;
procedure Header (S : String; Format : Adjust := Left) is
-- Set Header and Column Format
begin
Header_Column := Header_Column + 1;
Column_Format (Header_Column) := Format;
Headers (Header_Column) := new String'(S);
end Header;
procedure Subitem (S : String) is
-- If the current cell is open, add S to it. Otherwise start a new
-- cell, but leave it open.
begin
if In_Subitem then
Insert (S);
else
Item (S);
end if;
In_Subitem := True;
end Subitem;
procedure Last_Subitem is
-- If the current cell is open, close it. If the current cell is
-- closed, we have an item that consists of zero subitems. Give it
-- a visible representation.
begin
if In_Subitem then
In_Subitem := False;
else
Item ("(none)");
end if;
end Last_Subitem;
function Image (P : Access_Item) return String is
-- P must be non-null
begin
if P.Next = null then
return P.Subitem;
end if;
return Image (P.Next) & Subitem_Separator & P.Subitem;
-- Recall that subitem lists are stored in reverse order
end Image;
procedure Display (On_File : Text_Io.File_Type) is
-- Dump the data structure we have been building by traversing it
-- recursively. Note that all of the lists are stored in reverse
-- order so that they were easy to build.
procedure Replicate (C : Character; N : Natural) is
-- Output N copies of C
S : constant String (1 .. N) := (others => C);
begin
Text_Io.Put (On_File, S);
end Replicate;
procedure Display (P : Access_Item) is
begin
if P /= null then
Text_Io.Put (On_File, Image (P));
end if;
end Display;
procedure Display_Headers is
Excess : Width_List;
begin
for J in Column_Index loop
Excess (J) := Max (Headers (J).all'Length, Max_Width (J)) -
Headers (J).all'Length;
end loop;
Replicate (' ', Excess (1) / 2);
for J in Column_Index loop
Text_Io.Put (On_File, Headers (J).all);
if J /= Column_Index'Last then
Replicate (' ', (Excess (J) + 1) / 2 + Excess (J + 1) / 2 +
Intercolumn_Spacing);
end if;
end loop;
Text_Io.New_Line (On_File);
end Display_Headers;
procedure Display_Adjusted (L : Line) is
Inner_Excess, Outer_Excess : Natural;
begin
for J in Column_Index loop
Inner_Excess := Max_Width (J) - L.Width (J);
Outer_Excess :=
Max (Headers (J).all'Length, Max_Width (J)) - Max_Width (J);
case Column_Format (J) is
when Left =>
Replicate (' ', Outer_Excess / 2);
Display (L.Values (J));
if J /= Column_Index'Last then
Replicate (' ',
(Outer_Excess + 1) / 2 + Inner_Excess +
Intercolumn_Spacing);
end if;
when Right =>
Replicate (' ', Outer_Excess / 2 + Inner_Excess);
Display (L.Values (J));
if J /= Column_Index'Last then
Replicate (' ', (Outer_Excess + 1) / 2 +
Intercolumn_Spacing);
end if;
when Centered =>
Replicate (' ', (Inner_Excess + Outer_Excess) / 2);
Display (L.Values (J));
if J /= Column_Index'Last then
Replicate (' ',
(Inner_Excess + Outer_Excess + 1) / 2 +
Intercolumn_Spacing);
end if;
end case;
end loop;
Text_Io.New_Line (On_File);
end Display_Adjusted;
procedure Display (L : Access_Line) is
begin
if L = null then
-- Center the header
Display_Headers;
-- A separator line
for J in Column_Index loop
Replicate ('=', Max
(Headers (J).all'Length, Max_Width (J)));
if J /= Column_Index'Last then
Replicate (' ', Intercolumn_Spacing);
end if;
end loop;
Text_Io.New_Line (On_File);
else
-- Display the head of the table
Display (L.Next);
-- Display the final line
Display_Adjusted (L.all);
end if;
end Display;
begin
Display (Current_Line);
end Display;
function Normalize return Natural is
-- Traverse the current structure looking for cells that consist
-- of more than one subitem, and concatentate the subitems into
-- a single item.
-- Return the number of rows in the table.
Result : Natural := 0;
Line : Access_Line := Current_Line;
P : Access_Item;
begin
while Line /= null loop
for J in Line.Values'Range loop
P := Line.Values (J);
if P = null then
Line.Values (J) := new An_Item'(0, "", null);
elsif P.Next /= null then
Line.Values (J) :=
new An_Item'(Line.Width (J), Image (P), null);
end if;
end loop;
Line := Line.Next;
Result := Result + 1;
end loop;
return Result;
end Normalize;
procedure Fill (Table : out Access_Line_Array) is
-- Transfers the linked list pointed to by Current_Line into
-- the sequential table.
P : Access_Line;
begin
P := Current_Line;
for J in reverse Table'Range loop
Table (J) := P;
P := P.Next;
end loop;
end Fill;
procedure Empty (Table : Access_Line_Array) is
-- rebuilds the Current_Line link list from the sequential table,
-- preserving the convention that lists are stored backwards.
begin
if Table'Length = 0 then
Current_Line := null;
return;
end if;
Table (Table'First).Next := null;
for J in Table'First + 1 .. Table'Last loop
Table (J).Next := Table (J - 1);
end loop;
Current_Line := Table (Table'Last);
end Empty;
procedure Sort (On_Field : Positive := 1) is
Table : Access_Line_Array (1 .. Normalize);
function "<" (Left, Right : Access_Line) return Boolean is
begin
return Left.Values (On_Field).Subitem <
Right.Values (On_Field).Subitem;
end "<";
procedure Table_Sort is
new Table_Sort_Generic (Element => Access_Line,
Index => Integer,
Element_Array => Access_Line_Array);
begin
Fill (Table);
Table_Sort (Table);
Empty (Table);
end Sort;
procedure Sort (On_Fields : Field_List) is
Table : Access_Line_Array (1 .. Normalize);
function "<" (Left, Right : Access_Line) return Boolean is
begin
for J in On_Fields'Range loop
if Left.Values (On_Fields (J)).Subitem <
Right.Values (On_Fields (J)).Subitem then
return True;
end if;
if Left.Values (On_Fields (J)).Subitem >
Right.Values (On_Fields (J)).Subitem then
return False;
end if;
end loop;
return False;
end "<";
procedure Table_Sort is
new Table_Sort_Generic (Element => Access_Line,
Index => Integer,
Element_Array => Access_Line_Array);
begin
Fill (Table);
Table_Sort (Table);
Empty (Table);
end Sort;
begin
-- Default to empty left justified headers.
for J in Column_Index loop
Column_Format (J) := Left;
Headers (J) := new String'("");
end loop;
end Table_Formatter;
nblk1=11
nid=0
hdr6=22
[0x00] rec0=22 rec1=00 rec2=01 rec3=030
[0x01] rec0=00 rec1=00 rec2=11 rec3=020
[0x02] rec0=1b rec1=00 rec2=02 rec3=07c
[0x03] rec0=03 rec1=00 rec2=10 rec3=01c
[0x04] rec0=1f rec1=00 rec2=03 rec3=070
[0x05] rec0=01 rec1=00 rec2=0f rec3=004
[0x06] rec0=25 rec1=00 rec2=04 rec3=014
[0x07] rec0=1c rec1=00 rec2=05 rec3=042
[0x08] rec0=1a rec1=00 rec2=06 rec3=042
[0x09] rec0=14 rec1=00 rec2=07 rec3=00a
[0x0a] rec0=1e rec1=00 rec2=08 rec3=012
[0x0b] rec0=20 rec1=00 rec2=09 rec3=028
[0x0c] rec0=01 rec1=00 rec2=0e rec3=010
[0x0d] rec0=23 rec1=00 rec2=0a rec3=004
[0x0e] rec0=00 rec1=00 rec2=0d rec3=010
[0x0f] rec0=1c rec1=00 rec2=0b rec3=012
[0x10] rec0=1e rec1=00 rec2=0c rec3=000
tail 0x2170b5caa8225428cea92 0x42a00088462063203