|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 41475 (0xa203)
Types: TextFile
Names: »B«
└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
└─⟦5cb1d1d7f⟧ »DATA«
└─⟦3b1ee7bd8⟧
└─⟦this⟧
with String_Utilities;
with Action;
with Directory;
with Ada_Text;
with Diana;
package body Diana_Utilities is
function "=" (D1, D2 : Diana.Node_Name) return Boolean renames Diana."=";
type Context_Clause_Kinds is
(A_With_Clause, A_Use_Clause, Not_A_Context_Clause);
type Element_Kinds is (A_Compilation_Unit,
A_Context_Clause, -- with or use clauses
A_Declaration, A_Statement, A_Pragma,
A_Representation_Clause, Not_A_Major_Element);
type Representation_Clause_Kinds is
(A_Length_Clause, An_Enumeration_Representation_Clause,
A_Record_Representation_Clause,
An_Address_Clause, Not_A_Representation_Clause);
type Statement_Kinds is
-- Simple statements:
(A_Null_Statement, An_Assignment_Statement, A_Procedure_Call_Statement,
An_Exit_Statement, A_Return_Statement, A_Goto_Statement,
An_Entry_Call_Statement, A_Delay_Statement,
An_Abort_Statement, A_Raise_Statement, A_Code_Statement,
-- compound statements:
An_If_Statement, A_Case_Statement, A_Loop_Statement,
A_Block_Statement, An_Accept_Statement,
A_Select_Statement, A_Conditional_Entry_Call_Statement,
A_Timed_Entry_Call_Statement, Not_A_Statement);
type Line_Iterator is new Ada_Text.Iterator;
type Valid_Modes is new Natural range 0 .. 15;
Invalid : constant Valid_Modes := 0;
Invisible : constant Valid_Modes := 1;
No_Check : constant Valid_Modes := 2;
Dn_Block_Parent : constant Valid_Modes := 3;
Dn_Pragma_Comment : constant Valid_Modes := 4;
type Kind_Modes is new Natural range 0 .. 15;
No_Conversion : constant Kind_Modes := 0;
Dn_Var_Is_Rename : constant Kind_Modes := 1;
Dn_Number_Is_Real_Or_Integer : constant Kind_Modes := 2;
Dn_Type_Is_Private_Or_Task : constant Kind_Modes := 3;
Dn_Package_Decl_Is_Rename_Or_Instance : constant Kind_Modes := 4;
Dn_Package_Body_Is_Subunit : constant Kind_Modes := 5;
Dn_Subprogram_Decl_Is_Rename_Or_Instance : constant Kind_Modes := 6;
-- also selects procedure, function or entry
Dn_Subprogram_Body_Is_Subunit : constant Kind_Modes := 7;
-- also selects procedure or function
Dn_Generic_Kind : constant Kind_Modes := 8;
-- selects package, procedure or function
Dn_Task_Body_Is_Subunit : constant Kind_Modes := 9;
Dn_Exception_Is_Rename : constant Kind_Modes := 10;
Dn_Simple_Rep_Is_Length_Or_Enum : constant Kind_Modes := 11;
type Data (Kind : Element_Kinds := Not_A_Major_Element) is
record
case Kind is
when Not_A_Major_Element =>
Invisible_Element : Boolean;
when A_Pragma =>
null;
when A_Compilation_Unit =>
Is_Subunit : Boolean;
when A_Context_Clause =>
Context_Clause_Kind : Context_Clause_Kinds;
when A_Declaration =>
Declaration_Kind : Declaration_Kinds;
when A_Statement =>
Statement_Kind : Statement_Kinds;
when A_Representation_Clause =>
Rep_Clause_Kind : Representation_Clause_Kinds;
end case;
end record;
type Data_Record (Valid_Mode : Valid_Modes := Invalid) is
record
case Valid_Mode is
when Invalid | Invisible =>
null;
when others =>
Kind_Mode : Kind_Modes;
Real_Data : Data;
end case;
end record;
Invalid_Item : constant Data_Record := Data_Record'(Valid_Mode => Invalid);
Invalid_Data : constant Data :=
Data'(Kind => Not_A_Major_Element, Invisible_Element => False);
Invisible_Item : constant Data_Record :=
Data_Record'(Valid_Mode => Invisible);
Invisible_Data : constant Data :=
Data'(Kind => Not_A_Major_Element, Invisible_Element => True);
use Diana;
Kind_Vector : constant array (Diana.Node_Name) of Data_Record :=
(Dn_Pragma =>
(Dn_Pragma_Comment, No_Conversion, Data'(Kind => A_Pragma)),
Dn_Comp_Unit =>
(No_Check, No_Conversion, Data'(A_Compilation_Unit, False)),
Dn_Subunit =>
(No_Check, No_Conversion, Data'(A_Compilation_Unit, True)),
Dn_Use =>
(No_Check, No_Conversion, Data'(A_Context_Clause, A_Use_Clause)),
Dn_With =>
(No_Check, No_Conversion, Data'(A_Context_Clause, A_With_Clause)),
Dn_Var =>
(No_Check, Dn_Var_Is_Rename,
Data'(A_Declaration, A_Variable_Declaration)), -- ren
Dn_Deferred_Constant | Dn_Constant =>
(No_Check, No_Conversion,
Data'(A_Declaration, A_Constant_Declaration)),
Dn_Number => (No_Check, Dn_Number_Is_Real_Or_Integer,
Data'(A_Declaration,
An_Integer_Number_Declaration)), -- int real
Dn_Type =>
(No_Check, Dn_Type_Is_Private_Or_Task,
Data'(A_Declaration, A_Type_Declaration)), -- tsk priv
Dn_Subtype => (No_Check, No_Conversion,
Data'(A_Declaration, A_Subtype_Declaration)),
Dn_Package_Decl =>
(No_Check, Dn_Package_Decl_Is_Rename_Or_Instance,
Data'(A_Declaration, A_Package_Declaration)), -- ren, inst
Dn_Package_Body =>
(No_Check, Dn_Package_Body_Is_Subunit,
Data'(A_Declaration, A_Package_Body_Declaration)), -- sub
Dn_Subprogram_Decl =>
(No_Check, Dn_Subprogram_Decl_Is_Rename_Or_Instance,
Data'
(A_Declaration,
A_Procedure_Declaration)), -- ren, inst, proc, func, entry
Dn_Subprogram_Body =>
(No_Check, Dn_Subprogram_Body_Is_Subunit,
Data'(A_Declaration,
A_Procedure_Body_Declaration)), -- sub, proc, func
Dn_Generic =>
(No_Check, Dn_Generic_Kind,
Data'(A_Declaration,
A_Generic_Package_Declaration)), -- pkg, proc, func
Dn_Task_Decl =>
(No_Check, No_Conversion, Data'(A_Declaration, A_Task_Declaration)),
Dn_Task_Body =>
(No_Check, Dn_Task_Body_Is_Subunit,
Data'(A_Declaration, A_Task_Body_Declaration)), -- sub
Dn_Exception =>
(No_Check, Dn_Exception_Is_Rename,
Data'(A_Declaration, An_Exception_Declaration)), -- ren
-- STATEMENTS
Dn_Null_Stm =>
(No_Check, No_Conversion, Data'(A_Statement, A_Null_Statement)),
Dn_Assign => (No_Check, No_Conversion,
Data'(A_Statement, An_Assignment_Statement)),
Dn_Procedure_Call => (No_Check, No_Conversion,
Data'(A_Statement, A_Procedure_Call_Statement)),
Dn_Exit =>
(No_Check, No_Conversion, Data'(A_Statement, An_Exit_Statement)),
Dn_Return =>
(No_Check, No_Conversion, Data'(A_Statement, A_Return_Statement)),
Dn_Goto =>
(No_Check, No_Conversion, Data'(A_Statement, A_Goto_Statement)),
Dn_Entry_Call => (No_Check, No_Conversion,
Data'(A_Statement, An_Entry_Call_Statement)),
Dn_Delay =>
(No_Check, No_Conversion, Data'(A_Statement, A_Delay_Statement)),
Dn_Abort =>
(No_Check, No_Conversion, Data'(A_Statement, An_Abort_Statement)),
Dn_Raise =>
(No_Check, No_Conversion, Data'(A_Statement, A_Raise_Statement)),
Dn_Code =>
(No_Check, No_Conversion, Data'(A_Statement, A_Code_Statement)),
Dn_If => (No_Check, No_Conversion, Data'(A_Statement, An_If_Statement)),
Dn_Case =>
(No_Check, No_Conversion, Data'(A_Statement, A_Case_Statement)),
Dn_Loop =>
(No_Check, No_Conversion, Data'(A_Statement, A_Loop_Statement)),
Dn_Block => (Dn_Block_Parent, No_Conversion,
Data'(A_Statement, A_Block_Statement)),
Dn_Accept =>
(No_Check, No_Conversion, Data'(A_Statement, An_Accept_Statement)),
Dn_Select =>
(No_Check, No_Conversion, Data'(A_Statement, A_Select_Statement)),
Dn_Cond_Entry =>
(No_Check, No_Conversion,
Data'(A_Statement, A_Conditional_Entry_Call_Statement)),
Dn_Timed_Entry => (No_Check, No_Conversion,
Data'(A_Statement, A_Timed_Entry_Call_Statement)),
Dn_Simple_Rep =>
(No_Check, Dn_Simple_Rep_Is_Length_Or_Enum,
Data'(A_Representation_Clause,
A_Length_Clause)), --length or enum
Dn_Record_Rep =>
(No_Check, No_Conversion,
Data'(A_Representation_Clause, A_Record_Representation_Clause)),
Dn_Address => (No_Check, No_Conversion,
Data'(A_Representation_Clause, An_Address_Clause)),
-- invalid items (not major) :
Dn_Void => Invalid_Item,
Dn_Aggregate => Invalid_Item,
Dn_Allocator .. Dn_Slice => Invalid_Item,
Dn_Used_Op | Dn_Used_Bltn_Op => Invalid_Item,
Dn_Used_Object_Id .. Dn_Used_Bltn_Id => Invalid_Item,
Dn_Attr_Id .. Dn_Enum_Id => Invalid_Item,
Dn_Def_Char .. Dn_No_Default => Invalid_Item,
Dn_Instantiation => Invalid_Item,
Dn_Labeled => Invalid_Item,
Dn_Named_Stm => Invalid_Item,
Dn_Named_Stm_Id => Invalid_Item,
Dn_Terminate => Invalid_Item,
Dn_Range => Invalid_Item,
Dn_Dscrmt_Aggregate .. Dn_Constrained => Invalid_Item,
Dn_Formal_Dscrt .. Dn_Formal_Integer => Invalid_Item,
Dn_Access .. Dn_Integer => Invalid_Item,
Dn_L_Private | Dn_Private => Invalid_Item,
Dn_Record => Invalid_Item,
Dn_Task_Spec => Invalid_Item,
Dn_Universal_Integer .. Dn_Universal_Real => Invalid_Item,
Dn_Stub | Dn_Pseudo_Stub => Invalid_Item,
Dn_Entry .. Dn_Package_Spec => Invalid_Item,
Dn_Out .. Dn_In_Out => Invalid_Item,
Dn_Rename .. Dn_Context => Invalid_Item,
Dn_In_Op .. Dn_Index => Invalid_Item,
Dn_Alternative_S .. Dn_Dscrmt_Var_S => Invalid_Item,
Dn_Variant .. Dn_Named => Invalid_Item,
Dn_Assoc .. Dn_Foo2 => Invalid_Item);
function Id_Image (Of_Tree : Diana.Tree) return String is
begin
return Diana.Image (Diana.Lx_Symrep (Diana.As_Id (Of_Tree)));
exception
when Constraint_Error => -- variant error
return "";
end Id_Image;
function Is_Valid (For_Diana_Node : Diana.Tree; With_Data : Data_Record)
return Boolean is
begin
case With_Data.Valid_Mode is
when Invalid | Invisible =>
return False;
when No_Check =>
return True;
when Dn_Block_Parent =>
case Diana.Kind (Diana.As_Parent (For_Diana_Node)) is
when Dn_Subprogram_Body | Dn_Package_Body | Dn_Task_Body =>
return False;
when others =>
return True;
end case;
when Dn_Pragma_Comment =>
return "_COMMENT" /= Diana_Utilities.Id_Image (For_Diana_Node);
when others =>
raise Program_Error;
end case;
end Is_Valid;
function Is_Visible (For_Diana_Node : Diana.Tree) return Boolean is
Item : Data_Record;
begin
Item := Kind_Vector (Diana.Kind (For_Diana_Node));
case Item.Valid_Mode is
when Invisible =>
return False;
when Invalid | No_Check | Dn_Block_Parent =>
return True;
when Dn_Pragma_Comment =>
return "_COMMENT" /= Diana_Utilities.Id_Image (For_Diana_Node);
when others =>
raise Program_Error;
end case;
end Is_Visible;
function Get_Data (For_Diana_Node : Diana.Tree) return Data is
Item : Data_Record;
begin
Item := Kind_Vector (Diana.Kind (For_Diana_Node));
if Is_Valid (For_Diana_Node, Item) then
case Item.Kind_Mode is
when No_Conversion =>
null;
when Dn_Var_Is_Rename =>
if Diana.Kind (Diana.As_Object_Def (For_Diana_Node)) =
Diana.Dn_Rename then
return Data'(A_Declaration,
An_Object_Rename_Declaration);
end if;
when Dn_Number_Is_Real_Or_Integer =>
if Diana.Kind
(Diana.Sm_Obj_Type
(Diana.Head (Diana.As_List
(Diana.As_Id_S
(For_Diana_Node))))) /=
Diana.Dn_Universal_Integer then
return Data'(A_Declaration, A_Real_Number_Declaration);
end if;
when Dn_Type_Is_Private_Or_Task =>
case Diana.Kind (Diana.As_Type_Spec (For_Diana_Node)) is
when Diana.Dn_Private | Diana.Dn_L_Private =>
return Data'(A_Declaration,
A_Private_Type_Declaration);
when Diana.Dn_Task_Spec =>
return Data'(A_Declaration,
A_Task_Type_Declaration);
when others =>
null;
end case;
when Dn_Package_Decl_Is_Rename_Or_Instance =>
case Diana.Kind (Diana.As_Package_Def (For_Diana_Node)) is
when Diana.Dn_Rename =>
return Data'(A_Declaration,
A_Package_Rename_Declaration);
when Diana.Dn_Instantiation =>
return Data'(A_Declaration,
A_Package_Instantiation);
when others =>
null;
end case;
when Dn_Package_Body_Is_Subunit =>
if Diana.Kind (Diana.As_Block_Stub (For_Diana_Node)) =
Diana.Dn_Stub then
return Data'(A_Declaration, A_Package_Subunit);
end if;
when Dn_Subprogram_Decl_Is_Rename_Or_Instance =>
-- also selects procedure, function or entry
case Diana.Kind (Diana.As_Header (For_Diana_Node)) is
when Diana.Dn_Entry =>
return Data'(A_Declaration, An_Entry_Declaration);
when Diana.Dn_Procedure =>
case Diana.Kind (Diana.As_Subprogram_Def
(For_Diana_Node)) is
when Diana.Dn_Rename =>
return Data'
(A_Declaration,
A_Procedure_Rename_Declaration);
when Diana.Dn_Instantiation =>
return Data'(A_Declaration,
A_Procedure_Instantiation);
when others =>
return Data'(A_Declaration,
A_Procedure_Declaration);
end case;
when Diana.Dn_Function =>
case Diana.Kind (Diana.As_Subprogram_Def
(For_Diana_Node)) is
when Diana.Dn_Rename =>
return Data'(A_Declaration,
A_Function_Rename_Declaration);
when Diana.Dn_Instantiation =>
return Data'(A_Declaration,
A_Function_Instantiation);
when others =>
return Data'(A_Declaration,
A_Function_Declaration);
end case;
when others =>
raise Program_Error;
end case;
when Dn_Subprogram_Body_Is_Subunit =>
-- also selects procedure or function
case Diana.Kind (Diana.As_Header (For_Diana_Node)) is
when Diana.Dn_Procedure =>
if Diana.Kind (Diana.As_Block_Stub
(For_Diana_Node)) =
Diana.Dn_Stub then
return Data'(A_Declaration,
A_Procedure_Subunit);
else
return Data'(A_Declaration,
A_Procedure_Body_Declaration);
end if;
when Diana.Dn_Function =>
if Diana.Kind (Diana.As_Block_Stub
(For_Diana_Node)) =
Diana.Dn_Stub then
return Data'(A_Declaration, A_Function_Subunit);
else
return Data'(A_Declaration,
A_Function_Body_Declaration);
end if;
when others =>
raise Program_Error;
end case;
when Dn_Generic_Kind =>
-- selects package, procedure or function
case Diana.Kind (Diana.As_Generic_Header
(For_Diana_Node)) is
when Diana.Dn_Procedure =>
return Data'(A_Declaration,
A_Generic_Procedure_Declaration);
when Diana.Dn_Function =>
return Data'(A_Declaration,
A_Generic_Function_Declaration);
when Diana.Dn_Package_Spec =>
return Data'(A_Declaration,
A_Generic_Package_Declaration);
when others =>
raise Program_Error;
end case;
when Dn_Task_Body_Is_Subunit =>
if Diana.Kind (Diana.As_Block_Stub (For_Diana_Node)) =
Diana.Dn_Stub then
return Data'(A_Declaration, A_Task_Subunit);
end if;
when Dn_Exception_Is_Rename =>
if Diana.Kind (Diana.As_Exception_Def (For_Diana_Node)) =
Diana.Dn_Rename then
return Data'(A_Declaration,
An_Exception_Rename_Declaration);
end if;
when Dn_Simple_Rep_Is_Length_Or_Enum =>
case Diana.Kind (Diana.As_Name (For_Diana_Node)) is
when Diana.Dn_Attribute | Diana.Dn_Attribute_Call =>
return Data'(A_Representation_Clause,
A_Length_Clause);
when others =>
return Data'(A_Representation_Clause,
An_Enumeration_Representation_Clause);
end case;
when others =>
raise Program_Error;
end case;
-- original info was correct, so ...
return Item.Real_Data;
else
if Is_Visible (For_Diana_Node) then
return Invalid_Data;
else
return Invisible_Data;
end if;
end if;
end Get_Data;
function Build_Iterator (Sequence : Diana.Sequence) return Iterator is
Iter : Iterator;
begin
Iter.Kind := Diana_Utilities.Sequence;
Iter.Sequence_Root := Sequence;
while not Is_Visible (Diana.Head (Iter.Sequence_Root)) loop
Iter.Sequence_Root := Diana.Tail (Iter.Sequence_Root);
end loop;
Iter.Sequence_Current := Iter.Sequence_Root;
return Iter;
end Build_Iterator;
function Build_Iterator (Seq_Type : Diana.Seq_Type) return Iterator is
Iter : Iterator;
begin
Iter.Kind := Diana_Utilities.Seq_Type;
Iter.Seq_Type_Root := Seq_Type;
while not Is_Visible (Diana.Head (Iter.Seq_Type_Root)) loop
Iter.Seq_Type_Root := Diana.Tail (Iter.Seq_Type_Root);
end loop;
Iter.Seq_Type_Current := Iter.Seq_Type_Root;
return Iter;
end Build_Iterator;
---------
procedure Next (Iter : in out Iterator) is
begin
loop
case Iter.Kind is
when Sequence =>
Iter.Sequence_Current := Diana.Tail (Iter.Sequence_Current);
exit when Is_Visible (Diana.Head (Iter.Sequence_Current));
when Seq_Type =>
Iter.Seq_Type_Current := Diana.Tail (Iter.Seq_Type_Current);
exit when Is_Visible (Diana.Head (Iter.Seq_Type_Current));
when None =>
null;
end case;
end loop;
end Next;
function Done (Iter : Iterator) return Boolean is
begin
case Iter.Kind is
when Sequence =>
return Diana.Is_Empty (Iter.Sequence_Current);
when Seq_Type =>
return Diana.Is_Empty (Iter.Seq_Type_Current);
when None =>
null;
end case;
end Done;
function Value (Iter : Iterator) return Diana.Tree is
begin
case Iter.Kind is
when Sequence =>
return Diana.Head (Iter.Sequence_Current);
when Seq_Type =>
return Diana.Head (Iter.Seq_Type_Current);
when None =>
null;
end case;
end Value;
procedure Reset (Iter : in out Iterator) is
begin
case Iter.Kind is
when Sequence =>
Iter.Sequence_Current := Iter.Sequence_Root;
when Seq_Type =>
Iter.Seq_Type_Current := Iter.Seq_Type_Root;
when None =>
null;
end case;
end Reset;
function Image (Program_Element : Diana.Tree) return Line_Iterator is
Handle : Ada_Text.Handle;
Status : Directory.Error_Status;
Area : Ada_Text.Area;
Iter : Ada_Text.Iterator;
begin
if Diana.Is_Empty (Program_Element) then
return Line_Iterator (Ada_Text.Nil_Iterator);
end if;
Area := Ada_Text.Where_Is (Subtree => Program_Element,
Unit => Handle,
And_Post_Comment => True);
Ada_Text.Initialize (Unit => Handle, Where => Area, Iter => Iter);
return Line_Iterator (Iter);
exception
when Program_Error =>
return Line_Iterator (Ada_Text.Nil_Iterator);
end Image;
function Image (Program_Element : Diana.Tree) return String is
begin
case Diana.Kind (Program_Element) is
when Diana.Dn_Argument_Id | Diana.Dn_Attr_Id |
Diana.Dn_Comp_Id | Diana.Dn_Const_Id | Diana.Dn_Def_Char |
Diana.Dn_Def_Op | Diana.Dn_Dscrmt_Id | Diana.Dn_Entry_Id |
Diana.Dn_Enum_Id | Diana.Dn_Exception_Id |
Diana.Dn_Function_Id | Diana.Dn_Generic_Id | Diana.Dn_In_Id |
Diana.Dn_In_Out_Id | Diana.Dn_Iteration_Id |
Diana.Dn_L_Private_Type_Id | Diana.Dn_Label_Id |
Diana.Dn_Named_Stm_Id | Diana.Dn_Number_Id | Diana.Dn_Out_Id |
Diana.Dn_Package_Id | Diana.Dn_Pragma_Id |
Diana.Dn_Private_Type_Id | Diana.Dn_Proc_Id |
Diana.Dn_String_Literal | Diana.Dn_Subtype_Id |
Diana.Dn_Task_Body_Id | Diana.Dn_Type_Id |
Diana.Dn_Used_Bltn_Id | Diana.Dn_Used_Bltn_Op |
Diana.Dn_Used_Char | Diana.Dn_Used_Name_Id |
Diana.Dn_Used_Object_Id | Diana.Dn_Used_Op | Diana.Dn_Var_Id =>
return Diana.Image (Diana.Id (Program_Element));
when others =>
declare
Iter : Line_Iterator := Image (Program_Element);
type Astring is access String;
String_Image : Astring;
begin
-- This is time and space wastefull but for small iterators
-- is probably faster th an the overhead of a more elaborate
-- mechanism. No garbage is generated (reclaimed on return).
if not Done (Iter) then
String_Image := new String'(Value (Iter));
Next (Iter);
while not Done (Iter) loop
String_Image :=
new String'(String_Image.all & Ascii.Lf &
Value (Iter));
Next (Iter);
end loop;
return String_Image.all;
else
return "";
end if;
exception
when Program_Error =>
return "HIDDEN";
end;
end case;
end Image;
function Get_Ids (A_Declaration : Diana.Tree) return Diana.Tree is
Local : Diana.Tree := A_Declaration;
begin
loop
case Diana.Kind (Local) is
when Diana.Dn_Type | Diana.Dn_Subtype | Diana.Dn_Package_Decl |
Diana.Dn_Task_Decl | Diana.Dn_Generic =>
return Diana.As_Id (Local);
when Diana.Dn_Var | Diana.Dn_Constant | Diana.Dn_Number |
Diana.Dn_Exception | Diana.Dn_Deferred_Constant |
Diana.Dn_Out .. Diana.Dn_In_Out =>
return Diana.As_Id_S (Local);
when Diana.Dn_Subprogram_Decl =>
return Diana.As_Designator (Local);
when Diana.Dn_Enum_Literal_S | Diana.Dn_Derived |
Diana.Dn_Task_Spec | Diana.Dn_Float | Diana.Dn_Integer |
Diana.Dn_Access | Diana.Dn_Array | Diana.Dn_Fixed |
Diana.Dn_Constrained | Diana.Dn_Record =>
Local := Diana.As_Parent (Local);
when Diana.Dn_In_Id | Diana.Dn_In_Out_Id | Diana.Dn_Out_Id =>
return Local;
when others =>
raise Program_Error;
end case;
end loop;
end Get_Ids;
function Identifier (A_Declaration : Diana.Tree) return Diana.Tree is
Ids : Diana.Tree;
begin
Ids := Get_Ids (A_Declaration);
if Diana.Kind (Ids) = Diana.Dn_Id_S then
return Diana.Head (Diana.As_List (Ids));
else
return Ids;
end if;
end Identifier;
function Name (Declaration : Diana.Tree) return String is
begin
return Image (Identifier (Declaration));
end Name;
function Is_Subprogram (A_Declaration : Diana.Tree) return Boolean is
begin
case Diana.Kind (A_Declaration) is
when Diana.Dn_Subprogram_Decl | Diana.Dn_Subprogram_Body =>
return True;
when Diana.Dn_Generic =>
case Diana.Kind (Diana.As_Generic_Header (A_Declaration)) is
when Diana.Dn_Procedure | Diana.Dn_Function =>
return True;
when others =>
return False;
end case;
when others =>
return False;
end case;
end Is_Subprogram;
function Parameter_Mode (Of_Parameter : Diana.Tree)
return Parameter_Modes is
begin
case Diana.Kind (Of_Parameter) is
when Diana.Dn_In =>
if Diana.Lx_Default (Of_Parameter) then
return Default_In_Mode;
else
return In_Mode;
end if;
when Diana.Dn_In_Out =>
return In_Out_Mode;
when Diana.Dn_Out =>
return Out_Mode;
when others =>
raise Inappropriate_Program_Element;
end case;
end Parameter_Mode;
function Header (Of_Subprogram_Decl : Diana.Tree) return Diana.Tree is
Subprogram_Def : Diana.Tree;
begin
if Diana.Kind (Of_Subprogram_Decl) = Diana.Dn_Subprogram_Decl then
Subprogram_Def := Diana.As_Subprogram_Def (Of_Subprogram_Decl);
case Diana.Kind (Subprogram_Def) is
when Diana.Dn_Instantiation =>
return Diana.Sm_Spec (Diana.Sm_Defn
(Diana.As_Name (Subprogram_Def)));
when others =>
return Diana.As_Header (Of_Subprogram_Decl);
end case;
else
raise Inappropriate_Program_Element;
end if;
end Header;
function Parameters (Procedure_Or_Function : Diana.Tree) return Iterator is
begin
return Build_Iterator
(Diana.As_List (Diana.As_Param_S
(Header (Procedure_Or_Function))));
end Parameters;
function Type_Spec_Of (Name : Diana.Tree) return Diana.Tree is
Node : Diana.Tree := Name;
begin
loop
case Diana.Kind (Node) is
when Diana.Dn_Constant | Diana.Dn_Var | Diana.Dn_Type =>
return Diana.As_Type_Spec (Node);
when Diana.Dn_Subtype =>
return Diana.As_Constrained (Node);
when Diana.Dn_Constrained =>
return Node;
when Diana.Dn_Const_Id | Diana.Dn_Var_Id | Diana.Dn_Number_Id |
Diana.Dn_In_Id | Diana.Dn_In_Out_Id | Diana.Dn_Out_Id =>
return Diana.Sm_Obj_Type (Node);
when Diana.Dn_Number =>
Node := Diana.As_Id_S (Node);
when Diana.Dn_Private_Type_Id | Diana.Dn_L_Private_Type_Id =>
return Diana.Sm_Type_Spec (Node);
when Diana.Dn_Type_Id | Diana.Dn_Subtype_Id =>
return Diana.Sm_Type_Spec (Node);
when Diana.Dn_In | Diana.Dn_In_Out | Diana.Dn_Out =>
Node := Diana.As_Name (Node);
when Diana.Dn_Id_S =>
Node := Diana.Head (Diana.As_List (Node));
when Diana.Dn_Selected =>
Node := Diana.As_Designator_Char (Node);
when Diana.Dn_Used_Object_Id | Diana.Dn_Used_Name_Id |
Diana.Dn_Used_Bltn_Id | Diana.Dn_Used_Char =>
Node := Diana.Sm_Defn (Node);
when Diana.Dn_Private | Diana.Dn_L_Private |
Diana.Dn_Deferred_Constant =>
return Node;
when others =>
raise Program_Error;
end case;
end loop;
end Type_Spec_Of;
function Return_Type (Of_Function : Diana.Tree) return Diana.Tree is
Function_Header : Diana.Tree;
begin
Function_Header := Header (Of_Function);
if Diana.Kind (Function_Header) = Diana.Dn_Function then
return Type_Spec_Of (Diana.As_Name_Void (Function_Header));
else
raise Inappropriate_Program_Element;
end if;
end Return_Type;
function Object_Type
(Object_Decl_Or_Object_Id : Diana.Tree) return Diana.Tree is
begin
return Type_Spec_Of (Object_Decl_Or_Object_Id);
end Object_Type;
function Convert (Declaration : Directory.Object) return Diana.Tree is
Result : Diana.Tree;
Status : Directory.Error_Status;
Key : Directory.Ada.Conversion_Key;
begin
Directory.Ada.Open (Directory.Ada.Get_Unit (Declaration),
Directory.Ada.Read, Result,
Key, Status, Action.Null_Id);
return Result;
end Convert;
function Kind (Declaration : Diana.Tree) return Declaration_Kinds is
Data_Item : Data := Get_Data (Declaration);
begin
if Data_Item.Kind = A_Declaration then
return Data_Item.Declaration_Kind;
else
return Not_A_Declaration;
end if;
end Kind;
function Type_Kind (A_Type_Definition : Diana.Tree)
return Type_Definition_Kind is
begin
case Diana.Kind (A_Type_Definition) is
when Diana.Dn_Enum_Literal_S =>
return An_Enumeration_Type_Definition;
when Diana.Dn_Derived =>
return A_Derived_Type_Definition;
when Diana.Dn_Access =>
return An_Access_Type_Definition;
when Diana.Dn_Record =>
return A_Record_Type_Definition;
when Diana.Dn_Integer =>
return An_Integer_Type_Definition;
when Diana.Dn_Float =>
return A_Float_Type_Definition;
when Diana.Dn_Fixed =>
return A_Fixed_Type_Definition;
when Diana.Dn_Task_Spec =>
return A_Task_Type_Definition;
when Diana.Dn_Array =>
return An_Array_Type_Definition;
when Diana.Dn_Constrained =>
return A_Subtype_Indication;
when others =>
return Not_A_Type_Definition;
end case;
end Type_Kind;
function Is_Predefined (Type_Def : Diana.Tree) return Boolean is
begin
return Diana.Id_Utilities.Is_Predefined
(Diana.Id_Utilities.Get_Id (Type_Def));
end Is_Predefined;
function Is_String (Type_Def : Diana.Tree) return Boolean is
begin
return String_Utilities.Equal
("string", Name (Diana.Id_Utilities.Get_Id (Type_Def)));
end Is_String;
function Is_Boolean (Type_Def : Diana.Tree) return Boolean is
begin
return String_Utilities.Equal
("boolean", Name (Diana.Id_Utilities.Get_Id (Type_Def)));
end Is_Boolean;
function Is_Character (Type_Def : Diana.Tree) return Boolean is
begin
return String_Utilities.Equal
("character", Name (Diana.Id_Utilities.Get_Id (Type_Def)));
end Is_Character;
function Is_Duration (Type_Def : Diana.Tree) return Boolean is
begin
return String_Utilities.Equal
("duration", Name (Diana.Id_Utilities.Get_Id (Type_Def)));
end Is_Duration;
function Is_Positive (Type_Def : Diana.Tree) return Boolean is
begin
return String_Utilities.Equal
("positive", Name (Diana.Id_Utilities.Get_Id (Type_Def)));
end Is_Positive;
function Is_Natural (Type_Def : Diana.Tree) return Boolean is
begin
return String_Utilities.Equal
("natural", Name (Diana.Id_Utilities.Get_Id (Type_Def)));
end Is_Natural;
function Is_Long_Integer (Type_Def : Diana.Tree) return Boolean is
begin
return String_Utilities.Equal
("long_integer", Name (Diana.Id_Utilities.Get_Id (Type_Def)));
end Is_Long_Integer;
function Base_Type (A_Subtype : Diana.Tree) return Diana.Tree is
Local : Diana.Tree := A_Subtype;
begin
loop
case Diana.Kind (Local) is
when Diana.Dn_Subtype =>
Local := Diana.As_Constrained (Local);
when Diana.Dn_Constrained =>
return Diana.Sm_Base_Type (Local);
when others =>
raise Inappropriate_Program_Element;
end case;
end loop;
end Base_Type;
function All_Ids (Of_Parameter : Diana.Tree) return Iterator is
begin
return Build_Iterator (Diana.As_List (Diana.As_Id_S (Of_Parameter)));
end All_Ids;
function Operator_Kind (Function_Decl : Diana.Tree) return Operator is
Local : Diana.Tree := Function_Decl;
begin
loop
case Diana.Kind (Local) is
when Diana.Dn_Subprogram_Decl =>
Local := Diana.As_Designator (Local);
when Diana.Dn_Def_Op =>
declare
Op_Name : constant String :=
Diana.Image (Diana.Lx_Symrep (Local));
begin
if Op_Name = "and" then
return And_Op;
elsif Op_Name = "or" then
return Or_Op;
elsif Op_Name = "xor" then
return Xor_Op;
elsif Op_Name = "=" then
return Eq_Op;
elsif Op_Name = "<" then
return Lt_Op;
elsif Op_Name = "<=" then
return Lt_Eq_Op;
elsif Op_Name = ">" then
return Gt_Op;
elsif Op_Name = ">=" then
return Gt_Eq_Op;
elsif Op_Name = "+" then
return Plus_Op;
elsif Op_Name = "-" then
return Minus_Op;
elsif Op_Name = "&" then
return Concat_Op;
elsif Op_Name = "*" then
return Mult_Op;
elsif Op_Name = "/" then
return Div_Op;
elsif Op_Name = "mod" then
return Mod_Op;
elsif Op_Name = "rem" then
return Rem_Op;
elsif Op_Name = "**" then
return Exp_Op;
elsif Op_Name = "abs" then
return Abs_Op;
elsif Op_Name = "not" then
return Not_Op;
else
return Not_An_Operator;
end if;
end;
when others =>
return Not_An_Operator;
end case;
end loop;
end Operator_Kind;
function Operator_Name (Function_Decl : Diana.Tree) return String is
begin
return Diana.Image (Diana.Lx_Symrep (Function_Decl));
end Operator_Name;
function Image (Op : Operator) return String is
begin
case Op is
when And_Op =>
return """" & "AND" & """";
when Or_Op =>
return """" & "OR" & """";
when Xor_Op =>
return """" & "XOR" & """";
when Eq_Op =>
return """" & "EQ" & """";
when Lt_Op =>
return """" & "<" & """";
when Lt_Eq_Op =>
return """" & "<=" & """";
when Gt_Op =>
return """" & ">" & """";
when Gt_Eq_Op =>
return """" & ">=" & """";
when Plus_Op =>
return """" & "+" & """";
when Minus_Op =>
return """" & "-" & """";
when Concat_Op =>
return """" & "&" & """";
when Unary_Plus_Op =>
return """" & "+" & """";
when Unary_Minus_Op =>
return """" & "-" & """";
when Mult_Op =>
return """" & "*" & """";
when Div_Op =>
return """" & "/" & """";
when Mod_Op =>
return """" & "MOD" & """";
when Rem_Op =>
return """" & "REM" & """";
when Exp_Op =>
return """" & "**" & """";
when Abs_Op =>
return """" & "ABS" & """";
when Not_Op =>
return """" & "NOT" & """";
when Not_An_Operator =>
return "<>";
end case;
end Image;
end Diana_Utilities;