|
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: 33792 (0x8400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body String_Map, seg_005831
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Unchecked_Deallocation;
with Arithmetic;
use Arithmetic;
with Vstring_Case;
with Vstring_Type;
use Vstring_Type;
package body String_Map is
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the name of Rational not be used in
-- advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- Rational disclaims all warranties with regard to this software, including
-- all implied warranties of merchantability and fitness, in no event shall
-- Rational be liable for any special, indirect or consequential damages or
-- any damages whatsoever resulting from loss of use, data or profits, whether
-- in an action of contract, negligence or other tortious action, arising out
-- of or in connection with the use or performance of this software.
------------------------------------------------------------------------------
type S_Natural_Array is array (S_Natural range <>) of S_Natural;
----Elements are simply pairs of string Keys and Range_Type values.
type String_Ptr is access E_String;
type Elem_Rec is
record
Hash : S_Natural := 0;
Key : String_Ptr := null;
Rt : Range_Type;
Next : Element := null;
end record;
----Maps are simply a table of Element linked lists.
type Element_Array is array (S_Natural range 0 .. Hash_Size - 1) of Element;
type Map_Rec is
record
Count : S_Natural := 0;
Table : Element_Array := (0 .. Hash_Size - 1 => null);
end record;
--\x0c
procedure Free_String_Ptr is new Unchecked_Deallocation (E_String,
String_Ptr);
procedure Free_Element is new Unchecked_Deallocation (Elem_Rec,
Element);
procedure Free_Map_Internal is new Unchecked_Deallocation (Map_Rec,
Map);
--\x0c
function Hash (Key : E_String) return S_Natural is
------------------------------------------------------------------------------
-- Key - Specfies the string to hash
--
-- Returns a hash value for the indicated string.
------------------------------------------------------------------------------
Xl : S_Natural_Array (Key'Range);
use Vstring_Case;
begin
if Exact_Case_Match then
for I in Key'Range loop
Xl (I) := Character'Pos (Key (I));
end loop;
else
for I in Key'Range loop
Xl (I) := Character'Pos (Vstring_Case.Uc_Char (Key (I)));
end loop;
end if;
case Key'Length is
when 0 =>
return 0;
when 1 =>
return Xl (Xl'First);
when 2 =>
return Xl (Xl'First) * 128
+ Xl (Xl'Last);
when 3 =>
return Xl (Xl'First) * 64
+ Xl (Xl'First + 1) * 128
+ Xl (Xl'Last);
when 4 =>
return Xl (Xl'First) * 32
+ Xl (Xl'First + 1) * 64
+ Xl (Xl'First + 2) * 128
+ Xl (Xl'Last);
when others =>
declare
I : S_Natural := Xl'First;
H : S_Natural := 0;
begin
while I + 3 <= Xl'Last loop
if S_Natural'Last / 3 < H then
----Prevent overflow on long strings.
H := H / 3;
end if;
H := H + Xl (I) * 32
+ Xl (I + 1) * 64
+ Xl (I + 2) * 128
+ Xl (I + 3);
I := I + 4;
end loop;
for J in I .. Xl'Last loop
H := H + Xl (J);
end loop;
return H;
end;
end case;
end Hash;
--\x0c
function Equal (A : E_String; B : E_String) return Boolean is
------------------------------------------------------------------------------
-- A - Specifies the first string
-- B - Specifies the second string
--
-- Returns TRUE if A = B when both are upper case. B is assumed to be
-- upper case already.
------------------------------------------------------------------------------
Ai : S_Natural := A'First;
Bi : S_Natural := B'First;
begin
----The lengths must be the same.
if A'Length /= B'Length then
return False;
end if;
----Check for any differences.
for I in S_Natural range 0 .. A'Length - 1 loop
if Vstring_Case.Uc_Char (A (Ai + I)) /= B (Bi + I) then
return False;
end if;
end loop;
----They are the same.
return True;
end Equal;
--\x0c
procedure Lookup (H : S_Natural;
Key : E_String;
Prev : out Element;
Elem : in out Element) is
------------------------------------------------------------------------------
-- H - Specifies the hash value for the Key
-- Key - Specifies the key we are looking for
-- Prev - Receives the last element in the initial Elem list or else the
-- Element whose .Next is Elem.
-- Elem - Receives NULL or else the Element that matches the Key/H values;
-- initially is the M.Table(H) value
------------------------------------------------------------------------------
El : Element := Elem;
begin
----Initially there is no Prev vaue.
Prev := null;
----Loop over all of the chained elements looking for matching H/Key values.
while El /= null loop
if El.Hash = H then
if Exact_Case_Match then
if El.Key.all = Key then
Elem := El;
return;
end if;
else
if Equal (Key, El.Key.all) then
Elem := El;
return;
end if;
end if;
end if;
Prev := El;
El := El.Next;
end loop;
----Nothing was found. Return null.
Elem := null;
end Lookup;
--\x0c
procedure New_Map (M : out Map) is
------------------------------------------------------------------------------
-- M - Receives a new Map.
--
-- Called to create and initialize a new Map. The Map Is_Empty.
------------------------------------------------------------------------------
begin
M := new Map_Rec;
end New_Map;
--\x0c
procedure Free_Map (M : in out Map) is
------------------------------------------------------------------------------
-- M - Specifies the existing Map to deallocate.
--
-- Called to destroy an existing Map. Map may have a None_Map value. All map
-- entries are destroyed. The Range_Type values contained in the map are
-- merely dropped and are not deallocated or manipulated in any way.
------------------------------------------------------------------------------
Elem1 : Element;
Elem2 : Element;
begin
----Free any existing table entries.
if M.Count > 0 then
for I in M.Table'Range loop
Elem1 := M.Table (I);
----Free elements on this chain; including the Key strings.
while Elem1 /= null loop
Elem2 := Elem1.Next;
Free_String_Ptr (Elem1.Key);
Free_Element (Elem1);
Elem1 := Elem2;
end loop;
end loop;
end if;
----Free the map itself.
Free_Map_Internal (M);
end Free_Map;
--\x0c
function Is_Empty (M : in Map) return Boolean is
------------------------------------------------------------------------------
-- M - Specifies the map
--
-- Returns TRUE if the map is completely empty.
------------------------------------------------------------------------------
begin
return M.Count = 0;
end Is_Empty;
--\x0c
function Cardinality (M : in Map) return S_Natural is
------------------------------------------------------------------------------
-- M - Specifies the map
--
-- Returns the number of entries in the map.
------------------------------------------------------------------------------
begin
return M.Count;
end Cardinality;
--\x0c
procedure Find (M : in Map;
Key : in E_String;
Rt : in out Range_Type;
Success : out Boolean) is
------------------------------------------------------------------------------
-- M - Specifies the map to use
-- Key - Specifies the string value to use for the lookup
-- Rt - Receives the Range_Type value from the map or is unchanged
-- Success - Receives TRUE if the Key was found and FALSE if not
--
-- Called to perform a lookup within the map. If the Key string is found
-- within the map then the associated Range_Type value is returned and
-- Success is set to TRUE. If the Key string is not found then Success is
-- set to FALSE and the Rt parameter remains unchanged. (Beware of
-- uninitialized locals being passed to Find; they will often be the cause
-- of Constraint_Errors.)
------------------------------------------------------------------------------
H : S_Natural := Hash (Key);
Prev : Element;
Elem : Element := M.Table (H rem Hash_Size);
begin
----Lookup the entry in the table with this hash value.
Lookup (H, Key, Prev, Elem);
if Elem /= null then
Rt := Elem.Rt;
Success := True;
return;
end if;
----We did not find the Key in the map.
Success := False;
end Find;
--\x0c
function Locate (M : in Map;
Key : in E_String) return Range_Type is
------------------------------------------------------------------------------
-- M - Specifies the map to use
-- Key - Specifies the string value to use for the lookup
--
-- Called to perform a lookup within the map. If the Key string is found
-- within the map then the associated Range_Type value is returned.
-- If the Key string is not found then Missing_Entry is raised.
------------------------------------------------------------------------------
H : S_Natural := Hash (Key);
Prev : Element;
Elem : Element := M.Table (H rem Hash_Size);
begin
----Lookup the entry in the table with this hash value.
Lookup (H, Key, Prev, Elem);
if Elem /= null then
return Elem.Rt;
end if;
----We did not find the Key in the map.
raise Missing_Entry;
end Locate;
--\x0c
procedure Insert (M : in Map;
Key : in E_String;
Rt : in Range_Type;
Dups_Ok : in Boolean := False) is
------------------------------------------------------------------------------
-- M - Specifies the map to use
-- Key - Specifies the string value to use for the insertion
-- Rt - Specifies the Range_Type value to be placed into the map
-- Dups_Ok - Specifies TRUE if the new entry is allowed to replace an
-- existing entry.
--
-- Called to insert a new Range_Type value into the map. If Dups_Ok => FALSE
-- then a preexisting map entry with the same Key value will cause
-- Duplicate_Entry to be raised.
------------------------------------------------------------------------------
H : S_Natural := Hash (Key);
Prev : Element;
Elem : Element := M.Table (H rem Hash_Size);
begin
----Lookup the entry in the table with this hash value. Replace any existing
-- entry if that is ok.
Lookup (H, Key, Prev, Elem);
if Elem /= null then
if Dups_Ok then
Elem.Rt := Rt;
return;
else
raise Duplicate_Entry;
end if;
end if;
----Create a new map element and put it into the map.
Elem := new Elem_Rec'(Hash => H,
Key => new E_String'(Key),
Rt => Rt,
Next => null);
H := H rem Hash_Size;
Elem.Next := M.Table (H);
M.Table (H) := Elem;
M.Count := M.Count + 1;
----If not matching on case of characters then make the Key string upper case.
if not Exact_Case_Match then
for I in Elem.Key'Range loop
Elem.Key (I) := Vstring_Case.Uc_Char (Elem.Key (I)); end loop;
end if;
end Insert;
--\x0c
procedure Delete (M : in Map;
Key : in E_String;
Missing_Ok : in Boolean := False) is
------------------------------------------------------------------------------
-- M - Specifies the map to use
-- Key - Specifies the string value to use for the lookup
-- Missing_Ok - Specifies TRUE if the entry need not exist
--
-- Called to delete an existing Range_Type value from the map. Raises
-- Missing_Entry if no matching Key entry is found unless Missing_Ok => TRUE.
------------------------------------------------------------------------------
H : S_Natural := Hash (Key);
H2 : S_Natural := H rem Hash_Size;
Prev : Element;
Elem : Element := M.Table (H2);
begin
----Lookup the entry in the table with this hash value and delete it.
Lookup (H, Key, Prev, Elem); if Elem /= null then
if Prev = null then
M.Table (H2) := Elem.Next;
else
Prev.Next := Elem.Next;
end if;
Free_String_Ptr (Elem.Key);
Free_Element (Elem);
M.Count := M.Count - 1;
return;
end if;
----We did not find the Key in the map.
if Missing_Ok then
return;
else
raise Missing_Entry;
end if;
end Delete;
--\x0c
procedure Remove (M : in Map;
Key : in E_String;
Rt : in out Range_Type;
Success : out Boolean) is
------------------------------------------------------------------------------
-- M - Specifies the map to use
-- Key - Specifies the string value to use for the lookup
-- Rt - Receives the Range_Type value from the map or is unchanged
-- Success - Receives TRUE if the Key was found and FALSE if not
--
-- Called to lookup and remove an entry within the map. If the Key string is
-- found -- within the map then the associated Range_Type value is returned and
-- Success is set to TRUE. If the Key string is not found then Success is
-- set to FALSE and the Rt parameter remains unchanged. (Beware of
-- uninitialized locals being passed to Find; they will often be the cause
-- of Constraint_Errors.)
------------------------------------------------------------------------------
H : S_Natural := Hash (Key);
H2 : S_Natural := H rem Hash_Size;
Prev : Element;
Elem : Element := M.Table (H2);
begin
----Lookup the entry in the table with this hash value and delete it.
Lookup (H, Key, Prev, Elem);
if Elem /= null then
if Prev = null then
M.Table (H2) := Elem.Next;
else
Prev.Next := Elem.Next;
end if;
Rt := Elem.Rt;
Free_String_Ptr (Elem.Key);
Free_Element (Elem);
M.Count := M.Count - 1;
Success := True;
return;
end if;
----We did not find the Key in the map.
Success := False;
end Remove;
--\x0c
procedure Initialize (M : in Map;
I : in out Iter) is
------------------------------------------------------------------------------
-- M - Specifies the map
-- I - Receives the new iteration value
--
-- Called to initialize an iterator for a particular map. Iterators are
-- used in this fashion:
-- declare
-- I : Iter;
-- M : Map;
-- Rt : Range_Type;
-- begin
-- Initilize (M, I);
-- while not Done (I) loop
-- Rt := Value (I);
-- .... Code using the Rt value ....
-- Next (I);
-- end loop;
-- end;
-- Iterators are affected by changes to the map. Deletions can cause
-- dereferencing of null pointers. Insertions are benign and new map entries
-- may or may not appear as Values in the iteration depending upon the
-- state of the Iter when the Insert is performed and also depending upon the
-- value of the Key string.
--
-- The iterator will advance through all entries within the map and the
-- processing order of the entries is determined by the hash value of the
-- Key strings and may or may not have any externally sensible ordering.
------------------------------------------------------------------------------
begin
----Search for any element whatsoever.
I.M := M;
for Ind in 0 .. Hash_Size - 1 loop
if M.Table (Ind) /= null then
I.Elem := M.Table (Ind);
I.Index := Ind;
return;
end if;
end loop;
----Map is empty. Finish the initializtion.
I.Elem := null;
I.Index := Hash_Size;
end Initialize;
--\x0c
function Done (I : in Iter) return Boolean is
------------------------------------------------------------------------------
-- I - Specifies the iterator to check
--
-- Returns TRUE when there are no more map entries to iterate through.
------------------------------------------------------------------------------
begin
----If we have an element waiting then we are not done.
if I.Elem /= null then
return False;
end if;
----We must be done.
return True;
end Done;
--\x0c
function Key (I : in Iter) return E_String is
------------------------------------------------------------------------------
-- I - Specifies the iterator to check
--
-- Returns the key string value associated with the current value of the
-- map iterator. Raises Missing_Entry if Done(I) = TRUE.
-----------------------------------------------------------------------------
begin
if I.Elem = null then
raise Missing_Entry;
end if;
return I.Elem.Key.all;
end Key;
--\x0c
function Value (I : in Iter) return Range_Type is
------------------------------------------------------------------------------
-- I - Specifies the iterator to check
--
-- Returns the Range_Type value associated with the current value of the
-- map iterator. Raises Missing_Entry if Done(I) = TRUE.
------------------------------------------------------------------------------
begin
if I.Elem = null then
raise Missing_Entry;
end if;
return I.Elem.Rt;
end Value;
--\x0c
procedure Next (I : in out Iter) is
------------------------------------------------------------------------------
-- I - Specifies the iterator
--
-- Advances the map iterator by one entry. Raises Missing_Entry if
-- Done(I) = TRUE already. Done(I) = TRUE will be true when this routine
-- returns if there are no more entries to be processed.
------------------------------------------------------------------------------
Elem : Element;
begin
----Locate the next element.
if I.Elem = null then
raise Missing_Entry;
end if;
if I.Elem.Next /= null then
I.Elem := I.Elem.Next;
return;
end if;
for Ind in I.Index + 1 .. Hash_Size - 1 loop
if I.M.Table (Ind) /= null then
I.Elem := I.M.Table (Ind);
I.Index := Ind;
return;
end if;
end loop;
----Nothing Next; we are Done.
I.Elem := null;
end Next;
--\x0c
end String_Map;
nblk1=20
nid=0
hdr6=40
[0x00] rec0=19 rec1=00 rec2=01 rec3=090
[0x01] rec0=1b rec1=00 rec2=02 rec3=030
[0x02] rec0=00 rec1=00 rec2=20 rec3=016
[0x03] rec0=1a rec1=00 rec2=03 rec3=022
[0x04] rec0=1c rec1=00 rec2=04 rec3=03a
[0x05] rec0=1a rec1=00 rec2=05 rec3=032
[0x06] rec0=23 rec1=00 rec2=06 rec3=054
[0x07] rec0=19 rec1=00 rec2=07 rec3=066
[0x08] rec0=23 rec1=00 rec2=08 rec3=054
[0x09] rec0=00 rec1=00 rec2=1f rec3=004
[0x0a] rec0=22 rec1=00 rec2=09 rec3=020
[0x0b] rec0=1f rec1=00 rec2=0a rec3=02c
[0x0c] rec0=18 rec1=00 rec2=0b rec3=03c
[0x0d] rec0=00 rec1=00 rec2=1e rec3=012
[0x0e] rec0=1f rec1=00 rec2=0c rec3=008
[0x0f] rec0=00 rec1=00 rec2=1d rec3=00a
[0x10] rec0=16 rec1=00 rec2=0d rec3=06c
[0x11] rec0=01 rec1=00 rec2=1c rec3=006
[0x12] rec0=1e rec1=00 rec2=0e rec3=038
[0x13] rec0=01 rec1=00 rec2=1b rec3=002
[0x14] rec0=1a rec1=00 rec2=0f rec3=002
[0x15] rec0=00 rec1=00 rec2=1a rec3=00e
[0x16] rec0=1f rec1=00 rec2=10 rec3=012
[0x17] rec0=16 rec1=00 rec2=11 rec3=04e
[0x18] rec0=01 rec1=00 rec2=19 rec3=00c
[0x19] rec0=23 rec1=00 rec2=12 rec3=02a
[0x1a] rec0=19 rec1=00 rec2=13 rec3=04e
[0x1b] rec0=00 rec1=00 rec2=18 rec3=002
[0x1c] rec0=23 rec1=00 rec2=14 rec3=032
[0x1d] rec0=00 rec1=00 rec2=17 rec3=002
[0x1e] rec0=21 rec1=00 rec2=15 rec3=014
[0x1f] rec0=1f rec1=00 rec2=16 rec3=000
tail 0x21500ae8081978ee1aa9b 0x42a00088462063203