|
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: 39936 (0x9c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Type_Analysis, seg_004427
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Errors;
with Common;
with Diana;
with Io;
with Table_Formatter;
with Bounds_Utilities;
with Names_And_Expressions;
with Compilation_Units;
with String_Utilities;
with Abstract_Document;
with Lrm_Renames;
use Lrm_Renames;
package body Type_Analysis is
package Ad renames Abstract_Document;
package Ad_Specify renames Abstract_Document.Specify;
package Flt_Io is new Io.Float_Io (Float);
Parent_Exp : constant String :=
"Name of the Unit containing the type declaration";
Decl_Exp : constant String := "Name of the type declaration";
Kind_Exp : constant String := "Kind of the type declaration";
Component_Exp : constant String := "Number of components in the Record";
function Full_Name (D : Data) return String is
begin
return Decls.Name (D.Parent_Comp_Unit_Decl) & "." & Decls.Name (D.Decl);
end Full_Name;
procedure Initialize (The_Db : in out Db) is
begin
Type_Map.Initialize (The_Db.Map);
end Initialize;
function Make_None (Id : Decl_Id; Decl : Ada.Element) return Data is
Return_Data : Data (None_Of_Above);
begin
Return_Data.Id := Id;
Return_Data.Decl := Decl;
Return_Data.Parent_Comp_Unit_Decl := Ada.Nil_Element;
return Return_Data;
end Make_None;
function Get_Value (From_Expression : Ada.Element) return Long_Integer is
Local : Ada.Element := From_Expression;
begin
if Names_And_Expressions.Is_Static (Local) then
return Names_And_Expressions.Static_Value (Local);
else
case Names_And_Expressions.Kind (Local) is
when Names_And_Expressions.A_Simple_Name =>
Local := Decls.Enclosing_Declaration
(Ada.Definition (Local));
case Decls.Kind (Local) is
when Decls.A_Variable_Declaration |
Decls.A_Constant_Declaration =>
if Decls.Is_Initialized (Local) then
return Get_Value (Decls.Initial_Value (Local));
else
return Long_Integer'Last;
end if;
when others =>
return Long_Integer'Last;
end case;
when others =>
return Long_Integer'Last;
end case;
end if;
end Get_Value;
function Get_Value (From_Expression : Ada.Element) return Float is
Local : Ada.Element := From_Expression;
begin
if Names_And_Expressions.Is_Static (Local) then
return Names_And_Expressions.Static_Value (Local);
else
case Names_And_Expressions.Kind (Local) is
when Names_And_Expressions.A_Simple_Name =>
Local := Decls.Enclosing_Declaration
(Ada.Definition (Local));
case Decls.Kind (Local) is
when Decls.A_Variable_Declaration |
Decls.A_Constant_Declaration =>
if Decls.Is_Initialized (Local) then
return Get_Value (Decls.Initial_Value (Local));
else
return Float'Last;
end if;
when others =>
return Float'Last;
end case;
when others =>
return Float'Last;
end case;
end if;
end Get_Value;
procedure Add_To_Database
(Decl : Ada.Element; Id : Decl_Id; The_Db : in out Db) is
Type_Def : Types.Type_Definition := Decls.Type_Specification (Decl);
The_Data : Data (Get_Kind (Type_Def));
Elems : Ada.Element_Iterator;
function Process (Type_Def : Types.Type_Definition) return Decl_Id is
Referenced_Decl : Ada.Declaration := Type_Def;
Completion_Decl : Ada.Declaration;
Id : Decl_Id;
begin
case Types.Kind (Type_Def) is
when Types.A_Subtype_Indication ..
Types.A_Task_Type_Definition =>
Referenced_Decl := Decls.Enclosing_Declaration
(Ada.Definition (Type_Def));
Id := Diana.Hash (Ada.Conversion.Convert (Referenced_Decl));
Add_Type_Decl (Referenced_Decl, The_Db);
when Types.A_Private_Type_Definition ..
Types.A_Limited_Private_Type_Definition =>
Completion_Decl :=
Ada.Definition (Decls.Enclosing_Declaration (Type_Def));
if not Ada.Is_Nil (Completion_Decl) then
Referenced_Decl :=
Decls.Enclosing_Declaration (Completion_Decl);
Id := Diana.Hash (Ada.Conversion.Convert
(Referenced_Decl));
Add_Type_Decl (Referenced_Decl, The_Db);
end if;
when others =>
Id := Diana.Hash (Ada.Conversion.Convert (Referenced_Decl));
Type_Map.Define (The_Map => The_Db.Map,
D => Id,
R => Make_None (Id, Referenced_Decl),
Trap_Multiples => False);
end case;
return Id;
end Process;
begin
The_Data.Id := Id;
The_Data.Decl := Decl;
The_Data.Parent_Comp_Unit_Decl :=
Compilation_Units.Unit_Declaration
(Compilation_Units.Parent_Compilation_Unit (Decl));
case The_Data.Kind is
when An_Integer_Type =>
declare
Upper, Lower : Types.Expression;
begin
Types.Bounds (Types.Integer_Constraint (Type_Def),
Lower, Upper);
The_Data.Lower := Get_Value (Lower);
The_Data.Upper := Get_Value (Upper);
exception
when others =>
The_Data.Upper := 0;
The_Data.Lower := 0;
end;
when A_Float_Type =>
declare
Upper, Lower : Types.Expression;
Constraint : Ada.Element :=
Types.Floating_Point_Constraint (Type_Def);
begin
if Ada.Is_Nil (Constraint) then
The_Data.Lower_Float_Bound := Float'First;
The_Data.Upper_Float_Bound := Float'Last;
else
Types.Bounds (Constraint, Lower, Upper);
The_Data.Lower_Float_Bound := Get_Value (Lower);
The_Data.Upper_Float_Bound := Get_Value (Upper);
end if;
exception
when others =>
The_Data.Lower_Float_Bound := Float'Last;
The_Data.Upper_Float_Bound := Float'Last;
end;
when A_Fixed_Type =>
declare
Static : Boolean;
begin
Bounds_Utilities.Fixed_Range_Constraint_Bounds
(Type_Def, Types.Fixed_Point_Constraint (Type_Def),
The_Data.Lower_Fixed_Bound,
The_Data.Upper_Fixed_Bound, Static);
end;
when An_Enumeration =>
Elems := Types.Enumeration_Literals (Type_Def);
while not Ada.Done (Elems) loop
The_Data.Num_Lits := The_Data.Num_Lits + 1;
Ada.Next (Elems);
end loop;
when A_Boolean_Type | A_Character_Type =>
null;
when A_String_Type =>
The_Data.String_Size := 0;
when A_Record_Type =>
Elems := Types.Record_Components (Type_Def);
while not Ada.Done (Elems) loop
case Types.Component_Kind (Ada.Value (Elems)) is
when Types.A_Null_Component =>
null;
when Types.A_Variant_Part_Component =>
null;
when others =>
The_Data.Ids (The_Data.Component_Count) :=
Process (Decls.Object_Type (Ada.Value (Elems)));
The_Data.Component_Count :=
The_Data.Component_Count + 1;
end case;
Ada.Next (Elems);
end loop;
when An_Array_Type =>
The_Data.Component_Type := Process
(Types.Component_Type (Type_Def));
if Types.Is_Constrained_Array (Type_Def) then
The_Data.Index_Type :=
Process (Ada.Value (Types.Index_Constraints (Type_Def)));
else
The_Data.Index_Type :=
Process (Ada.Value (Types.Index_Subtype_Definitions
(Type_Def)));
end if;
when An_Access_Type =>
The_Data.Accessed_Type := Process (Types.Access_To (Type_Def)); when A_Derived_Type =>
The_Data.Referenced_Type := Process
(Types.Derived_From (Type_Def));
when A_Task_Type =>
null;
when A_Private_Type | A_Limited_Private_Type =>
The_Data.Completion_Type := Process (Type_Def);
when A_Subtype =>
The_Data.Subtyped_Type := Process (Type_Def);
when None_Of_Above =>
null;
end case;
Type_Map.Define (The_Map => The_Db.Map,
D => Id,
R => The_Data,
Trap_Multiples => False);
end Add_To_Database;
procedure Add_Type_Decl (Decl : Ada_Program.Element; To : in out Db) is
Id : Decl_Id := Diana.Hash (Ada.Conversion.Convert (Decl));
Existing_Data : Data;
begin
Existing_Data := Type_Map.Eval (The_Map => To.Map, D => Id);
exception
when Type_Map.Undefined =>
Add_To_Database (Decl, Id, To);
end Add_Type_Decl;
function Type_Decl (Id : Decl_Id; The_Db : Db) return Ada.Element is
Existing_Data : Data;
begin
Existing_Data := Type_Map.Eval (The_Db.Map, Id);
return Existing_Data.Decl;
exception
when Type_Map.Undefined =>
return Ada.Nil_Element;
end Type_Decl;
function Ground_Kind (Type_Decl : Ada.Declaration) return String is
Kind : Type_Kinds := Get_Kind (Decls.Type_Specification (Type_Decl));
Defin : Ada.Element;
begin
case Kind is
when A_Private_Type | A_Limited_Private_Type =>
Defin := Decls.Enclosing_Declaration
(Ada.Definition (Type_Decl));
if Ada.Is_Nil (Defin) then
if Decls.Is_Generic_Formal (Type_Decl) then
return "GENERIC FORMAL";
else
return "NO COMPLETION";
end if;
else
Kind := Get_Kind (Types.Ground_Type
(Decls.Type_Specification (Defin)));
end if;
when others =>
if Decls.Is_Incomplete (Type_Decl) then
Defin := Ada.Definition (Type_Decl);
Kind := Get_Kind (Types.Ground_Type (Defin));
else
Kind := Get_Kind
(Types.Ground_Type
(Decls.Type_Specification (Type_Decl)));
end if;
end case;
case Kind is
when An_Integer_Type =>
return "INTEGER";
when A_Float_Type =>
return "FLOAT";
when A_Fixed_Type =>
return "FIXED"; when An_Enumeration =>
return "ENUM";
when A_Boolean_Type =>
return "BOOLEAN";
when A_Character_Type =>
return "CHARACTER";
when A_String_Type =>
return "STRING";
when A_Record_Type =>
return "RECORD";
when An_Array_Type =>
return "ARRAY";
when An_Access_Type =>
return "ACCESS";
when A_Derived_Type =>
return "DERIVED";
when A_Task_Type =>
return "TASK";
when A_Private_Type =>
return "PRIVATE";
when A_Limited_Private_Type =>
return "L_PRIVATE";
when A_Subtype =>
return "SUBTYPE";
when None_Of_Above =>
return "";
end case;
end Ground_Kind;
function Check_Kind
(Kind : Type_Kinds; For_Sort : Sort_Type) return Boolean is
begin
case For_Sort is
when Name_Sort | Kind_Sort =>
case Kind is
when None_Of_Above =>
return False;
when others =>
return True;
end case;
when Record_Sort =>
case Kind is
when A_Record_Type =>
return True;
when others =>
return False;
end case;
when Scalar_Sort =>
case Kind is
when An_Integer_Type | A_Float_Type | A_Fixed_Type |
An_Enumeration | A_Boolean_Type | A_Character_Type =>
return True;
when others =>
return False;
end case;
when Subtype_Sort =>
case Kind is
when A_Subtype | A_Derived_Type =>
return True;
when others =>
return False;
end case;
end case;
end Check_Kind;
procedure Display (The_Db : Db;
Sort : Sort_Type := Type_Analysis.Kind_Sort;
To_Document : in out Abstract_Document.Handle) is
package Table is new Table_Formatter (5);
Name_Sort_Table : constant Table.Field_List (1 .. 4) := (1, 2, 3, 4);
Record_Sort_Table : constant Table.Field_List (1 .. 3) := (2, 1, 5);
Scalar_Sort_Table : constant Table.Field_List (1 .. 3) := (3, 4, 5);
Subtype_Sort_Table : constant Table.Field_List (1 .. 2) := (3, 4);
Status : Errors.Condition;
Iter : Type_Map.Iterator;
procedure Add_Line (D : Data) is
S : String (1 .. 100);
Ref_Decl : Ada.Element;
Comp_Decl : Ada.Element;
Num_Components : Component_Index;
begin
Ref_Decl := Type_Decl (D.Id, The_Db);
declare
Parent : constant String :=
Decls.Name (D.Parent_Comp_Unit_Decl);
Name : constant String := Decls.Name (Ref_Decl);
begin
case D.Kind is
when None_Of_Above =>
null;
when A_Record_Type =>
Num_Components := D.Component_Count - 1;
Table.Item (Parent,
Explanation => Parent_Exp,
Linkage => D.Parent_Comp_Unit_Decl);
Table.Item (Name,
Explanation => Decl_Exp,
Linkage => Ref_Decl);
Table.Item ("RECORD",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item (String_Utilities.Strip
(Component_Index'Image (Num_Components)),
Explanation => Component_Exp);
Table.Item ("+", Explanation => "Starting component");
case Sort is
-- put in all components
when Record_Sort =>
for I in reverse 1 .. Num_Components loop
Table.Item
(Parent,
Explanation => Parent_Exp,
Linkage => D.Parent_Comp_Unit_Decl);
Table.Item (Name,
Explanation => Decl_Exp,
Linkage => Ref_Decl);
Table.Item ("COMPONENT",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Comp_Decl := Type_Decl (D.Ids (I), The_Db);
Table.Item (Decls.Name (Comp_Decl),
Explanation => "Component name",
Linkage => Comp_Decl);
if I = 1 then
Table.Item (String_Utilities.Strip
(Component_Index'Image
(Num_Components)),
Explanation =>
Component_Exp);
else
Table.Item
(".",
Explanation =>
"Intermediate Component");
end if;
end loop;
when others =>
null;
end case;
when others =>
Table.Item (Parent,
Explanation => Parent_Exp,
Linkage => D.Parent_Comp_Unit_Decl);
Table.Item (Name,
Explanation => Decl_Exp,
Linkage => Ref_Decl);
end case;
end;
case D.Kind is
when An_Integer_Type =>
Table.Item ("INTEGER",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item (Long_Integer'Image (D.Lower),
Explanation => "Lower Bound");
Table.Item (Long_Integer'Image (D.Upper),
Explanation => "Upper Bound");
when A_Float_Type =>
Table.Item ("FLOAT",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Flt_Io.Put (S, D.Lower_Float_Bound, Aft => 6);
Table.Item (String_Utilities.Strip (S),
Explanation => "Lower Bound");
Flt_Io.Put (S, D.Upper_Float_Bound, Aft => 6);
Table.Item (String_Utilities.Strip (S),
Explanation => "Upper Bound");
when A_Fixed_Type =>
Table.Item ("FIXED",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item (Long_Integer'Image (D.Lower_Fixed_Bound),
Explanation => "Lower Bound");
Table.Item (Long_Integer'Image (D.Upper_Fixed_Bound),
Explanation => "Upper Bound");
when An_Enumeration =>
Table.Item ("ENUM",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item (Integer'Image (D.Num_Lits),
Explanation =>
"Number of enumeration literals");
Table.Item ("");
when A_Boolean_Type =>
Table.Item ("BOOLEAN",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item ("");
Table.Item ("");
when A_Character_Type =>
Table.Item ("CHARACTER",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item ("");
Table.Item ("");
when A_String_Type =>
Table.Item ("STRING",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item (Integer'Image (D.String_Size),
Explanation =>
"Number of characters in the string");
Table.Item ("");
when A_Record_Type =>
null; -- see above
when An_Array_Type =>
Table.Item ("ARRAY",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Ref_Decl := Type_Decl (D.Index_Type, The_Db);
Table.Item (Ada.Image (Ref_Decl),
Explanation => "Index type of the array",
Linkage => Ref_Decl);
Ref_Decl := Type_Decl (D.Component_Type, The_Db);
Table.Item (Decls.Name (Ref_Decl),
Explanation => "Component type of the array",
Linkage => Ref_Decl);
when An_Access_Type =>
Table.Item ("ACCESS",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Ref_Decl := Type_Decl (D.Accessed_Type, The_Db);
Table.Item (Decls.Name (Ref_Decl),
Explanation =>
"Name of the type being accessed",
Linkage => Ref_Decl);
Table.Item (Ground_Kind (Ref_Decl),
Explanation =>
"Kind of the type being accessed");
when A_Derived_Type =>
Table.Item ("DERIVED",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Ref_Decl := Type_Decl (D.Referenced_Type, The_Db);
Table.Item (Decls.Name (Ref_Decl),
Explanation => "Name of the type derived",
Linkage => Ref_Decl);
Table.Item (Ground_Kind (D.Decl), Explanation => Kind_Exp);
when A_Task_Type =>
Table.Item ("TASK",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item ("");
Table.Item ("");
when A_Private_Type =>
Table.Item ("PRIVATE",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item ("");
Table.Item
(Ground_Kind (D.Decl),
Explanation =>
"Kind of the completion of the private type");
when A_Limited_Private_Type =>
Table.Item ("L_PRIVATE",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Table.Item ("");
Table.Item
(Ground_Kind (D.Decl),
Explanation =>
"Kind of the completion of the limited private type");
when A_Subtype =>
Table.Item ("SUBTYPE",
Explanation => Kind_Exp,
Linkage => Ref_Decl);
Ref_Decl := Type_Decl (D.Subtyped_Type, The_Db);
Table.Item (Decls.Name (Ref_Decl),
Explanation => "Type being subtyped",
Linkage => Ref_Decl);
Table.Item (Ground_Kind (D.Decl),
Explanation =>
"Kind of the type being subtyped");
when None_Of_Above =>
null;
end case;
end Add_Line;
begin
Table.Header ("PARENT UNIT");
Table.Header ("Type");
Table.Header ("Kind");
Table.Header ("Data 1");
Table.Header ("Data 2");
Type_Map.Init (Iter, The_Db.Map);
while not Type_Map.Done (Iter) loop
declare
D : Data := Type_Map.Eval (The_Db.Map, Type_Map.Value (Iter));
begin
if Check_Kind (D.Kind, Sort) then
Add_Line (D);
end if;
Type_Map.Next (Iter);
end;
end loop;
case Sort is
when Name_Sort =>
Table.Sort (Name_Sort_Table);
when Record_Sort =>
Table.Sort (Record_Sort_Table);
when Kind_Sort =>
Table.Sort (3);
when Scalar_Sort =>
Table.Sort (Scalar_Sort_Table);
when Subtype_Sort =>
Table.Sort (4);
end case;
Table.Display (To_Document, "TYPE ANALYSIS");
end Display;
function Hash (Id : Decl_Id) return Integer is
begin
return Integer (Id mod Long_Integer (Integer'Last));
end Hash;
end Type_Analysis;
nblk1=26
nid=0
hdr6=4c
[0x00] rec0=20 rec1=00 rec2=01 rec3=012
[0x01] rec0=01 rec1=00 rec2=26 rec3=02a
[0x02] rec0=19 rec1=00 rec2=02 rec3=024
[0x03] rec0=17 rec1=00 rec2=03 rec3=02c
[0x04] rec0=18 rec1=00 rec2=04 rec3=01e
[0x05] rec0=16 rec1=00 rec2=05 rec3=08c
[0x06] rec0=01 rec1=00 rec2=25 rec3=002
[0x07] rec0=1a rec1=00 rec2=06 rec3=032
[0x08] rec0=00 rec1=00 rec2=24 rec3=004
[0x09] rec0=19 rec1=00 rec2=07 rec3=010
[0x0a] rec0=00 rec1=00 rec2=23 rec3=004
[0x0b] rec0=15 rec1=00 rec2=08 rec3=078
[0x0c] rec0=18 rec1=00 rec2=09 rec3=018
[0x0d] rec0=16 rec1=00 rec2=0a rec3=002
[0x0e] rec0=18 rec1=00 rec2=0b rec3=03c
[0x0f] rec0=00 rec1=00 rec2=22 rec3=016
[0x10] rec0=1a rec1=00 rec2=0c rec3=02a
[0x11] rec0=00 rec1=00 rec2=21 rec3=002
[0x12] rec0=1a rec1=00 rec2=0d rec3=03e
[0x13] rec0=01 rec1=00 rec2=20 rec3=002
[0x14] rec0=1e rec1=00 rec2=0e rec3=01a
[0x15] rec0=19 rec1=00 rec2=0f rec3=040
[0x16] rec0=1b rec1=00 rec2=10 rec3=04e
[0x17] rec0=01 rec1=00 rec2=1f rec3=00e
[0x18] rec0=16 rec1=00 rec2=11 rec3=028
[0x19] rec0=00 rec1=00 rec2=1e rec3=01a
[0x1a] rec0=12 rec1=00 rec2=12 rec3=060
[0x1b] rec0=10 rec1=00 rec2=13 rec3=028
[0x1c] rec0=15 rec1=00 rec2=14 rec3=02a
[0x1d] rec0=12 rec1=00 rec2=15 rec3=022
[0x1e] rec0=12 rec1=00 rec2=16 rec3=02a
[0x1f] rec0=14 rec1=00 rec2=17 rec3=04a
[0x20] rec0=13 rec1=00 rec2=18 rec3=006
[0x21] rec0=11 rec1=00 rec2=19 rec3=014
[0x22] rec0=15 rec1=00 rec2=1a rec3=016
[0x23] rec0=16 rec1=00 rec2=1b rec3=038
[0x24] rec0=20 rec1=00 rec2=1c rec3=006
[0x25] rec0=04 rec1=00 rec2=1d rec3=001
tail 0x217001712815c63e3d118 0x42a00088462061e03