|
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: 67584 (0x10800)
Types: Ada Source
Notes: 03_class, FILE, Long Ada Source, R1k_Segment, e3_tag, generic, package body Lrm_Utilities, seg_028aed
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Unbounded_String;
with String_Utilities;
with Universal;
with Ada_Program;
with Diana;
with Lrm_Renames;
use Lrm_Renames;
package body Lrm_Utilities is
package Unbounded is new Unbounded_String (80);
type State is
record
Data_Types_List : Ada.Element_List := Ada.Nil_List;
end record;
function Diana_Node (An_Element : Ada_Program.Element) return Diana.Tree
renames Ada_Program.Conversion.Convert;
function Count (Elements : Ada_Program.Element_Iterator) return Natural is
Iter : Ada_Program.Element_Iterator := Elements;
Count : Natural := 0;
begin
while not Ada_Program.Done (Iter) loop
Count := Count + 1;
Ada_Program.Next (Iter);
end loop;
return Count;
end Count;
function Count (Elements : Ada_Program.Element_List) return Natural is
Iter : Ada_Program.Element_List := Elements;
Count : Natural := 0;
begin
while not Ada_Program.Done (Iter) loop
Count := Count + 1;
Ada_Program.Next (Iter);
end loop;
return Count;
end Count;
function Ground_Type (Type_Def : Ada_Program.Type_Definition)
return Ada_Program.Type_Definition is
Local : Ada.Element := Type_Def;
begin
loop
case Types.Kind (Local) is
when Types.A_Subtype_Indication =>
Local := Decls.Type_Specification
(Ada.Definition (Types.Type_Mark (Local)));
when Types.A_Derived_Type_Definition =>
Local := Types.Derived_From (Local);
when others =>
return Local;
end case;
end loop;
end Ground_Type;
function Is_Named_Loop
(Loop_Statement : Ada_Program.Statement) return Boolean is
begin
case Diana.Kind (Ada.Conversion.Convert (Loop_Statement)) is
when Diana.Dn_Named_Stm =>
return True;
when others =>
return False;
end case;
end Is_Named_Loop;
function Get_Named_Loop (Statement_Element : Ada_Program.Element)
return Ada_Program.Statement is
Tree : Diana.Tree := Ada.Conversion.Convert (Statement_Element);
begin
case Diana.Kind (Tree) is
when Diana.Dn_Named_Stm =>
return Ada.Conversion.Convert (Diana.As_Stm (Tree));
when others =>
raise Ada.Inappropriate_Program_Element;
end case;
end Get_Named_Loop;
function Loop_Name (Named_Loop : Ada_Program.Element) return String is
Tree : Diana.Tree := Ada.Conversion.Convert (Named_Loop);
begin
case Diana.Kind (Tree) is
when Diana.Dn_Named_Stm =>
return Diana.Image (Diana.Lx_Symrep (Diana.As_Id (Tree)));
when others =>
raise Ada.Inappropriate_Program_Element;
end case;
end Loop_Name;
function Is_Named_Parameter_Id
(Id_Ref : Ada_Program.Identifier_Reference) return Boolean is
Elem_Diana : Diana.Tree := Ada_Program.Conversion.Convert (Id_Ref);
begin
case Diana.Kind (Elem_Diana) is
when Diana.Dn_Used_Name_Id =>
case Diana.Kind (Diana.As_Parent (Elem_Diana)) is
when Diana.Dn_Choice_S =>
return True;
when others =>
return False;
end case;
when others =>
return False;
end case;
end Is_Named_Parameter_Id;
function Is_Actual_Declaration
(Item : Ada_Program.Element) return Boolean is
begin
return Item = Declarations.Enclosing_Declaration (Item);
end Is_Actual_Declaration;
function Is_Initialized
(Object_Decl : Declarations.Object_Declaration)
return Boolean is
Decl : Diana.Tree := Diana_Node (Object_Decl);
begin
if Diana."=" (Diana.Kind (Decl), Diana.Dn_Dscrmt_Var) then
return not Diana.Is_Empty (Diana.As_Object_Def (Decl));
else
return Declarations.Is_Initialized (Object_Decl);
end if;
end Is_Initialized;
function In_Scope (Subprogram_Name : String;
Of_Element : Ada_Program.Element) return Boolean is
Found : Boolean := False;
Scope : Ada_Program.Element;
Scope_Kind : Ada_Program.Element_Kinds;
Decl_Kind : Declarations.Declaration_Kinds;
Decl_List : Ada_Program.Element_Iterator;
begin
Scope := Ada_Program.Parent (Of_Element);
Scope_Kind := Ada_Program.Kind (Scope);
case Scope_Kind is
when Ada.A_Declaration =>
Decl_Kind := Declarations.Kind (Scope);
case Decl_Kind is
when Declarations.A_Package_Body_Declaration =>
Decl_List :=
Stmts.Declarative_Items
(Declarations.Package_Body_Block (Scope));
when Declarations.A_Procedure_Body_Declaration |
Declarations.A_Function_Body_Declaration =>
Decl_List := Stmts.Declarative_Items
(Declarations.Subprogram_Block (Scope));
when Declarations.A_Task_Body_Declaration =>
Decl_List := Stmts.Declarative_Items
(Declarations.Task_Body_Block (Scope));
when Declarations.A_Package_Declaration =>
Decl_List :=
Declarations.Visible_Part_Declarations (Scope);
when Declarations.Not_A_Declaration =>
--if Scope /= Ada_Program.Nil_Element and then
-- stmts.Kind (Scope) =
--stmts.A_Block_Statement then
--Decl_List := stmts.Declarative_Items (Scope);
--else
return False;
--end if;
when others =>
return False;
end case;
when Ada.A_Compilation_Unit =>
declare
Unit : Ada.Element := Comp_Units.Unit_Declaration (Scope);
Unit_Kind : Declarations.Declaration_Kinds :=
Declarations.Kind (Unit);
begin
if (Unit_Kind = Declarations.A_Procedure_Declaration or else
Unit_Kind = Declarations.
A_Function_Declaration) and then
String_Utilities.Equal
(Declarations.Name (Unit), Subprogram_Name) then
return True;
else
return False;
end if;
end;
when Ada.A_Statement =>
if Stmts.Kind (Scope) = Stmts.A_Block_Statement then
Decl_List := Stmts.Declarative_Items (Scope);
else
return False;
end if;
when others =>
return False;
end case;
while not Ada_Program.Done (Decl_List) loop
declare
A_Decl : Ada_Program.Element;
begin
A_Decl := Ada_Program.Value (Decl_List);
Decl_Kind := Declarations.Kind (A_Decl);
if (Decl_Kind = Declarations.A_Procedure_Declaration or else
Decl_Kind = Declarations.
A_Procedure_Body_Declaration or else
Decl_Kind = Declarations.A_Function_Declaration or else
Decl_Kind = Declarations.
A_Function_Body_Declaration) and then
String_Utilities.Equal
(Declarations.Name (A_Decl), Subprogram_Name) then
Found := True;
exit;
end if;
Ada_Program.Next (Decl_List);
end;
end loop;
return Found;
end In_Scope;
generic
type T is private;
with function Static_Value (Expr : Ada_Program.Expression) return T;
function Look_Through (Expr : Ada_Program.Expression) return T;
function Look_Through (Expr : Ada_Program.Expression) return T is
begin
case Exprs.Kind (Expr) is
when Exprs.An_Attribute =>
declare
Att_Name : constant String :=
Ada_Program.Image
(Exprs.Attribute_Designator_Name (Expr));
Type_Spec : Ada_Program.Element :=
Declarations.Type_Specification
(Ada_Program.Definition (Expr));
Constraint : Ada_Program.Element;
Range_Info : Ada_Program.Element;
Ubound, Lbound : Ada_Program.Element;
begin
loop
case Types.Kind (Type_Spec) is
when Types.A_Subtype_Indication =>
Constraint := Types.Constraint (Type_Spec);
case Types.Constraint_Kind (Constraint) is
when Types.A_Simple_Range =>
Range_Info := Constraint;
when Types.A_Floating_Point_Constraint =>
Range_Info :=
Types.Floating_Point_Constraint
(Constraint);
when Types.A_Fixed_Point_Constraint =>
Range_Info :=
Types.Fixed_Point_Constraint
(Constraint);
when others =>
Type_Spec := Declarations.
Type_Specification
(Ada_Program.Definition
(Type_Spec));
end case;
case Types.Constraint_Kind (Constraint) is
when Types.A_Simple_Range |
Types.A_Floating_Point_Constraint |
Types.A_Fixed_Point_Constraint =>
Types.Bounds (Range_Info,
Lbound, Ubound);
if String_Utilities.Equal
(Att_Name, "FIRST") then
return Static_Value (Lbound);
elsif String_Utilities.Equal
(Att_Name, "LAST") then
return Static_Value (Ubound);
else
raise Not_Static;
end if;
when others =>
null;
end case;
when Types.A_Derived_Type_Definition =>
Type_Spec := Types.Derived_From (Type_Spec);
when others =>
raise Not_Static;
end case;
end loop;
end;
when Exprs.A_Simple_Name | Exprs.A_Selected_Component =>
declare
Def : Ada.Element := Ada_Program.Definition (Expr);
begin
case Declarations.Kind (Def) is
when Declarations.A_Constant_Declaration =>
return Static_Value
(Declarations.Initial_Value (Def));
when others =>
raise Not_Static;
end case;
end;
when others =>
raise Not_Static;
end case;
end Look_Through;
function Integer_Look_Through is
new Look_Through (Long_Integer, Static_Value);
function Float_Look_Through is new Look_Through (Float, Static_Value);
function Static_Value (Expression : Ada_Program.Expression)
return Long_Integer is
Exp : Diana.Tree := Ada_Program.Conversion.Convert (Expression);
Li : Long_Integer;
begin
if Exprs.Is_Literal (Expression) then
return Exprs.Position_Number (Expression);
end if;
case Diana.Kind (Diana.Sm_Value (Exp)) is
when Diana.Integer_Valued =>
Li := Universal.Convert (Diana.Integer_Value
(Diana.Sm_Value (Exp)));
return Li;
when Diana.Float_Valued =>
raise Not_Static;
when Diana.No_Value | Diana.Uninitialized =>
return Integer_Look_Through (Expression);
end case;
exception
when others =>
raise Not_Static;
end Static_Value;
function Static_Value (Expression : Ada_Program.Expression) return Float is
Exp : Diana.Tree := Ada_Program.Conversion.Convert (Expression);
Fl : Float;
Ufl : Universal.Float;
begin
case Diana.Kind (Diana.Sm_Value (Exp)) is
when Diana.Float_Valued =>
Ufl := Diana.Float_Value (Diana.Sm_Value (Exp));
Fl := Universal.Convert (Ufl);
return Fl;
when Diana.Integer_Valued =>
raise Not_Static;
when others =>
return Float_Look_Through (Expression);
end case;
exception
when others =>
raise Not_Static;
end Static_Value;
function Is_Actual_Variable_Declaration
(Variable_Declaration : Ada_Program.Element) return Boolean is
Parent : Ada_Program.Element :=
Ada_Program.Parent (Variable_Declaration);
begin
case Declarations.Kind (Parent) is
when Declarations.A_Type_Declaration =>
return False;
when others =>
return True;
end case;
end Is_Actual_Variable_Declaration;
function Is_Library_Unit_Id
(Decl : Ada_Program.Declaration) return Boolean is
Parent : Ada_Program.Element;
begin
case Ada_Program.Id_Kind (Decl) is
when Ada_Program.An_Identifier_Definition =>
Parent := Ada_Program.Parent
(Declarations.Enclosing_Declaration (Decl));
return Ada_Program.Kind (Parent) =
Ada_Program.A_Compilation_Unit;
when others =>
return False;
end case;
end Is_Library_Unit_Id;
function Qualified_Reference
(Decl : Ada_Program.Declaration) return String is
Parent_Comp_Unit_Name : constant String :=
Declarations.Name (Comp_Units.Unit_Declaration
(Comp_Units.Parent_Compilation_Unit (Decl)));
function Parent_Name (Decl : Ada_Program.Declaration) return String is
Enclosing : Ada_Program.Declaration :=
Declarations.Enclosing_Declaration (Ada_Program.Parent (Decl));
begin
if Is_Actual_Declaration (Decl) or Is_Library_Unit_Id (Decl) then
null;
else
Enclosing := Declarations.Enclosing_Declaration
(Ada_Program.Parent (Enclosing));
end if;
declare
Name : constant String := Declarations.Name (Enclosing);
begin
if String_Utilities.Equal (Name, Parent_Comp_Unit_Name) then
return Name;
else
return Parent_Name (Enclosing) & "." & Name;
end if;
end;
end Parent_Name;
begin
if Is_Library_Unit_Id (Decl) or
String_Utilities.Equal ("Standard", Parent_Comp_Unit_Name) then
return Declarations.Name (Decl);
else
return Parent_Name (Decl) & "." & Declarations.Name (Decl);
end if;
end Qualified_Reference;
function Get_Full_Name (Simple_Name : Ada_Program.Element)
return Ada_Program.Element is
Local : Diana.Tree := Ada.Conversion.Convert (Simple_Name);
Parent : Diana.Tree;
begin
loop
Parent := Diana.As_Parent (Local);
case Diana.Kind (Parent) is
when Diana.Dn_Selected | Diana.Dn_Indexed =>
ocal := Parent;
when others =>
return Ada.Conversion.Convert (Local);
end case;
end loop;
end Get_Full_Name;
function Hash (Elem : Ada_Program.Element) return Integer is
Id : Long_Integer := Ada_Program.Conversion.Unique_Id (Elem);
begin
return Integer (Id mod Long_Integer (Integer'Last));
end Hash;
function Comp_Unit_Id (For_Element : Ada_Program.Element)
return Ada_Program.Identifier_Definition is
begin
return Ada.Value (Declarations.Identifiers
(Comp_Units.Unit_Declaration
(Comp_Units.Parent_Compilation_Unit
(For_Element))));
end Comp_Unit_Id;
function Pragma_Name (For_Pragma : Pragmas.Pragma_Kinds) return String is
begin
case For_Pragma is
when Pragmas.Controlled =>
return "Controlled";
when Pragmas.Elaborate =>
return "Elaborate";
when Pragmas.Inline =>
return "Inline";
when Pragmas.Interface =>
return "Interface";
when Pragmas.List =>
return "List";
when Pragmas.Memory_Size =>
return "Memory_Size";
when Pragmas.Optimize =>
return "Optimize";
when Pragmas.Pack =>
return "Pack";
when Pragmas.Page =>
return "Page";
when Pragmas.Priority =>
return "Priority";
when Pragmas.Shared =>
return "Shared";
when Pragmas.Storage_Unit =>
return "Storage_Unit";
when Pragmas.Suppress =>
return "Suppress";
when Pragmas.System_Name =>
return "System_Name";
when Pragmas.Bias_Key =>
return "Bias_Key";
when Pragmas.Closed_Private_Part =>
return "Closed_PRivate_Part";
when Pragmas.Disable_Deallocation =>
return "Disable_Deallocation";
when Pragmas.Enable_Deallocation =>
return "Enable_Deallocation";
when Pragmas.Loaded_Main =>
return "Loaded_Main";
when Pragmas.Main =>
return "Main";
when Pragmas.Module_Name =>
return "Module_Name";
when Pragmas.Must_Be_Constrained =>
return "Must_Be_Constrained";
when Pragmas.Open_Private_Part =>
return "Open_Private_Part";
when Pragmas.Page_Limit =>
return "Page_Limit";
when Pragmas.Private_Eyes_Only =>
return "Private_Eyes_Only";
when Pragmas.Subsystem =>
return "Subsystem";
when others =>
return "UNKNOWN";
end case;
end Pragma_Name;
function Is_Numeric_Type (Type_Decl : Ada_Program.Element) return Boolean is
Ground : Ada.Element := Types.Ground_Type
(Decls.Type_Specification (Type_Decl));
begin
case Types.Kind (Ground) is
when Types.An_Integer_Type_Definition |
Types.A_Float_Type_Definition |
Types.A_Fixed_Type_Definition =>
return True;
when others =>
return False;
end case;
end Is_Numeric_Type;
function Position_Number
(Enum_Lit_Or_Id : Ada_Program.Element) return Long_Integer is
Node : Diana.Tree;
begin
case Exprs.Kind (Enum_Lit_Or_Id) is
when Exprs.An_Enumeration_Literal =>
return Exprs.Position_Number (Enum_Lit_Or_Id);
when others =>
return Long_Integer (Diana.Sm_Pos (Ada.Conversion.Convert
(Enum_Lit_Or_Id)));
end case;
exception
when others =>
raise Ada.Inappropriate_Program_Element;
end Position_Number;
function Is_Name_Id (Elem : Ada_Program.Element) return Boolean is
Elem_Diana : Diana.Tree := Ada_Program.Conversion.Convert (Elem);
begin
case Diana.Kind (Elem_Diana) is
when Diana.Dn_Used_Name_Id =>
case Diana.Kind (Diana.As_Parent (Elem_Diana)) is
when Diana.Dn_Choice_S =>
return True;
when others =>
return False;
end case;
when others =>
return False;
end case;
end Is_Name_Id;
function Get_Component_Expression
(Named : String; In_Aggregate : Ada_Program.Element)
return Ada_Program.Element is
Components : Ada.Element_Iterator := Exprs.Components (In_Aggregate);
Component : Ada.Element;
Choice : Ada.Element;
Id : Ada.Element;
begin
while not Ada.Done (Components) loop
Component := Ada.Value (Components);
Choice := Ada.Value (Exprs.Component_Choices (Component));
Id := Types.Choice_Identifier (Choice);
if String_Utilities.Equal (Named, Ada.String_Name (Id)) then
return (Exprs.Component_Expression (Component));
end if;
Ada.Next (Components);
end loop;
raise No_Component;
end Get_Component_Expression;
function Is_Boolean
(Type_Def : Type_Information.Type_Definition) return Boolean is
Type_Decl : Ada_Program.Element :=
Declarations.Enclosing_Declaration (Type_Def);
begin
return String_Utilities.Equal
("BOOLEAN", Declarations.Name
(Declarations.Enclosing_Declaration
(Type_Decl)));
end Is_Boolean;
function Is_Character_Literal (Elem : Ada.Element) return Boolean is
Node : Diana.Tree := Ada.Conversion.Convert (Elem);
begin
case Diana.Kind (Node) is
when Diana.Dn_Def_Char =>
return True;
when others =>
return False;
end case;
end Is_Character_Literal;
function Is_Character (Enum_Type_Def : Type_Information.Type_Definition)
return Boolean is
Lits : Ada.Element_Iterator;
A_Lit : Ada.Element;
begin
Lits := Type_Information.Enumeration_Literals (Enum_Type_Def);
while not Ada.Done (Lits) loop
A_Lit := Ada.Value (Lits);
if Is_Character_Literal (A_Lit) then
-- character types are those with a least one
-- character literal in their enumeration list.
return True;
end if;
Ada.Next (Lits);
end loop;
return False;
end Is_Character;
function Get_Kind (Type_Def : Type_Information.Type_Definition)
return Type_Kinds is
begin
if Ada_Program.Is_Nil (Type_Def) then
return None_Of_Above; -- perhaps an incomplete type
end if;
case Type_Information.Kind (Type_Def) is
when Type_Information.A_Subtype_Indication =>
return A_Subtype;
when Type_Information.An_Enumeration_Type_Definition =>
if Is_Character (Type_Def) then
return A_Character_Type;
elsif Type_Information.Is_Predefined (Type_Def) and then
Is_Boolean (Type_Def) then
return A_Boolean_Type;
else
return An_Enumeration;
end if;
when Type_Information.An_Integer_Type_Definition =>
return An_Integer_Type;
when Type_Information.A_Float_Type_Definition =>
return A_Float_Type;
when Type_Information.A_Fixed_Type_Definition =>
return A_Fixed_Type;
when Type_Information.An_Array_Type_Definition =>
declare
Comp_Type : Ada_Program.Element;
Comp_Id : Ada_Program.Element;
begin
Comp_Type := Type_Information.Component_Type (Type_Def);
Comp_Id := Ada_Program.Definition (Comp_Type);
case Get_Kind (Declarations.Type_Specification (Comp_Id)) is
when A_Character_Type =>
return A_String_Type;
when others =>
return An_Array_Type;
end case;
exception
when others =>
return An_Array_Type;
end;
when Type_Information.A_Record_Type_Definition =>
return A_Record_Type;
when Type_Information.An_Access_Type_Definition =>
return An_Access_Type;
when Type_Information.A_Derived_Type_Definition =>
return A_Derived_Type;
when Type_Information.A_Task_Type_Definition =>
return A_Task_Type;
when Type_Information.A_Private_Type_Definition =>
return A_Private_Type;
when Type_Information.A_Limited_Private_Type_Definition =>
return A_Limited_Private_Type;
when Type_Information.Not_A_Type_Definition =>
declare
Tree : Diana.Tree := Ada.Conversion.Convert (Type_Def);
begin
case Diana.Kind (Tree) is
when Diana.Dn_Universal_Real =>
return A_Float_Type;
when Diana.Dn_Universal_Fixed =>
return A_Fixed_Type;
when Diana.Dn_Universal_Integer =>
return An_Integer_Type;
when others =>
return None_Of_Above;
end case;
end;
end case;
end Get_Kind;
function Last_Line_Number
(For_This_Element : Ada_Program.Element) return Natural is
The_Image : Ada_Program.Line_Iterator :=
Ada_Program.Image (For_This_Element);
Current_Line : Natural := Ada_Program.Line_Number (For_This_Element);
begin
while not Ada_Program.Done (The_Image) loop
Current_Line := Current_Line + 1; Ada_Program.Next (The_Image);
end loop;
return Current_Line - 1;
end Last_Line_Number;
procedure Analyze_Element (This_Element : in Ada.Element;
With_State : in out State;
And_Control : in out Ada.Traversal_Control) is
Declaration_Kind : Decls.Declaration_Kinds :=
Decls.Kind (A_Declaration => This_Element);
begin
if Declaration_Kind = Decls.A_Type_Declaration or
Declaration_Kind = Decls.A_Subtype_Declaration then
Ada.Append (Program_Element => This_Element,
To_List => With_State.Data_Types_List);
And_Control := Ada.Abandon_Children;
else
And_Control := Ada.Continue;
end if;
end Analyze_Element;
procedure No_Op (This_Element : in Ada.Element;
With_State : in out State;
And_Control : in out Ada.Traversal_Control) is
begin
And_Control := Ada.Continue;
end No_Op;
procedure Traverse_For_Types is new Ada.Depth_First_Traversal
(State, Analyze_Element, No_Op);
function Types_Defined (In_This_Ada_Unit : in String)
return Ada_Program.Element_List is
The_State : State;
The_Comp_Unit : Ada.Compilation_Unit :=
Comp_Units.Parent_Compilation_Unit
(Of_Program_Element =>
Ada.Conversion.Resolve
(Element_Name => "\" & In_This_Ada_Unit));
begin
Traverse_For_Types (The_Comp_Unit,
The_State,
Major_Elements_Only => False);
return The_State.Data_Types_List;
end Types_Defined;
function Last_Rep_Clause (For_This_Type_Definition : Ada_Program.Element)
return Ada_Program.Element is
Size_Rep_Spec : Ada.Element :=
Rep_Specs.Associated_Size (For_This_Type_Definition);
function Enum_Rep_Clause
(This_Type_Def : Ada.Element) return Ada.Element is
type Type_Defs is
record
The_Definition : Ada.Element := This_Type_Def;
Rep_Spec : Ada.Element := Ada.Nil_Element;
end record;
The_Def : Type_Defs;
procedure Pre_Op (The_Element : Ada.Element;
Type_Def : in out Type_Defs;
Control : in out Ada.Traversal_Control) is
begin
case Rep_Specs.Kind (The_Element) is
when Rep_Specs.An_Enumeration_Representation_Clause =>
if Ada."=" (Type_Def.The_Definition,
Rep_Specs.Associated_Type
(The_Element)) then
Type_Def.Rep_Spec := The_Element;
Control := Ada.Terminate_Immediately;
end if;
when others =>
null;
end case;
end Pre_Op;
procedure Post_Op (The_Element : Ada.Element;
Curr_State : in out Type_Defs;
Control : in out Ada.Traversal_Control) is
begin
Control := Ada.Continue;
end Post_Op;
procedure Traverse_Unit is new Ada.Depth_First_Traversal
(Type_Defs, Pre_Op, Post_Op);
begin
Traverse_Unit (Root_Element =>
Comp_Units.Parent_Compilation_Unit
(Of_Program_Element => This_Type_Def),
State => The_Def,
Major_Elements_Only => True);
return The_Def.Rep_Spec;
end Enum_Rep_Clause;
begin
case Type_Information.Kind (For_This_Type_Definition) is
when Type_Information.An_Enumeration_Type_Definition =>
declare
Enum_Rep_Spec : Ada.Element :=
Enum_Rep_Clause (For_This_Type_Definition);
begin
if Ada.Is_Nil (Enum_Rep_Spec) then
return Size_Rep_Spec;
elsif Ada.Is_Nil (Size_Rep_Spec) then
return Enum_Rep_Spec;
elsif Ada.Line_Number (Enum_Rep_Spec) >
Ada.Line_Number (Size_Rep_Spec) then
return Enum_Rep_Spec;
else
return Size_Rep_Spec;
end if;
end;
when others =>
return Ada.Nil_Element;
end case;
end Last_Rep_Clause;
function Initial_Value (For_This_Type_Definition : Ada.Type_Definition;
Original_Comp_Unit_Name : String) return String is
function Type_Definition_From (This_Type_Identifier : Ada.Element)
return Ada.Type_Definition is
The_Type_Definition : Ada.Element;
begin
begin
The_Type_Definition :=
Ada.Definition (Reference => This_Type_Identifier,
Visible => True);
exception
when Ada.Failed =>
raise It_Has_No_Definition;
end;
return Decls.Type_Specification
(Type_Declaration_Or_Id =>
Decls.Enclosing_Declaration
(Element => The_Type_Definition));
end Type_Definition_From;
function Lower_Bound (Of_This_Discrete_Range : Ada.Element)
return Ada.Expression is
Lower, Upper : Ada.Expression;
begin
Types.Bounds (Of_This_Discrete_Range, Lower, Upper);
return Lower;
end Lower_Bound;
function Prefix_Name (For_This_Type_Definition : Ada.Type_Definition;
Original_Comp_Unit_Name : String) return String is
This_Prefix : constant String :=
Declarations.Name (Comp_Units.Unit_Declaration
(Comp_Units.Parent_Compilation_Unit
(For_This_Type_Definition)));
begin
if This_Prefix = Original_Comp_Unit_Name then
return "";
elsif This_Prefix = "Standard" then
return "";
else
return This_Prefix & ".";
end if;
end Prefix_Name;
begin
declare
Full_Type_Name : constant String :=
Prefix_Name (For_This_Type_Definition, Original_Comp_Unit_Name) &
Decls.Name (A_Declaration =>
Types.Parent_Declaration
(Type_Def => For_This_Type_Definition));
begin
case Types.Kind (A_Type_Definition => For_This_Type_Definition) is
when Types.An_Enumeration_Type_Definition |
Types.An_Integer_Type_Definition |
Types.A_Float_Type_Definition |
Types.A_Fixed_Type_Definition =>
return Full_Type_Name & "'First";
when Types.An_Access_Type_Definition =>
return "null";
when Types.A_Subtype_Indication =>
declare
Constraint : Ada.Element :=
Types.Constraint (For_This_Type_Definition);
begin
case Types.Constraint_Kind (Constraint) is
when Types.An_Index_Constraint =>
return
"(others => " &
Initial_Value
(Type_Definition_From
(This_Type_Identifier =>
Types.Component_Type
(Array_Type =>
Type_Definition_From
(This_Type_Identifier =>
For_This_Type_Definition))),
Original_Comp_Unit_Name) &
")";
when Types.Not_A_Constraint =>
return Initial_Value
(Type_Definition_From
(For_This_Type_Definition),
Original_Comp_Unit_Name);
when others =>
return Full_Type_Name & "'First";
end case;
end;
when Types.A_Derived_Type_Definition =>
declare
The_Subtype : Ada.Element :=
Types.Derived_From (For_This_Type_Definition);
Constraint : Ada.Element :=
Types.Constraint (The_Subtype);
begin
case Types.Constraint_ind (Constraint) is
when Types.An_Index_Constraint =>
return
"(others => " &
Initial_Value
(Type_Definition_From
(Types.Component_Type
(Type_Definition_From
(For_This_Type_Definition))),
Original_Comp_Unit_Name) &
")";
when Types.Not_A_Constraint =>
declare
Default_Value : constant String :=
Initial_Value (Type_Definition_From
(The_Subtype),
Original_Comp_Unit_Name);
begin
if String_Utilities.Locate
("=>", Default_Value) > 0 then
return Default_Value;
else
return
Full_Type_Name & "(" &
Default_Value & ")";
end if;
end;
when others =>
return Full_Type_Name & "'First";
end case;
end;
when Types.An_Array_Type_Definition =>
declare
Base_Type_Definition : Ada.Element :=
Type_Definition_From
(Types.Component_Type
(Array_Type => For_This_Type_Definition));
begin
if Types.Is_Constrained_Array
(For_This_Type_Definition) then
declare
The_Indices : Ada.Element_Iterator :=
Types.Index_Constraints
(For_This_Type_Definition);
Num_Dimensions : Natural := 0;
Init_Value : Unbounded.Variable_String :=
Unbounded.Nil;
begin
Ada.Reset (The_Indices);
while not Ada.Done (The_Indices) loop
Num_Dimensions := Num_Dimensions + 1;
Ada.Next (The_Indices);
end loop;
for I in 1 .. Num_Dimensions loop
Unbounded.Append
(Init_Value, "(others => ");
end loop;
Unbounded.Append
(Init_Value, Initial_Value
(Base_Type_Definition,
Original_Comp_Unit_Name));
for I in 1 .. Num_Dimensions loop
Unbounded.Append (Init_Value, ")");
end loop;
return Unbounded.Image (Init_Value);
end;
else
declare
Index_Type_Name : constant String :=
Ada.Image
(Ada.Value
(Types.Index_Subtype_Definitions
(For_This_Type_Definition)));
begin
return
"(" & Index_Type_Name
(Index_Type_Name'First ..
String_Utilities.Locate
(' ', Index_Type_Name) - 1) &
"'First => " &
Initial_Value (Base_Type_Definition,
Original_Comp_Unit_Name) &
")";
end;
end if;
end;
when Types.A_Record_Type_Definition =>
declare
Components : Ada.Element_Iterator :=
Types.Record_Components (For_This_Type_Definition);
The_Value : Unbounded.Variable_String := Unbounded.Nil;
begin
Ada.Reset (Components);
while not Ada.Done (Components) loop
declare
One_Component : Ada.Element :=
Ada.Value (Components);
Component_Name : constant String :=
Decls.Name (One_Component);
Component_Type : Ada.Element :=
Decls.Object_Type (One_Component);
Component_Constraint : Ada.Element :=
Types.Constraint (Component_Type);
begin
Unbounded.Append (The_Value,
Component_Name & " => ");
case Types.Constraint_Kind
(Component_Constraint) is
when Types.An_Index_Constraint =>
Unbounded.Append
(The_Value,
"(others => " &
Initial_Value
(Type_Definition_From
(Types.Component_Type
(Type_Definition_From
(Component_Type))),
Original_Comp_Unit_Name) &
")");
when Types.Not_A_Constraint =>
Unbounded.Append
(The_Value,
Initial_Value
(Type_Definition_From
(Component_Type),
Original_Comp_Unit_Name));
when others =>
Unbounded.Append
(The_Value,
Ada.Image
(Lower_Bound
(Component_Constraint)));
end case;
Ada.Next (Components);
if not Ada.Done (Components) then
Unbounded.Append (The_Value, ", ");
end if;
end;
end loop;
return "(" & Unbounded.Image (The_Value) & ")";
end;
when Types.A_Private_Type_Definition |
Types.A_Limited_Private_Type_Definition =>
raise Its_A_Private_Type;
when others =>
return "; --[Can't generate " &
Types.Type_Definition_Kinds'Image
(Types.Kind (For_This_Type_Definition)) &
"_Null_Parameter constant definition] ";
end case;
end;
end Initial_Value;
function Initial_Value
(For_This_Type_Definition : Ada_Program.Type_Definition)
return String is
Comp_Unit_Name : constant String :=
Declarations.Name (Comp_Units.Unit_Declaration
(Comp_Units.Parent_Compilation_Unit
(For_This_Type_Definition)));
begin
return Initial_Value (For_This_Type_Definition, Comp_Unit_Name);
end Initial_Value;
end Lrm_Utilities;
nblk1=41
nid=0
hdr6=82
[0x00] rec0=22 rec1=00 rec2=01 rec3=01a
[0x01] rec0=00 rec1=00 rec2=41 rec3=004
[0x02] rec0=1b rec1=00 rec2=02 rec3=012
[0x03] rec0=19 rec1=00 rec2=03 rec3=038
[0x04] rec0=1b rec1=00 rec2=04 rec3=062
[0x05] rec0=1a rec1=00 rec2=05 rec3=058
[0x06] rec0=01 rec1=00 rec2=40 rec3=016
[0x07] rec0=12 rec1=00 rec2=06 rec3=026
[0x08] rec0=13 rec1=00 rec2=07 rec3=062
[0x09] rec0=19 rec1=00 rec2=08 rec3=05c
[0x0a] rec0=00 rec1=00 rec2=3f rec3=006
[0x0b] rec0=1a rec1=00 rec2=09 rec3=042
[0x0c] rec0=16 rec1=00 rec2=0a rec3=042
[0x0d] rec0=00 rec1=00 rec2=3e rec3=002
[0x0e] rec0=11 rec1=00 rec2=0b rec3=040
[0x0f] rec0=11 rec1=00 rec2=0c rec3=05e
[0x10] rec0=17 rec1=00 rec2=0d rec3=050
[0x11] rec0=1b rec1=00 rec2=0e rec3=00c
[0x12] rec0=00 rec1=00 rec2=3d rec3=002
[0x13] rec0=1c rec1=00 rec2=37 rec3=000
[0x14] rec0=01 rec1=00 rec2=0f rec3=006
[0x15] rec0=18 rec1=00 rec2=10 rec3=006
[0x16] rec0=19 rec1=00 rec2=11 rec3=004
[0x17] rec0=18 rec1=00 rec2=12 rec3=028
[0x18] rec0=00 rec1=00 rec2=3c rec3=002
[0x19] rec0=1a rec1=00 rec2=13 rec3=02c
[0x1a] rec0=1b rec1=00 rec2=14 rec3=028
[0x1b] rec0=17 rec1=00 rec2=15 rec3=036
[0x1c] rec0=1a rec1=00 rec2=16 rec3=02e
[0x1d] rec0=1a rec1=00 rec2=17 rec3=078
[0x1e] rec0=1a rec1=00 rec2=18 rec3=012
[0x1f] rec0=01 rec1=00 rec2=3b rec3=028
[0x20] rec0=1a rec1=00 rec2=19 rec3=016
[0x21] rec0=00 rec1=00 rec2=3a rec3=002
[0x22] rec0=19 rec1=00 rec2=1a rec3=04c
[0x23] rec0=15 rec1=00 rec2=1b rec3=006
[0x24] rec0=00 rec1=00 rec2=39 rec3=008
[0x25] rec0=15 rec1=00 rec2=1c rec3=08c
[0x26] rec0=19 rec1=00 rec2=1d rec3=05a
[0x27] rec0=01 rec1=00 rec2=38 rec3=002
[0x28] rec0=19 rec1=00 rec2=1e rec3=022
[0x29] rec0=1a rec1=00 rec2=1f rec3=032
[0x2a] rec0=17 rec1=00 rec2=20 rec3=076
[0x2b] rec0=01 rec1=00 rec2=36 rec3=002
[0x2c] rec0=16 rec1=00 rec2=21 rec3=07a
[0x2d] rec0=00 rec1=00 rec2=35 rec3=014
[0x2e] rec0=18 rec1=00 rec2=22 rec3=036
[0x2f] rec0=1a rec1=00 rec2=23 rec3=028
[0x30] rec0=16 rec1=00 rec2=24 rec3=018
[0x31] rec0=1c rec1=00 rec2=25 rec3=01a
[0x32] rec0=10 rec1=00 rec2=26 rec3=030
[0x33] rec0=15 rec1=00 rec2=27 rec3=05c
[0x34] rec0=00 rec1=00 rec2=34 rec3=002
[0x35] rec0=11 rec1=00 rec2=28 rec3=05a
[0x36] rec0=16 rec1=00 rec2=29 rec3=044
[0x37] rec0=11 rec1=00 rec2=2a rec3=034
[0x38] rec0=00 rec1=00 rec2=33 rec3=00e
[0x39] rec0=12 rec1=00 rec2=2b rec3=020
[0x3a] rec0=14 rec1=00 rec2=2c rec3=01c
[0x3b] rec0=11 rec1=00 rec2=2d rec3=006
[0x3c] rec0=00 rec1=00 rec2=32 rec3=04a
[0x3d] rec0=10 rec1=00 rec2=2e rec3=024
[0x3e] rec0=10 rec1=00 rec2=2f rec3=044
[0x3f] rec0=19 rec1=00 rec2=30 rec3=036
[0x40] rec0=09 rec1=00 rec2=31 rec3=000
tail 0x21500444e815c65fc0ca1 0x42a00088462061e03