|
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 - metrics - download
Length: 35840 (0x8c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Table_Formatter, seg_0046d0
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Document;
with Mapping;
with Errors;
with Table_Sort_Generic;
package body Table_Formatter is
package Ad renames Abstract_Document;
package Ad_Specify renames Abstract_Document.Specify;
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; Explain_Length : Natural);
type Access_Item is access An_Item;
type An_Item (Subitem_Length : Natural; Explain_Length : Natural) is
record
Subitem : String (1 .. Subitem_Length);
Explanation : String (1 .. Explain_Length);
Links : Ada_Program.Element_List;
Objects : Object.Iterator;
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;
Integer_Valued : array (Column_Index) of Boolean;
function Justification (A : Adjust) return Abstract_Document.Position is
begin
case A is
when Left =>
return Abstract_Document.Left;
when Right =>
return Abstract_Document.Right;
when Centered =>
return Abstract_Document.Center;
end case;
end Justification;
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;
Explanation : String := "";
Element_Linkage : Ada.Element_List := Ada.Nil_List;
Object_Linkage : Object.Iterator := Object.Nil) 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);
Slid : constant String (1 .. S'Length) := S;
Explain_Text : constant String (1 .. Explanation'Length) := Explanation;
Li : Long_Integer;
begin
if Integer_Valued (Current_Column) then
Li := Long_Integer'Value (S);
end if;
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'(Slid'Length, Explain_Text'Length,
Slid, Explain_Text, Element_Linkage,
Object_Linkage, Cell);
end Insert;
procedure Item (S : String;
Linkage : Ada.Element := Ada.Nil_Element;
Linkage_List : Ada.Element_List := Ada.Nil_List;
Object_Linkage : Object.Handle := Object.Nil;
Object_Linkage_List : Object.Iterator := Object.Create;
Explanation : String := "") is
The_Object : Object.Handle := Object_Linkage;
Objects : Object.Iterator := Object_Linkage_List;
Elements : Ada.Element_List := Linkage_List;
Dup : Boolean;
-- 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;
if not Object.Is_Nil (The_Object) then
Object.Add (Objects, The_Object, Dup);
end if;
if not Ada.Is_Nil (Linkage) then
Ada.Append (Linkage, Elements);
end if;
Insert (S, Explanation, Elements, Objects);
In_Subitem := False;
end Item;
procedure Header (S : String;
Format : Adjust := Left;
Is_Integer : Boolean := False) is
-- Set Header and Column Format
begin
Header_Column := Header_Column + 1;
Column_Format (Header_Column) := Format;
Integer_Valued (Header_Column) := Is_Integer;
Headers (Header_Column) := new String'(S);
Max_Width (Header_Column) := S'Length;
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 => S);
else
Item (S => 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;
function Buffer_Length return Positive is
-- There may be reason for 1 or 2 additional spaces; 32 is overkill.
Result : Positive := 32 + Intercolumn_Spacing * Number_Of_Columns;
begin
for I in Max_Width'Range loop
Result := Result + Max_Width (I);
end loop;
return Result;
end Buffer_Length;
procedure Display (On_File : 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.
Buffer : String (1 .. Buffer_Length);
Last_Char : Natural := 0;
-- Document : Ad.Handle;
Status : Errors.Condition;
procedure Put (S : String) is
First_Char : constant Natural := Last_Char + 1;
begin
Last_Char := Last_Char + S'Length;
Buffer (First_Char .. Last_Char) := S;
end Put;
procedure New_Line is
begin
Io.Put_Line (On_File, Buffer (1 .. Last_Char));
Last_Char := 0;
end New_Line;
procedure Replicate (C : Character; N : Natural) is
-- Output N copies of C
First_Char : constant Natural := Last_Char + 1;
begin
Last_Char := Last_Char + N;
-- We assume small values of N
for I in First_Char .. Last_Char loop
Buffer (I) := C;
end loop;
end Replicate;
procedure Display (P : Access_Item) is begin
if P /= null then
Put (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
Put (Headers (J).all);
if J /= Column_Index'Last then
Replicate (' ', (Excess (J) + 1) / 2 + Excess (J + 1) / 2 +
Intercolumn_Spacing);
end if;
end loop;
New_Line;
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;
New_Line;
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;
New_Line;
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 Gen_Linkage (From : Access_Item;
In_Document : Abstract_Document.Handle)
return Ad.Linkage_Info is
Local_List : Ada.Element_List := From.Links;
Object_Reference : Document.Element := Document.Nil_Element;
Object_References : Document.Element_List := Document.Nil_List;
Status : Errors.Condition;
begin
Object.Reset (From.Objects);
while not Object.Done (From.Objects) loop
Document.Resolve (Object_Reference, Object.Value (From.Objects),
Status => Status);
Document.Add (Object_Reference, Object_References);
Object.Next (From.Objects);
end loop;
Document.Reset (Object_References);
return Ad_Specify.Gen_Linkage
(In_Document,
Explain => From.Explanation,
Definition =>
Mapping.Create (From.Links, Object_References));
end Gen_Linkage;
procedure Display (In_Document : in out Abstract_Document.Handle;
Table_Title : String) 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.
Status : Errors.Condition;
procedure Display (P : Access_Item) is
begin
if P /= null then
Ad_Specify.Table_Entry (In_Document, Image (P),
Gen_Linkage (P, In_Document));
end if;
end Display;
procedure Display_Headers is
begin
for J in Column_Index loop
Ad_Specify.Column_Information
(In_Document, (Headers (J).all),
Justification (Column_Format (J)));
end loop;
end Display_Headers;
procedure Display (L : Access_Line) is
begin
if L = null then
Display_Headers;
else
-- Display the head of the table
Display (L.Next);
for J in Column_Index loop
Display (L.Values (J));
end loop;
end if;
end Display;
begin
if Current_Line /= null then
-- create and initialize table.
Ad_Specify.Start_Table (In_Document, Table_Title, "");
Display (Current_Line);
Ad_Specify.End_Table (In_Document);
end if;
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, 0, "", "",
Ada_Program.Nil_List,
Object.Create, null);
elsif P.Next /= null then
Line.Values (J) := new
An_Item'(Line.Width (J), 0, Image (P),
"", Ada_Program.Nil_List,
Object.Create, 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;
function Abs_Field (On_Field : Integer) return Integer is
begin
if On_Field > 0 then
return On_Field;
elsif On_Field < 0 then
return -On_Field;
else
return 1;
end if;
end Abs_Field;
procedure Sort (On_Field : Integer := 1) is
Table : Access_Line_Array (1 .. Normalize);
Dont_Care : Integer := 0;
Real_Field : Positive := Abs_Field (On_Field);
function "<" (Left, Right : Access_Line) return Boolean is
begin
if Real_Field = On_Field then
if Integer_Valued (On_Field) then
return Long_Integer'Value (Left.Values (On_Field).Subitem) <
Long_Integer'Value
(Right.Values (On_Field).Subitem);
else
return Left.Values (On_Field).Subitem <
Right.Values (On_Field).Subitem;
end if;
else
if Integer_Valued (On_Field) then
return Long_Integer'Value
(Left.Values (Real_Field).Subitem) >
Long_Integer'Value
(Right.Values (Real_Field).Subitem);
else
return Left.Values (Real_Field).Subitem >
Right.Values (Real_Field).Subitem;
end if;
end if;
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);
Dont_Care : Integer := 0;
Real_Fields : Field_List (On_Fields'Range);
function "<" (Left, Right : Access_Line) return Boolean is
begin
for J in Real_Fields'Range loop
declare
Field : Integer := Real_Fields (J);
Increasing : Boolean := Field = On_Fields (J);
Left_Value : String renames Left.Values (Field).Subitem;
Right_Value : String renames Right.Values (Field).Subitem;
Left_Integer : Long_Integer;
Right_Integer : Long_Integer;
begin
if Integer_Valued (Field) then
Left_Integer := Long_Integer'Value (Left_Value);
Right_Integer := Long_Integer'Value (Right_Value);
if Increasing then
if Left_Integer < Right_Integer then
return True;
end if;
if Left_Integer > Right_Integer then
return False;
end if;
else
if Left_Integer > Right_Integer then
return True;
end if;
if Left_Integer < Right_Integer then
return False;
end if;
end if;
else
if Increasing then
if Left_Value < Right_Value then
return True;
end if;
if Left_Value > Right_Value then
return False;
end if;
else
if Left_Value > Right_Value then
return True;
end if;
if Left_Value < Right_Value then
return False;
end if;
end if;
end if;
end;
end loop;
return False;
end "<";
procedure Table_Sort is
new Table_Sort_Generic (Element => Access_Line,
Index => Integer,
Element_Array => Access_Line_Array);
begin
for I in On_Fields'Range loop
Real_Fields (I) := Abs_Field (On_Fields (I));
end loop;
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=22
nid=0
hdr6=44
[0x00] rec0=1f rec1=00 rec2=01 rec3=004
[0x01] rec0=00 rec1=00 rec2=21 rec3=02a
[0x02] rec0=1c rec1=00 rec2=22 rec3=01e
[0x03] rec0=01 rec1=00 rec2=02 rec3=01e
[0x04] rec0=17 rec1=00 rec2=03 rec3=08a
[0x05] rec0=03 rec1=00 rec2=20 rec3=008
[0x06] rec0=1c rec1=00 rec2=04 rec3=014
[0x07] rec0=00 rec1=00 rec2=1f rec3=006
[0x08] rec0=1f rec1=00 rec2=05 rec3=022
[0x09] rec0=00 rec1=00 rec2=1e rec3=010
[0x0a] rec0=1f rec1=00 rec2=06 rec3=01e
[0x0b] rec0=1f rec1=00 rec2=07 rec3=016
[0x0c] rec0=1f rec1=00 rec2=08 rec3=05c
[0x0d] rec0=01 rec1=00 rec2=1d rec3=002
[0x0e] rec0=20 rec1=00 rec2=09 rec3=03c
[0x0f] rec0=14 rec1=00 rec2=0a rec3=072
[0x10] rec0=1b rec1=00 rec2=0b rec3=028
[0x11] rec0=1f rec1=00 rec2=0c rec3=038
[0x12] rec0=00 rec1=00 rec2=1c rec3=022
[0x13] rec0=1c rec1=00 rec2=0d rec3=00a
[0x14] rec0=1f rec1=00 rec2=0e rec3=024
[0x15] rec0=1b rec1=00 rec2=0f rec3=092
[0x16] rec0=01 rec1=00 rec2=1b rec3=016
[0x17] rec0=1d rec1=00 rec2=10 rec3=090
[0x18] rec0=01 rec1=00 rec2=1a rec3=00c
[0x19] rec0=23 rec1=00 rec2=11 rec3=010
[0x1a] rec0=00 rec1=00 rec2=19 rec3=00e
[0x1b] rec0=16 rec1=00 rec2=12 rec3=036
[0x1c] rec0=19 rec1=00 rec2=13 rec3=044
[0x1d] rec0=00 rec1=00 rec2=18 rec3=012
[0x1e] rec0=18 rec1=00 rec2=17 rec3=038
[0x1f] rec0=01 rec1=00 rec2=14 rec3=008
[0x20] rec0=1b rec1=00 rec2=15 rec3=06a
[0x21] rec0=14 rec1=00 rec2=16 rec3=001
tail 0x217002a24815c6719afd3 0x42a00088462061e03