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 - downloadIndex: ┃ B T ┃
Length: 33048 (0x8118) Types: TextFile Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00 └─ ⟦0c20f784e⟧ »DATA« └─⟦1abbe589f⟧ └─⟦059497ac5⟧ └─⟦this⟧
with Unchecked_Deallocation; with Xlbt_Arithmetic; use Xlbt_Arithmetic; package body Xlbip_String_Map_Generic is ------------------------------------------------------------------------------ -- X Library String to Other type map generic -- -- Xlbp_String_Map_Generic - Map from an Ada string value to some other value ------------------------------------------------------------------------------ -- 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. ------------------------------------------------------------------------------ -- ***************************************************************************** -- * Date - /Name/ Comment -- * -- * 24-OCT-90 - /DRK/ Changed Hash to accept the null string. -- * 21-JAN-91 - /GEB/ Add the Find_Ptr, Insert_Ptr, and Key_Ptr routines. -- ***************************************************************************** --\f ----Elements are simply pairs of string Keys and Range_Type values. type Elem_Rec is record Hash : S_Long := 0; Next : Element := null; Rt : Range_Type; Key : String_Pointer; end record; ----Maps are simply a table of Element linked lists. type Element_Array is array (S_Long range 0 .. S_Long (Hash_Size) - 1) of Element; type Map_Rec is record Count : S_Natural := 0; Table : Element_Array := (others => null); end record; procedure Free_String_Pointer is new Unchecked_Deallocation (String, String_Pointer); procedure Free_Element is new Unchecked_Deallocation (Elem_Rec, Element); procedure Free_Map_Internal is new Unchecked_Deallocation (Map_Rec, Map); --\f function Hash (Key : String) return S_Long is ------------------------------------------------------------------------------ -- Key - Specifies the string to hash -- -- Returns a hash value for the indicated string. ------------------------------------------------------------------------------ Xl : U_Char_Array (S_Long (Key'First) .. S_Long (Key'Last)); begin ----Convert the characters in the string into a series of numeric values. if Exact_Case_Match then for I in Key'Range loop Xl (S_Natural (I)) := Character'Pos (Key (I)); end loop; else for I in Key'Range loop if Key (I) in Character'Val (Standard.Character'Pos ('a')) .. Character'Val (Standard.Character'Pos ('z')) then Xl (S_Natural (I)) := Character'Pos (Key (I)) - (Standard.Character'Pos ('a') - Standard.Character'Pos ('A')); else Xl (S_Natural (I)) := Character'Pos (Key (I)); end if; end loop; end if; ----Take the string of numeric values and turn them into a hash code. case Key'Length is when 0 => return 0; when 1 => return S_Long (Xl (Xl'First)); when 2 => return S_Long (Xl (Xl'First)) * 128 + S_Long (Xl (Xl'Last)); when 3 => return S_Long (Xl (Xl'First)) * 128 ** 2 + S_Long (Xl (Xl'First + 1)) * 128 + S_Long (Xl (Xl'Last)); when 4 => return S_Long (Xl (Xl'First)) * 128 ** 3 + S_Long (Xl (Xl'First + 1)) * 128 ** 2 + S_Long (Xl (Xl'First + 2)) * 128 + S_Long (Xl (Xl'Last)); when others => declare I : S_Natural := Xl'First; H : S_Long := 0; begin while I + 3 <= Xl'Last loop if S_Long'Last - 2 ** 28 < H then ----Prevent overflow on long strings. H := H / 3; end if; H := H + S_Long (Xl (I)) * 128 ** 3 + S_Long (Xl (I + 1)) * 128 ** 2 + S_Long (Xl (I + 2)) * 128 + S_Long (Xl (I + 3)); I := I + 4; end loop; for J in I .. Xl'Last loop H := H + S_Long (Xl (J)); end loop; return H; end; end case; end Hash; --\f function Equal (A : String; B : 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 : Index := A'First; Bi : Index := 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 Index range 1 .. A'Length loop if A (Ai + I - 1) /= B (Bi + I - 1) then if (A (Ai + I - 1) not in Character'Val (Standard.Character'Pos ('a')) .. Character'Val (Standard.Character'Pos ('z')) or else Character'Val (Character'Pos (A (Ai + I - 1)) - (Standard.Character'Pos ('a') - Standard.Character'Pos ('A'))) /= B (Bi + I - 1)) then return False; end if; end if; end loop; ----They are the same. return True; end Equal; --\f procedure Lookup (H : S_Long; Key : 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; --\f 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; --\f 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 ----Don't free a non-existend map. if M = null then return; end if; ----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_Pointer (Elem1.Key); Free_Element (Elem1); Elem1 := Elem2; end loop; end loop; end if; ----Free the map itself. Free_Map_Internal (M); end Free_Map; --\f 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; --\f 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; --\f procedure Find (M : in Map; Key : in String; Rt : in out Range_Type; Status : 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 -- Status - 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 -- Status is set to TRUE. If the Key string is not found then Status 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_Long := Hash (Key); Prev : Element; Elem : Element := M.Table (H rem S_Long (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; Status := True; return; end if; ----We did not find the Key in the map. Status := False; end Find; --\f procedure Find (M : in Map; Key : in String; Ptr : in out String_Pointer; Rt : in out Range_Type; Status : out Boolean) is ------------------------------------------------------------------------------ -- M - Specifies the map to use -- Key - Specifies the string value to use for the lookup -- Ptr - Receives the string pointer from the map or is unchanged -- Rt - Receives the Range_Type value from the map or is unchanged -- Status - 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 -- Status is set to TRUE. If the Key string is not found then Status 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.) Do not free the Ptr value returned by a successful -- lookup. It is shared by the map and deallocating it will cause -- unpredicatble program behavior. ------------------------------------------------------------------------------ H : S_Long := Hash (Key); Prev : Element; Elem : Element := M.Table (H rem S_Long (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; Ptr := Elem.Key; Status := True; return; end if; ----We did not find the Key in the map. Status := False; end Find; --\f procedure Find_Ptr (M : in Map; Key : in out String_Pointer; Rt : in out Range_Type; Status : 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 -- Status - 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 -- Status is set to TRUE. If the Key string is not found then Status 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_Long := Hash (Key.all); Prev : Element; Elem : Element := M.Table (H rem S_Long (Hash_Size)); begin ----Lookup the entry in the table with this hash value. Lookup (H, Key.all, Prev, Elem); if Elem /= null then Rt := Elem.Rt; Key := Elem.Key; Status := True; return; end if; ----We did not find the Key in the map. Status := False; end Find_Ptr; --\f function Locate (M : in Map; Key : in 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_Long := Hash (Key); Prev : Element; Elem : Element := M.Table (H rem S_Long (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; --\f procedure Insert (M : in Map; Key : in 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 pre-existing map entry with the same Key value will cause -- Duplicate_Entry to be raised. ------------------------------------------------------------------------------ H : S_Long := Hash (Key); Prev : Element; Elem : Element := M.Table (H rem S_Long (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. declare New_Elem : Elem_Rec; begin New_Elem.Hash := H; New_Elem.Key := new String'(Key); New_Elem.Rt := Rt; Elem := new Elem_Rec'(New_Elem); end; H := H rem S_Long (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 if Elem.Key (I) in Character'Val (Standard.Character'Pos ('a')) .. Character'Val (Standard.Character'Pos ('z')) then Elem.Key (I) := Character'Val (Character'Pos (Elem.Key (I)) - (Standard.Character'Pos ('a') - Standard.Character'Pos ('A'))); end if; end loop; end if; end Insert; --\f procedure Insert_Ptr (M : in Map; Key : in String_Pointer; 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 pre-existing map entry with the same Key value will cause -- Duplicate_Entry to be raised. ------------------------------------------------------------------------------ H : S_Long := Hash (Key.all); Prev : Element; Elem : Element := M.Table (H rem S_Long (Hash_Size)); begin ----Lookup the entry in the table with this hash value. Replace any existing -- entry if that is ok. Lookup (H, Key.all, Prev, Elem); if Elem /= null then if Dups_Ok then Free_String_Pointer (Elem.Key); Elem.Key := Key; Elem.Rt := Rt; return; else raise Duplicate_Entry; end if; end if; ----Create a new map element and put it into the map. declare New_Elem : Elem_Rec; begin New_Elem.Hash := H; New_Elem.Key := Key; New_Elem.Rt := Rt; Elem := new Elem_Rec'(New_Elem); end; H := H rem S_Long (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 if Elem.Key (I) in Character'Val (Standard.Character'Pos ('a')) .. Character'Val (Standard.Character'Pos ('z')) then Elem.Key (I) := Character'Val (Character'Pos (Elem.Key (I)) - (Standard.Character'Pos ('a') - Standard.Character'Pos ('A'))); end if; end loop; end if; end Insert_Ptr; --\f procedure Delete (M : in Map; Key : in 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_Long := Hash (Key); H2 : S_Long := H rem S_Long (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_Pointer (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; --\f procedure Remove (M : in Map; Key : in String; Rt : in out Range_Type; Status : 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 -- Status - 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 -- Status is set to TRUE. If the Key string is not found then Status 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_Long := Hash (Key); H2 : S_Long := H rem S_Long (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_Pointer (Elem.Key); Free_Element (Elem); M.Count := M.Count - 1; Status := True; return; end if; ----We did not find the Key in the map. Status := False; end Remove; --\f 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 -- Initialize (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 S_Long range 0 .. S_Long (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 := S_Long (Hash_Size); end Initialize; --\f procedure Initialize (M : in Map; I : in out Iter; Rng : in Range_Type) is ------------------------------------------------------------------------------ -- M - Specifies the map -- I - Receives the new iteration value -- Rng - Specifies the Range_Type value that we are iterating upon -- -- Just like the other Initialize procedure except that the first value -- returned by this iterator will have a Range_Type value equal to Rng -- if Done(I) != TRUE. ------------------------------------------------------------------------------ begin ----Search for any element whatsoever. I.M := M; for Ind in S_Long range 0 .. S_Long (Hash_Size) - 1 loop if M.Table (Ind) /= null then I.Elem := I.M.Table (Ind); loop if I.Elem.Rt = Rng then I.Index := Ind; return; end if; if I.Elem.Next = null then exit; end if; I.Elem := I.Elem.Next; end loop; end if; end loop; ----Map is empty. Finish the initialization. I.Elem := null; I.Index := S_Long (Hash_Size); end Initialize; --\f 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; --\f 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; --\f function Key (I : in Iter) return String is ------------------------------------------------------------------------------ -- I - Specifies the iterator to check -- -- Returns the string key 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; --\f function Key_Ptr (I : in Iter) return String_Pointer is ------------------------------------------------------------------------------ -- I - Specifies the iterator to check -- -- Returns the string key 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_Ptr; --\f 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. ------------------------------------------------------------------------------ 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 .. S_Long (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; --\f procedure Next (I : in out Iter; Rng : in Range_Type) is ------------------------------------------------------------------------------ -- I - Specifies the iterator -- Rng - Specifies the Range_Type value that we are iterating upon -- -- Advances the map iterator by N entries. Stops advancing the iterator when -- the next entry with a Range_Type entry equal to Rng is found or when -- the last entry in the map has been passed over. Raises Missing_Entry if -- Done(I) = TRUE already. Done(I) = TRUE will be true when this routine -- returns and there are no more entries to be processed. ------------------------------------------------------------------------------ begin ----Locate the next element. if I.Elem = null then raise Missing_Entry; end if; if I.Elem.Next /= null then loop I.Elem := I.Elem.Next; if I.Elem.Rt = Rng then return; end if; if I.Elem.Next = null then exit; end if; end loop; end if; for Ind in I.Index + 1 .. S_Long (Hash_Size) - 1 loop if I.M.Table (Ind) /= null then I.Elem := I.M.Table (Ind); loop if I.Elem.Rt = Rng then I.Index := Ind; return; end if; if I.Elem.Next = null then exit; end if; I.Elem := I.Elem.Next; end loop; end if; end loop; ----Nothing Next; we are Done. I.Elem := null; end Next; --\f end Xlbip_String_Map_Generic;