|
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 ┆