|
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: 75776 (0x12800)
Types: Ada Source
Notes: 03_class, FILE, Long Ada Source, R1k_Segment, e3_tag, package body Type_Display, seg_004429
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Io;
with Lrm_Utilities;
with Editor;
with Object_Editor;
with Common;
with Table_Formatter;
with Sizing_Parameters;
use Sizing_Parameters;
with String_Utilities;
with Errors;
with Abstract_Document;
with Representation_Clauses;
with Names_And_Expressions;
with Bounds_Utilities;
with Declarations;
with Ada_Program;
with Type_Information;
with List_Generic;
with Unbounded_String;
package body Type_Display is
package Ad renames Abstract_Document;
package Ad_Specify renames Abstract_Document.Specify;
package Unbounded is new Unbounded_String (60);
Current_Level : Natural;
type Special_Kind is (Array_Index,
Index_Constraint,
Discriminant,
Discriminant_Constraint,
Choice,
Not_Special);
type Node_Data is
record
Level : Positive;
Elem : Ada_Program.Element;
Kind : Special_Kind := Not_Special;
Size : Long_Natural := 0;
Static : Boolean := False;
Size_Expression : Unbounded.Variable_String;
end record;
package List is new List_Generic (Node_Data);
The_List : List.List := List.Nil;
package Rep_Specs renames Representation_Clauses;
package Decls renames Declarations;
package Ada renames Ada_Program;
package Types renames Type_Information;
function "=" (Left, Right : Types.Type_Definition_Kinds) return Boolean
renames Types."=";
function "=" (Left, Right : Ada.Element) return Boolean renames Ada."=";
procedure Size (Ref_Id : Ada_Program.Identifier_Reference :=
Ada_Program.Nil_Element;
Original : Type_Information.Type_Definition;
Constraint : Type_Information.Type_Constraint;
Result : in out Long_Natural;
Requires_Alignment : in out Boolean;
Static : in out Boolean);
procedure Size (For_Type : Type_Information.Type_Definition;
Result : in out Long_Natural;
Requires_Alignment : in out Boolean;
Static : in out Boolean);
procedure Number_Of_Ids (Object : Declarations.Object_Declaration;
Count : out Long_Natural) is
Ids : Ada_Program.Element_List := Declarations.Identifiers (Object);
Total : Long_Natural := 0;
begin
while not Ada_Program.Done (Ids) loop
Total := Total + 1;
Ada_Program.Next (Ids);
end loop;
Count := Total;
end Number_Of_Ids;
function Round_Up_To_Alignment
(Exact_Size : Long_Natural; Alignment : Long_Natural)
return Long_Natural is
begin
if Exact_Size mod Alignment = 0 then
return Exact_Size;
else
return ((Exact_Size / Alignment) + 1) * Alignment;
end if;
end Round_Up_To_Alignment;
procedure Expression_Value (Of_Expression : Ada.Element;
Result : out Long_Natural;
Static : out Boolean) is
begin
if Names_And_Expressions.Is_Static (Of_Expression) then
Result := Names_And_Expressions.Static_Value (Of_Expression);
Static := True;
else
Result := 0;
Static := False;
end if;
end Expression_Value;
procedure Access_Size (Of_Access : Types.Type_Definition;
Result : out Long_Natural;
Static : in out Boolean) is
begin
-- Storage_Size := Rep_Specs.Associated_Storage_Size (Of_Access);
-- could be used to compute the collection size
Result := Access_Type_Size;
Static := True;
end Access_Size;
function Size_Of_Dimension
(Lower_Bound, Upper_Bound : Long_Integer) return Long_Natural is
Size : Long_Natural;
begin
Size := Upper_Bound - Lower_Bound + 1;
return Size;
exception
when Constraint_Error =>
return 0;
when Numeric_Error =>
return 0;
end Size_Of_Dimension;
-- procedure Record_Rep_Spec_Size (Rep_Spec : Ada.Element;
-- Result : out Long_Natural;
-- Static : in out Boolean) is
-- Components : Ada.Element_Iterator;
-- Component : Ada.Element;
-- Current_Offset : Long_Natural := 0;
-- Current_Size, Max_Size : Long_Natural := 0;
-- Ubound, Lbound : Long_Integer := 0;
-- Non_Static_Lbound, Non_Static_Ubound : Ada.Element;
-- begin
-- Components := Rep_Specs.Clause_Components (Rep_Spec);
--
-- while not Ada.Done (Components) loop -- iterate through component
-- -- rep specs
-- Component := Ada.Value (Components);
--
-- if Rep_Specs.Valid_Component (Component) then
--
-- Expression_Value (Rep_Specs.Component_Offset (Component),
-- Current_Offset, Static);
-- Bounds_Utilities.Find_Range
-- (Rep_Specs.Component_Range (Component), Lbound, Ubound,
-- Static, Non_Static_Lbound, Non_Static_Ubound);
--
-- Current_Size := Current_Offset * Bytes + Ubound + 1;
--
-- if Current_Size > Max_Size then -- multiple offsets with
-- -- different ranges
-- Max_Size := Current_Size;
-- end if;
-- end if;
-- Ada.Next (Components);
-- end loop;
--
-- Result := Max_Size;
-- end Record_Rep_Spec_Size;
--
--
function Get_Referenced_Enum_Literal
(Constraint : Ada.Element) return Ada.Element is
Assocs : Ada.Element_Iterator :=
Type_Information.Discriminant_Associations (Constraint);
Elem : Ada.Element;
begin
while not Ada.Done (Assocs) loop
Elem := Ada.Value (Assocs);
case Names_And_Expressions.Kind (Elem) is
when Names_And_Expressions.An_Enumeration_Literal =>
return Ada.Definition (Elem);
when others =>
return Ada.Nil_Element;
end case;
end loop;
end Get_Referenced_Enum_Literal;
function Choice_Matches_Constraint
(Choices : Ada.Element_Iterator; Constraint : Ada.Element)
return Boolean is
Local_Choices : Ada.Element_Iterator := Choices;
Choice : Ada.Element;
Constraint_Literal : Ada.Element;
begin
if Ada.Is_Nil (Constraint) then
return False;
else
Constraint_Literal := Get_Referenced_Enum_Literal (Constraint);
end if;
while not Ada.Done (Local_Choices) loop
Choice := Ada.Value (Local_Choices);
case Type_Information.Choice_Kind (Choice) is
when Type_Information.A_Simple_Expression =>
return False;
when Type_Information.A_Discrete_Range =>
declare
Upper, Lower : Ada.Expression;
Lit_Pos, Ubound, Lbound : Long_Natural;
begin
Types.Bounds (Types.Choice_Range (Choice),
Lower, Upper);
Lbound := Lrm_Utilities.Static_Value (Lower);
Ubound := Lrm_Utilities.Static_Value (Upper);
Lit_Pos := Lrm_Utilities.Static_Value
(Constraint_Literal);
return Lit_Pos <= Ubound and Lit_Pos >= Lbound;
exception
when Lrm_Utilities.Not_Static =>
return False;
end;
when Type_Information.Others_Choice =>
return False;
-- return True; -- could be if
-- simple expressions are implemented
when Type_Information.An_Identifier_Reference =>
return Ada.Definition
(Type_Information.Choice_Identifier (Choice)) =
Constraint_Literal;
when Type_Information.Not_A_Choice =>
return False;
end case;
Ada.Next (Local_Choices);
end loop;
return False;
end Choice_Matches_Constraint;
procedure Component_List_Size
(Components : in out Ada.Element_Iterator;
With_Constraints : Type_Information.Type_Constraint;
Record_Discriminants_Have_Defaults : Boolean;
Result : out Long_Natural;
Requires_Alignment : in out Boolean;
Final_Static : in out Boolean) is
-- compute the total size of all components
Component_List : Ada_Program.Element_List;
Component, Component_Type : Ada.Element;
Current_Size, Temp_Size, Accume_Size : Long_Natural := 0;
Inner_Components : Ada.Element_Iterator;
Variant_Items : Ada.Element_List;
Component_Requires_Alignment : Boolean;
Variant_Component_Requires_Alignment : Boolean;
Variant : Ada.Element;
Variant_Choices : Ada.Element_Iterator;
Number_Of_Id_Decls : Long_Natural := 1;
Static : Boolean;
Node : Node_Data;
Found_Match : Boolean := False;
begin
Ada_Program.Copy (Components, Component_List);
Ada_Program.Invert (Component_List);
Result := 0;
Final_Static := True;
Requires_Alignment := False;
while not Ada.Done (Component_List) loop
Component := Ada.Value (Component_List);
Current_Size := 0;
case Types.Component_Kind (Component) is
when Types.A_Variable_Component =>
Number_Of_Ids (Component, Number_Of_Id_Decls);
Component_Type := Declarations.Object_Type (Component);
Size (Component_Type, Current_Size,
Component_Requires_Alignment, Static);
when Types.A_Variant_Part_Component =>
-- compute the size of the largest variant
-- unless constraint selects a variant
Ada_Program.Copy
(Types.Variant_Item_List (Component), Variant_Items);
Ada_Program.Invert (Variant_Items);
while not Ada.Done (Variant_Items) loop
Variant := Ada.Value (Variant_Items);
Variant_Choices :=
Type_Information.Variant_Choices (Variant);
Inner_Components :=
Types.Inner_Record_Components (Variant);
Component_List_Size
(Inner_Components, With_Constraints,
Record_Discriminants_Have_Defaults, Temp_Size,
Variant_Component_Requires_Alignment, Static);
Node.Level := Current_Level + 1;
Node.Elem := Variant;
Node.Size := Long_Natural'Last;
Node.Kind := Choice;
The_List := List.Make (Node, The_List);
if Static then
if not Record_Discriminants_Have_Defaults and then
not Found_Match and then
Choice_Matches_Constraint
(Variant_Choices, With_Constraints) then
Found_Match := True;
Current_Size := Temp_Size;
Component_Requires_Alignment :=
Variant_Component_Requires_Alignment;
exit; -- this variant is selected by the
-- constraint
elsif Temp_Size > Current_Size then
Current_Size := Temp_Size;
Component_Requires_Alignment :=
Variant_Component_Requires_Alignment;
end if;
else
Result := 0;
end if;
Ada.Next (Variant_Items);
end loop;
when Types.A_Null_Component =>
Current_Size := 0;
Static := True;
when Types.Not_A_Component =>
Result := 0;
Static := False;
end case;
if Static then
if Component_Requires_Alignment then
Requires_Alignment := True;
Accume_Size :=
Current_Size +
Number_Of_Id_Decls *
Round_Up_To_Alignment
(Accume_Size, Record_Component_Alignment);
else
Accume_Size := Accume_Size +
(Number_Of_Id_Decls * Current_Size);
end if;
else
Final_Static := Final_Static and Static;
end if;
Ada.Next (Component_List);
end loop;
if Final_Static then
Result := Accume_Size;
else
Result := 0;
end if;
end Component_List_Size;
function Has_Default_Values
(Discriminants : Ada.Element_Iterator) return Boolean is
Local : Ada.Element_Iterator := Discriminants;
Discriminant : Ada.Element;
begin
while not Ada.Done (Local) loop
Discriminant := Ada.Value (Local);
if Lrm_Utilities.Is_Initialized (Discriminant) then
return True;
end if;
Ada.Next (Local);
end loop;
return False;
end Has_Default_Values;
procedure Record_Size (Of_Record : Type_Information.Type_Definition;
With_Constraints : Type_Information.Type_Constraint;
Result : out Long_Natural;
Requires_Alignment : in out Boolean;
Static : in out Boolean) is
Record_Components : Ada.Element_Iterator;
begin
Record_Components := Types.Record_Components (Of_Record);
if Type_Information.Is_Discriminated (Of_Record) and then
Has_Default_Values (Type_Information.Discriminants (Of_Record)) then
Component_List_Size (Components => Record_Components,
With_Constraints => Ada.Nil_Element,
Record_Discriminants_Have_Defaults => True,
Result => Result,
Requires_Alignment => Requires_Alignment,
Final_Static => Static);
else
Component_List_Size (Components => Record_Components,
With_Constraints => With_Constraints,
Record_Discriminants_Have_Defaults => False,
Result => Result,
Requires_Alignment => Requires_Alignment,
Final_Static => Static);
end if;
end Record_Size;
procedure Number_Of_Elements
(Index_Constraints : Ada_Program.Element_Iterator;
Count : out Long_Natural;
Static : in out Boolean) is
Indices : Ada.Element_Iterator := Index_Constraints;
Index_Constraint : Types.Subtype_Indication;
Lower_Expression, Upper_Expression : Types.Expression;
Lower, Upper : Long_Integer;
Total_Elements : Long_Natural := 1;
begin
Static := True;
while not Ada.Done (Indices) loop
Index_Constraint := Ada.Value (Indices);
Bounds_Utilities.Find_Range (Index_Constraint, Lower, Upper, Static,
Lower_Expression, Upper_Expression);
exit when not Static;
Total_Elements := Total_Elements * Size_Of_Dimension (Lower, Upper);
Ada.Next (Indices);
end loop;
Count := Total_Elements;
end Number_Of_Elements;
function Is_Character (Type_Def : Types.Type_Definition) return Boolean is
Last : Ada.Element := Types.Last_Constraint (Type_Def);
begin
return String_Utilities.Equal (Ada.Image (Last), "CHARACTER") or else
String_Utilities.Equal
(Declarations.Name (Ada.Parent (Last)), "CHARACTER");
end Is_Character;
function Is_Boolean (Type_Def : Types.Type_Definition) return Boolean is
Last : Ada.Element := Types.Last_Constraint (Type_Def);
begin
return String_Utilities.Equal (Ada.Image (Last), "BOOLEAN") or else
String_Utilities.Equal
(Declarations.Name (Ada.Parent (Last)), "BOOLEAN");
end Is_Boolean;
procedure Array_Size (Of_Array : Type_Information.Type_Definition;
Index_Constraints : Ada_Program.Element_Iterator;
Result : out Long_Natural;
Static : in out Boolean) is
Array_Elements : Long_Natural;
Array_Component_Type : Types.Type_Definition;
Component_Size : Long_Natural;
Requires_Alignment : Boolean := False;
begin
Result := 0; Array_Component_Type := Types.Component_Type (Of_Array);
if Is_Character (Array_Component_Type) then -- string type
Component_Size := Character_Size;
elsif Is_Boolean (Array_Component_Type) then -- bit string
Component_Size := Boolean_Size;
else
Size (For_Type => Declarations.Type_Specification
(Ada_Program.Definition
(Array_Component_Type)),
Result => Component_Size,
Requires_Alignment => Requires_Alignment,
Static => Static);
Component_Size := Round_Up_To_Alignment
(Component_Size, Array_Component_Alignment);
end if;
if Static then
Number_Of_Elements (Index_Constraints, Array_Elements, Static);
if Static then
if Requires_Alignment then
Result := Array_Elements * Round_Up_To_Alignment
(Component_Size,
Record_Component_Alignment);
else
Result := Array_Elements * Component_Size;
end if;
end if;
end if;
end Array_Size;
procedure Find_Fixed_Constraints
(Ref_Id : Ada.Identifier_Reference := Ada.Nil_Element;
Root : Types.Type_Definition;
First : Types.Type_Constraint;
Range_Constraint : out Types.Type_Constraint;
Delta_Constraint : out Types.Type_Constraint) is
Got_Range, Got_Delta : Boolean := False;
Element : Ada.Element;
procedure Process_Constraint (Current : Types.Type_Constraint) is
begin
case Types.Constraint_Kind (Current) is
when Types.A_Simple_Range | Types.A_Range_Attribute =>
if not Got_Range then
Range_Constraint := Current;
Got_Range := True;
end if;
when Types.A_Fixed_Point_Constraint =>
if not Got_Delta then
Delta_Constraint := Current;
Got_Delta := True;
end if;
if not Got_Range and then
not Ada.Is_Nil (Types.Fixed_Point_Constraint
(Current)) then
Range_Constraint :=
Types.Fixed_Point_Constraint (Current);
Got_Range := True;
end if;
when others =>
null;
end case;
end Process_Constraint;
begin
Range_Constraint := Ada.Nil_Element;
Delta_Constraint := Ada.Nil_Element;
Element := Ref_Id;
Process_Constraint (First);
while not Got_Range or else not Got_Delta loop
if Ada.Is_Nil (Element) then
Process_Constraint (Types.Ground_Type (Root));
exit;
end if;
Element := Ada.Definition (Element);
exit when Ada.Is_Nil (Element); -- For Generic Formal types.
Element := Types.Last_Constraint
(Decls.Type_Specification (Element));
case Types.Kind (Element) is
when Types.A_Subtype_Indication =>
Process_Constraint (Types.Constraint (Element));
when Types.A_Fixed_Type_Definition =>
Process_Constraint (Element);
when others =>
exit; -- shouldn't happen
end case;
end loop;
end Find_Fixed_Constraints;
procedure Size (For_Type : Type_Information.Type_Definition;
Result : in out Long_Natural;
Requires_Alignment : in out Boolean;
Static : in out Boolean) is
Element : Ada.Element := Types.Last_Constraint (For_Type);
Ubound, Lbound : Long_Integer;
U_Bound, L_Bound : Float;
Digits_Accuracy : Long_Natural;
Constraint, Range_Constraint, Delta_Constraint : Types.Type_Constraint;
Is_Packed : Boolean;
Node : Node_Data;
begin
Current_Level := Current_Level + 1;
Node.Level := Current_Level;
Node.Elem := For_Type;
Result := 0;
Requires_Alignment := False;
loop
if Ada.Is_Nil (Element) then
Static := False;
exit;
end if;
case Types.Kind (Element) is
when Types.A_Subtype_Indication =>
Constraint := Types.Constraint (Element);
if Ada.Is_Nil (Constraint) then
-- Can't happen, LAST_CONSTRAINT returns
-- a constrained subtype or a base type ...
Static := False;
exit;
end if;
Size (Ref_Id => Types.Type_Mark (Element),
Original => Element,
Constraint => Constraint,
Result => Result,
Requires_Alignment => Requires_Alignment,
Static => Static);
exit;
when Types.An_Enumeration_Type_Definition =>
if Is_Character (Element) then
Result := Character_Size;
Static := True;
elsif Is_Boolean (Element) then
Result := Boolean_Size;
Static := True;
else
Bounds_Utilities.Enumeration_Range
(Element, Lbound, Ubound);
Result := Enumeration_Type_Size
(Lbound, Ubound, Is_Packed);
Static := Ubound >= Lbound;
end if;
exit;
when Types.An_Integer_Type_Definition =>
Bounds_Utilities.Integer_Range_Constraint_Bounds
(Types.Integer_Constraint (Element),
Lbound, Ubound, Static);
if Static then
Result := Integer_Type_Size (Lbound, Ubound);
end if;
exit;
when Types.A_Float_Type_Definition =>
Bounds_Utilities.Float_Range_Constraint_Bounds
(Types.Floating_Point_Constraint (Element),
L_Bound, U_Bound, Static);
Expression_Value
(Types.Digits_Accuracy_Definition (Element),
Digits_Accuracy, Static);
if Static then
Result := Float_Type_Size
(L_Bound, U_Bound, Digits_Accuracy);
end if;
exit;
when Types.A_Task_Type_Definition =>
Result := Task_Type_Size;
Static := True;
Requires_Alignment := True;
exit;
when Types.A_Fixed_Type_Definition =>
Find_Fixed_Constraints
(Root => Element,
First => Element,
Range_Constraint => Range_Constraint,
Delta_Constraint => Delta_Constraint);
Bounds_Utilities.Fixed_Range_Constraint_Bounds
(Delta_Constraint, Range_Constraint,
Lbound, Ubound, Static);
if Static then
Result := Integer_Type_Size (Lbound, Ubound, Is_Packed);
exit;
end if;
when Types.An_Array_Type_Definition =>
if Type_Information.Is_Constrained_Array (Element) then
Array_Size (Element, Types.Index_Constraints (Element),
Result, Static);
declare
Node : Node_Data;
begin
Node.Level := Current_Level;
Node.Elem := Element;
Node.Size := Long_Natural'Last;
Node.Kind := Array_Index;
The_List := List.Make (Node, The_List);
end;
else
Static := False;
end if;
exit;
when Types.An_Access_Type_Definition =>
Access_Size (Element, Result, Static);
Requires_Alignment := True;
exit;
when Types.A_Record_Type_Definition =>
Record_Size (Element, Ada_Program.Nil_Element,
Result, Requires_Alignment, Static);
Node.Elem := Element;
if Type_Information.Is_Discriminated (Element) then
declare
Node : Node_Data;
begin
Node.Level := Current_Level;
Node.Elem := Element;
Node.Size := Long_Natural'Last;
Node.Kind := Discriminant;
The_List := List.Make (Node, The_List);
end;
end if;
exit;
when Types.A_Derived_Type_Definition =>
Element := Types.Last_Constraint
(Types.Derived_From (Element));
-- loop on type that was derived
when Types.A_Private_Type_Definition ..
Types.A_Limited_Private_Type_Definition =>
Element := Declarations.Enclosing_Declaration (Element);
Element := Ada_Program.Definition (Element);
when Types.Not_A_Type_Definition =>
Result := 0;
Static := False;
exit;
end case;
end loop;
Node.Size := Result;
Node.Static := Static;
The_List := List.Make (Node, The_List);
Current_Level := Current_Level - 1;
end Size;
procedure Size (Ref_Id : Ada_Program.Identifier_Reference :=
Ada_Program.Nil_Element;
Original : Type_Information.Type_Definition;
Constraint : Type_Information.Type_Constraint;
Result : in out Long_Natural;
Requires_Alignment : in out Boolean;
Static : in out Boolean) is
Ground : Types.Type_Definition := Types.Ground_Type (Original);
Range_Constraint, Delta_Constraint : Types.Type_Constraint;
Lbound, Ubound : Long_Integer;
L_Bound, U_Bound : Float;
Digits_Accuracy : Long_Natural;
Is_Packed : Boolean;
Node : Node_Data;
begin
Result := 0;
Requires_Alignment := False;
case Types.Kind (Ground) is
when Types.An_Enumeration_Type_Definition =>
Bounds_Utilities.Enumeration_Range_Constraint_Bounds
(Constraint, Lbound, Ubound, Static);
if Static then
Result := Enumeration_Type_Size (Lbound, Ubound, Is_Packed);
else
Result := 0;
end if;
when Types.An_Integer_Type_Definition =>
Bounds_Utilities.Integer_Range_Constraint_Bounds
(Constraint, Lbound, Ubound, Static);
if Static then
Result := Integer_Type_Size (Lbound, Ubound, Is_Packed);
else
Result := 0;
end if;
when Types.A_Fixed_Type_Definition =>
Find_Fixed_Constraints (Ref_Id => Ref_Id,
Root => Constraint,
First => Constraint,
Range_Constraint => Range_Constraint,
Delta_Constraint => Delta_Constraint);
Bounds_Utilities.Fixed_Range_Constraint_Bounds
(Delta_Constraint, Range_Constraint, Lbound, Ubound, Static);
if Static then
Result := Integer_Type_Size (Lbound, Ubound, Is_Packed);
else
Result := 0;
end if;
when Types.A_Float_Type_Definition =>
Bounds_Utilities.Float_Range_Constraint_Bounds
(Constraint, L_Bound, U_Bound, Static);
Expression_Value (Types.Digits_Accuracy_Definition (Ground),
Digits_Accuracy, Static);
if Static then
Result := Float_Type_Size
(L_Bound, U_Bound, Digits_Accuracy);
end if;
when Types.An_Array_Type_Definition =>
Array_Size (Ground, Types.Discrete_Ranges (Constraint),
Result, Static);
Node.Level := Current_Level;
Node.Elem := Constraint;
Node.Size := Long_Natural'Last;
Node.Kind := Index_Constraint;
The_List := List.Make (Node, The_List);
when Types.A_Record_Type_Definition =>
Record_Size (Ground, Constraint, Result,
Requires_Alignment, Static);
Node.Level := Current_Level;
Node.Elem := Constraint;
Node.Size := Long_Natural'Last;
Node.Kind := Discriminant_Constraint;
The_List := List.Make (Node, The_List);
when others =>
-- Can't happen ...
Result := 0;
Static := False;
end case;
end Size;
function Indent (Level : Natural; Image : String; Char : Character := ' ')
return String is
Dots : constant String (1 .. Level) := (others => Char);
begin
return Dots & String_Utilities.Strip (Image);
end Indent;
function Choices_Image (Variant : Ada_Program.Element) return String is
Im : Unbounded.Variable_String;
Choices : Ada_Program.Element_Iterator :=
Type_Information.Variant_Choices (Variant);
begin
Unbounded.Copy (Im, "when ");
while not Ada_Program.Done (Choices) loop
Unbounded.Append (Im, Ada_Program.Image
(Ada_Program.Value (Choices)));
Ada_Program.Next (Choices);
if not Ada_Program.Done (Choices) then
Unbounded.Append (Im, " | ");
end if;
end loop;
return Unbounded.Image (Im);
end Choices_Image;
function Discrim_Image (Type_Def : Ada_Program.Element) return String is
Im : Unbounded.Variable_String;
Discrims : Ada_Program.Element_Iterator :=
Type_Information.Discriminants (Type_Def);
begin
while not Ada_Program.Done (Discrims) loop
Unbounded.Append (Im, Ada_Program.Image
(Ada_Program.Value (Discrims)));
Ada_Program.Next (Discrims);
if not Ada_Program.Done (Discrims) then
Unbounded.Append (Im, "; ");
end if;
end loop;
return Unbounded.Image (Im);
end Discrim_Image;
function Index_Image (Type_Def : Ada_Program.Element) return String is
Im : Unbounded.Variable_String;
Indexes : Ada_Program.Element_Iterator :=
Type_Information.Index_Constraints (Type_Def);
begin
while not Ada_Program.Done (Indexes) loop
Unbounded.Append (Im, Ada_Program.Image
(Ada_Program.Value (Indexes)));
Ada_Program.Next (Indexes);
if not Ada_Program.Done (Indexes) then
Unbounded.Append (Im, ", ");
end if;
end loop;
return Unbounded.Image (Im);
end Index_Image;
function Kind (Type_Def : Ada_Program.Element;
Ground : Ada_Program.Element;
Spec_Kind : Special_Kind) return String;
function Kind (Type_Def : Ada_Program.Element;
Ground : Ada_Program.Element;
Spec_Kind : Special_Kind) return String is
Decl : Ada_Program.Element := Declarations.Enclosing_Declaration
(Ada_Program.Definition (Type_Def));
begin
case Spec_Kind is
when Choice =>
return Choices_Image (Type_Def);
when Array_Index =>
return Index_Image (Type_Def);
when Index_Constraint =>
return Ada.Image (Type_Def);
when Discriminant =>
return Discrim_Image (Type_Def);
when Discriminant_Constraint =>
return Ada.Image (Type_Def);
when Not_Special =>
if Ada_Program.Is_Nil (Decl) then
Decl := Declarations.Enclosing_Declaration (Type_Def);
end if;
if Declarations.Is_Generic_Formal
(Declarations.Enclosing_Declaration (Type_Def)) then
return "GEN FORMAL";
elsif Declarations.Is_Private (Decl) then
return "P(" & Kind (Ground, Ground, Spec_Kind) & ")";
elsif Declarations.Is_Limited (Decl) then
return "LP(" & Kind (Ground, Ground, Spec_Kind) & ")";
end if;
case Type_Information.Kind (Ground) is
when Type_Information.A_Subtype_Indication =>
return "SUBTYPE";
when Type_Information.An_Enumeration_Type_Definition =>
if Type_Information.Is_Predefined (Ground) then
if Is_Boolean (Ground) then
return "BOOLEAN";
else
return "CHARACTER";
end if;
else
return "ENUM";
end if;
when Type_Information.An_Integer_Type_Definition =>
return "INTEGER";
when Type_Information.A_Float_Type_Definition =>
return "FLOAT";
when Type_Information.A_Fixed_Type_Definition =>
return "FIXED";
when Type_Information.An_Array_Type_Definition =>
if Is_Character (Types.Component_Type (Ground)) then
return "STRING";
else
return "ARRAY";
end if;
when Type_Information.A_Record_Type_Definition =>
return "RECORD";
when Type_Information.An_Access_Type_Definition =>
return "ACCESS";
when Type_Information.A_Derived_Type_Definition =>
return "DERIVED";
when Type_Information.A_Task_Type_Definition =>
return "TASK";
when Type_Information.A_Private_Type_Definition =>
return "";
when Type_Information.A_Limited_Private_Type_Definition =>
return "";
when Type_Information.Not_A_Type_Definition =>
return "UNKNOWN";
end case;
end case;
exception
when others =>
return Ada_Program.Image (Type_Def);
end Kind;
function Image (Kind : Special_Kind) return String is
begin
case Kind is
when Array_Index =>
return "^INDEX";
when Index_Constraint =>
return "^CONSTRAINT";
when Discriminant =>
return "^DISCRIMS";
when Discriminant_Constraint =>
return "^CONSTRAINT";
when Choice =>
return ">>CHOICE";
when Not_Special =>
return "";
end case;
end Image;
procedure Display (Type_Decl : Ada_Program.Declaration;
Type_Sizing_File_Name : String :=
"!toolkit.analysis.ada_analysis'view" &
".units.type_sizing_for_r1000";
To_Preview_Object : String := "type_display") is
Requires_Alignment : Boolean;
Type_Def : Ada_Program.Element :=
Declarations.Type_Specification (Type_Decl);
Status : Errors.Condition;
Document : Abstract_Document.Handle;
Node : Node_Data;
Iter : List.Iterator;
Local_Size : Long_Natural;
Static : Boolean;
package Table is new Table_Formatter (2);
procedure Add_Node_To_Display (Node : Node_Data) is
Expression : constant String :=
Unbounded.Image (Node.Size_Expression);
begin
if Node.Size = Long_Natural'Last then
Table.Item ("");
elsif Node.Size = 0 then
if Expression = "" then
Table.Item
(Indent (Node.Level, "NS", '.'),
Explanation =>
"Size cannot be statically computed, expression unknown");
else
Table.Item
(Indent (Node.Level, "NS", '.'),
Explanation =>
"Size cannot be statically computed, expression: " &
Expression);
end if;
else
Table.Item (Indent (Node.Level,
Long_Natural'Image (Node.Size / 8), '.'),
Explanation => "Size in bytes");
end if;
if Node.Kind = Not_Special then
Table.Item (Indent (4 * (Node.Level - 1),
Declarations.Name
(Declarations.Enclosing_Declaration
(Node.Elem)) &
" : " & Kind (Node.Elem,
Type_Information.Ground_Type
(Node.Elem),
Node.Kind)),
Explanation => "Name and kind of the component",
Linkage => Node.Elem);
else
Table.Item (Indent (4 * (Node.Level - 1), Image (Node.Kind)) &
" - " & Kind (Node.Elem, Node.Elem, Node.Kind),
Explanation => "Name and kind of the component",
Linkage => Node.Elem);
end if;
end Add_Node_To_Display;
begin
Current_Level := 0;
Size (Type_Def, Local_Size, Requires_Alignment, Static);
Table.Header ("Size");
Table.Header ("Items");
List.Init (Iter, The_List);
while not List.Done (Iter) loop
Add_Node_To_Display (List.Value (Iter));
List.Next (Iter);
end loop;
Ad.Create (Document, To_Preview_Object, Status);
Ad_Specify.Cover (Document, "INFORMATION");
Ad_Specify.Cover_Item (Document, "");
Ad_Specify.Paragraph (Document, 1, "");
Table.Display (Document, "EXPLODED TYPE DISPLAY");
Ad.Close (Document);
Common.Definition (To_Preview_Object);
end Display;
procedure Display_Selected_Type
(Type_Sizing_File_Name : String :=
"!toolkit.analysis.ada_analysis'view" &
".units.type_sizing_for_r1000";
To_Preview_Object : String := "type_display") is
Decl : Ada_Program.Element :=
Declarations.Enclosing_Declaration
(Ada_Program.Conversion.Resolve (Object_Editor.Get_Name));
begin
Sizing_Parameters.Initialize ("_" & Type_Sizing_File_Name);
case Declarations.Kind (Decl) is
when Declarations.A_Type_Declaration |
Declarations.A_Task_Type_Declaration |
Declarations.A_Subtype_Declaration =>
Display (Decl, To_Preview_Object);
when others =>
Editor.Alert;
Io.Echo_Line ("Image is not a type declaration");
end case;
end Display_Selected_Type;
end Type_Display;
nblk1=49
nid=2
hdr6=90
[0x00] rec0=27 rec1=00 rec2=01 rec3=048
[0x01] rec0=19 rec1=00 rec2=49 rec3=016
[0x02] rec0=00 rec1=00 rec2=31 rec3=07e
[0x03] rec0=17 rec1=00 rec2=30 rec3=072
[0x04] rec0=01 rec1=00 rec2=03 rec3=018
[0x05] rec0=1b rec1=00 rec2=04 rec3=05e
[0x06] rec0=1d rec1=00 rec2=05 rec3=00c
[0x07] rec0=13 rec1=00 rec2=06 rec3=07e
[0x08] rec0=1d rec1=00 rec2=07 rec3=00c
[0x09] rec0=00 rec1=00 rec2=48 rec3=004
[0x0a] rec0=18 rec1=00 rec2=08 rec3=070
[0x0b] rec0=01 rec1=00 rec2=47 rec3=00a
[0x0c] rec0=13 rec1=00 rec2=09 rec3=00e
[0x0d] rec0=00 rec1=00 rec2=46 rec3=004
[0x0e] rec0=1b rec1=00 rec2=0a rec3=04c
[0x0f] rec0=01 rec1=00 rec2=45 rec3=004
[0x10] rec0=1c rec1=00 rec2=0b rec3=006
[0x11] rec0=00 rec1=00 rec2=44 rec3=058
[0x12] rec0=16 rec1=00 rec2=0c rec3=07e
[0x13] rec0=00 rec1=00 rec2=43 rec3=010
[0x14] rec0=17 rec1=00 rec2=0d rec3=00a
[0x15] rec0=00 rec1=00 rec2=42 rec3=008
[0x16] rec0=1b rec1=00 rec2=0e rec3=01e
[0x17] rec0=00 rec1=00 rec2=41 rec3=01a
[0x18] rec0=1c rec1=00 rec2=0f rec3=05c
[0x19] rec0=00 rec1=00 rec2=40 rec3=00e
[0x1a] rec0=18 rec1=00 rec2=10 rec3=090
[0x1b] rec0=15 rec1=00 rec2=11 rec3=050
[0x1c] rec0=00 rec1=00 rec2=3f rec3=012
[0x1d] rec0=1d rec1=00 rec2=12 rec3=01e
[0x1e] rec0=17 rec1=00 rec2=13 rec3=002
[0x1f] rec0=00 rec1=00 rec2=3e rec3=038
[0x20] rec0=17 rec1=00 rec2=14 rec3=004
[0x21] rec0=17 rec1=00 rec2=15 rec3=028
[0x22] rec0=00 rec1=00 rec2=3d rec3=01a
[0x23] rec0=19 rec1=00 rec2=16 rec3=056
[0x24] rec0=01 rec1=00 rec2=3c rec3=022
[0x25] rec0=1c rec1=00 rec2=17 rec3=000
[0x26] rec0=01 rec1=00 rec2=3b rec3=010
[0x27] rec0=1f rec1=00 rec2=18 rec3=02a
[0x28] rec0=00 rec1=00 rec2=36 rec3=01a
[0x29] rec0=16 rec1=00 rec2=19 rec3=00c
[0x2a] rec0=15 rec1=00 rec2=1a rec3=034
[0x2b] rec0=15 rec1=00 rec2=1b rec3=016
[0x2c] rec0=00 rec1=00 rec2=3a rec3=030
[0x2d] rec0=13 rec1=00 rec2=1c rec3=074
[0x2e] rec0=00 rec1=00 rec2=39 rec3=004
[0x2f] rec0=17 rec1=00 rec2=1d rec3=04a
[0x30] rec0=00 rec1=00 rec2=38 rec3=008
[0x31] rec0=19 rec1=00 rec2=1e rec3=000
[0x32] rec0=01 rec1=00 rec2=37 rec3=006
[0x33] rec0=19 rec1=00 rec2=1f rec3=032
[0x34] rec0=01 rec1=00 rec2=35 rec3=008
[0x35] rec0=16 rec1=00 rec2=20 rec3=064
[0x36] rec0=13 rec1=00 rec2=21 rec3=016
[0x37] rec0=16 rec1=00 rec2=22 rec3=046
[0x38] rec0=01 rec1=00 rec2=34 rec3=00e
[0x39] rec0=1a rec1=00 rec2=23 rec3=018
[0x3a] rec0=00 rec1=00 rec2=33 rec3=00a
[0x3b] rec0=19 rec1=00 rec2=24 rec3=02c
[0x3c] rec0=00 rec1=00 rec2=32 rec3=016
[0x3d] rec0=19 rec1=00 rec2=25 rec3=060
[0x3e] rec0=17 rec1=00 rec2=26 rec3=000
[0x3f] rec0=14 rec1=00 rec2=27 rec3=00a
[0x40] rec0=12 rec1=00 rec2=28 rec3=034
[0x41] rec0=1d rec1=00 rec2=29 rec3=072
[0x42] rec0=1a rec1=00 rec2=2a rec3=050
[0x43] rec0=01 rec1=00 rec2=2f rec3=010
[0x44] rec0=14 rec1=00 rec2=2b rec3=068
[0x45] rec0=1a rec1=00 rec2=2c rec3=016
[0x46] rec0=19 rec1=00 rec2=2d rec3=00e
[0x47] rec0=0b rec1=00 rec2=2e rec3=000
[0x48] rec0=00 rec1=00 rec2=00 rec3=000
tail 0x21700171a815c63f74ef5 0x42a00088462061e03
Free Block Chain:
0x2: 0000 00 00 00 33 80 30 61 69 6e 74 20 20 20 20 20 20 ┆ 3 0aint ┆