|
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: 19456 (0x4c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body String_Heap, seg_00582f
└─⟦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_Heap 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 Elem_Rec is
record
Hash : S_Natural := 0;
Key : E_String_Pointer := null;
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,
E_String_Pointer);
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.
------------------------------------------------------------------------------
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)) /=
Vstring_Case.Uc_Char (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
function Share (M : in Map;
Key : in E_String) return E_String_Pointer is
------------------------------------------------------------------------------
-- M - Specifies the map to use
-- Key - Specifies the string value to use for the lookup
--
-- Returns a shared string containing the same characters as are found in Key.
------------------------------------------------------------------------------
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
return Elem.Key;
end if;
----Create a new map element and put it into the map.
Elem := new Elem_Rec'(Hash => H,
Key => new E_String'(Key),
Next => null);
H := H rem Hash_Size;
Elem.Next := M.Table (H);
M.Table (H) := Elem;
M.Count := M.Count + 1;
return Elem.Key;
end Share;
--\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;
-- Vl : E_String_Pointer;
-- begin
-- Initilize (M, I);
-- while not Done (I) loop
-- Vl := Key (I);
-- .... Code using the Vl 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 initialization.
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_Pointer 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;
end Key;
--\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_Heap;
nblk1=12
nid=0
hdr6=24
[0x00] rec0=19 rec1=00 rec2=01 rec3=08e
[0x01] rec0=19 rec1=00 rec2=02 rec3=052
[0x02] rec0=00 rec1=00 rec2=12 rec3=02a
[0x03] rec0=1a rec1=00 rec2=03 rec3=054
[0x04] rec0=1d rec1=00 rec2=04 rec3=002
[0x05] rec0=1b rec1=00 rec2=05 rec3=008
[0x06] rec0=21 rec1=00 rec2=06 rec3=03a
[0x07] rec0=1a rec1=00 rec2=07 rec3=03a
[0x08] rec0=22 rec1=00 rec2=08 rec3=042
[0x09] rec0=00 rec1=00 rec2=10 rec3=004
[0x0a] rec0=23 rec1=00 rec2=09 rec3=05e
[0x0b] rec0=1e rec1=00 rec2=0a rec3=026
[0x0c] rec0=20 rec1=00 rec2=11 rec3=022
[0x0d] rec0=02 rec1=00 rec2=0b rec3=012
[0x0e] rec0=17 rec1=00 rec2=0c rec3=022
[0x0f] rec0=23 rec1=00 rec2=0d rec3=000
[0x10] rec0=20 rec1=00 rec2=0e rec3=014
[0x11] rec0=1d rec1=00 rec2=0f rec3=000
tail 0x21500ae5681978ecfda4d 0x42a00088462063203