|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 130180 (0x1fc84)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
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;