|
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: 54741 (0xd5d5)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦3948734d4⟧
└─⟦this⟧
with Bounded_String, Text_Io;
package T_Value is
Error_Integer_Value : exception;
Error_Boolean_Value : exception;
Error_Real_Value : exception;
Error_String_Value : exception;
Error_Equal_Value : exception;
Max_Value_String : constant := 80;
type Kind_Of_Values is (Undefined_Value, Integer_Value,
String_Value, Boolean_Value);
type Object (Kind : Kind_Of_Values := Undefined_Value) is private;
NULL_VALUE:Constant object;
subtype V_File is Text_Io.File_Type;
--Creation
procedure New_Value (V : out T_Value.Object);
--Liberation
procedure Dispose (V : in out T_Value.Object);
--Access
function Kind_Of_Value (V : in T_Value.Object) return Kind_Of_Values;
function Get (V : in T_Value.Object) return Integer;
function Get (V : in T_Value.Object) return Boolean;
function Get (V : in T_Value.Object) return String;
function Equal (V1 : in T_Value.Object; V2 : in T_Value.Object)
return Boolean;
function Image (V : in T_Value.Object) return String;
procedure Value_To_File (V : in T_Value.Object; F : V_File);
--Modification
procedure Undefine (V : in out T_Value.Object);
procedure Set (V : in out T_Value.Object; I : in Integer);
procedure Set (V : in out T_Value.Object; S : in String);
procedure Set (V : in out T_Value.Object; B : in Boolean);
procedure Copy (To_Value : in out T_Value.Object;
The_Value : in T_Value.Object);
procedure Set_Value_Using_File (V : in out T_Value.Object; F : V_File);
private
type String_Access is access String;
type Object (Kind : Kind_Of_Values := Undefined_Value) is
record
case Kind is
when Integer_Value =>
The_Integer : Integer;
when String_Value =>
The_String : String_Access;
when Boolean_Value =>
The_Boolean : Boolean;
when Undefined_Value =>
null;
end case;
end record;
NULL_VALUE :Constant Object:= (Kind => Undefined_Value);
end T_Value;
with Unchecked_Deallocation, Text_Io;
package body T_Value is
procedure Free is new Unchecked_Deallocation (String, String_Access);
--Creation
procedure New_Value (V : out T_Value.Object) is
begin
V := (Kind => Undefined_Value);
end New_Value;
--Liberation
procedure Dispose (V : in out Object) is
begin
if V.Kind = String_Value then
Free (V.The_String);
end if;
V := (Kind => Undefined_Value);
end Dispose;
--Access
function Kind_Of_Value (V : in Object) return Kind_Of_Values is
begin
return (V.Kind);
end Kind_Of_Value;
function Get (V : in T_Value.Object) return Integer is
begin
if (V.Kind = Integer_Value) then
return (V.The_Integer);
else
raise Error_Integer_Value;
end if;
end Get;
function Get (V : in T_Value.Object) return Boolean is
begin
if (V.Kind = Boolean_Value) then
return (V.The_Boolean);
else
raise Error_Boolean_Value;
end if;
end Get;
function Get (V : in T_Value.Object) return String is
begin
if (V.Kind = String_Value) then
return (V.The_String.all);
else
raise Error_String_Value;
end if;
end Get;
function Equal (V1 : in Object; V2 : in Object) return Boolean is
begin
if (V1.Kind = V2.Kind) then
case V1.Kind is
when Integer_Value =>
return (V1.The_Integer = V2.The_Integer);
when Boolean_Value =>
return (V1.The_Boolean = V2.The_Boolean);
when String_Value =>
return (V1.The_String.all = V2.The_String.all);
when Undefined_Value =>
return True;
end case;
else
return False;
end if;
exception
when Constraint_Error =>
raise Error_Equal_Value;
end Equal;
function Image (V : in T_Value.Object) return String is
begin
case V.Kind is
when Integer_Value =>
return (Integer'Image (V.The_Integer));
when Boolean_Value =>
return (Boolean'Image (V.The_Boolean));
when String_Value =>
return (V.The_String.all);
when Undefined_Value =>
return ("Undefined Value");
end case;
end Image;
procedure Value_To_File (V : in T_Value.Object; F : V_File) is
begin
-- Text_IO.Put(F,T_Value_Image(V));
Text_Io.Put_Line ("Function not yet implemented");
end Value_To_File;
-- Modification
procedure Undefine (V : in out Object) is
begin
Dispose (V);
New_Value (V);
end Undefine;
procedure Set (V : in out Object; I : in Integer) is
begin
Undefine (V);
V := (Kind => Integer_Value, The_Integer => I);
exception
when Constraint_Error =>
raise Error_Integer_Value;
end Set;
procedure Set (V : in out Object; S : in String) is
Ptr : String_Access;
begin
Undefine (V);
if not (S'Length > Max_Value_String) then
Ptr := new String (1 .. S'Length);
V := (Kind => String_Value, The_String => Ptr);
V.The_String.all := S;
else
raise Error_String_Value;
end if;
exception
when Constraint_Error =>
raise Error_String_Value;
end Set;
procedure Set (V : in out Object; B : in Boolean) is
begin
Undefine (V);
V := (Kind => Boolean_Value, The_Boolean => B);
exception
when Constraint_Error =>
raise Error_Boolean_Value;
end Set;
procedure Copy (To_Value : in out T_Value.Object;
The_Value : in T_Value.Object) is
begin
if (The_Value.Kind = String_Value) then
Set (To_Value, The_Value.The_String.all);
else
Undefine (To_Value);
To_Value := The_Value;
end if;
end Copy;
procedure Set_Value_Using_File (V : in out Object; F : V_File) is
begin
-- Text_IO.Get(F,Value_Image(V));
Text_Io.Put_Line ("Function not yet implemented");
end Set_Value_Using_File;
end T_Value;
with T_Value, Text_Io, Bounded_String,binary_trees_pkg;
package Dynamic_Object is
Error_Attribute_Store : exception;
Error_Attribute_Index : exception;
type Dynamic_Object is private;
type Attribute_Index is private;
subtype D_File is Text_Io.File_Type;
Max_Attribute_String : constant := 32;
--Creation
procedure New_Object (D : in out Dynamic_Object);
--Access
function Has_Attribute
(D : in Dynamic_Object; Name : in String) return Boolean;
procedure Get_Attribute_By_Name
(D : Dynamic_Object; Name : String; V : in out T_Value.Object);
procedure Dump_Number_Of_Attribute(D : in Dynamic_Object);
procedure Dump_Object_Attributes (D : in Dynamic_Object);
function Object_Image (D : in Dynamic_Object) return String;
procedure Object_To_File (D : Dynamic_Object; F : D_File);
function Equal (Left,Right:Dynamic_Object) return Boolean;
--Modification
procedure Store_Attribute
(D : in out Dynamic_Object; Name : String; V : T_Value.Object);
procedure Store_Attribute
(D : in out Dynamic_Object; Name : String; I : Integer);
procedure Store_Attribute
(D : in out Dynamic_Object; Name : String; S : String);
procedure Store_Attribute
(D : in out Dynamic_Object; Name : String; B : Boolean);
procedure Delete_Attribute (D : in out Dynamic_Object; Name : String);
procedure Object_From_File (D : in out Dynamic_Object; F : D_File);
procedure Copy_Object (To_Object : in out Dynamic_Object;
The_Object : Dynamic_Object);
procedure Surface_Copy(To_Object : in out Dynamic_Object;
The_Object : Dynamic_Object);
--Liberation
procedure Dispose_Object (D : in out Dynamic_Object);
--Iteration
procedure Open_Attribute_Indexation
(D : Dynamic_Object; I : in out Attribute_Index);
procedure Next_Attribute_Index (I : in out Attribute_Index);
function Get_Indexed_Attribute_Name (I : Attribute_Index) return String;
procedure Get_Indexed_Attribute_Value
(I : Attribute_Index; V : in out T_Value.Object);
function No_More_Attributes (I : Attribute_Index) return Boolean;
private
type Attribute is
record
Name : Bounded_String.Variable_String (Max_Attribute_String);
Value : T_Value.Object;
end record;
function Compare (A, B : Attribute) return integer;
package Object_Tree is new binary_Trees_pkg(Attribute,Compare);
type Dynamic_Object is
record
Node : Object_Tree.Tree;
end record;
type Attribute_Index is
record
Node : Object_Tree.Iterator;
end record;
end Dynamic_Object;
with T_Value,
Text_Io,
Bounded_String,
binary_trees_pkg;
package body Dynamic_Object is
Use Object_Tree;
INF :constant Integer := -1;
EQU :constant Integer := 0;
SUP :constant Integer := 1;
Current_Attribute :Attribute;
LookAhead :Boolean;
function Create_Attribute(N: String;V : T_Value.Object) return Attribute is
A:Attribute;
begin
Bounded_string.free(A.Name);
Bounded_string.Copy(A.Name,N);
T_Value.New_Value (A.Value);
T_Value.Copy (A.Value,V);
return A;
end;
function Compare (A, B : Attribute) return integer is
begin
declare
Use Bounded_String;
begin
if image(A.name) < image(B.name) then
return INF;
elsif image(A.name) = image(B.name) then
return EQU;
else return SUP;
end if;
end;
end Compare;
procedure Dispose_Attribute (The_Attribute : in out Attribute) is
begin
T_Value.Dispose (The_Attribute.Value);
Bounded_String.Free(The_Attribute.Name);
end Dispose_Attribute;
procedure Destroy_Object is New Destroy_Deep(Free_Value =>Dispose_Attribute);
function Copy_Attribute ( A : Attribute ) return Attribute is
begin
return Create_Attribute(Bounded_String.Image(A.Name),A.Value);
end Copy_Attribute;
function Copy_Object_Tree is new Copy_Tree ( Copy_Value => Copy_Attribute ) ;
procedure Dump_An_Attribute ( A : Attribute ) is
begin
Text_Io.Put_Line ( Bounded_String.image(A.Name) &" : "& T_Value.Image (A.Value));
end Dump_An_Attribute ;
procedure Dump is new Visit ( Process => Dump_An_Attribute ) ;
--Creation
procedure New_Object (D : in out Dynamic_Object) is
begin
D.Node := Object_Tree.Create;
end New_Object;
--Access
procedure Dump_Number_Of_Attribute(D : in Dynamic_Object) is
begin
text_io.put_line("Number of Attribute:"&natural'image(Object_Tree.size(D.Node)));
end;
function Has_Attribute
(D : in Dynamic_Object; Name : in String) return Boolean is
A : Attribute;
begin
A:=Create_Attribute(Name,T_Value.NULL_VALUE);
return Object_Tree.Is_Found (A,D.node);
Dispose_Attribute(A);
end Has_Attribute;
procedure Get_Attribute_By_Name (D : Dynamic_Object;
Name : String;
V : in out T_Value.Object) is
Found : Boolean := False;
A : Attribute;
begin
A:=Create_Attribute(Name,V);
Object_Tree.Find(A,D.node,Found,A);
T_Value.New_Value (V);
T_Value.Copy (V,A.Value);
if not Found then T_Value.Undefine (V); end if;
Dispose_Attribute(A);
end Get_Attribute_By_Name;
function Equal (Left,Right:Dynamic_Object) return Boolean is
Index : Attribute_Index;
Val_R : T_Value.Object;
Val_L : T_Value.Object;
memo :boolean:=LookAhead; -- memorize to avoid modification on Lookahead
begin
if Object_Tree.size(Left.Node) /= Object_Tree.size(Right.Node)
then return False;
end if;
Open_Attribute_Indexation (Left , Index);
TEST_EQUAL:
while not No_More_Attributes(Index) loop
if Has_Attribute(Right,Get_Indexed_Attribute_Name (Index))
then
Get_Attribute_By_Name(Right,
Get_Indexed_Attribute_Name (Index),
Val_R);
Get_Indexed_Attribute_Value (Index,Val_L);
if not T_value.Equal (Val_L,Val_R)
then LookAhead:=Memo; return false; end if;
else LookAhead:=Memo; return false;
end if;
Next_Attribute_Index (Index);
end loop TEST_EQUAL;
LookAhead:=Memo;
return true;
end;
procedure Dump_Object_Attributes (D : in Dynamic_Object) is
begin
Dump ( D.Node,Object_Tree.preorder);
end Dump_Object_Attributes;
function Object_Image (D : in Dynamic_Object) return String is
begin
return ("Function not yet implemented");
end Object_Image;
procedure Object_To_File (D : Dynamic_Object; F : D_File) is
begin
Text_Io.Put_Line ("function not yet implemented");
end Object_To_File;
--Modification
procedure Store_Attribute (D : in out Dynamic_Object;
Name : String;
V : T_Value.Object) is
Found : Boolean := False;
A : Attribute;
begin
Object_Tree.Replace_If_Found (Create_Attribute(Name,V),D.Node,Found,A);
if Found then Dispose_Attribute(A);end if;
exception
when others =>
raise Error_Attribute_Store;
end Store_Attribute;
procedure Store_Attribute
(D : in out Dynamic_Object; Name : String; I : Integer) is
V : T_Value.Object;
begin
T_Value.New_Value (V);
T_Value.Set (V, I);
Store_Attribute (D, Name, V);
T_Value.Dispose (V);
end Store_Attribute;
procedure Store_Attribute
(D : in out Dynamic_Object; Name : String; S : String) is
V : T_Value.Object;
begin
T_Value.New_Value (V);
T_Value.Set (V, S);
Store_Attribute (D, Name, V);
T_Value.Dispose (V);
end Store_Attribute;
procedure Store_Attribute
(D : in out Dynamic_Object; Name : String; B : Boolean) is
V : T_Value.Object;
begin
T_Value.New_Value (V);
T_Value.Set (V, B);
Store_Attribute (D, Name, V);
T_Value.Dispose (V);
end Store_Attribute;
procedure Delete_Attribute (D : in out Dynamic_Object; Name : String) is
begin
Text_Io.Put_Line ("function not yet implemented");
end Delete_Attribute;
procedure Object_From_File (D : in out Dynamic_Object; F : D_File) is
begin
Text_Io.Put_Line ("function not yet implemented");
end Object_From_File;
procedure Copy_Object (To_Object : in out Dynamic_Object;
The_Object : Dynamic_Object) is
begin
To_Object.Node:= Copy_Object_Tree(T=>The_Object.Node);
end Copy_Object;
procedure Surface_Copy (To_Object : in out Dynamic_Object;
The_Object : Dynamic_Object) is
begin
To_Object.Node:= The_Object.Node;
end;
--Liberation
procedure Dispose_Object (D : in out Dynamic_Object) is
begin
Destroy_Object(D.Node);
end Dispose_Object;
--Iteration
procedure Open_Attribute_Indexation
(D : Dynamic_Object; I : in out Attribute_Index) is
begin
I.Node := Object_Tree.Make_Iter(D.Node);
LookAhead:=FALSE;
Next_Attribute_Index(I);
end Open_Attribute_Indexation;
procedure Next_Attribute_Index (I : in out Attribute_Index) is
begin
if not Lookahead then
if Object_Tree.More (I.Node) then
Object_Tree.Next(I.Node,Current_Attribute);
else
raise Error_Attribute_Index;
end if;
end if;
end Next_Attribute_Index;
function Get_Indexed_Attribute_Name (I : Attribute_Index) return String is
begin
return Bounded_String.Image (Current_Attribute.Name);
exception
when others=> raise Error_Attribute_Index;
end Get_Indexed_Attribute_Name;
procedure Get_Indexed_Attribute_Value
(I : Attribute_Index; V : in out T_Value.Object) is
begin
T_Value.Copy (V, Current_Attribute.Value);
exception
when others=> raise Error_Attribute_Index;
raise Error_Attribute_Index;
end Get_Indexed_Attribute_Value;
function No_More_Attributes (I : Attribute_Index) return Boolean is
More:Boolean:=TRUE;
begin
More:= Object_Tree.More (I.Node);
if More then return (False); end if;
if (not More AND not LookAhead) then
Lookahead:=TRUE;
return(FALSE);
elsif (not More AND LookAhead) then
return(TRUE);
end if;
end No_More_Attributes;
end Dynamic_Object;
generic
type Value_Type is private; --| Type of values stored in the tree.
with function Difference(P, Q: Value_Type) return integer is <>;
--| Must return a value > 0 if P > Q, 0 if P = Q, and less than
--| zero otherwise.
package binary_trees_pkg is --| Efficient implementation of binary trees.
--| OVERVIEW
--| This package is an efficient implementation of unbalanced binary trees.
--| These trees have the following properties:
--|-
--| 1. Inserting a value is cheap (log n Differences per insertion).
--| 2. Finding a value is cheap (log n Differences per querey).
--| 3. Can iterate over the values in sorted order in linear time.
--| 4. Space overhead is moderate (2 "pointers" per value stored).
--|+
--| They are thus useful both for sorting sequences of indeterminate size
--| and for lookup tables.
--|
--| OPERATIONS
--|
--|-The following operations are provided:
--|
--| Insert Insert a node into a tree
--| Insert_if_not_Found Insert a node into a tree if not there already
--| Replace_if_Found Replace a node if duplicate exists, else insert.
--| Destroy Destroy a tree
--| Destroy_Deep* Destroy a tree and its contents
--| Balanced_Tree* Create a balanced tree from values supplied in order
--| Copy* Copy a tree. The copy is balanced.
--|
--| Queries:
--| Is_Empty Return TRUE iff a tree is empty.
--| Find Search tree for a node
--| Is_Found Return TRUE iff tree contains specified value.
--| Size Return number of nodes in the tree.
--|
--| Iterators:
--| Visit* Apply a procedure to every node in specified order
--| Make_Iter Create an iterator for ordered scan
--| More Test for exhausted iterator
--| Next Bump an iterator to the next element
--|
--| * Indicates generic subprogram
--|
--| USAGE
--|
--| The following example shows how to use this package where nodes in
--| the tree are labeled with a String_Type value (for which a natural
--| Difference function is not available).
--|-
--| package SP renames String_Pkg;
--|
--| type my_Value is record
--| label: SP.string_type;
--| value: integer;
--| end record;
--|
--| function differ_label(P, Q: SP.string_type) return integer is
--| begin
--| if SP."<"(P, Q) then return -1;
--| elsif SP."<"(Q, P) then return 1;
--| else return 0;
--| end if;
--| end differ_label;
--|
--| package my_Tree is new Binary_Trees_pkg(my_Value, differ_Label);
--|
--| Note that the required Difference function may be easily written in terms
--| of "<" if that is available, but that frequently two comparisons must
--| be done for each Difference. However, both comparisons would have
--| to be done internally by this package for every instantiation if the
--| generic parameter were "<" instead of Difference.
--|
--| PERFORMANCE
--|
--| Every node can be visited in the tree in linear time. The cost
--| of creating an iterator is small and independent of the size
--| of the tree.
--|
--| Recognizing that comparing values can be expensive, this package
--| takes a Difference function as a generic parameter. If it took
--| a comparison function such as "<", then two comparisons would be
--| made per node visited during a search of the tree. Of course this
--| is more costly when "<" is a trivial operation, but in those cases,
--| Difference can be bound to "-" and the overhead in negligable.
--|
--| Two different kinds of iterators are provided. The first is the
--| commonly used set of functions Make_Iter, More, and Next. The second
--| is a generic procedure called Visit. The generic parameter to Visit is
--| a procedure which is called once for each value in the tree. Visit
--| is more difficult to use and results in code that is not quite as clear,
--| but its overhead is about 20% of the More/Next style iterator. It
--| is therefore recommended for use only in time critical inner loops.
----------------------------------------------------------------------------
-- Exceptions --
----------------------------------------------------------------------------
Duplicate_Value: exception;
--| Raised on attempt to insert a duplicate node into a tree.
Not_Found: exception;
--| Raised on attempt to find a node that is not in a tree.
No_More: exception;
--| Raised on attempt to bump an iterator that has already scanned the
--| entire tree.
Out_Of_Order: exception;
--| Raised if a problem in the ordering of a tree is detected.
Invalid_Tree: exception;
--| Value is not a tree or was not properly initialized.
----------------------------------------------------------------------------
-- Types --
----------------------------------------------------------------------------
type Scan_Kind is (inorder, preorder, postorder);
--| Used to specify the order in which values should be scanned from a tree:
--|-
--| inorder: Left, Node, Right (nodes visited in increasing order)
--| preorder: Node, Left, Right (top down)
--| postorder: Left, Right, Node (bottom up)
type Tree is private;
type Iterator is private;
----------------------------------------------------------------------------
-- Operations --
----------------------------------------------------------------------------
Function Create --| Return an empty tree.
return Tree;
--| Effects: Create and return an empty tree. Note that this allocates
--| a small amount of storage which can only be reclaimed through
--| a call to Destroy.
----------------------------------------------------------------------------
Procedure Insert( --| Insert a value into a tree.
V: Value_Type; --| Value to be inserted
T: Tree --| Tree to contain the new value
);
--| Raises: Duplicate_Value, Invalid_Tree.
--| Effects: Insert V into T in the proper place. If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, the exception Duplicate_Value is raised.
--| Caution: Since this package does not attempt to balance trees as
--| values are inserted, it is important to remember that inserting
--| values in sorted order will create a degenerate tree, where search
--| and insertion is proportional to the N instead of to Log N. If
--| this pattern is common, use the Balanced_Tree function below.
----------------------------------------------------------------------------
procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean; --| Becomes True iff V already in tree
Duplicate: out Value_Type --| the duplicate value, if there is one
); --| Raises: Invalid_Tree.
--| Effects: Insert V into T in the proper place. If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, Found will be True and Duplicate will be the duplicate
--| value. This might be a sequence of values with the same key, and
--| V can then be added to the sequence.
----------------------------------------------------------------------------
procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean; --| Becomes True iff L already in tree
Old_Value: out Value_Type --| the duplicate value, if there is one
); --| Raises: Invalid_Tree.
--| Effects: Search for V in T. If found, replace the old value with V,
--| and return Found => True, Old_Value => the old value. Otherwise,
--| simply insert V into T and return Found => False.
----------------------------------------------------------------------------
procedure Destroy( --| Free space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
);
--| Effects: The space allocated to T is reclaimed. The space occupied by
--| the values stored in T is not however, recovered.
----------------------------------------------------------------------------
generic
with procedure free_Value(V: in out Value_Type) is <>;
procedure Destroy_Deep( --| Free all space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
);
--| Effects: The space allocated to T is reclaimed. The values stored
--| in T are reclaimed using Free_Value, and the tree nodes themselves
--| are then reclaimed (in a single walk of the tree).
----------------------------------------------------------------------------
generic
with function next_Value return Value_Type is <>;
--| Each call to this procedure should return the next value to be
--| inserted into the balanced tree being created. If necessary,
--| this function should check that each value is greater than the
--| previous one, and raise Out_of_Order if necessary. If values
--| are not returned in strictly increasing order, the results are
--| unpredictable.
Function Balanced_Tree(
Count: natural
) return Tree;
--| Effects: Create a balanced tree by calling next_Value Count times.
--| Each time Next_Value is called, it must return a value that compares
--| greater than the preceeding value. This function is useful for balancing
--| an existing tree (next_Value iterates over the unbalanced tree) or
--| for creating a balanced tree when reading data from a file which is
--| already sorted.
----------------------------------------------------------------------------
generic
with function Copy_Value(V: Value_Type) return Value_Type is <>;
--| This function is called to copy a value from the old tree to the
--| new tree.
Function Copy_Tree(
T: Tree
) return Tree; --| Raises Invalid_Tree.
--| Effects: Create a balanced tree that is a copy of the tree T.
--| The exception Invalid_Tree is raised if T is not a valid tree.
----------------------------------------------------------------------------
Function Is_Empty( --| Check for an empty tree.
T: Tree
) return boolean;
--| Effects: Return TRUE iff T is an empty tree or if T was not initialized.
----------------------------------------------------------------------------
Function Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Value_Type; --| Raises: Not_Found, Invalid_Tree.
--| Effects: Search T for a value that matches V. The matching value is
--| returned. If no matching value is found, the exception Not_Found
--| is raised.
Procedure Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree; --| Tree to be searched
Found: out Boolean; --| TRUE iff a match was found
Match: out Value_Type --| Matching value found in the tree
); --| Raises: Invalid_Tree;
--| Effects: Search T for a value that matches V. On return, if Found is
--| TRUE then the matching value is returned in Match. Otherwise, Found
--| is FALSE and Match is undefined.
----------------------------------------------------------------------------
function is_Found( --| Check a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Boolean; --| Raises: Invalid_Tree;
--| Effects: Return TRUE iff V is found in T.
----------------------------------------------------------------------------
function Size( --| Return the count of values in T.
T: Tree --| a tree
) return natural;
--| Effects: Return the number of values stored in T.
----------------------------------------------------------------------------
generic
with procedure Process(V: Value_Type) is <>;
procedure Visit(
T: Tree;
Order: Scan_Kind
); --| Raises: Invalid_Tree;
--| Effects: Invoke Process(V) for each value V in T. The nodes are visited
--| in the order specified by Order. Although more limited than using
--| an iterator, this function is also much faster.
----------------------------------------------------------------------------
function Make_Iter( --| Create an iterator over a tree
T: Tree
) return Iterator; --| Raises: Invalid_Tree;
----------------------------------------------------------------------------
function More( --| Test for exhausted iterator
I: Iterator --| The iterator to be tested
) return boolean;
--| Effects: Return TRUE iff unscanned nodes remain in the tree being
--| scanned by I.
----------------------------------------------------------------------------
procedure Next( --| Scan the next value in I
I: in out Iterator; --| an active iterator
V: out Value_Type --| Next value scanned
); --| Raises: No_More.
--| Effects: Return the next value in the tree being scanned by I.
--| The exception No_More is raised if there are no more values to scan.
----------------------------------------------------------------------------
private
type Node;
type Node_Ptr is access Node;
type Node is
record
Value: Value_Type;
Less: Node_Ptr;
More: Node_Ptr;
end record;
type Tree_Header is
record
Count: natural := 0;
Root: Node_Ptr := Null;
end record;
type Tree is access Tree_Header;
type Iter_State is (Left, Middle, Right, Done);
type Iterator_Record;
type Iterator is access Iterator_Record;
type Iterator_Record is
record
State: Iter_State;
Parent: Iterator;
subtree: Node_Ptr;
end record;
end binary_trees_pkg;
with unchecked_deallocation;
Package body Binary_Trees_Pkg is
--| Efficient implementation of binary trees.
----------------------------------------------------------------------------
-- Local Operations --
----------------------------------------------------------------------------
procedure Free_Node is
new unchecked_deallocation(Node, Node_Ptr);
procedure Free_Tree is
new unchecked_deallocation(Tree_Header, Tree);
procedure Free_Iterator is
new unchecked_deallocation(Iterator_Record, Iterator);
----------------------------------------------------------------------------
-- Visible Operations --
----------------------------------------------------------------------------
Function Create --| Return an empty tree.
return Tree is
begin
return new Tree_Header'(0, Null);
end Create;
----------------------------------------------------------------------------
Procedure Insert_Node(
V: Value_Type;
N: in out Node_Ptr;
Found: out boolean;
Duplicate: out Value_Type
)
is
D: integer;
begin
Found := False;
if N = null then
N := new Node'(V, Null, Null);
else
D := Difference(V, N.Value);
if D < 0 then
Insert_Node(V, N.Less, Found, Duplicate);
elsif D > 0 then
Insert_Node(V, N.More, Found, Duplicate);
else
Found := True;
Duplicate := N.Value;
end if;
end if;
end Insert_Node;
Procedure Replace_Node(
V: Value_Type;
N: in out Node_Ptr;
Found: out boolean;
Duplicate: out Value_Type
)
is
D: integer;
begin
Found := False;
if N = null then
N := new Node'(V, Null, Null);
else
D := Difference(V, N.Value);
if D < 0 then
Replace_Node(V, N.Less, Found, Duplicate);
elsif D > 0 then
Replace_Node(V, N.More, Found, Duplicate);
else
Found := True;
Duplicate := N.Value;
N.Value := V;
end if;
end if;
end Replace_Node;
Procedure Insert( --| Insert a value into a tree.
V: Value_Type; --| Value to be inserted
T: Tree --| Tree to contain the new value
) --| Raises: Duplicate_Value, Invalid_Tree.
is
Found: boolean;
Duplicate: Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Insert_Node(V, T.Root, Found, Duplicate);
if Found then
raise Duplicate_Value;
end if;
T.Count := T.Count + 1;
end Insert;
Procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean;
Duplicate: out Value_Type
) --| Raises: Invalid_Tree.
is
was_Found: boolean;
begin
if T = null then
raise Invalid_Tree;
end if;
Insert_Node(V, T.Root, was_Found, Duplicate);
Found := was_Found;
if not was_Found then
T.Count := T.Count + 1;
end if;
end Insert_if_Not_Found;
procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean; --| Becomes True iff L already in tree
Old_Value: out Value_Type --| the duplicate value, if there is one
) --| Raises: Invalid_Tree.
is
was_Found: boolean;
Duplicate: Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Replace_Node(V, T.Root, was_Found, Duplicate);
Found := was_Found;
if was_Found then
Old_Value := Duplicate;
else
T.Count := T.Count + 1;
end if;
end Replace_if_Found;
----------------------------------------------------------------------------
procedure Destroy_Nodes(
N: in out Node_Ptr
) is
begin
if N /= null then
Destroy_Nodes(N.Less);
Destroy_Nodes(N.More);
Free_Node(N);
end if;
end Destroy_Nodes;
procedure Destroy( --| Free space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
) is
begin
if T /= Null then
Destroy_Nodes(T.Root);
Free_Tree(T);
end if;
end Destroy;
----------------------------------------------------------------------------
procedure Destroy_Deep( --| Free all space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
)
is
procedure Destroy_Nodes(
N: in out node_Ptr
) is
begin
if N /= null then
Free_Value(N.Value);
Destroy_Nodes(N.Less);
Destroy_Nodes(N.More);
Free_Node(N);
end if;
end Destroy_Nodes;
begin
if T /= Null then
Destroy_Nodes(T.Root);
Free_Tree(T);
end if;
end Destroy_Deep;
----------------------------------------------------------------------------
Function Balanced_Tree(
Count: natural
) return Tree
is
new_Tree: Tree := Create;
procedure subtree(Count: natural; N: in out Node_Ptr)
is
new_Node: Node_Ptr;
begin
if Count = 1 then
new_Node := new Node'(next_Value, Null, Null);
elsif Count > 1 then
new_node := new Node;
subtree(Count/2, new_Node.Less); -- Half are less
new_Node.Value := next_Value; -- Median value
subtree(Count - Count/2 - 1, new_Node.More); -- Other half are more
end if;
N := new_Node;
end subtree;
begin
new_Tree.Count := Count;
subtree(Count, new_Tree.Root);
return new_Tree;
end Balanced_Tree;
----------------------------------------------------------------------------
Function Copy_Tree(
T: Tree
) return Tree
is
I: Iterator;
function next_Val return Value_type
is
V: Value_Type;
begin
Next(I, V);
return copy_Value(V);
end next_Val;
function copy_Balanced is new Balanced_Tree(next_Val);
begin
I := Make_Iter(T); -- Will raise Invalid_Tree if necessary
return copy_Balanced(Size(T));
end Copy_Tree;
----------------------------------------------------------------------------
Function Is_Empty( --| Check for an empty tree.
T: Tree
) return boolean is
begin
return T = Null or else T.Root = Null;
end Is_Empty;
----------------------------------------------------------------------------
procedure Find_Node(
V: Value_Type; --| Value to be located
N: Node_Ptr; --| subtree to be searched
Match: out Value_Type; --| Matching value found in the tree
Found: out Boolean --| TRUE iff a match was found
)
is
D: integer;
begin
if N = null then
Found := False;
return;
end if;
D := Difference(V, N.Value);
if D < 0 then
Find_Node(V, N.Less, Match, Found);
elsif D > 0 then
Find_Node(V, N.More, Match, Found);
else
Match := N.Value;
Found := TRUE;
end if;
end Find_Node;
Function Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Value_Type --| Raises: Not_Found.
is
Found: Boolean;
Match: Value_Type;
begin
if T = Null then
raise Invalid_Tree;
end if;
Find_Node(V, T.Root, Match, Found);
if Found then
return Match;
else
raise Not_Found;
end if;
end Find;
Procedure Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree; --| Tree to be searched
Found: out Boolean; --| TRUE iff a match was found
Match: out Value_Type --| Matching value found in the tree
) is
begin
if T = Null then
raise Invalid_Tree;
end if;
Find_Node(V, T.Root, Match, Found);
end Find;
----------------------------------------------------------------------------
function is_Found( --| Check a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Boolean
is
Found: Boolean;
Match: Value_Type;
begin
if T = Null then
raise Invalid_Tree;
end if;
Find_Node(V, T.Root, Match, Found);
return Found;
end is_Found;
----------------------------------------------------------------------------
function Size( --| Return the count of values in T.
T: Tree --| a tree
) return natural is
begin
if T = Null then
Return 0;
else
Return T.Count;
end if;
end Size;
----------------------------------------------------------------------------
procedure Visit(
T: Tree;
Order: Scan_Kind
) is
procedure visit_Inorder(N: Node_Ptr) is
begin
if N.Less /= null then
visit_Inorder(N.Less);
end if;
Process(N.Value);
if N.More /= null then
visit_Inorder(N.More);
end if;
end visit_Inorder;
procedure visit_preorder(N: Node_Ptr) is
begin
Process(N.Value);
if N.Less /= null then
visit_preorder(N.Less);
end if;
if N.More /= null then
visit_preorder(N.More);
end if;
end visit_preorder;
procedure visit_postorder(N: Node_Ptr) is
begin
if N.Less /= null then
visit_postorder(N.Less);
end if;
if N.More /= null then
visit_postorder(N.More);
end if;
Process(N.Value);
end visit_postorder;
begin
if T = Null then
raise Invalid_Tree;
else
case Order is
when inorder =>
Visit_Inorder(T.Root);
when preorder =>
Visit_preorder(T.Root);
when postorder =>
Visit_postorder(T.Root);
end case;
end if;
end Visit;
----------------------------------------------------------------------------
function subtree_Iter( --| Create an iterator over a subtree
N: Node_Ptr;
P: Iterator
) return Iterator is
begin
if N = Null then
return new Iterator_Record'(State => Done, Parent => P, subtree => N);
elsif N.Less = Null then
return new Iterator_Record'(State => Middle, Parent => P, subtree => N);
else
return new Iterator_Record'(State => Left, Parent => P, subtree => N);
end if;
end subtree_Iter;
function Make_Iter( --| Create an iterator over a tree
T: Tree
) return Iterator is
begin
if T = Null then
raise Invalid_Tree;
end if;
return subtree_Iter(T.Root, Null);
end Make_Iter;
----------------------------------------------------------------------------
function More( --| Test for exhausted iterator
I: Iterator --| The iterator to be tested
) return boolean is
begin
if I = Null then
return False;
elsif I.Parent = Null then
return I.State /= Done and I.subtree /= Null;
elsif I.State = Done then
return More(I.Parent);
else
return True;
end if;
end More;
----------------------------------------------------------------------------
procedure pop_Iterator(
I: in out Iterator
)
is
NI: Iterator;
begin
loop
NI := I;
I := I.Parent;
Free_Iterator(NI);
exit when I = Null;
exit when I.State /= Done;
end loop;
end pop_Iterator;
procedure Next( --| Scan the next value in I
I: in out Iterator; --| an active iterator
V: out Value_Type --| Next value scanned
) --| Raises: No_More.
is
NI: Iterator;
begin
if I = Null or I.State = Done then
raise No_More;
end if;
case I.State is
when Left => -- Return the leftmost value
while I.subtree.Less /= Null loop -- Find leftmost subtree
I.State := Middle; -- Middle is next at this level
I := subtree_Iter(I.subtree.Less, I);
end loop;
V := I.subtree.Value;
if I.subtree.More /= Null then -- There will be more...
I.State := Right; -- ... coming from the right
else -- Nothing else here
pop_Iterator(I); -- Pop up to parent iterator
end if;
when Middle =>
V := I.subtree.Value;
if I.subtree.More /= Null then -- There will be more...
I.State := Right; -- ... coming from the right
else -- Nothing else here so...
pop_Iterator(I); -- ... Pop up to parent iterator
end if;
when Right => -- Return the value on the right
I.State := Done; -- No more at this level
I := subtree_Iter(I.subtree.More, I);
Next(I, V);
when Done =>
pop_Iterator(I);
Next(I, V);
end case;
end Next;
----------------------------------------------------------------------------
end binary_trees_pkg;
with Dynamic_Object,Text_Io, Bounded_String,binary_trees_pkg;
package Symbols is
Error_Symbol_Store : exception;
Error_Symbol_Index : exception;
Error_Symbol_Search: exception;
type Object is limited private;
type Symbol_Index is limited private;
Max_Symbol_String : constant := 32;
--Creation
procedure Create (D : in out Object);
--Access
function Has_Symbol
(D : in Object; Name : in String) return Boolean;
function Get_Symbol_Type_By_Name(D : Object; Name : String)return String;
Procedure Get_Symbol_Value_By_Name(D : Object; Name : String;F:in out Dynamic_Object.Dynamic_Object);
procedure Dump_Symbols (D : in Object);
procedure Dump_Number_Of_Symbol(D : in Object);
--Modification
procedure Store_Symbol
(D : in out Object; aName : String;aType :String;F :Dynamic_Object.Dynamic_Object);
--Liberation
procedure Dispose_Object (D : in out Object);
--Iteration
procedure Open_Symbol_Indexation
(D : Object; I : in out Symbol_Index);
procedure Next_Symbol_Index (I : in out Symbol_Index);
function Get_Indexed_Symbol_Name (I : Symbol_Index) return String;
function Get_Indexed_Symbol_Type (I : Symbol_Index) return String;
procedure Get_Indexed_Symbol_Value(I : Symbol_Index;F:in out Dynamic_Object.Dynamic_Object);
function No_More_Symbols (I : Symbol_Index) return Boolean;
private
type Symbol is
record
Symbol_Name : Bounded_String.Variable_String (Max_Symbol_String);
Symbol_Type : Bounded_String.Variable_String (Max_Symbol_String);
Symbol_Value : Dynamic_Object.Dynamic_Object;
end record;
function Compare (A, B : Symbol) return integer;
package Symbols_Tree is new binary_Trees_pkg(Symbol,Compare);
type Object is
record
Node : Symbols_Tree.Tree;
end record;
type Symbol_Index is
record
Node : Symbols_Tree.Iterator;
end record;
end Symbols;
with Dynamic_Object, Text_Io, Bounded_String,binary_trees_pkg;
package body Symbols is
Use Symbols_Tree;
INF :constant Integer := -1;
EQU :constant Integer := 0;
SUP :constant Integer := 1;
Current_Symbol :Symbol;
LookAhead :Boolean;
function Create_Symbol(N: String;T: String; F : Dynamic_Object.Dynamic_Object) return Symbol is
A:Symbol;
begin
Bounded_string.free(A.Symbol_Name);
Bounded_string.Copy(A.Symbol_Name,N);
Bounded_string.free(A.Symbol_Type);
Bounded_string.Copy(A.Symbol_Type,T);
Dynamic_Object.Surface_copy(A.Symbol_Value,F);
return A;
end;
function Compare (A, B : Symbol) return integer is
begin
declare
Use Bounded_String;
begin
if image(A.Symbol_name) < image(B.Symbol_name) then
return INF;
elsif image(A.Symbol_name) = image(B.Symbol_name) then
return EQU;
else return SUP;
end if;
end;
end Compare;
procedure Dispose_Symbol (The_Symbol : in out Symbol) is
begin
Dynamic_Object.Dispose_Object(The_Symbol.Symbol_Value);
Bounded_String.Free(The_Symbol.Symbol_Name);
Bounded_String.Free(The_Symbol.Symbol_Type);
end Dispose_Symbol;
procedure Destroy_Object is New Destroy_Deep(Free_Value =>Dispose_Symbol);
procedure Dump_An_Symbol ( A : Symbol ) is
begin
Text_IO.Put_Line("........................................");
Text_Io.Put_Line ( Bounded_String.image(A.Symbol_Name) &" "&
Bounded_String.image(A.Symbol_Type) &"With Object:");
Dynamic_Object.Dump_Object_Attributes(A.Symbol_Value);
end Dump_An_Symbol ;
procedure Dump is new Visit ( Process => Dump_An_Symbol ) ;
--Creation
procedure Create (D : in out Object) is
begin
D.Node := Symbols_Tree.Create;
end ;
--Access
procedure Dump_Number_Of_Symbol(D : in Object) is
begin
text_io.put_line("Number of Symbol:"&natural'image(Symbols_tree.size(D.Node)));
end;
function Has_Symbol
(D : in Object; Name : in String) return Boolean is
A : Symbol;
F : Dynamic_Object.Dynamic_Object;
begin
Dynamic_Object.New_Object(F);
A:=Create_Symbol(Name,Name,F); -- Only the first param. is important
return Symbols_tree.Is_Found (A,D.node);
end Has_Symbol;
function Get_Symbol_Type_By_Name(D : Object; Name : String)return String is
Found : Boolean := False;
A : Symbol;
B :Dynamic_Object.Dynamic_Object;
begin
Dynamic_Object.New_Object(B);
A:=Create_Symbol(Name,Name,B); -- Only the first param. is important
Symbols_tree.Find(A,D.node,Found,A);
if found then
return Bounded_String.Image(A.Symbol_Type);
else return "";
end if;
exception
when others =>
raise Error_Symbol_Search;
end;
Procedure Get_Symbol_Value_By_Name(D : Object; Name : String;F:in out Dynamic_Object.Dynamic_Object) is
Found : Boolean := False;
A : Symbol;
B :Dynamic_Object.Dynamic_Object;
begin
Dynamic_Object.New_Object(B);
A:=Create_Symbol(Name,Name,B); -- Only the first param. is important
Symbols_tree.Find(A,D.node,Found,A);
if found then
Dynamic_Object.Copy_Object(F,A.Symbol_Value);
end if;
exception
when others =>
raise Error_Symbol_Search;
end;
procedure Dump_Symbols (D : in Object) is
begin
Dump ( D.Node,Symbols_tree.inorder);
end Dump_Symbols;
--Modification
procedure Store_Symbol
(D : in out Object; aName : String;aType :String;F :Dynamic_Object.Dynamic_Object)is
Found : Boolean := False;
A : Symbol;
B :Dynamic_Object.Dynamic_Object;
begin
Dynamic_Object.New_Object(B);
Dynamic_Object.Copy_Object(B,F);
Symbols_tree.Replace_If_Found (Create_Symbol(aName,aType,B),D.Node,Found,A);
if Found then Dispose_Symbol(A); end if;
exception
when others =>
raise Error_Symbol_Store;
end Store_Symbol;
--Liberation
procedure Dispose_Object (D : in out Object) is
begin
Destroy_Object(D.Node);
end Dispose_Object;
--Iteration
procedure Open_Symbol_Indexation
(D : Object; I : in out Symbol_Index) is
begin
I.Node := Symbols_tree.Make_Iter(D.Node);
LookAhead:=FALSE;
Next_Symbol_Index(I);
end Open_Symbol_Indexation;
procedure Next_Symbol_Index (I : in out Symbol_Index) is
begin
if not Lookahead then
if Symbols_tree.More (I.Node) then
Symbols_tree.Next(I.Node,Current_Symbol);
else
raise Error_Symbol_Index;
end if;
end if;
end Next_Symbol_Index;
function Get_Indexed_Symbol_Name (I : Symbol_Index) return String is
begin
return Bounded_String.Image (Current_Symbol.Symbol_Name);
exception
when others=> raise Error_Symbol_Index;
end Get_Indexed_Symbol_Name;
function Get_Indexed_Symbol_Type (I : Symbol_Index) return String is
begin
return Bounded_String.Image (Current_Symbol.Symbol_Type);
exception
when others=> raise Error_Symbol_Index;
end Get_Indexed_Symbol_Type;
procedure Get_Indexed_Symbol_Value(I : Symbol_Index;F:in out Dynamic_Object.Dynamic_Object) is
begin
Dynamic_Object.Copy_Object (F, Current_Symbol.Symbol_Value);
exception
when others=> raise Error_Symbol_Index;
raise Error_Symbol_Index;
end Get_Indexed_Symbol_Value;
function No_More_Symbols (I : Symbol_Index) return Boolean is
More:Boolean:=TRUE;
begin
More:= Symbols_tree.More (I.Node);
if More then return (False); end if;
if (not More AND not LookAhead) then
Lookahead:=TRUE;
return(FALSE);
elsif (not More AND LookAhead) then
return(TRUE);
end if;
end No_More_Symbols;
end Symbols;
with Symbols,dynamic_object,text_io;
procedure main is
D1,D2,D3 : dynamic_object.Dynamic_object;
S : Symbols.object;
procedure Print_With_Index(D :Symbols.Object) is
Index : Symbols.Symbol_Index;
Val : dynamic_object.Dynamic_object;
begin
Symbols.Open_Symbol_Indexation (D , Index);
while not Symbols.No_More_Symbols(Index) loop
Text_IO.Put_Line("****************************************");
Text_Io.Put_Line (Symbols.Get_Indexed_Symbol_Name (Index) &
" : " & Symbols.Get_Indexed_Symbol_Type(Index)&"-> WITH:");
dynamic_object.New_Object(val);
Symbols.Get_Indexed_Symbol_Value(Index,val);
dynamic_object.Dump_Object_Attributes(val);
dynamic_object.Dispose_Object(val);
Symbols.Next_Symbol_Index (Index);
end loop;
end Print_With_Index;
begin
dynamic_object.New_Object(D1);
dynamic_object.New_Object(D2);
dynamic_object.New_Object(D3);
Symbols.Create(S);
dynamic_object.Store_Attribute(D1,name=>"Nom ",S=>"Asterix");
dynamic_object.Store_Attribute(D1,name=>"Age ",I=>45);
dynamic_object.Store_Attribute(D1,name=>"Est un ",S=>"Gaulois");
dynamic_object.Store_Attribute(D1,name=>"Moustachu",B=>TRUE);
dynamic_object.Store_Attribute(D1,name=>"Poids ",I=>58);
text_io.put_line("....................................");
dynamic_object.Dump_Number_Of_Attribute(D=>D1);
dynamic_object.Dump_Object_Attributes(D1);
dynamic_object.Store_Attribute(D2,name=>"Nom ",S=>"Obelix ");
dynamic_object.Store_Attribute(D2,name=>"Force ",I=>99);
text_io.put_line("....................................");
dynamic_object.Dump_Number_Of_Attribute(D=>D2);
dynamic_object.Dump_Object_Attributes(D2);
dynamic_object.Store_Attribute(D3,name=>"Nom ",S=>"Idefix ");
dynamic_object.Store_Attribute(D3,name=>"Est un ",S=>"Chien ");
dynamic_object.Store_Attribute(D3,name=>"Chien ",B=>TRUE);
dynamic_object.Store_Attribute(D3,name=>"Couleur ",I=>1);
text_io.put_line("....................................");
dynamic_object.Dump_Number_Of_Attribute(D=>D3);
dynamic_object.Dump_Object_Attributes(D3);
Symbols.Store_Symbol(S,"ASTERIX ","GAULOIS ",D1);
Symbols.Store_Symbol(S,"OBELIX ","GAULOIS ",D2);
Symbols.Store_Symbol(S,"IDEFIX ","ANIMAL ",D3);
Text_IO.Put_Line("----------------------------------------");
Text_IO.Put_Line("--- Print Table des Symbols ----------");
Symbols.Dump_Symbols(S);
Symbols.Dump_Number_Of_Symbol(S);
text_io.put_line("....................................");
Text_Io.Put_Line ( "Print Using an Iterator -> ");
Print_With_Index(S);
text_io.put_line("....................................");
Text_Io.Put_Line ( "Destroy Dynamic Object");
dynamic_object.Dispose_Object(D1);
dynamic_object.Dispose_Object(D2);
dynamic_object.Dispose_Object(D3);
dynamic_object.Dump_Number_Of_Attribute(D1);
dynamic_object.Dump_Number_Of_Attribute(D2);
dynamic_object.Dump_Number_Of_Attribute(D3);
Symbols.Dispose_Object(S);
Symbols.Dump_Number_Of_Symbol(S);
end main