DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download
Index: ┃ B T

⟦e6122ba31⟧ TextFile

    Length: 130180 (0x1fc84)
    Types: TextFile
    Names: »B«

Derivation

└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
    └─ ⟦0c20f784e⟧ »DATA« 
        └─⟦1abbe589f⟧ 
            └─⟦059497ac5⟧ 
                └─⟦this⟧ 

TextFile

with Text_Io;  
with Unchecked_Deallocation;

with Xlbt_Arithmetic;  
use Xlbt_Arithmetic;  
with Xlbt_Basic;  
use Xlbt_Basic;  
with Xlbt_Exceptions;  
use Xlbt_Exceptions;  
with Xlbt_Font;  
use Xlbt_Font;  
with Xlbt_Hint;  
use Xlbt_Hint;  
with Xlbt_Proc_Var;  
use Xlbt_Proc_Var;  
with Xlbt_Rm;  
use Xlbt_Rm;  
with Xlbt_Rm2;  
use Xlbt_Rm2;  
with Xlbt_String7;  
use Xlbt_String7;  
with Xlbt_String;  
use Xlbt_String;  
with Xlbt_String16;  
use Xlbt_String16;  
with Xlbt_Univ_Ptr;  
use Xlbt_Univ_Ptr;  
with Xlbt_Window;  
use Xlbt_Window;

with Xlbp_Display;  
use Xlbp_Display;  
with Xlbp_Error;  
use Xlbp_Error;  
with Xlbp_Proc_Var;  
use Xlbp_Proc_Var;  
with Xlbp_Rm_Name;  
use Xlbp_Rm_Name;  
with Xlbp_U_Char_Converters;  
use Xlbp_U_Char_Converters;

with Xlbit_Library3;  
use Xlbit_Library3;  
with Xlbit_Library4;  
use Xlbit_Library4;

with Xlbip_Internal;  
use Xlbip_Internal;

with Xlbmt_Network_Types;  
use Xlbmt_Network_Types;  
with Xlbmt_Parameters;  
use Xlbmt_Parameters;

with Xlbmp_Environment;  
use Xlbmp_Environment;  
with Xlbmp_Error_Log;  
use Xlbmp_Error_Log;

pragma Elaborate (Xlbit_Library3);  
pragma Elaborate (Xlbit_Library4);

package body Xlbp_Rm is
------------------------------------------------------------------------------
-- X Library Resource Manager
--
-- Xlbp_Rm - Manager of application/window/object resources
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1987 - 1989 by Digital Equipment Corporation, Maynard, Mass.
-- Copyright 1987 - 1989 by Massachusetts Institute of Technology,
--                          Cambridge, Massachusetts.
--
--                  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 names of Digital, MIT, or Rational
-- not be used in advertising or publicity pertaining to distribution of
-- the software without specific, written prior permission.
--
-- Digital, MIT, and Rational disclaim all warranties with regard to this
-- software, including all implied warranties of merchantability and fitness,
-- in no event shall Digital, MIT, or 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.
------------------------------------------------------------------------------
--
-- These Xrm routines allow very fast lookup of resources in the resource
-- database.  Several usage patterns are exploited:
--
-- (1) Widgets get a lot of resources at one time.  Rather than look up each
-- from scratch, we can precompute the prioritized list of database levels once,
-- then search for each resource starting at the beginning of the list.
--
-- (2) Many database levels don't contain any leaf resource nodes.  There is no
-- point in looking for resources on a level that doesn't contain any.  This
-- information is kept on a per-level basis...if even just a single hash bucket
-- contains a value, that level is searched.  I considered having 4 arrays
-- coming off each database level, split by tight/loose and intermediate/leaf,
-- but this looked like it would burn a lot of memory for negligible performance
-- gains.
--
-- (3) Sometimes the widget instance tree is structured such that you get the
-- same class name repeated on the fully qualified widget name.  This can result
-- in the same database level occurring multiple times on the search list.  The
-- code below only checks to see if you get two identical search lists in a row,
-- rather than look back through all database levels, but in practice this
-- removes all duplicates I've ever observed.
--
-- Joel McCormack
------------------------------------------------------------------------------
-- *****************************************************************************
-- * Date      - /Name/ Comment
-- *
-- * 23-OCT-90 - /DRK/ Fixed Free_X_Rm_Hash_Bucket to not dereference
-- *           -  null pointers and to release more storage.
-- * 24-OCT-90 - /DRK/ Removed some hard-coded list lengths of 100.
-- *           -  Added exception handlers for bad resource names and
-- *           -  representations in Put_Line_Resources.
-- * 30-OCT-90 - /DRK/ Fixed Put_Entry to correctly update the
-- *           -  X_Lib.Resource_Quarks bit vector.
-- *  2-NOV-90 - /DRK/ Fixed X_Rm_Put_File_Database to handle null DBs,
-- *           -  and to close its file handle.
-- *           - /DRK/ Fixed Print_Binding_Quark_List to stop looping
-- *           -  when it reached the end of the list.
-- *           - /DRK/ Rewrote Strip_C_Style_Quoting to make it work.
-- *  6-NOV-90 - /GEB/ Convert to the new X_Lib multitasking protection for
-- *           -  library state.
-- *  7-FEB-91 - /GEB/ Remove all Xt conversion hooks.  Xt will be doing that
-- *           -  directly; these facilities are not nearly good enough.
-- ******************************************************************************

    Xrm_Error_Display_Defaults : constant X_String :=  
       "Xrm; Unexpected exception while processing server" & Lf &  
          "defaults from %1.  Server defaults not loaded." & Lf &  
          "Exception: %6";

    Xrm_Error_Bad_Character : constant X_String :=  
       "Xrm; Bad character constant {%1}; value reduced." & Lf &  
          "Line: {%2}";

    Xrm_Error_Bad_Quoting : constant X_String :=  
       "Xrm; Bad character quoting {%1}; ignored." & Lf &  
          "Line: {%2}";

    Xrm_Error_Bad_Line : constant X_String :=  
       "Xrm; Resource line has bad format; missing :/!" & Lf &  
          "after name.  Line: {%1}";

    Xrm_Error_Read_Conversion : constant X_String :=  
       "Xrm; conversion error on {%1}" & Lf &  
          "Raised exception: %6";

    Xrm_Error_Bad_Resource_Name : constant X_String :=  
       "Xrm; Bad resource name: {%1}" & Lf &  
          "Line: {%2}";

    Xrm_Error_Bad_Resource_Rep : constant X_String :=  
       "Xrm; Bad resource representation: {%1}" & Lf &  
          "Line: {%2}";

    Xrm_Error_Bad_Kind : constant X_String :=  
       "Xrm; Resource line has bad format; missing ':'" & Lf &  
          "after name!rep!kind.  Line: {%1}";

    Xrm_Error_Read_Db : constant X_String :=  
       "Xrm; Error reading database file %1";

    Xrm_Error_Cmd_Bad_Kind : constant X_String :=  
       "Xrm; Error parsing command line argument %1 (%2)." & Lf &  
          "Option 'kind' not recognized.";

    Xrm_Error_Cmd_Bad_Default : constant X_String :=  
       "Xrm; Error parsing command line argument %1 (%2)." & Lf &  
          "Default value bad/inappropriate/unreadable.";

    Xrm_Error_Cmd_Bad_Line : constant X_String :=  
       "Xrm; Error parsing command line argument %1 (%2)." & Lf &  
          "Argument: {%3}";

    type X_Rm_Search_List_Pointer is access X_Rm_Search_List;

--/ if Enable_Deallocation then
    pragma Enable_Deallocation (X_Rm_Search_List_Pointer);
--/ end if;

    procedure Free_X_Rm_Search_List_Pointer is  
       new Unchecked_Deallocation (X_Rm_Search_List,  
                                   X_Rm_Search_List_Pointer);

    procedure Heap_Free_X_Rm_Hash_Table is  
       new Unchecked_Deallocation (X_Rm_Hash_Bucket_Array,  
                                   X_Rm_Hash_Table);

    procedure Heap_Free_X_Rm_Hash_Bucket is  
       new Unchecked_Deallocation (X_Rm_Hash_Bucket_Rec,  
                                   X_Rm_Hash_Bucket);

    procedure Heap_Free_X_Rm_Database is  
       new Unchecked_Deallocation (X_Rm_Database_Rec,  
                                   X_Rm_Database);

--\f

    procedure Had_Errors (Status : in out X_Rm_Status) is  
    begin  
        if Status < Rm_Had_Errors then  
            Status := Rm_Had_Errors;  
        end if;  
    end Had_Errors;

    procedure Failed (Status : in out X_Rm_Status) is  
    begin  
        if Status < Rm_Failed then  
            Status := Rm_Failed;  
        end if;  
    end Failed;

--\f

    procedure Free_X_Rm_Entry_Rec is new Unchecked_Deallocation (X_Rm_Entry_Rec,  
                                                                 X_Rm_Entry);

--\f

    procedure Private_Free_X_Rm_Value (Destination : in out X_Rm_Value) is
------------------------------------------------------------------------------
--  Destination - Specifies the X_Rm_Value to free
--
-- Called to free up any heap storage occupied by an X_Rm_Value.
------------------------------------------------------------------------------
    begin

        case Destination.Kind is

----These guys do not have any type of heap storage associated with them.

            when Is_None | Is_Boolean | Is_Float | Is_U_Char |  
                 Is_U_Short | Is_S_Char | Is_S_Short | Is_S_Long |  
                 Is_X_Atom | Is_X_Color | Is_X_Colormap | Is_X_Cursor |  
                 Is_X_Font | Is_X_Initial_Window_State | Is_X_Pixel |  
                 Is_X_Pixmap | Is_X_Time | Is_X_Window =>  
                null;

----These guys have storage but we don't free them because they belong to some
--  other guy that would get freed some other way and thus cause them to get
--  freed.

            when Is_X_Screen | Is_X_Visual =>  
                null;

----These guys may have storage that needs to be freed.

            when Is_X_Display =>  
                X_Close_Display (Destination.V_X_Display);

            when Is_X_Rm_File_Type =>  
                begin  
                    Text_Io.Close (Destination.V_X_Rm_File_Type.all);  
                exception  
                    when others =>  
                        null;  
                end;  
                Free_X_Rm_File_Type (Destination.V_X_Rm_File_Type);

            when Is_X_Font_Struct =>  
                Free_X_Font_Struct (Destination.V_X_Font_Struct);

            when Is_X_String7_Pointer =>  
                if Destination.V_X_String7_Pointer /= null then  
                    Free_X_String7_Pointer (Destination.V_X_String7_Pointer);  
                end if;

            when Is_X_String_Pointer =>  
                if Destination.V_X_String_Pointer /= null then  
                    Free_X_String_Pointer (Destination.V_X_String_Pointer);  
                end if;

            when Is_X_String16_Pointer =>  
                if Destination.V_X_String16_Pointer /= null then  
                    Free_X_String16_Pointer (Destination.V_X_String16_Pointer);  
                end if;

            when Is_U_Char_List =>  
                if Destination.V_U_Char_List /= null then  
                    Free_U_Char_List (Destination.V_U_Char_List);  
                end if;

            when Is_X_Universal_Pointer =>  
                if Destination.V_X_Universal_Pointer.Free /=  
                   None_X_Procedure_Variable then  
                    Proc_Var_X_Univ_Free.Call  
                       (Proc_Var_X_Univ_Free.To_Pv  
                           (Destination.V_X_Universal_Pointer.Free),  
                        Destination.V_X_Universal_Pointer.Pointer);  
                end if;  
        end case;

    end Private_Free_X_Rm_Value;

--\f

    procedure Free_X_Rm_Entry (Val : in out X_Rm_Entry) is
------------------------------------------------------------------------------
--  Val - Specifies the X_Rm_Entry that is to be deleted/freed
--
-- Called to free up the heap storage occupied by an X_Rm_Entry.  The
-- X_Rm_Entry is deallocated as well as the storage occupied by the X_Rm_Value
-- contained within the X_Rm_Entry.
------------------------------------------------------------------------------
    begin

----Free the storage contained in the data .Value and then free the Entry
--  itself.

        Private_Free_X_Rm_Value (Val.Value);  
        Free_X_Rm_Entry_Rec (Val);

    end Free_X_Rm_Entry;

--\f

    procedure Reset_X_Rm_Entry (Destination : X_Rm_Entry) is
------------------------------------------------------------------------------
--  Destination - Specifies the entry to zap.
--
-- Zap all storage inside of an X_Rm_Entry.  We leave it empty with no
-- data.
------------------------------------------------------------------------------
    begin

        Private_Free_X_Rm_Value (Destination.Value);  
        Destination.all := (False, None_X_Rm_Representation, None_X_Rm_Value);

    end Reset_X_Rm_Entry;

--\f

    function X_New_Rm_Database return X_Rm_Database is
------------------------------------------------------------------------------
-- Called to obtain a newly allocated, completely empty database.  Free the
-- database after use with Free_X_Rm_Database.
------------------------------------------------------------------------------
    begin  
        return new X_Rm_Database_Rec;  
    end X_New_Rm_Database;

--\f

    function Hash_Index (Name : X_Rm_Name) return S_Natural is  
    begin  
        return S_Natural (Name.Id) rem X_Rm_Hash_Bucket_Array'Length;  
    end Hash_Index;

--\f

    procedure Get_Entry (Tight    :     X_Rm_Hash_Table;  
                         Loose    :     X_Rm_Hash_Table;  
                         Names    :     X_Rm_Name_Array;  
                         Classes  :     X_Rm_Class_Array;  
                         Db_Entry : out X_Rm_Entry;  
                         Ret_Val  : out Boolean) is
------------------------------------------------------------------------------
--  Tight   - Specifies the "tight" binding at this point in the lookup
--  Loose   - Specifies the "loose" binding at this point in the lookup
--  Names   - Specifies the names we are looking for
--  Classes - Specifies the classes we are looking for
--  Db_Entry- Receives the value of our result (which may be None_X_Rm_Entry)
--  Ret_Val - Receives TRUE if we have a result and FALSE if not
------------------------------------------------------------------------------
        Names_I   : S_Natural := Names'First;  
        Classes_I : S_Natural := Classes'First;  
        Bucket    : X_Rm_Hash_Bucket;  
        Ntight    : X_Rm_Hash_Table;  
        Nloose    : X_Rm_Hash_Table;  
        Db2       : X_Rm_Entry;

        function Get_Entry_Lookup (Table : X_Rm_Hash_Table;  
                                   Name  : X_Rm_Name) return Boolean is
------------------------------------------------------------------------------
--  Table   - Specifies the hash table to look within
--  Name    - Specifies the name we are looking for
--
-- Called to see if a particular name is located within a particular table.
-- If it is then we return all the way back to the original caller with the
-- database entry that we just found.
------------------------------------------------------------------------------
            Flag : Boolean;  
        begin

----Grab a hash bucket and loop over all buckets in the chain.

            Bucket := Table (Hash_Index (Name));  
            while Bucket /= null loop

----See if we just found the name.  If so then we are very happy.

                if Bucket.Name = Name then

----If this is the "terminal" or "last" part of the name sequence that we
--  are seeking, and if there is any data here, then return that data.

                    if Names (Names_I + 1) = None_X_Rm_Name then
                        ----Must be leaf node with data, else doesn't match
                        --  Has both data and name.
                        Db2      := Bucket.Value;  
                        Db_Entry := Db2;  
                        return Db2 /= None_X_Rm_Entry;

----If this isn't the final part of the name sequence then recurse upon
--  ourselves and finish the lookup.  Exit all the way back.

                    else  
                        Ntight := Bucket.Tables (X_Rm_Bind_Tightly);  
                        Nloose := Bucket.Tables (X_Rm_Bind_Loosely);  
                        if Ntight /= null or else Nloose /= null then  
                            Get_Entry (Ntight, Nloose,  
                                       Names (Names_I + 1 .. Names'Last),  
                                       Classes (Classes_I + 1 .. Classes'Last),  
                                       Db_Entry, Flag);  
                            if Flag then  
                                return True;  
                            end if;  
                        end if;  
                        return False;  
                    end if;  
                end if;

----Get the next bucket in the chain.

                Bucket := Bucket.Next;  
            end loop;  
            return False;

        end Get_Entry_Lookup;

    begin

----Sanity check upon ourselves and our caller.

--/ if DEBUG then
        if not ((Tight /= null or Loose /= null) and  
                Names (Names'First) /= None_X_Rm_Name) then  
            raise X_Library_Confusion;  
        end if;
--/ end if;

----Check the very first name & class in both tight and loose tables

        if Tight /= null and then  
           Get_Entry_Lookup (Tight, Names (Names_I)) then  
            Ret_Val := True;  
            return;  
        end if;  
        if Loose /= null and then  
           Get_Entry_Lookup (Loose, Names (Names_I)) then  
            Ret_Val := True;  
            return;  
        end if;  
        if Tight /= null and then  
           Get_Entry_Lookup (Tight, X_Rm_Name (Classes (Classes_I))) then  
            Ret_Val := True;  
            return;  
        end if;  
        if Loose /= null and then  
           Get_Entry_Lookup (Loose, X_Rm_Name (Classes (Classes_I))) then  
            Ret_Val := True;  
            return;  
        end if;

----Now check any remaining names and class, but just in the loose table.

        if Loose /= null then  
            while Names (Names_I + 1) /= None_X_Rm_Name loop  
                Names_I   := Names_I + 1;  
                Classes_I := Classes_I + 1;  
                if Get_Entry_Lookup (Loose, Names (Names_I)) then  
                    Ret_Val := True;  
                    return;  
                end if;  
                if Get_Entry_Lookup (Loose,  
                                     X_Rm_Name (Classes (Classes_I))) then  
                    Ret_Val := True;  
                    return;  
                end if;  
            end loop;  
        end if;

----Didn't find any of the names or classes in either hash table.

        Db_Entry := None_X_Rm_Entry;  
        Ret_Val  := False;

    end Get_Entry;

--\f

    procedure X_Rm_Get_Resource (Database       :     X_Rm_Database;  
                                 Names          :     X_Rm_Name_Array;  
                                 Classes        :     X_Rm_Class_Array;  
                                 Representation : out X_Rm_Representation;  
                                 Value          : out X_Rm_Value) is
--------------------------------------------------------------------------
--  Database      - Specifies the database to use for the lookup.
--  Names         - Specifies the fully qualified name of the value; e.g. a.b.c
--  Classes       - Specifies the fully qualified class of the value; e.g. A.B.C
--  Representation- Receives the representation of the value
--  Value         - Receives the entry from the database or None_X_Rm_Value
--
-- If successful (Value /= None_X_Rm_Value) then Value has received an
-- X_Rm_Value from within the database.  Any heap based data returned is shared
-- with the database (and possibly other databases) so do not attempt free the
-- data contained within the value.
--
-- Will raise Constraint_Error if either Names or Classes contains
-- illegal characters.
--------------------------------------------------------------------------

        Rdbi     : X_Rm_Hash_Bucket;  
        Tight    : X_Rm_Hash_Table;  
        Loose    : X_Rm_Hash_Table;  
        Db_Entry : X_Rm_Entry;  
        Ret_Val  : Boolean;  
    begin

        if Database /= None_X_Rm_Database and then  
           Database.Contents /= None_X_Rm_Hash_Bucket then  
            Rdbi  := Database.Contents;  
            Tight := Rdbi.Tables (X_Rm_Bind_Tightly);  
            Loose := Rdbi.Tables (X_Rm_Bind_Loosely);  
            if (Tight /= null or else Loose /= null) and then  
               Names (Names'First) /= None_X_Rm_Name then  
                Get_Entry (Tight, Loose, Names, Classes, Db_Entry, Ret_Val);  
                if Ret_Val then  
                    Representation := Db_Entry.Representation;  
                    Value          := Db_Entry.Value;  
                else  
                    Representation := None_X_Rm_Representation;  
                    Value          := None_X_Rm_Value;  
                end if;  
                return;  
            end if;  
        end if;  
        Representation := None_X_Rm_Representation;  
        Value          := None_X_Rm_Value;

    end X_Rm_Get_Resource;

--\f

    function Components (Name : X_String) return S_Natural is
--------------------------------------------------------------------------
--  Name      - Specifies a resource name being parsed.
--
-- Return the number of components in the Resource_Name.  If a complete
-- Resource_Spec is supplied the correct answer is still returned.
--------------------------------------------------------------------------
        Count : S_Natural := 0;  
    begin
        -- Count the separators
        for Pos in Name'Range loop  
            if Name (Pos) = '.' or else Name (Pos) = '*' then  
                Count := Count + 1;  
            elsif Name (Pos) = ':' then  
                exit;  
            end if;  
        end loop;

        if Count <= 0 then
            -- Even the empty string has one component.
            return 1;  
        elsif Name (Name'First) = '.' or else Name (Name'First) = '*' then
            -- Initial separator didn't separate any components.
            return Count;  
        else
            -- All separators were real.
            return Count + 1;  
        end if;  
    end Components;
--\f

    procedure X_Rm_Get_Resource (Database       :     X_Rm_Database;  
                                 Names          :     X_String;  
                                 Classes        :     X_String;  
                                 Representation : out X_Rm_Representation;  
                                 Value          : out X_Rm_Value) is
--------------------------------------------------------------------------
--  Database  - Specifies the database to use for the lookup.
--  Names     - Specifies the fully qualified name of the value.
--  Classes   - Specifies the fully qualified class of the value.
--  Representation- Receives the representation of the value
--  Value         - Receives the entry from the database or None_X_Rm_Value
--
-- If successful (Value /= None_X_Rm_Value) then Value has received an
-- X_Rm_Value from within the database.  Any heap based data returned is shared
-- with the database (and possibly other databases) so do not attempt free the
-- data contained within the entry.
--------------------------------------------------------------------------

        Names_Array   : X_Rm_Name_Array (1 .. Components (Names) + 1);  
        Classes_Array : X_Rm_Class_Array (1 .. Components (Classes) + 1);  
    begin

        X_Rm_String_To_Name_List (Names, Names_Array);  
        X_Rm_String_To_Class_List (Classes, Classes_Array);  
        X_Rm_Get_Resource (Database, Names_Array, Classes_Array,  
                           Representation, Value);

    end X_Rm_Get_Resource;

--\f

    procedure Put_Entry (Bucket         : X_Rm_Hash_Bucket;  
                         Bindings       : X_Rm_Binding_Array;  
                         Names          : X_Rm_Name_Array;  
                         Representation : X_Rm_Representation;  
                         Value          : X_Rm_Value;  
                         Db_Owner       : Boolean) is
------------------------------------------------------------------------------
--  Bucket      - Specifies the database to modify
--  Bindings    - Specifies the tight/loose qualifiers
--  Names       - Specifies the name sequence of the new entry
--  Representation       - Specifies the user's representation (logical) for the value
--  Value       - Specifies the (physical) value
--  Db_Owner    - Specifies TRUE if the database must deallocate heap storage
--
-- Called to put a value (or replace and old value) within a database.
------------------------------------------------------------------------------
        Ibucket    : S_Natural;  
        Pbucket    : X_Rm_Hash_Bucket := Bucket;  
        Binding    : X_Rm_Binding;  
        Name       : X_Rm_Name;  
        Table      : X_Rm_Hash_Table;  
        Parent     : X_Rm_Hash_Bucket;  
        Quark_Id   : S_Natural; -- U_Long;
        Quark_Bits : X_Rm_Quark_Bit_List;  
    begin

----Search over the entire name sequence.  Exit the loop when we reach the
--  end of the sequence.

        for I in S_Natural range 0 .. Names'Length - 1 loop  
            exit when Names (Names'First + I) = None_X_Rm_Name;  
            Name    := Names (Names'First + I);  
            Binding := Bindings (Bindings'First + I);

----Remember the parent for marking later.

            Parent := Pbucket;

----Allocate new hash table if needed to make this binding in this bucket
--  non-null.

            Table := Pbucket.Tables (Binding);  
            if Table = null then  
                Table                    := new X_Rm_Hash_Bucket_Array;  
                Pbucket.Tables (Binding) := Table;  
            end if;

----Find bucket containing the name; if possible.

            Ibucket := Hash_Index (Name);  
            Pbucket := Table (Ibucket);  
            while Pbucket /= null and then Pbucket.Name /= Name loop  
                Pbucket := Pbucket.Next;  
            end loop;

----Create new bucket if we didn't find the name..

            if Pbucket = null then  
                Pbucket         := new X_Rm_Hash_Bucket_Rec;  
                Pbucket.Next    := Table (Ibucket);  
                Table (Ibucket) := Pbucket;  
                Pbucket.Name    := Name;  
            end if;  
        end loop;

----Mark parent database as having a child with a value, and
--  update X_Lib.Resource_Quarks.

        if Parent /= None_X_Rm_Hash_Bucket then  
            Parent.Has_Values (Binding) := True;  
            Quark_Id                    := S_Natural (Name.Id);  
            X_Lib.Seize_Resource_Quarks (Quark_Bits);  
            if Quark_Bits = None_X_Rm_Quark_Bit_List then  
                Quark_Bits := new X_Rm_Quark_Bit_Array'  
                                     (Quark_Id .. Quark_Id => False);  
            elsif Quark_Id not in Quark_Bits'Range then  
                declare  
                    Nb : X_Rm_Quark_Bit_List;  
                begin  
                    if Quark_Id < Quark_Bits'First then  
                        Nb := new X_Rm_Quark_Bit_Array'  
                                     (Quark_Id .. Quark_Bits'Last => False);  
                    else  
                        Nb := new X_Rm_Quark_Bit_Array'  
                                     (Quark_Bits'First .. Quark_Id => False);  
                    end if;  
                    Nb (Quark_Bits'Range) := Quark_Bits.all;  
                    Nb (Quark_Id)         := True;  
                    Free_X_Rm_Quark_Bit_List (Quark_Bits);  
                    Quark_Bits := Nb;  
                end;  
            end if;  
            Quark_Bits (Quark_Id) := True;  
            X_Lib.Release_Resource_Quarks (Quark_Bits);  
        end if;

----The hash bucket is modified to contain the value that was passed in.
--  Special case: Kind = Is_None => just clobber the old value.

        if Value.Kind = Is_None then
            ----New value is "none".  Clobber old value.
            if Pbucket.Value = None_X_Rm_Entry then  
                return;  
            else  
                Free_X_Rm_Entry (Pbucket.Value);  
            end if;  
        else
            ----New value is not "none".  Clobber old value and assign new.
            if Pbucket.Value = None_X_Rm_Entry then  
                Pbucket.Value := new X_Rm_Entry_Rec;  
            else  
                Reset_X_Rm_Entry (Pbucket.Value);  
            end if;  
            Pbucket.Value.all := (Representation => Representation,  
                                  Value          => Value,  
                                  Owner          => Db_Owner);  
        end if;

    end Put_Entry;

--\f

    procedure X_Rm_Put_Resource (Database       : in out X_Rm_Database;  
                                 Bindings       :        X_Rm_Binding_Array;  
                                 Quarks         :        X_Rm_Quark_Array;  
                                 Representation :        X_Rm_Representation;  
                                 Value          :        X_Rm_Value;  
                                 Db_Owner       :        Boolean := True) is  
        Names : X_Rm_Name_Array (Quarks'Range);  
    begin

        if Database = None_X_Rm_Database then  
            Database          := new X_Rm_Database_Rec;  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        elsif Database.Contents = None_X_Rm_Hash_Bucket then  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        end if;  
        for I in Quarks'Range loop  
            Names (I) := X_Rm_Name (Quarks (I));  
        end loop;  
        Put_Entry (Bucket         => Database.Contents,  
                   Bindings       => Bindings,  
                   Names          => Names,  
                   Representation => Representation,  
                   Value          => Value,  
                   Db_Owner       => Db_Owner);

    end X_Rm_Put_Resource;

--\f

    procedure X_Rm_Put_Resource (Database       : in out X_Rm_Database;  
                                 Bindings       :        X_Rm_Binding_Array;  
                                 Classes        :        X_Rm_Class_Array;  
                                 Representation :        X_Rm_Representation;  
                                 Value          :        X_Rm_Value;  
                                 Db_Owner       :        Boolean := True) is  
        Names : X_Rm_Name_Array (Classes'Range);  
    begin

        if Database = None_X_Rm_Database then  
            Database          := new X_Rm_Database_Rec;  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        elsif Database.Contents = None_X_Rm_Hash_Bucket then  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        end if;  
        for I in Classes'Range loop  
            Names (I) := X_Rm_Name (Classes (I));  
        end loop;  
        Put_Entry (Bucket         => Database.Contents,  
                   Bindings       => Bindings,  
                   Names          => Names,  
                   Representation => Representation,  
                   Value          => Value,  
                   Db_Owner       => Db_Owner);

    end X_Rm_Put_Resource;

--\f

    procedure X_Rm_Put_Resource (Database       : in out X_Rm_Database;  
                                 Bindings       :        X_Rm_Binding_Array;  
                                 Names          :        X_Rm_Name_Array;  
                                 Representation :        X_Rm_Representation;  
                                 Value          :        X_Rm_Value;  
                                 Db_Owner       :        Boolean := True) is
--------------------------------------------------------------------------
--  Database             - Specifies the database to modify; if NULL then a new
--                    database record will be created.
--  Bindings        - Specifies a list of binding types.
--  Names           - Specifies the partial name or class list of the resource.
--  Representation  - Specifies the type of the resource.
--  Value           - Specifies the value of the resource.
--  Db_Owner        - Specifies TRUE if the database is to be responsible for
--                    deallocating any heap storage utilized by Value once the
--                    last database entry for this Value is overwritten or
--                    released.
--
-- Place an X_Rm_Value into the database.
--
-- To "remove" a value from the database simply pass an X_Rm_Value'(Kind =>
-- Is_None) in as Value.  The database storage space will not grow if the
-- indicated value was not there to begin with and it will shrink (by a tiny
-- amount) if the value is eliminated by an Is_None assignment.
--
-- If Db_Owner is TRUE (the default) then any heap storage represented by
-- the Value becomes the "property" of the database and it must not be
-- subsequently modified or freed.  If several entries in one database (or
-- individual entries in multiple databases) are all to be given entries
-- which will all have the same heap-using Value then either a) none of the
-- database entries should be made with Db_Owner => TRUE (meaning that the
-- application is responsible for releasing the heap storage), or b) only
-- one database entry should have Db_Owner => TRUE and that database must
-- be deallocated last of any databases sharing this value.
--
-- Note that if Value is an Is_Universal then Db_Owner has no affect if
-- the Free routine within the Value is X_Univ_Free.None.  A database cannot
-- free a Universal pointer when no Free routine has been provided.
--------------------------------------------------------------------------
    begin

        if Database = None_X_Rm_Database then  
            Database          := new X_Rm_Database_Rec;  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        elsif Database.Contents = None_X_Rm_Hash_Bucket then  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        end if;  
        Put_Entry (Bucket         => Database.Contents,  
                   Bindings       => Bindings,  
                   Names          => Names,  
                   Representation => Representation,  
                   Value          => Value,  
                   Db_Owner       => Db_Owner);

    end X_Rm_Put_Resource;

--\f

    procedure X_Rm_Put_String_Resource (Database : in out X_Rm_Database;  
                                        Bindings :        X_Rm_Binding_Array;  
                                        Names    :        X_Rm_Name_Array;  
                                        Value    :        X_String) is
--------------------------------------------------------------------------
-- Just like X_Rm_Put_Resource above except it is only for installing string
-- values.
------------------------------------------------------------------------------
    begin

        if Database = None_X_Rm_Database then  
            Database          := new X_Rm_Database_Rec;  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        elsif Database.Contents = None_X_Rm_Hash_Bucket then  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        end if;  
        Put_Entry (Bucket => Database.Contents,  
                   Bindings => Bindings,  
                   Names => Names,  
                   Representation => X_Lib_X_Rm_R_String,  
                   Value => (Kind               => Is_X_String_Pointer,  
                             V_X_String_Pointer => new X_String'(Value)),  
                   Db_Owner => True);

    end X_Rm_Put_String_Resource;

--\f

    procedure X_Rm_Put_Resource (Database       : in out X_Rm_Database;  
                                 Specifier      :        X_String;  
                                 Representation :        X_String;  
                                 Value          :        X_Rm_Value;  
                                 Db_Owner       :        Boolean := True) is
------------------------------------------------------------------------------
--  Database        - Specifies the database to modify; if NULL then a new
--                    database record will be created and returned.
--  Specifier       - Specifies the (may be partial) specification of the
--                    resource.
--  Representation  - Specifies the type of the resource.
--  Value           - Specifies the value of the resource.
--  Db_Owner        - Specifies TRUE if the database is to be responsible for
--                    deallocating any heap storage utilized by Value once the
--                    last database entry for this Value is overwritten or
--                    released.
--
-- A convenience routine that calls X_Rm_String_To_Representation for the
-- Representation string, calls X_Rm_String_To_Binding_Name_List for the
-- Specifier, and calls X_Rm_Put_Resource above to actually install the
-- resource.
------------------------------------------------------------------------------
        Bindings : X_Rm_Binding_Array (1 .. Components (Specifier) + 1);  
        Names    : X_Rm_Name_Array (1 .. Bindings'Length);  
    begin

        if Database = None_X_Rm_Database then  
            Database          := new X_Rm_Database_Rec;  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        elsif Database.Contents = None_X_Rm_Hash_Bucket then  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        end if;  
        X_Rm_String_To_Binding_Name_List (Specifier, Bindings, Names);  
        Put_Entry (Bucket         => Database.Contents,  
                   Bindings       => Bindings,  
                   Names          => Names,  
                   Representation =>  
                      X_Rm_String_To_Representation (Str => Representation),  
                   Value          => Value,  
                   Db_Owner       => Db_Owner);

    end X_Rm_Put_Resource;

--\f

    procedure X_Rm_Put_String_Resource (Database  : in out X_Rm_Database;  
                                        Specifier :        X_String;  
                                        Value     :        X_String) is
------------------------------------------------------------------------------
-- Just like X_Rm_Put_Resource above except it is only for installing string
-- values.
------------------------------------------------------------------------------
        Bindings : X_Rm_Binding_Array (1 .. Components (Specifier) + 1);  
        Names    : X_Rm_Name_Array (1 .. Bindings'Length);  
    begin

        if Database = None_X_Rm_Database then  
            Database          := new X_Rm_Database_Rec;  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        elsif Database.Contents = None_X_Rm_Hash_Bucket then  
            Database.Contents := new X_Rm_Hash_Bucket_Rec;  
        end if;  
        X_Rm_String_To_Binding_Name_List (Specifier, Bindings, Names);  
        Put_Entry (Bucket => Database.Contents,  
                   Bindings => Bindings,  
                   Names => Names,  
                   Representation => X_Lib_X_Rm_R_String,  
                   Value => (Kind               => Is_X_String_Pointer,  
                             V_X_String_Pointer => new X_String'(Value)),  
                   Db_Owner => True);

    end X_Rm_Put_String_Resource;

--\f

    function Get_Tables (Tight   : X_Rm_Hash_Table;  
                         Loose   : X_Rm_Hash_Table;  
                         Names   : X_Rm_Name_Array;  
                         Classes : X_Rm_Class_Array) return X_Rm_Search_List is
------------------------------------------------------------------------------
--  Tight   - Specifies the "tight" tables at this point in the lookup
--  Loose   - Specifies the "loose" tables at this point in the lookup
--  Names   - Specifies the name sequence we are looking for
--  Classes - Specifies the class sequence we are looking for
--
-- Called when we are doing a lookup that will take us to the database
-- "neighborhood" where we want to do a large number of related lookups.
-- We call this to lookup the context for a toolkit widget and then we
-- use the tables to do the lookups of the widget's individual resources.
------------------------------------------------------------------------------

        Tables : X_Rm_Search_List (1 .. 100);  -- Result; unless we overflow
        Tables_Ptr : X_Rm_Search_List_Pointer; -- Result; if we overflow
        Tables_Ptr2 : X_Rm_Search_List_Pointer;-- Temp during overflow
        Tables_I : S_Natural := 0;               -- Current count of results

        procedure Save_Table (Table : X_Rm_Hash_Table) is
------------------------------------------------------------------------------
--  Table   - Specifies a table to return to the caller; saved as a result
--
-- Called to put a Table into our set of return tables.  Since, in the
-- absolute worst case, there are (Names'Length)! possible return values,
-- and since we have no way of usefully predicting the actual number of
-- return values prior to finding them, we will use a mixed strategy.
-- There will usually be a "small" number of return tables.  I.e. < 100.
-- However, there could be very very many.  So, the first 100 go into the
-- local area and if we happen to overflow that then we will use heap
-- storage to store our intermediate results.
------------------------------------------------------------------------------
        begin  
            if Tables_I > 1 then  
                if Tables_I <= Tables'Last then  
                    if Tables (Tables_I) = X_Rm_Search_List_Entry (Table) then  
                        return;  
                    end if;  
                else  
                    if Tables_Ptr (Tables_I) =  
                       X_Rm_Search_List_Entry (Table) then  
                        return;  
                    end if;  
                end if;  
            end if;  
            Tables_I := Tables_I + 1;  
            if Tables_I <= Tables'Last then             -- Fits local table
                Tables (Tables_I) := X_Rm_Search_List_Entry (Table);  
                return;  
            elsif Tables_Ptr = null then                -- Create a heap table
                Tables_Ptr := new X_Rm_Search_List (1 .. Tables'Last * 2);  
                Tables_Ptr (Tables'Range) := Tables;  
            elsif Tables_I <= Tables_Ptr'Last then      -- Fits in heap table
                null;  
            else                                        -- Recreate heap table
                Tables_Ptr2 := new X_Rm_Search_List (1 .. Tables_Ptr'Last * 2);  
                Tables_Ptr2 (Tables_Ptr'Range) := Tables_Ptr.all;  
                Free_X_Rm_Search_List_Pointer (Tables_Ptr);  
                Tables_Ptr := Tables_Ptr2;  
            end if;  
            Tables_Ptr (Tables_I) := X_Rm_Search_List_Entry (Table);  
        end Save_Table;

        procedure Get_Tables (Tight   : X_Rm_Hash_Table;  
                              Loose   : X_Rm_Hash_Table;  
                              Names   : X_Rm_Name_Array;  
                              Classes : X_Rm_Class_Array) is
------------------------------------------------------------------------------
-- Same as the function.
--
-- This is the workhorse.  This is the guy who recursively walks the database
-- calling Save_Table for each table that we want to return.
------------------------------------------------------------------------------

            Bucket    : X_Rm_Hash_Bucket;           -- Current entry
            Ntight    : X_Rm_Hash_Table;            -- Current tight table
            Nloose    : X_Rm_Hash_Table;            -- Current loose table
            Names_I   : S_Natural := Names'First;  
            Classes_I : S_Natural := Classes'First;

            procedure Get_Tables_Lookup (Table : X_Rm_Hash_Table;  
                                         Name  : X_Rm_Name) is
------------------------------------------------------------------------------
--  Table   - Specifies the hash table to look within
--  Name    - Specifies the name we are looking for
--
-- Called to see if a particular name is located within a particular table.
-- If it is then we return all the way back to the original caller with the
-- database table that we just found.
------------------------------------------------------------------------------
            begin

----Grab a hash bucket and loop over all buckets in the chain.

                Bucket := Table (Hash_Index (Name));  
                while Bucket /= null loop

----See if we just found the name.  If so then we are very happy.

                    if Bucket.Name = Name then

----If this entry has further tables then we keep it.  If not then just return.

                        Ntight := Bucket.Tables (X_Rm_Bind_Tightly);  
                        Nloose := Bucket.Tables (X_Rm_Bind_Loosely);  
                        if Ntight = null and then Nloose = null then  
                            return;  
                        end if;

----If we aren't at the end of the name list then recurse.

                        if Names (Names_I + 1) /= None_X_Rm_Name then  
                            Get_Tables (Ntight, Nloose,  
                                        Names (Names_I + 1 .. Names'Last),  
                                        Classes (Classes_I + 1 ..  
                                                    Classes'Last));  
                        end if;

----If there is a Tight table then return that if there is room for it.

                        if Ntight /= null and then  
                           Bucket.Has_Values (X_Rm_Bind_Tightly) then  
                            Save_Table (Ntight);  
                        end if;

----If there is a loose table then return that if there is room for it.

                        if Nloose /= null and then  
                           Bucket.Has_Values (X_Rm_Bind_Loosely) then  
                            Save_Table (Nloose);  
                        end if;  
                        return;  
                    end if;

----Loop for the next bucket.

                    Bucket := Bucket.Next;  
                end loop;

            end Get_Tables_Lookup;

        begin   -- body of procedure Get_Tables

----Sanity check upon ourselves and our caller.

--/ if DEBUG then
            if not ((Tight /= null or Loose /= null) and  
                    Names (Names'First) /= None_X_Rm_Name) then  
                raise X_Library_Confusion;  
            end if;
--/ end if;

----Check the very first name & class in both tight and loose tables

            if Tight /= null then  
                Get_Tables_Lookup (Tight, Names (Names_I));  
            end if;  
            if Loose /= null then  
                Get_Tables_Lookup (Loose, Names (Names_I));  
            end if;  
            if Tight /= null then  
                Get_Tables_Lookup (Tight, X_Rm_Name (Classes (Classes_I)));  
            end if;  
            if Loose /= null then  
                Get_Tables_Lookup (Loose, X_Rm_Name (Classes (Classes_I)));  
            end if;

----Now check any remaining names and class, but just in the loose table.

            if Loose /= null then  
                while Names (Names_I + 1) /= None_X_Rm_Name loop  
                    Names_I   := Names_I + 1;  
                    Classes_I := Classes_I + 1;  
                    Get_Tables_Lookup (Loose, Names (Names_I));  
                    Get_Tables_Lookup (Loose, X_Rm_Name (Classes (Classes_I)));  
                end loop;  
            end if;

        end Get_Tables;

    begin   -- body of function Get_Tables

----Return whatever it is that we find.

        Get_Tables (Tight, Loose, Names, Classes);  
        if Tables_I <= Tables'Last then  
            return Tables (1 .. Tables_I);  
        end if;  
        declare  
            Tbls : X_Rm_Search_List (1 .. Tables_I) :=  
               Tables_Ptr (1 .. Tables_I);  
        begin  
            Free_X_Rm_Search_List_Pointer (Tables_Ptr);  
            return Tbls;  
        end;

    exception

        when others =>  
            Free_X_Rm_Search_List_Pointer (Tables_Ptr);  
            raise;

    end Get_Tables;

--\f

    function X_Rm_Get_Search_List (Database : X_Rm_Database;  
                                   Names    : X_Rm_Name_Array;  
                                   Classes  : X_Rm_Class_Array)  
                                  return X_Rm_Search_List is
--------------------------------------------------------------------------
--  Database     - Specifies the database to search.
--  Names   - Specifies a list of resource names.
--  Classes - Specifies a list of class names.
--
-- Takes a list of names and classes and returns a list of database levels
-- and wildcards where a match might occur.
--------------------------------------------------------------------------
        Ntight : X_Rm_Hash_Table;  
        Nloose : X_Rm_Hash_Table;

        function Tbls return X_Rm_Search_List is
------------------------------------------------------------------------------
-- If there is a non-empty Names list then get the tables for that list.
-- Otherwise return an empty list.
------------------------------------------------------------------------------
        begin  
            if Names (Names'First) /= None_X_Rm_Name then  
                return Get_Tables (Ntight, Nloose, Names, Classes);  
            else  
                return (1 .. 0 => null);  
            end if;  
        end Tbls;

    begin

---If there isn't any database then there isn't any list.

        if Database = None_X_Rm_Database or else  
           Database.Contents = None_X_Rm_Hash_Bucket then  
            return (1 .. 0 => null);  
        end if;

----See if we can find any tables that match this sequence of names.
--  We want the tables that match the Names list concatenated with the
--  Ntight and then the Nloose tables on the end of the list.

        Ntight := Database.Contents.Tables (X_Rm_Bind_Tightly);  
        Nloose := Database.Contents.Tables (X_Rm_Bind_Loosely);  
        if Ntight /= null and then  
           Database.Contents.Has_Values (X_Rm_Bind_Tightly) then  
            if Nloose /= null and then  
               Database.Contents.Has_Values (X_Rm_Bind_Loosely) then  
                return Tbls & X_Rm_Search_List_Entry (Ntight) &  
                          X_Rm_Search_List_Entry (Nloose);  
            else  
                return Tbls & X_Rm_Search_List_Entry (Ntight);  
            end if;  
        elsif Nloose /= null and then  
              Database.Contents.Has_Values (X_Rm_Bind_Loosely) then  
            return Tbls & X_Rm_Search_List_Entry (Nloose);  
        else  
            return Tbls;  
        end if;

    end X_Rm_Get_Search_List;

--\f

    procedure X_Rm_Get_Search_Resource  
                 (List           :     X_Rm_Search_List;  
                  Name           :     X_Rm_Name;  
                  Class          :     X_Rm_Class;  
                  Representation : out X_Rm_Representation;  
                  Value          : out X_Rm_Value) is
--------------------------------------------------------------------------
--  List    - Specifies the search list to use.
--  Name    - Specifies a name to look up via the list.
--  Class   - Specifies a class name to look up via the list.
--  Representation- Receives the representation of the value
--  Value         - Receives the entry from the database or None_X_Rm_Value
--
-- If successful (Value /= None_X_Rm_Value) then Value has received an
-- X_Rm_Value from within the database.  Any heap based data returned is shared
-- with the database (and possibly other databases) so do not attempt free the
-- data contained within the entry.
--------------------------------------------------------------------------

        Bucket       : X_Rm_Hash_Bucket;  
        Db2          : X_Rm_Entry;  
        Name_Hash    : S_Natural;  
        Class_Hash   : S_Natural;  
        Name_Search  : Boolean;  
        Class_Search : Boolean;  
        Quark_Bits   : X_Rm_Quark_Bit_List;  
        Db_Entry     : X_Rm_Entry;  
    begin

-- My numbers show an average of 0.3 searches per call.  Compare this to
-- the maximal bound of 2 searches per call.  Further, the searchList
-- tends to be short--often 1 or 2 tables, generally not more than 4.
-- So this routine optimizes for the common cases.  Code is minimized
-- if there is nothing to do, and only three registers are used to
-- avoid saving/restoring.

        X_Lib.Seize_Resource_Quarks (Quark_Bits);  
        if Quark_Bits /= None_X_Rm_Quark_Bit_List and then  
           S_Natural (Name.Id) in Quark_Bits'Range then  
            Name_Search := Quark_Bits (S_Natural (Name.Id));  
            Name_Hash   := Hash_Index (Name);  
        else  
            Name_Search := False;  
        end if;  
        if Quark_Bits /= None_X_Rm_Quark_Bit_List and then  
           S_Natural (Class.Id) in Quark_Bits'Range then  
            Class_Search := Quark_Bits (S_Natural (Class.Id));  
            Class_Hash   := Hash_Index (X_Rm_Name (Class));  
        else  
            Class_Search := False;  
        end if;  
        X_Lib.Release_Resource_Quarks (Quark_Bits);  
        if not Name_Search and then not Class_Search then
            ----Most common case.
            Representation := None_X_Rm_Representation;  
            Value          := None_X_Rm_Value;  
            return;  
        end if;

----Check each table in the search list.

        for I in List'Range loop  
            if List (I) /= null then

----Look for the Name in this table.

                if Name_Search then  
                    Bucket := List (I) (Name_Hash);  
                    while Bucket /= null loop  
                        if Bucket.Name = Name then  
                            Db2 := Bucket.Value;  
                            if Db2 /= None_X_Rm_Entry and then  
                               Db2.Value.Kind /= Is_None then  
                                Representation := Db2.Representation;  
                                Value          := Db2.Value;  
                                return;  
                            end if;  
                            exit;  
                        end if;  
                        Bucket := Bucket.Next;  
                    end loop;  
                end if;

----Look for the Class in this table.

                if Class_Search then  
                    Bucket := List (I) (Class_Hash);  
                    while Bucket /= null loop  
                        if Bucket.Name = X_Rm_Name (Class) then  
                            Db2 := Bucket.Value;  
                            if Db2 /= None_X_Rm_Entry and then  
                               Db2.Value.Kind /= Is_None then  
                                Representation := Db2.Representation;  
                                Value          := Db2.Value;  
                                return;  
                            end if;  
                            exit;  
                        end if;  
                        Bucket := Bucket.Next;  
                    end loop;  
                end if;  
            end if;  
        end loop;

----We didn't find anything.

        Representation := None_X_Rm_Representation;  
        Value          := None_X_Rm_Value;

    end X_Rm_Get_Search_Resource;

--\f

    procedure Skip_Whitespace (Str : in out X_String;  
                               Pos : in out S_Natural) is
------------------------------------------------------------------------------
-- Scan the string starting at character Pos until we find a non-whitespace
-- character.  Pos is set to point to the first non-white character.
------------------------------------------------------------------------------
    begin

        for I in Pos .. Str'Last loop  
            if Str (I) /= ' ' and then Str (I) /= Ht then  
                Pos := I;  
                return;  
            end if;  
        end loop;  
        Pos := Str'Last + 1;

    end Skip_Whitespace;

--\f

    procedure Read_A_Name (Str        : in out X_String;  
                           Str_End    :        S_Natural;  
                           Pos        : in out S_Natural;  
                           Name_Begin : out    S_Natural;  
                           Name_End   : out    S_Natural;  
                           End_Char   : in out X_Character;  
                           Status     : in out X_Rm_Status) is
------------------------------------------------------------------------------
-- Scan the string from Pos..Str_End looking for ':', '!', or whitespace
-- followed by one of those.  Running off the end of the string is the same
-- as hitting a ':'.  Name_Begin..Name_End is the name found.  Pos is the
-- character after the ':' or '!'.  End_Char is the ':' or '!' found.
-- Name_Begin = 0 if we got a "format" error and this line should be
-- abandoned.
------------------------------------------------------------------------------
    begin

----Skip whitespace and mark the beginning of the name.

        Skip_Whitespace (Str, Pos);  
        Name_Begin := Pos;  
        Name_End   := Pos - 1;  
        End_Char   := ':';

----Loop over the remaining string.

        while Pos <= Str_End loop

----If we hit the :/! then we are done.  Return our values.

            if Str (Pos) = ':' or else Str (Pos) = '!' then  
                End_Char := Str (Pos);  
                Name_End := Pos - 1;  
                Pos      := Pos + 1;  
                exit;  
            end if;

----If we hit whitespace then we have the end of the name.  Skip the space
--  and make sure that we get end-of-string, ':', or '!'.

            if Str (Pos) = ' ' or else Str (Pos) = Ht then  
                Name_End := Pos - 1;  
                Skip_Whitespace (Str, Pos);  
                if Pos <= Str_End then  
                    End_Char := Str (Pos);  
                    if End_Char /= ':' and then End_Char /= '!' then  
                        Failed (Status);  
                        X_Report_Error ("XrmError", "BadLine",  
                                        Xrm_Error_Bad_Line,  
                                        Str (Str'First .. Str_End));  
                        Name_Begin := 0;  
                        Name_End   := 0;  
                        return;  
                    end if;  
                end if;  
                Pos := Pos + 1;  
                exit;  
            end if;

----Loop on the rest of the string.

            Pos := Pos + 1;  
        end loop;

    end Read_A_Name;

--\f

    function Hex (H : X_String) return U_Char_Array is
------------------------------------------------------------------------------
--  H   - Specifies the string containing a series of 2-digit hex numbers
--
-- Called to turn a "hex" string into a U_Char_Array value.
------------------------------------------------------------------------------
        Hi : S_Natural := H'First;  
        Y  : U_Char;  
        B  : U_Char_Array (1 .. H'Length / 2);  
        Ch : X_String (1 .. 2);  
    begin

----Loop over all of the expected raw data values.

        if H'Length rem 2 = 1 then  
            raise Constraint_Error;     -- Only *pairs* of hex digits allowed.
        end if;  
        for I in B'Range loop

----Get the first number (2 digits) and convert it.

            Ch := H (Hi .. Hi + 1);  
            Hi := Hi + 1;  
            Y  := 0;  
            if Ch (1) /= '0' then  
                if Ch (1) in '0' .. '9' then  
                    Y := (X_Character'Pos (Ch (1))  
                           - X_Character'Pos ('0')) * 16;  
                elsif Ch (1) in 'A' .. 'F' then  
                    Y := (X_Character'Pos (Ch (1))  
                           - X_Character'Pos ('A') + 10) * 16;  
                elsif Ch (1) in 'a' .. 'f' then  
                    Y := (X_Character'Pos (Ch (1))  
                           - X_Character'Pos ('a') + 10) * 16;  
                end if;  
            end if;  
            if Ch (2) in '0' .. '9' then  
                Y := Y + (X_Character'Pos (Ch (2))  
                           - X_Character'Pos ('0')) * 16;  
            elsif Ch (2) in 'A' .. 'F' then  
                Y := Y + (X_Character'Pos (Ch (2))  
                           - X_Character'Pos ('A') + 10) * 16;  
            elsif Ch (2) in 'a' .. 'f' then  
                Y := Y + (X_Character'Pos (Ch (2))  
                           - X_Character'Pos ('a') + 10) * 16;  
            end if;  
            B (I) := Y;  
        end loop;

----Return our result.

        return B;

    end Hex;

--\f

    procedure Get_Db_Value (Buf      : in out X_String;  
                            Full_Buf :        X_String;  
                            Value    : in out X_Rm_Value;  
                            Status   : in out X_Rm_Status) is
------------------------------------------------------------------------------
--  Buf         - Specifies the string value to be placed into the database
--  Full_Buf    - Specifies the full input line for error messages
--  Value       - Receives the converted value
--
-- Called when we have read an entry from an Ascii database file.  We convert
-- the string that we read into a database value.
------------------------------------------------------------------------------
    begin

        case Value.Kind is

            when Is_None | Is_X_Rm_File_Type | Is_X_Universal_Pointer |  
                 Is_X_Atom | Is_X_Color | Is_X_Colormap | Is_X_Cursor |  
                 Is_X_Display | Is_X_Font | Is_X_Font_Struct | Is_X_Pixel |  
                 Is_X_Pixmap | Is_X_Screen | Is_X_Visual | Is_X_Window =>  
                Value := (Kind => Is_None);

            when Is_Boolean =>  
                Value := (Kind      => Is_Boolean,  
                          V_Boolean => Boolean'Value (To_String (Buf)));

            when Is_Float =>  
                declare  
                    Last : Positive;  
                begin  
                    Value := (Kind    => Is_Float,  
                              V_Float => 0.0);  
                    Float_Io.Get (To_String (Buf), Value.V_Float, Last);  
                end;

            when Is_U_Char =>  
                Value := (Kind     => Is_U_Char,  
                          V_U_Char => U_Char'Value (To_String (Buf)));

            when Is_U_Short =>  
                Value := (Kind      => Is_U_Short,  
                          V_U_Short => U_Short'Value (To_String (Buf)));

            when Is_S_Char =>  
                Value := (Kind     => Is_S_Char,  
                          V_S_Char => S_Char'Value (To_String (Buf)));

            when Is_S_Short =>  
                Value := (Kind      => Is_S_Short,  
                          V_S_Short => S_Short'Value (To_String (Buf)));

            when Is_S_Long =>  
                Value := (Kind     => Is_S_Long,  
                          V_S_Long => S_Long'Value (To_String (Buf)));

            when Is_X_Initial_Window_State =>  
                Value := (Kind                     => Is_X_Initial_Window_State,  
                          V_X_Initial_Window_State =>  
                             X_Initial_Window_State'Value (To_String (Buf)));

            when Is_X_Time =>  
                Value := (Kind     => Is_X_Time,  
                          V_X_Time => X_Time'Value (To_String (Buf)));

            when Is_X_String7_Pointer =>  
                Value := (Kind                => Is_X_String7_Pointer,  
                          V_X_String7_Pointer => new String'(To_String (Buf)));

            when Is_X_String_Pointer =>  
                declare  
                    Uca : constant U_Char_Array := Hex (Buf);  
                begin  
                    Value := (Kind               => Is_X_String_Pointer,  
                              V_X_String_Pointer =>  
                                 new X_String (1 .. Uca'Length));  
                    From_Uca (Value.V_X_String_Pointer.all, Uca);  
                end;

            when Is_X_String16_Pointer =>  
                declare  
                    Uca : constant U_Char_Array := Hex (Buf);  
                begin  
                    Value := (Kind                 => Is_X_String16_Pointer,  
                              V_X_String16_Pointer =>  
                                 new X_String16 (1 .. Uca'Length / 2));  
                    From_Uca (Value.V_X_String16_Pointer.all, Uca);  
                end;

            when Is_U_Char_List =>  
                Value := (Kind          => Is_U_Char_List,  
                          V_U_Char_List => new U_Char_Array'(Hex (Buf)));  
        end case;

    exception

        when others =>  
            Failed (Status);  
            X_Report_Exception ("XrmError", "ReadConversion",  
                                Xrm_Error_Read_Conversion,  
                                Full_Buf);  
            Value := (Kind => Is_None);

    end Get_Db_Value;
--\f

    procedure Strip_C_Style_Quoting (Buf      : in out X_String;  
                                     Buf_Last : in out S_Natural;  
                                     Status   : in out X_Rm_Status) is
------------------------------------------------------------------------------
--  Buf      - Specifies the string to process.
--  Buf_Last - Specifies and returns the last in-use position within Buf.
--
-- Called to strip the '\' quoting from a string (normal C conventions).
--  - "\n" becomes a single Ascii.Lf in the final value.
--  - "\n" followed by an Ascii.Lf in the Line string becomes just Ascii.Lf
--  - "\000" where "000" is any three digit octal number becomes the
--    Ascii character with that Character'Pos.
--  - "\\" becomes just a single "\".
--
-- Buf_Last is updated to indicate the end of the still-existent Buf when
-- we are done.  Buf is modified in-place.
------------------------------------------------------------------------------
        Ch_0    : constant S_Natural := X_Character'Pos ('0');  
        Ch_Max  : constant S_Natural := X_Character'Pos (X_Character'Last);  
        In_Pos  : S_Long             := Buf'First;  
        Out_Pos : S_Long             := Buf'First;  
        Char    : S_Natural;  
    begin
        -- Each iteration of this loop produces one "output" character,
        -- but may consume several "input" characters.
        while In_Pos <= Buf_Last loop  
            if Buf (In_Pos) /= '\' then
                -- Everything except "\" is copied unchanged.
                Buf (Out_Pos) := Buf (In_Pos);

            elsif (In_Pos = Buf_Last) or else (Buf (In_Pos + 1) = '\') then
                -- "\\" becomes "\", as does a trailing "\".
                In_Pos        := In_Pos + 1;  
                Buf (Out_Pos) := '\';

            elsif Buf (In_Pos + 1) = 'n' then
                -- "\n" becomes Lf.
                In_Pos        := In_Pos + 1;  
                Buf (Out_Pos) := Lf;

                -- "\n" & Lf becomes a single Lf.
                if (In_Pos < Buf_Last) and then (Buf (In_Pos + 1) = Lf) then  
                    In_Pos := In_Pos + 1;  
                end if;

            elsif (In_Pos + 3 <= Buf_Last and then  
                   Buf (In_Pos + 1) in '0' .. '7' and then  
                   Buf (In_Pos + 2) in '0' .. '7' and then  
                   Buf (In_Pos + 3) in '0' .. '7') then
                -- "\ddd" becomes a single character.
                Char := (X_Character'Pos (Buf (In_Pos + 1)) - Ch_0) * 64 +  
                           (X_Character'Pos (Buf (In_Pos + 2)) - Ch_0) * 8 +  
                           (X_Character'Pos (Buf (In_Pos + 3)) - Ch_0);

                -- Complain if this isn't a legal character.
                if Char > Ch_Max then  
                    Char := Char mod (Ch_Max + 1);  
                    Had_Errors (Status);  
                    X_Report_Warning ("XrmWarning", "BadCharacter",  
                                      Xrm_Error_Bad_Character,  
                                      Buf (In_Pos .. In_Pos + 3),  
                                      Buf (Buf'First .. Out_Pos - 1) &  
                                         Buf (In_Pos .. Buf_Last));  
                end if;

                -- Save the conversion result.
                In_Pos        := In_Pos + 3;  
                Buf (Out_Pos) := X_Character'Val (Char);

            else
                -- All other quoting is an error.
                Had_Errors (Status);  
                X_Report_Warning ("XrmWarning", "BadQuoting",  
                                  Xrm_Error_Bad_Quoting,  
                                  Buf (In_Pos .. In_Pos + 1),  
                                  Buf (Buf'First .. Out_Pos - 1) &  
                                     Buf (In_Pos .. Buf_Last));  
                In_Pos        := In_Pos + 1;  
                Buf (Out_Pos) := Buf (In_Pos);  
            end if;

            -- Examine the next character.
            Out_Pos := Out_Pos + 1;  
            In_Pos  := In_Pos + 1;  
        end loop;

        -- Set the new buffer length.
        Buf_Last := Out_Pos - 1;  
    end Strip_C_Style_Quoting;

--\f

    procedure Put_Line_Resources (Pdb    : in out X_Rm_Database;  
                                  Buf_In :        X_String;  
                                  Status : in out X_Rm_Status) is
------------------------------------------------------------------------------
--  Pdb     - Specifies the database to modify
--  Buf     - Specifies the resource line we are to process
--
-- Called to put one resource line (as from a database file) into an
-- existing database.
------------------------------------------------------------------------------
        Buf            : X_String (1 .. Buf_In'Length) := Buf_In;  
        Bufi           : S_Natural;  
        S              : S_Natural;  
        Ch             : X_Character;  
        Name_Str       : S_Natural;  
        Name_End       : S_Natural;  
        Bindings       : X_Rm_Binding_Array (1 .. Components (Buf_In) + 1);  
        Names          : X_Rm_Name_Array (1 .. Bindings'Length);  
        Value          : X_Rm_Value;  
        Representation : X_Rm_Representation;  
        Kind           : X_Rm_Value_Kind;  
    begin

----Scan the string and remove any '\' quotings.  \ on the end of the string
--  is ignored.  \n is translated to Ascii.Lf.  Any other character after a
--  \ is simply copied minus the \ unless it looks like an octal number.

        if Buf'Length = 0 or else  
           Buf (Buf'First) = '!' then  
            return;                     -- Ignore comment lines.
        end if;  
        Bufi := Buf'Last;  
        Strip_C_Style_Quoting (Buf, Bufi, Status);

----Scan to the end of the resource name/class specification.  We skip
--  leading whitespace.  We scan for :/!/whitespace as the termination of
--  the name.  If the name ends in whitespace then we skip that and we
--  expect the first non-whitespace to be a :/!.

        S := Buf'First;  
        Read_A_Name (Buf, Bufi, S, Name_Str, Name_End, Ch, Status);  
        if Name_Str = 0 then  
            return;  
        end if;  
        begin  
            X_Rm_String_To_Binding_Name_List (Buf (Name_Str .. Name_End),  
                                              Bindings,  
                                              Names);  
        exception  
            when Constraint_Error =>  
                Had_Errors (Status);  
                X_Report_Error ("XrmWarning", "BadName",  
                                Xrm_Error_Bad_Resource_Name,  
                                Buf (Name_Str .. Name_End), Buf_In);  
                return;  
        end;

----We either have Ch='!' indicating that a representation clause comes next
--  or we have Ch=':' indicating that a string value comes next.  If we see
--  a ':' then we assume that the format is String and the Kind is String.
--  If we see a ! then we have a representation. next.  Get that name and it is our
--  Representation.  After the representation. name may be another ! followed by a Kind.
--  Assume Is_Bytes if Kind is not there.

        if Ch = ':' then  
            Representation := X_Lib_X_Rm_R_String;  
            Kind           := Is_X_String_Pointer;  
        else  
            Read_A_Name (Buf, Bufi, S, Name_Str, Name_End, Ch, Status);  
            if Name_Str = 0 then  
                return;  
            end if;  
            begin  
                Representation :=  
                   X_Rm_String_To_Representation (Buf (Name_Str .. Name_End));  
            exception  
                when Constraint_Error =>  
                    Had_Errors (Status);  
                    X_Report_Error ("XrmWarning", "BadRep",  
                                    Xrm_Error_Bad_Resource_Rep,  
                                    Buf (Name_Str .. Name_End), Buf_In);  
                    return;  
            end;  
            if Name_Str = 0 then  
                return;  
            end if;  
            if Ch = ':' then  
                Kind := Is_U_Char_List;  
            else  
                Read_A_Name (Buf, Bufi, S, Name_Str, Name_End, Ch, Status);  
                begin  
                    Kind := X_Rm_Value_Kind'Value  
                               (To_String (Buf (Name_Str .. Name_End)));  
                exception  
                    when others =>  
                        Had_Errors (Status);  
                        X_Report_Error ("XrmWarning", "BadKind",  
                                        Xrm_Error_Bad_Kind,  
                                        Buf (Buf'First .. Bufi));  
                        return;  
                end;  
            end if;  
        end if;

----If Kind is Is_String then skip whitespace and take the rest of the line
--  as the value.

        if Kind = Is_X_String_Pointer then  
            Skip_Whitespace (Buf, S);  
            Value := (Kind               => Is_X_String_Pointer,  
                      V_X_String_Pointer => new X_String'(Buf (S .. Bufi)));  
            X_Rm_Put_Resource (Pdb, Bindings, Names, Representation, Value,  
                               Db_Owner => True);  
        elsif Kind = Is_X_String7_Pointer then  
            Skip_Whitespace (Buf, S);  
            Value := (Kind                => Is_X_String7_Pointer,  
                      V_X_String7_Pointer =>  
                         new String'(To_String (Buf (S .. Bufi))));  
            X_Rm_Put_Resource (Pdb, Bindings, Names, Representation, Value,  
                               Db_Owner => True);

----If Kind is not Is_String then the rest of the line is a bunch of bytes
--  encoded 2 hex characters at a time.  Dispatch based upon Kind and do
--  the right thing.

        else  
            Skip_Whitespace (Buf, S);  
            Get_Db_Value (Buf (S .. Buf'Last), Buf, Value, Status);  
            X_Rm_Put_Resource (Pdb, Bindings, Names, Representation, Value,  
                               Db_Owner => True);  
        end if;

    end Put_Line_Resources;

--\f

    function File_Get_Line (File : Text_Io.File_Type) return X_String is
------------------------------------------------------------------------------
-- Called to read the next "line" in from a file.  The next "line" is number of
-- Ada's IO lines up to the first one that does not end in '\'.
------------------------------------------------------------------------------
        Buf  : String (1 .. 1000);  
        Bufi : Integer := 0;  
        Eol  : Boolean := False;  
    begin

----Read in one Ada line.

        Text_Io.Get_Line (File, Buf, Bufi);

----If we got the whole Ada line and if this Ada line ends in \ then remove
--  that \ and pretend that EOL was not seen.

        Eol := Text_Io."=" (Text_Io.Col (File), 1);  
        if Eol then
            -- An odd number of trailing '\'s means this line is continued.
            for I in reverse 1 .. Bufi loop  
                exit when Buf (Bufi) /= '\';  
                Eol := not Eol;  
            end loop;

            -- Remove the '\' that caused the continuation.
            if not Eol then  
                Bufi := Bufi - 1;  
            end if;  
        end if;

----If we don't have a whole line (either we didn't read the entire Ada line
--  or else we need to read another Ada line) then recurse and return the
--  concatenated fruit of our labors.

        if not Eol then  
            begin  
                return To_X_String (Buf (1 .. Bufi)) & File_Get_Line (File);  
            exception  
                when Text_Io.End_Error =>  
                    null;  
            end;  
        end if;

----We're happy, return our "line".

        return To_X_String (Buf (1 .. Bufi));

    end File_Get_Line;

--\f

    procedure X_Rm_Add_Resource (Database : in out X_Rm_Database;  
                                 Line     :        X_String;  
                                 Status   : out    X_Rm_Status) is
------------------------------------------------------------------------------
--  Database   - Specifies the database to update; if NULL then a new database
--          record will be created.
--  Line  - Specifies the "name:value", "name!rep:value", or
--          "name!rep!kind:value" string.  The name contains any
--          full or partial resource specification.  The representation is any
--          Resource Manager representation.  The kind is any X_Rm_Value_Kind
--          And, the value is the string/hex-string representation of the
--          resource.
--  Status   - Receives Rm_Successful, Rm_Had_Errors, or Rm_Failed.
--
-- Called to add one entry to a database.
--
-- The name/representation/kind/string are separated by optional whitespace and
-- non-optional '!'/':' characters.  The representation and kind are optional.  Kind
-- cannot be specified if representation is not specified.
--
-- The name, representation, and kind are any initial portions of the string that are not
-- whitespace; leading and trailing whitespace surrounding the name, representation, or,
-- kind is dropped.
--
-- The value begins with the first non-whitespace character after the colon
-- and continues up to the end of the string or until an embedded Ascii.Lf
-- is found.
--
-- If the representation is "String" (the default if no representation is given) then the value
-- is a simple string of characters using many of the normal C conventions.
--  - "\n" becomes a single Ascii.Lf in the final value
--  - "\n" followed by an Ascii.Lf in the Line string becomes just Ascii.Lf
--  - "\000" where "000" is any octal number of 1..3 digits becomes the
--    Ascii character wit that Character'Pos
--  - "\\" becomes just a single "\"
------------------------------------------------------------------------------

        Str     : X_String renames Line;  
        Stri    : S_Natural := Str'First;  
        Lstatus : X_Rm_Status;

        function String_Get_Line return X_String is
------------------------------------------------------------------------------
-- Called to read the next "line" in from Str.  The next "line" is all
-- unread characters up to the end of the string or up to the first Ascii.Lf
-- that is not preceded by a '\'.  Any '\' & Ascii.Lf combinations are
-- squeezed out of the result.
------------------------------------------------------------------------------
            I : S_Natural;  
            B : S_Natural := Stri;  
        begin

----If the string is empty then raise End_Error to signal end-of-string.

            if Stri > Str'Last then  
                raise Text_Io.End_Error;  
            end if;

----Loop over the contents of the string.

            I := Stri;  
            while I <= Str'Last loop

----If we hit a Lf then we've found the end of the line.

                if Str (I) = Lf then  
                    Stri := I + 1;  
                    return Str (B .. I - 1);  
                end if;

----If we find a '\' then: a) if at the end of the string then drop it and
--  return the rest of what we've scanned; b) if followed by Ascii.Lf then
--  drop it and the Lf and return what we've scanned with a recursive scan.
--  Otherwise skip the \ and whatever character comes after it.

                if Str (I) = '\' then  
                    if I = Str'Last then  
                        Stri := Str'Last + 1;  
                        return Str (B .. I - 1);  
                    elsif Str (I + 1) = Lf then  
                        Stri := I + 2;  
                        return Str (B .. I - 1) & String_Get_Line;  
                    end if;  
                    I := I + 1;  
                end if;

----Loop for the next character.

                I := I + 1;  
            end loop;

----Ran off the end of the string; return the entire contents.

            Stri := Str'Last + 1;  
            return Str (B .. Str'Last);

        end String_Get_Line;

    begin

        Lstatus := Rm_Successful;  
        begin  
            loop  
                Put_Line_Resources (Database, String_Get_Line, Lstatus);  
            end loop;  
        exception  
            when Text_Io.End_Error =>  
                null;  
        end;  
        Status := Lstatus;

    end X_Rm_Add_Resource;

--\f

    procedure X_Rm_Get_String_Database (Data     :     X_String;  
                                        Database : out X_Rm_Database;  
                                        Status   : out X_Rm_Status) is
------------------------------------------------------------------------------
-- Just like X_Rm_Get_File_database except that it reads a string instead
-- of a file.
------------------------------------------------------------------------------
        Ldb : X_Rm_Database := None_X_Rm_Database;  
    begin

        X_Rm_Add_Resource (Ldb, Data, Status);  
        Database := Ldb;

    end X_Rm_Get_String_Database;

--\f

    procedure X_Rm_Get_File_Database (Filename :     String;  
                                      Database : out X_Rm_Database;  
                                      Status   : out X_Rm_Status) is
------------------------------------------------------------------------------
--  Filename  - Specifies the name of the file to read.
--  Database  - Receives the database read; which may be empty; i.e. no entries
--  Status   - Receives Rm_Successful, Rm_Had_Errors, or Rm_Failed.
--
-- Opens the specified file and attempts to read it and create a new database.
-- The file must contain lines acceptable to X_Rm_Put_Line_Resource.
--
-- Note: Files created by X Library implementations other than this one
-- may or may not be usable and files written with this X Library
-- implementation may or may not work properly with other implementation
-- unless the resource values consist only of strings.
--
-- Currently (Sep-1989) this implementation provides a superset of the
-- functionality of the existing C X Library implementation.  This means that
-- this routine can read resource files created by other implementations and
-- other implementations can read files created here as long as only string
-- values are involved.  Compatibility is a goal and as much compatibility as
-- possible will be maintained in the future.
------------------------------------------------------------------------------
        File    : Text_Io.File_Type;  
        Ldb     : X_Rm_Database := None_X_Rm_Database;  
        Lstatus : X_Rm_Status;  
    begin

----No errors as yet.

        Lstatus := Rm_Successful;

----If there is no filename or if there is no file of that name then simply
--  return the "empty" database.

        if Filename'Length = 0 then  
            Database := Ldb;  
            return;  
        end if;  
        begin  
            Text_Io.Open (File, Text_Io.In_File, Filename);  
        exception  
            when Text_Io.Name_Error =>  
                Database := Ldb;  
                Failed (Lstatus);  
                Status := Lstatus;  
                X_Report_Error ("XrmError", "FileNotFound",  
                                "Xrm; File not found: %1",  
                                To_X_String (Filename));  
                return;  
            when others =>  
                Database := Ldb;  
                Failed (Lstatus);  
                Status := Lstatus;  
                X_Report_Error ("XrmError", "FileCannotRead",  
                                "Xrm; Cannot open file for reading: %1",  
                                To_X_String (Filename));  
                return;  
        end;

----Loop getting lines from the file until we run out.

        begin  
            loop  
                Put_Line_Resources (Ldb, File_Get_Line (File), Lstatus);  
            end loop;  
        exception  
            when Text_Io.End_Error =>  
                null;       -- Simple End-Of-File on the input file.
            when Storage_Error =>  
                Failed (Lstatus);  
                Status := Lstatus;  
                X_Report_Error ("XlibError", "NoMemory",  
                                "No free memory available.");  
            when others =>  
                Failed (Lstatus);  
                Status := Lstatus;  
                X_Report_Error  
                   ("XrmError", "FileReadException",  
                    "Xrm; Unexpected exception while reading file: %1",  
                    To_X_String (Filename));  
        end;

----Close the file and return the Database.

        Text_Io.Close (File);  
        Database := Ldb;  
        Status   := Lstatus;

    end X_Rm_Get_File_Database;

--\f

    procedure Print_Binding_Quark_List (Bindings : X_Rm_Binding_Array;  
                                        Names    : X_Rm_Name_Array;  
                                        File     : Text_Io.File_Type) is
------------------------------------------------------------------------------
--  Bindings  - Specifies the bindings between names; '.' and '*'
--  Names     - Specifies a name list
--  File      - Specifies the output file
--
-- Called when dumping a database to Ascii.  We print the name sequence
-- that was used to reach a particular value within the database; complete with
-- '.' and '*'s.
------------------------------------------------------------------------------
        First_Name_Seen : Boolean := False;  
    begin

        for I in S_Natural range 0 .. Names'Length - 1 loop  
            exit when Names (Names'First + I) = None_X_Rm_Name;  
            if Bindings (Bindings'First + I) = X_Rm_Bind_Loosely then  
                Text_Io.Put (File, '*');  
            elsif First_Name_Seen then  
                Text_Io.Put (File, '.');  
            end if;  
            First_Name_Seen := True;  
            Text_Io.Put  
               (File,  
                To_String (X_Rm_Name_To_String (Names (Names'First + I))));  
        end loop;

    end Print_Binding_Quark_List;

--\f

    procedure Dump_Bytes (File : Text_Io.File_Type;  
                          Uca  : U_Char_Array) is  
        Uca_I : S_Natural := Uca'First;  
        Uca_J : S_Natural;  
        R     : S_Natural;  
    begin

----Loop doing 50 byte chunks at a time.

        loop  
            Uca_J := Uca_I + 49;  
            if Uca_J > Uca'Last then  
                Uca_J := Uca'Last;  
            end if;

----Put out the 50 characters.

            for I in Uca_I .. Uca_J loop  
                Text_Io.Put (File, ' ');  
                R := S_Natural (Uca (I)) / 16;  
                if R <= 9 then  
                    Text_Io.Put (File, Character'Val (Character'Pos ('0') + R));  
                else  
                    Text_Io.Put (File, Character'Val  
                                          (Character'Pos ('A') - 10 + R));  
                end if;  
                R := S_Natural (Uca (I)) rem 16;  
                if R <= 9 then  
                    Text_Io.Put (File, Character'Val (Character'Pos ('0') + R));  
                else  
                    Text_Io.Put (File, Character'Val  
                                          (Character'Pos ('A') - 10 + R));  
                end if;  
            end loop;

----Now continue or terminate the line if we are done.

            if Uca_J < Uca'Last then  
                Text_Io.Put_Line (File, "\");  
            else  
                exit;  
            end if;  
            Uca_I := Uca_J + 1;  
        end loop;  
        Text_Io.New_Line (File);

    end Dump_Bytes;

--\f

    procedure Dump_Entry (Bindings       : X_Rm_Binding_Array;  
                          Names          : X_Rm_Name_Array;  
                          Representation : X_Rm_Representation;  
                          Value          : X_Rm_Value;  
                          File           : Text_Io.File_Type) is
------------------------------------------------------------------------------
--  Bindings        - Specifies the tight/loose bindings of the database entry
--  Names           - Specifies the name components of the database entry
--  Representation  - Specifies the user's representation type
--  Value           - Specifies the actual database entry and the physical type
--  File            - Specifies the output file to use
--
-- Called to dump a single database entry to an Ascii output file.
------------------------------------------------------------------------------

        function Printable (Astr : X_String7_Pointer) return Boolean is
------------------------------------------------------------------------------
--  Astr    - Specifies the string to examine
--
-- Returns TRUE if a string contains nothing but "printable" characters.
-- Characters are printable if they aren't Ascii.Del or Ascii control
-- characters.  Ascii.Ht, Ascii.Lf are "ok".
------------------------------------------------------------------------------
        begin

            for I in Astr'Range loop  
                if Astr (I) /= Ascii.Lf and then  
                   Astr (I) /= Ascii.Ht and then  
                   (Astr (I) < ' ' or else  
                    Astr (I) >= Ascii.Del) then  
                    return False;  
                end if;  
            end loop;  
            return True;

        end Printable;

        function Printable (Astr : X_String_Pointer) return Boolean is
------------------------------------------------------------------------------
--  Astr    - Specifies the string to examine
--
-- Returns TRUE if a string contains nothing but "printable" characters.
-- Characters are printable if they aren't Ascii.Del or Ascii control
-- characters.  Ascii.Ht, Ascii.Lf are "ok".
------------------------------------------------------------------------------
        begin

            for I in Astr'Range loop  
                if Astr (I) /= Xlbt_String.Lf and then  
                   Astr (I) /= Xlbt_String.Ht and then  
                   (Astr (I) < Xlbt_String.' ' or else  
                    Astr (I) >= Xlbt_String.Del) then  
                    return False;  
                end if;  
            end loop;  
            return True;

        end Printable;

    begin

----Start the output with the name of the database entry.  Put in the right
--  type of '.' and '*' divisions in the name.

        Print_Binding_Quark_List (Bindings, Names, File);

----String values are the easiest.  They just dump straight to the file.
--  This is also the only compatible-across-all-X-Library-implementations
--  type of entry.

        if Representation = X_Lib_X_Rm_R_String and then  
           Value.Kind = Is_X_String7_Pointer and then  
           Printable (Value.V_X_String7_Pointer) then

----We have a string value and it contains only printable characters.
--  Put it out in up-to 200 character increments with '\' continuation lines.

            declare  
                Ptr    : X_String7_Pointer := Value.V_X_String7_Pointer;  
                Char_I : Natural           := Ptr'First;  
                Char_J : Natural;  
            begin  
                Text_Io.Put (File, ':' & Ascii.Ht);

----Loop doing 200 character chunks at a time.

                loop  
                    Char_J := Char_I + 199;  
                    if Char_J > Ptr'Last then  
                        Char_J := Ptr'Last;  
                    end if;

----Put out the 200 characters.  Watch for line-feed and '\' and quote them.

                    for I in Char_I .. Char_J loop  
                        if Ptr (I) = Ascii.Lf then  
                            Text_Io.Put (File, "\n");  
                        elsif Ptr (I) = '\' then  
                            Text_Io.Put (File, "\\");  
                        else  
                            Text_Io.Put (File, Ptr (I));  
                        end if;  
                    end loop;

----Now continue or terminate the line if we are done.

                    if Char_J < Ptr'Last then  
                        Text_Io.Put_Line (File, "\");  
                    else  
                        exit;  
                    end if;  
                    Char_I := Char_J + 1;  
                end loop;  
                Text_Io.New_Line (File);  
            end;  
            return;  
        end if;

----String values are the next easiest.  They just dump straight to the file.
--  This is also the only compatible-across-all-X-Library-implementations
--  type of entry.

        if Representation = X_Lib_X_Rm_R_String and then  
           Value.Kind = Is_X_String_Pointer and then  
           Printable (Value.V_X_String_Pointer) then

----We have a string value and it contains only printable characters.
--  Put it out in up-to 200 character increments with '\' continuation lines.

            declare  
                Ptr    : X_String_Pointer := Value.V_X_String_Pointer;  
                Char_I : S_Natural        := Ptr'First;  
                Char_J : S_Natural;  
            begin  
                Text_Io.Put (File, ':' & Ascii.Ht);

----Loop doing 200 character chunks at a time.

                loop  
                    Char_J := Char_I + 199;  
                    if Char_J > Ptr'Last then  
                        Char_J := Ptr'Last;  
                    end if;

----Put out the 200 characters.  Watch for line-feed and '\' and quote them.

                    for I in Char_I .. Char_J loop  
                        if Ptr (I) = Xlbt_String.Lf then  
                            Text_Io.Put (File, "\n");  
                        elsif Ptr (I) = Xlbt_String.'\' then  
                            Text_Io.Put (File, "\\");  
                        else  
                            Text_Io.Put (File, Character'Val  
                                                  (X_Character'Pos (Ptr (I))));  
                        end if;  
                    end loop;

----Now continue or terminate the line if we are done.

                    if Char_J < Ptr'Last then  
                        Text_Io.Put_Line (File, "\");  
                    else  
                        exit;  
                    end if;  
                    Char_I := Char_J + 1;  
                end loop;  
                Text_Io.New_Line (File);  
            end;  
            return;  
        end if;

----We have a non-string (or non-printable) entry.  Put it out in the extended
--      name!Representation: value
----Put the value out using the appropriate mechanism.  Based upon the Kind of
--  the physical data.

        case Value.Kind is

            when Is_None | Is_X_Rm_File_Type | Is_X_Universal_Pointer |  
                 Is_X_Atom | Is_X_Color | Is_X_Colormap | Is_X_Cursor |  
                 Is_X_Display | Is_X_Font | Is_X_Font_Struct | Is_X_Pixel |  
                 Is_X_Pixmap | Is_X_Screen | Is_X_Visual | Is_X_Window =>  
                Text_Io.Put_Line (File, ':' & Ascii.Ht);

            when Is_Boolean =>  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Text_Io.Put_Line (File, Boolean'Image (Value.V_Boolean));

            when Is_Float =>  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Float_Io.Put (File, Value.V_Float);  
                Text_Io.New_Line (File);

            when Is_U_Char =>  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Text_Io.Put_Line (File, U_Char'Image (Value.V_U_Char));

            when Is_U_Short =>  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Text_Io.Put_Line (File, U_Short'Image (Value.V_U_Short));

            when Is_S_Char =>  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Text_Io.Put_Line (File, S_Char'Image (Value.V_S_Char));

            when Is_S_Short =>  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Text_Io.Put_Line (File, S_Short'Image (Value.V_S_Short));

            when Is_S_Long =>  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Text_Io.Put_Line (File, S_Long'Image (Value.V_S_Long));

            when Is_X_Initial_Window_State =>  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Text_Io.Put_Line (File, X_Initial_Window_State'Image  
                                           (Value.V_X_Initial_Window_State));

            when Is_X_Time =>  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Text_Io.Put_Line (File, X_Time'Image (Value.V_X_Time));

            when Is_X_String7_Pointer =>  
                Text_Io.Put (File, '!');  
                Text_Io.Put (File, To_String (X_Rm_Representation_To_String  
                                                 (Representation)));  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                declare  
                    Uca : U_Char_Array (1 .. Value.V_X_String7_Pointer'Length);  
                begin  
                    To_Uca (Uca, Value.V_X_String7_Pointer.all);  
                    Dump_Bytes (File, Uca);  
                end;

            when Is_X_String_Pointer =>  
                Text_Io.Put (File, '!');  
                Text_Io.Put (File, To_String (X_Rm_Representation_To_String  
                                                 (Representation)));  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                declare  
                    Uca : U_Char_Array (1 .. Value.V_X_String_Pointer'Length);  
                begin  
                    To_Uca (Uca, Value.V_X_String_Pointer.all);  
                    Dump_Bytes (File, Uca);  
                end;

            when Is_X_String16_Pointer =>  
                Text_Io.Put (File, '!');  
                Text_Io.Put (File, To_String (X_Rm_Representation_To_String  
                                                 (Representation)));  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                declare  
                    Uca : U_Char_Array (1 .. Value.V_X_String16_Pointer'Length);  
                begin  
                    To_Uca (Uca, Value.V_X_String16_Pointer.all);  
                    Dump_Bytes (File, Uca);  
                end;

            when Is_U_Char_List =>  
                Text_Io.Put (File, '!');  
                Text_Io.Put (File, To_String (X_Rm_Representation_To_String  
                                                 (Representation)));  
                Text_Io.Put (File, ':' & Ascii.Ht);  
                Dump_Bytes (File, Value.V_U_Char_List.all);

        end case;

    end Dump_Entry;

--\f

    procedure Enum (Database :        X_Rm_Hash_Bucket;  
                    Bindings : in out X_Rm_Binding_Array;  
                    Names    : in out X_Rm_Name_Array;  
                    Count    :        S_Natural;  
                    File     :        Text_Io.File_Type) is
------------------------------------------------------------------------------
--  Bindings    - Specifies a temp area to use for binding info
--  Names       - Specifies a temp area to use for names
--  Count       - Specifies where our caller was in the temp areas
--  File        - Specifies the output file to use
--
-- Called to recursively traverse a database and to dump all entries in the
-- database into the Ascii output file.
------------------------------------------------------------------------------

        procedure Enum_Table (Binding : X_Rm_Binding) is
------------------------------------------------------------------------------
--  Binding - Specifies the type of binding to handle
--
-- Called by Enum to handle the Tight or Loose binding for the current
-- database entry.  This is the guy that actually recurses via Enum calls.
------------------------------------------------------------------------------
            Bucket : X_Rm_Hash_Bucket;  
            Table  : X_Rm_Hash_Table;  
        begin

----Loop over all table entries.  Then loop over the buckets in each entry.
--  Recurse on each one we find.

            Table := Database.Tables (Binding);  
            if Table /= null then  
                Bindings (Count)  := Binding;  
                Names (Count + 1) := None_X_Rm_Name;  
                for I in Table'Range loop  
                    Bucket := Table (I);  
                    while Bucket /= null loop  
                        Names (Count) := Bucket.Name;  
                        Enum (Bucket, Bindings, Names, Count + 1, File);  
                        Bucket := Bucket.Next;  
                    end loop;  
                end loop;  
            end if;

        end Enum_Table;

    begin

----Do nothing if this entry was null.

        if Database = null then  
            return;  
        end if;

----Handle longer bindings first; Tight and then Loose ones.

        Enum_Table (X_Rm_Bind_Tightly);  
        Enum_Table (X_Rm_Bind_Loosely);

----Now handle the current binding.  It has the shorter name of the three.

        Names (Count) := None_X_Rm_Name;  
        if Database.Value /= null then  
            Dump_Entry (Bindings, Names, Database.Value.Representation,  
                        Database.Value.Value, File);  
        end if;

    end Enum;

--\f

    procedure X_Rm_Put_File_Database (Filename :     String;  
                                      Database :     X_Rm_Database;  
                                      Status   : out X_Rm_Status) is
------------------------------------------------------------------------------
--  Filename  - Specifies the name of the file to write.
--  Database        - Specifies the database to write.
--  Status   - Receives Rm_Successful, Rm_Had_Errors, or Rm_Failed.
--
-- Opens the specified file and writes the contents of the database in a
-- form acceptable to X_Rm_Put_Line_Resource.
--
-- Note: Files created by this X Library implementation may or may not be
-- readable by other X Library implementations unless the resource values
-- consist only of strings.
--
-- Currently (Sep-1989) this implementation provides a superset of the
-- functionality of the existing C X Library implementation.  This means that
-- this routine can read resource files created by other implementations and
-- other implementations can read files created here as long as only string
-- values are involved.  Compatibility is a goal and as much compatibility as
-- possible will be maintained in the future.
------------------------------------------------------------------------------
        Bindings : X_Rm_Binding_Array (1 .. 100);  
        Quarks   : X_Rm_Name_Array (1 .. 100);  
        File     : Text_Io.File_Type;  
        Lstatus  : X_Rm_Status;  
    begin

        Lstatus := Rm_Successful;
        -- Obtain a writable file handle
        begin  
            Text_Io.Create (File, Text_Io.Out_File, Filename);  
        exception  
            when others =>  
                begin  
                    Text_Io.Open (File, Text_Io.Out_File, Filename);  
                exception  
                    when others =>  
                        Failed (Lstatus);  
                        Status := Lstatus;  
                        X_Report_Error ("XrmError", "FileCannotWrite",  
                                        "Xrm; Cannot open file for writing: %1",  
                                        To_X_String (Filename));  
                        return;  
                end;  
        end;

        -- Do the work.
        if Database /= None_X_Rm_Database then  
            Enum (Database.Contents, Bindings, Quarks, Bindings'First, File);  
        end if;

        -- Close the handle.
        Text_Io.Close (File);  
        Status := Lstatus;  
    exception  
        when others =>  
            begin  
                Text_Io.Close (File);  
            exception  
                when others =>  
                    null;  
            end;  
            Failed (Lstatus);  
            Status := Lstatus;  
            X_Report_Error ("XrmError", "FileWriteException",  
                            "Unexpected exception while writing file: %1",  
                            To_X_String (Filename));

    end X_Rm_Put_File_Database;

--\f

    procedure Merge (Neww   : in out X_Rm_Hash_Bucket;  
                     Old    :        X_Rm_Hash_Bucket;  
                     Status : out    X_Rm_Status) is

--  Neww    - Specifies the "new" data to be added to the "old" database
--  Old     - Specifies the "old" database to be updated
--
-- Called to merge Neww data into an Old database.  The Neww database is
-- irrevocably lost (it all goes into the Old database).

        New_Table         : X_Rm_Hash_Table;  
        Old_Table         : X_Rm_Hash_Table;  
        Old_Bucket        : X_Rm_Hash_Bucket;  
        New_Bucket        : X_Rm_Hash_Bucket;  
        Next_New_Bucket   : X_Rm_Hash_Bucket;  
        Old_Search_Bucket : X_Rm_Hash_Bucket;  
    begin

----Merge data in new into old, and destroy new in the process.

--/ if DEBUG then
        if not (Neww /= null and then Old /= null) then  
            raise X_Library_Confusion;  
        end if;
--/ end if;

----Merge neww value into old value.

        if Neww.Value /= null then  
            if Old.Value /= null then  
                Free_X_Rm_Entry (Old.Value);  
            end if;  
            Old.Value := Neww.Value;  
        end if;

----Merge new hash tables into old hash tables.

        for Binding in X_Rm_Binding loop  
            Neww.Has_Values (Binding) :=  
               Neww.Has_Values (Binding) or Old.Has_Values (Binding);  
            Old_Table                 := Old.Tables (Binding);  
            New_Table                 := Neww.Tables (Binding);  
            if Old_Table = null then  
                Old.Tables (Binding) := New_Table;  
            elsif New_Table /= null then

----Copy each bucket over individually.

                for I in New_Table'Range loop  
                    Old_Bucket := Old_Table (I);  
                    New_Bucket := New_Table (I);

----Find each item in newBucket list in the oldBucket list.

                    while New_Bucket /= null loop  
                        Next_New_Bucket   := New_Bucket.Next;  
                        Old_Search_Bucket := Old_Bucket;

----Locate the Name in the list.

                        while Old_Search_Bucket /= null and then  
                                 Old_Search_Bucket.Name /= New_Bucket.Name loop  
                            Old_Search_Bucket := Old_Search_Bucket.Next;  
                        end loop;

---Name not found; just stick newBucket at head of old bucket list

                        if Old_Search_Bucket = null then  
                            New_Bucket.Next := Old_Table (I);  
                            Old_Table (I)   := New_Bucket;

----Name found; merge two buckets with the same Name.

                        else  
                            Merge (New_Bucket, Old_Search_Bucket, Status);  
                        end if;  
                        New_Bucket := Next_New_Bucket;  
                    end loop;  
                end loop;

----Deallocate this table.

                Free_X_Rm_Hash_Table (New_Table);  
            end if;  
        end loop;

----Deallocate this bucket.

        Free_X_Rm_Hash_Bucket (Neww);

    end Merge;

--\f

    procedure X_Rm_Merge_Databases (Source      : in out X_Rm_Database;  
                                    Destination :        X_Rm_Database;  
                                    Status      : out    X_Rm_Status) is
------------------------------------------------------------------------------
--  Source  - Specifies the source database.
--  Destination      - Specifies the target database.
--
-- Merges the contents of one database into another.  The original Source
-- database is destroyed by this operation and the Destination database is modified
-- by it.  Values in the original Destination database that are replaced by new
-- values of the same name and/or class will cause the old values to be
-- updated.
--
-- Note: This update will cause the old values to be freed if they are
-- heap-based values and if the values were placed into the database with
-- Db_Owner => TRUE (always the case if X_Rm_Get_@ or X_Rm_Add_@ routines
-- were used to create the database).  So beware of dangling pointers.
-- For example, if Destination has a Foo value that is an X_Font_Struct pointer,
-- and if Source replaces Foo with a new X_Font_Struct pointer, then the
-- old X_Font_Struct will be freed.  If the application has previously
-- queried the database and has obtained the old value then continued usage
-- of the old value by the application will eventually cause some sort of
-- mysterious failure.
------------------------------------------------------------------------------
        Newww        : X_Rm_Hash_Bucket := Source.Contents;  
        Destinationo : X_Rm_Hash_Bucket := Destination.Contents;  
    begin

        Status          := Rm_Successful;  
        Source.Contents := null;  
        Free_X_Rm_Database (Source);  
        if Destinationo = null then  
            Destination.Contents := Newww;  
        elsif Newww /= null then  
            Merge (Newww, Destinationo, Status);  
        end if;

    end X_Rm_Merge_Databases;

--\f

    procedure Init_Defaults (Display : X_Display) is
------------------------------------------------------------------------------
--  Display - Specifies the display to initialize
--
-- Called when we want to initialize the default database of a display.
-- We do the equivalent of reading in the Unix ~/.Xdefaults file.
------------------------------------------------------------------------------
        Userdb         : X_Rm_Database     := None_X_Rm_Database;  
        Xdb            : X_Rm_Database     := None_X_Rm_Database;  
        Status         : X_Rm_Status;  
        Home           : constant X_String := X_Env_Get_Home_Dir;  
        Xdefaults_File : constant X_String :=  
           X_Env_Concat_Dir_File (Home, To_X_String (X_Option_File));  
        Xev            : X_String_Pointer;  
    begin

----First, get the defaults from the server; if there are none then load
--  defaults from the local machine's equivalent of ~/.Xdefaults.  Next,
--  if there is an XENVIRONMENT variable (or local equivalent) then load that
--  file.

        if Display.X_Defaults /= null then  
            begin  
                X_Rm_Get_String_Database (Display.X_Defaults.all, Xdb, Status);  
            exception  
                when others =>  
                    X_Report_Exception ("XrmError", "DisplayDefaults",  
                                        Xrm_Error_Display_Defaults,  
                                        Display.Display_Name.all);  
                    X_Rm_Get_File_Database  
                       (To_String (Xdefaults_File), Xdb, Status);  
            end;  
        else  
            X_Rm_Get_File_Database (To_String (Xdefaults_File), Xdb, Status);  
        end if;

----If there was an error with the .Xdefaults file then report that here.

        if Status /= Rm_Successful then  
            X_Report_Error ("XrmError", "ReadDb",  
                            Xrm_Error_Read_Db,  
                            Xdefaults_File);  
        end if;

----If there is an XENVIRONMENT environment variable then read that file.
--  If not then read the local equivalent to the ~/.Xdefaults-<host> file.

        Xev := X_Env_Get_Environment_Variable  
                  (To_X_String (X_Var_Xenvironment));  
        if Xev = None_X_String_Pointer or else  
           Xev'Length = 0 then

            X_Rm_Get_File_Database  
               (To_String (Home) & "." & X_Environment_File &  
                To_String (X_Env_Get_Host_Name),  
                Userdb,  
                Status);  
            if Status /= Rm_Successful then  
                X_Report_Error ("XrmError", "ReadDb",  
                                Xrm_Error_Read_Db,  
                                Home & "." & To_X_String (X_Environment_File) &  
                                   X_Env_Get_Host_Name);  
            end if;

        else

            X_Rm_Get_File_Database (To_String (Xev.all), Userdb, Status);  
            if Status /= Rm_Successful then  
                X_Report_Error ("XrmError", "ReadDb",  
                                Xrm_Error_Read_Db,  
                                Xev.all);  
            end if;

        end if;  
        Free_X_String_Pointer (Xev);

----Now merge the two databases together and use the result.  If there is
--  no result then simply create a new and totally empty database record.

        if Userdb /= None_X_Rm_Database then  
            X_Rm_Merge_Databases (Userdb, Xdb, Status);  
        end if;  
        if Xdb /= None_X_Rm_Database then  
            Display.Database := Univ_X_Rm_Database.To_X_Universal_Pointer (Xdb);  
        else  
            Display.Database := Univ_X_Rm_Database.To_X_Universal_Pointer  
                                   (new X_Rm_Database_Rec);  
        end if;

    end Init_Defaults;

--\f

    procedure X_Get_Default (Display        :     X_Display;  
                             Program        :     X_String;  
                             Option         :     X_String;  
                             Representation : out X_Rm_Representation;  
                             Value          : out X_Rm_Value) is
------------------------------------------------------------------------------
--  Display         - Specifies the display to use.
--  Program         - Specifies the program name for the X_Library defaults.
--                    The name must be passed in with the program arguments
--                    (usually as ArgV[ArgV'First]).
--  Option          - Specifies the option name.
--  Representation  - Receives the representation of the value;
--                    None_X_Rm_Representation if the option is not in the
--                    database
--  Value           - Receives the value of the option if Type /= None
--
-- Returns the representation and the value for the specified option.
------------------------------------------------------------------------------
        Db_Entry    : X_Rm_Entry;  
        Namelist    : X_Rm_Name_Array (1 .. 5);  
        Classlist   : X_Rm_Class_Array (1 .. 5);  
        Simple_Name : constant X_String := X_Env_Strip_Program_Name (Program);  
    begin

----See if database has ever been initialized.  Lookups can be done
--  without locks.

        Lock_Display (Display);  
        begin  
            if Display.Database = None_X_Universal_Pointer then  
                Init_Defaults (Display);  
            end if;  
        exception  
            when others =>  
                X_Report_Exception ("XrmError", "DisplayDefaults",  
                                    Xrm_Error_Display_Defaults,  
                                    Display.Display_Name.all);  
        end;  
        Unlock_Display (Display);

----See if there is a database to work with.

        if Display.Database = None_X_Universal_Pointer then  
            Representation := None_X_Rm_Representation;  
            Value          := None_X_Rm_Value;  
            return;  
        end if;

----Get the name/class lists to use for the lookup.

        X_Rm_String_To_Name_List (Simple_Name & '.' & Option, Namelist);  
        X_Rm_String_To_Class_List ("Program.Name", Classlist);

----Do the lookup and return any result.

        X_Rm_Get_Resource (Univ_X_Rm_Database.From_X_Universal_Pointer  
                              (Display.Database),  
                           Namelist, Classlist, Representation, Value);

    end X_Get_Default;

--\f

    procedure X_Rm_Parse_Command (Database : in out X_Rm_Database;  
                                  Options  :        X_Rm_Option_Desc_Array;  
                                  Prefix   :        X_String;  
                                  Arg_C    : in out S_Natural;  
                                  Arg_V    : in out X_String_Pointer_Array;  
                                  Status   : out    X_Rm_Status) is
------------------------------------------------------------------------------
--  Database        - Specifies the database to use for the parsing.
--  Table           - Specifies a table of command line argument data.
--  Prepend_Name    - Specifies the application name
--  Arg_C           - Specifies the number of argument strings.
--  Arg_V           - Specifies the argument strings and returns those not
--                    used.
--
-- Parse command line and store argument values into resource database.
-- Allows any unambiguous abbreviation for an option name, but requires
-- that the table be ordered with any options that are prefixes of
-- other options appearing before the longer option name.
------------------------------------------------------------------------------
        type Sort_State is (Dont_Care, Check, Not_Sorted, Sorted);

        Found_Option    : S_Natural;  
        Arg_Save        : S_Natural;  
        Arg_Vi          : S_Natural := Arg_V'First;  
        Myargc          : S_Natural;  
        I               : S_Natural;  
        Bindings        : X_Rm_Binding_Array (1 .. 100);  
        Names           : X_Rm_Name_Array (1 .. 100);  
        Start_Bindings  : S_Natural;  
        Start_Names     : S_Natural;  
        Arg_P           : S_Natural;  
        Matches         : S_Natural;  
        Table_Is_Sorted : Sort_State;  
        Arg_Str         : X_String_Pointer;  
        Opt_Str         : X_String_Pointer;  
        Lstatus         : X_Rm_Status;  
        Tstatus         : X_Rm_Status;

        procedure Put_Command_Resource (Value_Str : X_String) is  
        begin  
            X_Rm_String_To_Binding_Name_List  
               (Options (I).Specifier.all,  
                Bindings (Start_Bindings .. Bindings'Last),  
                Names (Start_Names .. Names'First));  
            X_Rm_Put_String_Resource (Database,  
                                      Bindings, Names, Value_Str);  
        end Put_Command_Resource;

    begin

        Lstatus  := Rm_Successful;  
        Myargc   := Arg_C;  
        Arg_Vi   := Arg_Vi + 1;  
        Arg_Save := Arg_Vi;

----Parse prefix into bindings and name list.

        X_Rm_String_To_Binding_Name_List (Prefix, Bindings, Names);  
        Start_Bindings := Bindings'First;  
        Start_Names    := Names'First;  
        while Names (Start_Names) /= None_X_Rm_Name loop  
            Start_Bindings := Start_Bindings + 1;  
            Start_Names    := Start_Names + 1;  
        end loop;

        if Myargc > 2 then  
            Table_Is_Sorted := Check;  
        else  
            Table_Is_Sorted := Dont_Care;  
        end if;  
        Myargc := Myargc - 1;  
        while Myargc > 0 loop  
            Found_Option := 0;  
            Matches      := 0;  
            I            := 0;  
            while I < Options'Length loop  
                Arg_Str := Arg_V (Arg_Vi);  
                Opt_Str := Options (Options'First + I).Option;  
                declare  
                    Arg_String : constant X_String := Arg_Str.all;  
                    Opt_String : constant X_String := Opt_Str.all;  
                begin
                    -- Checking the sort order first insures we don't have to
                    -- redo the check if the arg hits on the last entry in the
                    -- table.  Useful because usually '=' is the last entry and
                    -- users frequently specify geometry early in the command.
                    if Table_Is_Sorted = Check and then  
                       I > 0 and then  
                       Opt_String < Options (Options'First + I - 1).  
                                       Option.all then  
                        Table_Is_Sorted := Not_Sorted;  
                    end if;  
                    if Arg_String = Opt_String then
                        -- Exact match found
                        Matches      := 1;  
                        Found_Option := I;  
                        exit;  
                    elsif Arg_String'Length > Opt_String'Length then
                        -- give preference to stick_arg and is_arg
                        if Arg_String (Arg_String'First ..  
                                          Arg_String'First - 1 +  
                                             Opt_String'Length) =  
                           Opt_String then  
                            if Options (I).Arg_Kind =  
                               X_Rm_Option_Sticky_Arg or else  
                               Options (I).Arg_Kind = X_Rm_Option_Is_Arg then  
                                Arg_P := Arg_String'First + Opt_String'Length;  
                                Matches := 1;  
                                Found_Option := I;  
                                exit;  
                            end if;  
                        end if;  
                    elsif Arg_String = Opt_String (Opt_String'First ..  
                                                      Opt_String'First - 1 +  
                                                         Arg_String'Length) then
                        -- may be an abbreviation for this option
                        Matches      := Matches + 1;  
                        Found_Option := I;  
                    elsif Table_Is_Sorted = Sorted and then  
                          Opt_String > Arg_String then  
                        exit;  
                    end if;  
                end;  
                I := I + 1;  
            end loop;

            if Table_Is_Sorted = Check and then  
               I >= Options'Length - 1 then  
                Table_Is_Sorted := Sorted;  
            end if;

            if Matches = 1 then  
                I := Found_Option;  
                case Options (I).Arg_Kind is  
                    when X_Rm_Option_No_Arg =>  
                        Arg_C := Arg_C - 1;  
                        Put_Command_Resource (Options (I).Value.all);

                    when X_Rm_Option_Is_Arg =>  
                        Arg_C := Arg_C - 1;  
                        Put_Command_Resource (Arg_V (Arg_Vi).all);

                    when X_Rm_Option_Sticky_Arg =>  
                        Arg_C := Arg_C - 1;  
                        declare  
                            Av : constant X_String := Arg_V (Arg_Vi).all;  
                        begin  
                            Put_Command_Resource (Av (Arg_P .. Av'Last));  
                        end;

                    when X_Rm_Option_Sep_Arg =>  
                        if Myargc >= 2 then  
                            Arg_C  := Arg_C - 2;  
                            Arg_Vi := Arg_Vi + 1;  
                            Myargc := Myargc - 1;  
                            Put_Command_Resource (Arg_V (Arg_Vi).all);  
                        else  
                            Arg_V (Arg_Save) := Arg_V (Arg_Vi);  
                            Arg_Save         := Arg_Save + 1;  
                        end if;

                    when X_Rm_Option_Res_Arg =>  
                        if Myargc >= 2 then  
                            Arg_Vi := Arg_Vi + 1;  
                            Myargc := Myargc - 1;  
                            Arg_C  := Arg_C - 2;  
                            X_Rm_Put_Line_Resource  
                               (Database, Arg_V (Arg_Vi).all, Tstatus);  
                            if Tstatus > Lstatus then  
                                Lstatus := Tstatus;  
                            end if;  
                            if Tstatus /= Rm_Successful then  
                                Had_Errors (Lstatus);  
                                X_Report_Error ("XrmError", "CmdBadLine",  
                                                Xrm_Error_Cmd_Bad_Line,  
                                                Options (I).Option.all,  
                                                Options (I).Specifier.all,  
                                                Arg_V (Arg_Vi).all);  
                            end if;  
                        else  
                            Arg_V (Arg_Save) := Arg_V (Arg_Vi);  
                            Arg_Save         := Arg_Save + 1;  
                        end if;

                    when X_Rm_Option_Skip_Arg =>  
                        if Myargc > 1 then  
                            Myargc           := Myargc - 1;  
                            Arg_V (Arg_Save) := Arg_V (Arg_Vi);  
                            Arg_Save         := Arg_Save - 1;  
                            Arg_Vi           := Arg_Vi + 1;  
                        end if;  
                        Arg_V (Arg_Save) := Arg_V (Arg_Vi);  
                        Arg_Save         := Arg_Save + 1;

                    when X_Rm_Option_Skip_Line =>  
                        while Myargc > 0 loop  
                            Arg_V (Arg_Save) := Arg_V (Arg_Vi);  
                            Arg_Save         := Arg_Save + 1;  
                            Arg_Vi           := Arg_Vi + 1;  
                            Myargc           := Myargc - 1;  
                        end loop;

                    when X_Rm_Option_Skip_N_Args =>  
                        declare  
                            J : S_Natural;  
                        begin  
                            J := 1 + S_Long'Value (To_String  
                                                      (Options (I).Value.all));  
                            if J > Myargc then  
                                J := Myargc;  
                            end if;  
                            Arg_V (Arg_Save) := Arg_V (Arg_Vi);  
                            Arg_Save         := Arg_Save + 1;  
                            while J > 1 loop  
                                J                := J - 1;  
                                Arg_V (Arg_Save) := Arg_V (Arg_Vi);  
                                Arg_Save         := Arg_Save + 1;  
                                Arg_Vi           := Arg_Vi + 1;  
                                Myargc           := Myargc - 1;  
                            end loop;  
                        exception  
                            when Constraint_Error =>  
                                Had_Errors (Lstatus);  
                                X_Report_Error ("XrmError", "CmdBadDefault",  
                                                Xrm_Error_Cmd_Bad_Default,  
                                                Options (I).Option.all,  
                                                Options (I).Specifier.all);  
                        end;

                    when others =>  
                        Failed (Lstatus);  
                        X_Report_Error ("XrmError", "CmdBadKind",  
                                        Xrm_Error_Cmd_Bad_Kind,  
                                        Options (I).Option.all,  
                                        Options (I).Specifier.all);  
                end case;  
            else  
                Arg_V (Arg_Save) := Arg_V (Arg_Vi);  --compress arg_list
                Arg_Save         := Arg_Save + 1;  
            end if;

            Myargc := Myargc - 1;  
            Arg_Vi := Arg_Vi + 1;  
        end loop;

        if Arg_Save <= Arg_V'Last then  
            Arg_V (Arg_Save) := None_X_String_Pointer;
            -- put NULL terminator on compressed arg_v
        end if;  
        Status := Lstatus;

    end X_Rm_Parse_Command;

--\f

    procedure Free_X_Rm_Hash_Bucket (Hb : in out X_Rm_Hash_Bucket) is  
    begin

        if Hb.Value /= null then  
            Free_X_Rm_Entry (Hb.Value);  
        end if;  
        for I in Hb.Tables'Range loop  
            if Hb.Tables (I) /= null then  
                for J in Hb.Tables (I)'Range loop  
                    if Hb.Tables (I) (J) /= null then  
                        Free_X_Rm_Hash_Bucket (Hb.Tables (I) (J));  
                    end if;  
                end loop;  
                Heap_Free_X_Rm_Hash_Table (Hb.Tables (I));  
            end if;  
        end loop;  
        if Hb.Next /= null then  
            Free_X_Rm_Hash_Bucket (Hb.Next);  
        end if;  
        Heap_Free_X_Rm_Hash_Bucket (Hb);

    end Free_X_Rm_Hash_Bucket;

--\f

    procedure Free_X_Rm_Database (Database : in out X_Rm_Database) is  
    begin

        if Database /= null then  
            if Database.Contents /= null then  
                Free_X_Rm_Hash_Bucket (Database.Contents);  
            end if;  
            Heap_Free_X_Rm_Database (Database);  
        end if;

    end Free_X_Rm_Database;

--\f

end Xlbp_Rm;