|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 30720 (0x7800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Xlbp_Error, seg_004f59
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Display3;
use Xlbt_Display3;
with Xlbt_Error;
use Xlbt_Error;
with Xlbt_Extension;
use Xlbt_Extension;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Rm3;
use Xlbt_Rm3;
with Xlbt_String;
use Xlbt_String;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbp_Rm;
use Xlbp_Rm;
with Xlbp_Rm_Name;
use Xlbp_Rm_Name;
with Xlbit_Library2;
use Xlbit_Library2;
with Xlbit_Library3;
use Xlbit_Library3;
with Xlbit_Library4;
use Xlbit_Library4;
with Xlbmt_Network_Types;
use Xlbmt_Network_Types;
with Xlbmt_Parameters;
use Xlbmt_Parameters;
with Xlbmp_Error_Log;
use Xlbmp_Error_Log;
package body Xlbp_Error is
------------------------------------------------------------------------------
-- X Library Error Control
--
-- Xlbp_Error - Provides control over error responses within the X Library.
------------------------------------------------------------------------------
-- 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.
------------------------------------------------------------------------------
-- ****************************************************************************
-- * Date - /Name/ Comment
-- *
-- * 7-NOV-90 - /GEB/ Implement the new multitasking protection scheme for
-- * - library state.
-- ****************************************************************************
--\x0c
procedure Initialize_Error_Message_Db is
begin
----If the database already exists then we're getting more than one call to
-- ourselves. More than one task may have looked, all at the same time,
-- to see if the database existed.
Lock_Mutex (Mutex); -- Lock out all other initializers.
if X_Lib_Error_Message_Db /= None_X_Rm_Database then
Unlock_Mutex (Mutex); -- Someone else got there first.
return; -- Return and use his database.
end if;
----No database, read it from the file. If we don't get a database back then
-- that's because of an error. Fake an empty database so we won't try again
-- and again recursively.
declare
Status : X_Rm_Status;
Fake : X_Rm_Database;
Real : X_Rm_Database;
begin
----Create an empty database so that X_Rm_Get_File_Database has a way to
-- report errors that doesn't recurse infinitely with us.
begin
Fake := new X_Rm_Database_Rec;
exception
when others =>
Unlock_Mutex (Mutex);
raise;
end;
X_Lib_Error_Message_Db := Fake; -- Prevent infinite recursion.
X_Rm_Get_File_Database (X_Error_Database, Real, Status);
if Real /= None_X_Rm_Database then
X_Lib_Error_Message_Db := Real;
Free_X_Rm_Database (Fake);
end if;
if Status /= Rm_Successful then
Unlock_Mutex (Mutex);
X_Report_Error ("XlibError",
"ReadErrorDb",
"Error reading error database file: %1",
To_X_String (X_Error_Database));
return;
end if;
----If we get any exceptions then we must perform damage control. If we have
-- no present database then fake an empty one before we report the error.
exception
when others =>
if Real /= None_X_Rm_Database then
X_Lib_Error_Message_Db := Real;
Free_X_Rm_Database (Fake);
end if;
Unlock_Mutex (Mutex);
raise;
end;
end Initialize_Error_Message_Db;
--\x0c
function X_Error_List (Error_Code : X_Error_Code) return X_String is
begin
case Error_Code is
when Success =>
-- No error
return X_Get_Error_String
("XProtoError", "0", "Not An Error (0)");
when Bad_Request =>
-- Bad_Request
return X_Get_Error_String
("XProtoError", "1",
"Bad_Request (1, invalid request code or " &
"no such operation)");
when Bad_Value =>
-- Bad_Value
return X_Get_Error_String
("XProtoError", "2", "Bad_Value (2, integer parameter out " &
"of range for operation)");
when Bad_Window =>
-- Bad_Window
return X_Get_Error_String
("XProtoError", "3",
"Bad_Window (3, invalid Window parameter)");
when Bad_Pixmap =>
-- Bad_Pixmap
return X_Get_Error_String
("XProtoError", "4",
"Bad_Pixmap (4, invalid Pixmap parameter)");
when Bad_Atom =>
-- Bad_Atom
return X_Get_Error_String
("XProtoError", "5",
"Bad_Atom (5, invalid Atom parameter)");
when Bad_Cursor =>
-- Bad_Cursor
return X_Get_Error_String
("XProtoError", "6",
"Bad_Cursor (6, invalid Cursor parameter)");
when Bad_Font =>
-- Bad_Font
return X_Get_Error_String
("XProtoError", "7",
"Bad_Font (7, invalid Font parameter)");
when Bad_Match =>
-- Bad_Match
return X_Get_Error_String
("XProtoError", "8",
"Bad_Match (8, invalid parameter attributes)");
when Bad_Drawable =>
-- Bad_Drawable
return
X_Get_Error_String
("XProtoError", "9",
"Bad_Drawable (9, invalid Pixmap or Window parameter)");
when Bad_Access =>
-- Bad_Access
return X_Get_Error_String
("XProtoError", "10",
"Bad_Access (10, attempt to access " &
"private resource denied)");
when Bad_Alloc =>
-- Bad_Alloc
return
X_Get_Error_String
("XProtoError", "11",
"Bad_Alloc (11, insufficient resources for operation)");
when Bad_Color =>
-- Bad_Color
return X_Get_Error_String
("XProtoError", "12",
"Bad_Color (12, invalid Colormap parameter)");
when Bad_Gc =>
-- Bad_GC
return X_Get_Error_String ("XProtoError", "13",
"Bad_Gc (13, invalid GC parameter)");
when Bad_Id_Choice =>
-- Bad_ID_Choice
return X_Get_Error_String
("XProtoError", "14",
"Bad_Id_Choice (14, invalid resource ID " &
"chosen for this connection)");
when Bad_Name =>
-- Bad_Name
return X_Get_Error_String
("XProtoError", "15",
"Bad_Name (15, named color or Font does not exist)");
when Bad_Length =>
-- Bad_Length
return X_Get_Error_String
("XProtoError", "16",
"Bad_Length (16, poly request too large or" &
" internal Xlib length error)");
when Bad_Implementation =>
-- Bad_Implementation
return X_Get_Error_String
("XProtoError", "17",
"Bad_Implementation " &
"(17, server does not implement operation)");
when others =>
return "**Unknown Error Code" &
To_X_String
(Natural'Image (X_Error_Code'Pos (Error_Code))) &
"** ";
end case;
end X_Error_List;
--\x0c
function X_Get_Error_Database_Text (Display : X_Display;
Name : X_String;
Message : X_String;
Default : X_String) return X_String is
Rep : X_Rm_Representation;
Result : X_Rm_Value;
Db : X_Rm_Database;
begin
if X_Lib_Error_Message_Db = None_X_Rm_Database then
Initialize_Error_Message_Db;
end if;
X_Rm_Get_Resource (Db, Name & '.' & Message,
"ErrorType.ErrorNumber", Rep, Result);
if Result /= None_X_Rm_Value then
declare
Str : constant X_String := Result.V_X_String_Pointer.all;
begin
return Str;
exception
when Constraint_Error =>
null;
end;
end if;
return Default;
end X_Get_Error_Database_Text;
--\x0c
function X_Get_Error_Text (Display : X_Display;
Kind : X_Error_Code) return X_String is
Ext : X_Extension;
Buff1 : constant X_String := To_X_String (X_Error_Code'Image (Kind));
begin
declare
Buff2 : constant X_String :=
Buff1 & " : " &
X_Get_Error_Database_Text
(Display, "XProtoError", Buff1, X_Error_List (Kind));
Buff3 : X_String (1 .. 2000);
Buffi : S_Natural := 0;
begin
Ext := Display.Ext_Procs;
while Ext /= null loop-- call out to any extensions
if Ext.Error_String /= None_X_Procedure_Variable then
declare
Buff4 : constant X_String :=
Proc_Var_X_Error_String_Extension.Call
(Proc_Var_X_Error_String_Extension.To_Pv
(Ext.Error_String), Display, Kind, Ext.Codes);
Buff4_Length : S_Natural := Buff4'Length;
begin
if Buff4_Length + 2 > Buff3'Last - Buffi then
Buff4_Length := Buff3'Last - Buffi - 2;
end if;
Buff3 (Buffi + 1) := '[';
Buff3 (Buffi + 1 + 1 .. Buffi + 1 + Buff4_Length) :=
Buff4;
Buff3 (Buffi + 1 + Buff4_Length + 1) := ']';
Buffi := Buffi + 2 + Buff4_Length;
end;
end if;
Ext := Ext.Next;
end loop;
if Buffi = 0 then
return Buff2;
else
return Buff2 & Buff3 (1 .. Buffi);
end if;
end;
end X_Get_Error_Text;
--\x0c
function X_Get_Error_String (Name1 : X_String;
Name2 : X_String;
Default : X_String) return X_String is
------------------------------------------------------------------------------
-- Name1 - Specifies the first part of the error name
-- Name2 - Specifies the second part of the error name
-- Default - Specifies a default error message string
--
-- Called to obtain Name1.Name2 or else Name1.Name2.1 & Name1.Name2.2 & ...
-- from the error message database. If we can't find either type of entry
-- then we return the Default value.
------------------------------------------------------------------------------
Error : X_Error_String;
Names : X_Rm_Name_Array (1 .. 4);
Classes : X_Rm_Class_Array (1 .. 4);
Rep : X_Rm_Representation;
Value : X_Rm_Value;
Db : X_Rm_Database;
function Further_Error_Lines (Level : S_Natural) return X_String is
----------------------------------------------------------------
-- Called to obtain Name1.Name2.2, Name1.Name2.3, etc. from
-- the error message database. Our caller has already obtained
-- Name1.Name2.1 from there. We return either "" or else
-- Lf & Name1.Name2.Level.
----------------------------------------------------------------
Level_String : constant X_String :=
To_X_String (S_Natural'Image (Level));
Rep : X_Rm_Representation;
Value : X_Rm_Value;
begin
Names (3) := X_Rm_String_To_Name (Level_String (Level_String'First + 1 ..
Level_String'Last));
X_Rm_Get_Resource (Db, Names, Classes, Rep, Value);
if Value = None_X_Rm_Value then
return "";
else
return Lf & Value.V_X_String_Pointer.all &
Further_Error_Lines (Level + 1);
end if;
end Further_Error_Lines;
begin
----Convert our arguments into the proper Quark values so we can query the
-- database.
Names (1) := X_Rm_String_To_Name (Name1);
Names (2) := X_Rm_String_To_Name (Name2);
Names (3) := None_X_Rm_Name;
Names (4) := None_X_Rm_Name;
Classes (1) := X_Rm_String_To_Class ("ErrorType");
Classes (2) := X_Rm_String_To_Class ("ErrorNumber");
Classes (3) := None_X_Rm_Class;
Classes (4) := None_X_Rm_Class;
----Lock the X_Lib database.
if X_Lib_Error_Message_Db = None_X_Rm_Database then
Initialize_Error_Message_Db;
end if;
----See if the database has an error message with these simple names.
X_Rm_Get_Resource (Db, Names, Classes, Rep, Value);
----If the entry is there then return the string value.
if Value /= None_X_Rm_Value then
declare
Str : constant X_String := Value.V_X_String_Pointer.all;
begin
return Str;
end;
----If the entry is not there then see if Name.Message.1 is there.
else
Names (3) := X_Rm_String_To_Name ("1");
X_Rm_Get_Resource (Db, Names, Classes, Rep, Value);
----If Name.Message.1 is not there then return the Default.
if Value = None_X_Rm_Value then
return Default;
end if;
----If Name.Message.1 is there then see if Name.Message.2 is there also.
declare
Str : constant X_String := Value.V_X_String_Pointer.all &
Further_Error_Lines (2);
begin
return Str;
end;
end if;
end X_Get_Error_String;
--\x0c
function X_Set_Error_Handler (Handler : Proc_Var_X_Error_Function.Pv)
return Proc_Var_X_Error_Function.Pv is
------------------------------------------------------------------------------
-- X_Error_Handler - This function sets the X non-fatal error handler
-- (X_Error_Function_Pv) to be the specified routine. If NULL is passed in
-- the original error handler is restored. The old routine is returned.
------------------------------------------------------------------------------
use Proc_Var_X_Error_Function;
Old : X_Procedure_Variable;
begin
X_Lib.Set_Error (Display => None_X_Display,
Proc => Proc_Var_X_Error_Function.From_Pv (Handler),
Old_Proc => Old,
All_Displays => True);
return Proc_Var_X_Error_Function.To_Pv (Old);
end X_Set_Error_Handler;
--\x0c
function X_Set_Error_Handler (Display : X_Display;
Handler : Proc_Var_X_Error_Function.Pv)
return Proc_Var_X_Error_Function.Pv is
------------------------------------------------------------------------------
-- X_Error_Handler - This function sets the X non-fatal error handler
-- (X_Error_Function_Pv) to be the specified routine. If NULL is passed in
-- the original error handler is restored. The old routine is returned.
------------------------------------------------------------------------------
use Proc_Var_X_Error_Function;
Old : X_Procedure_Variable;
begin
X_Lib.Set_Error (Display => Display,
Proc => Proc_Var_X_Error_Function.From_Pv (Handler),
Old_Proc => Old,
All_Displays => False);
return Proc_Var_X_Error_Function.To_Pv (Old);
end X_Set_Error_Handler;
--\x0c
function X_Set_Io_Error_Handler (Handler : Proc_Var_X_Io_Error_Function.Pv)
return Proc_Var_X_Io_Error_Function.Pv is
------------------------------------------------------------------------------
-- X_Set_IO_Error_Handler - This function sets the X fatal I/O error handler
-- (X_IO_Error_Function_Pv) to be the specified routine. If NULL is passed in
-- the original error handler is restored. The previous routine is returned.
------------------------------------------------------------------------------
use Proc_Var_X_Io_Error_Function;
Old : X_Procedure_Variable;
begin
X_Lib.Set_Io_Error
(Display => None_X_Display,
Proc => Proc_Var_X_Io_Error_Function.From_Pv (Handler),
Old_Proc => Old,
All_Displays => True);
return Proc_Var_X_Io_Error_Function.To_Pv (Old);
end X_Set_Io_Error_Handler;
--\x0c
function X_Set_Io_Error_Handler (Display : X_Display;
Handler : Proc_Var_X_Io_Error_Function.Pv)
return Proc_Var_X_Io_Error_Function.Pv is
------------------------------------------------------------------------------
-- X_Set_IO_Error_Handler - This function sets the X fatal I/O error handler
-- (X_IO_Error_Function_Pv) to be the specified routine. If NULL is passed in
-- the original error handler is restored. The previous routine is returned.
------------------------------------------------------------------------------
use Proc_Var_X_Io_Error_Function;
Old : X_Procedure_Variable;
begin
X_Lib.Set_Io_Error
(Display => Display,
Proc => Proc_Var_X_Io_Error_Function.From_Pv (Handler),
Old_Proc => Old,
All_Displays => False);
return Proc_Var_X_Io_Error_Function.To_Pv (Old);
end X_Set_Io_Error_Handler;
--\x0c
function X_Set_Report_Handler (Handler : Proc_Var_X_Report_Error.Pv)
return Proc_Var_X_Report_Error.Pv is
------------------------------------------------------------------------------
-- X_Report_Error_Handler - This function sets the handler that prints all
-- error messages (X_Error_Report_Pv) to be the specified routine. If NULL is
-- passed in the original error handler is restored. The old routine is
-- returned.
------------------------------------------------------------------------------
use Proc_Var_X_Report_Error;
Old : X_Procedure_Variable;
begin
X_Lib.Set_Io_Error (Display => None_X_Display,
Proc => Proc_Var_X_Report_Error.From_Pv (Handler),
Old_Proc => Old,
All_Displays => True);
return Proc_Var_X_Report_Error.To_Pv (Old);
end X_Set_Report_Handler;
--\x0c
function X_Set_Report_Handler (Display : X_Display;
Handler : Proc_Var_X_Report_Error.Pv)
return Proc_Var_X_Report_Error.Pv is
------------------------------------------------------------------------------
-- X_Report_Error_Handler - This function sets the handler that prints all
-- error messages (X_Error_Report_Pv) to be the specified routine. If NULL is
-- passed in the original error handler is restored. The old routine is
-- returned.
------------------------------------------------------------------------------
use Proc_Var_X_Report_Error;
Old : X_Procedure_Variable;
begin
X_Lib.Set_Io_Error (Display => Display,
Proc => Proc_Var_X_Report_Error.From_Pv (Handler),
Old_Proc => Old,
All_Displays => False);
return Proc_Var_X_Report_Error.To_Pv (Old);
end X_Set_Report_Handler;
--\x0c
end Xlbp_Error;
nblk1=1d
nid=0
hdr6=3a
[0x00] rec0=2c rec1=00 rec2=01 rec3=046
[0x01] rec0=11 rec1=00 rec2=02 rec3=076
[0x02] rec0=14 rec1=00 rec2=03 rec3=028
[0x03] rec0=1a rec1=00 rec2=04 rec3=036
[0x04] rec0=00 rec1=00 rec2=1d rec3=002
[0x05] rec0=17 rec1=00 rec2=05 rec3=016
[0x06] rec0=1b rec1=00 rec2=06 rec3=002
[0x07] rec0=15 rec1=00 rec2=07 rec3=020
[0x08] rec0=15 rec1=00 rec2=08 rec3=070
[0x09] rec0=15 rec1=00 rec2=09 rec3=074
[0x0a] rec0=14 rec1=00 rec2=0a rec3=04c
[0x0b] rec0=1b rec1=00 rec2=0b rec3=06e
[0x0c] rec0=00 rec1=00 rec2=1c rec3=00e
[0x0d] rec0=1e rec1=00 rec2=0c rec3=020
[0x0e] rec0=00 rec1=00 rec2=1b rec3=014
[0x0f] rec0=11 rec1=00 rec2=0d rec3=01e
[0x10] rec0=01 rec1=00 rec2=1a rec3=004
[0x11] rec0=18 rec1=00 rec2=0e rec3=010
[0x12] rec0=15 rec1=00 rec2=0f rec3=002
[0x13] rec0=00 rec1=00 rec2=19 rec3=03e
[0x14] rec0=1b rec1=00 rec2=10 rec3=038
[0x15] rec0=1f rec1=00 rec2=11 rec3=090
[0x16] rec0=19 rec1=00 rec2=12 rec3=012
[0x17] rec0=15 rec1=00 rec2=13 rec3=004
[0x18] rec0=13 rec1=00 rec2=14 rec3=054
[0x19] rec0=13 rec1=00 rec2=15 rec3=02e
[0x1a] rec0=14 rec1=00 rec2=16 rec3=068
[0x1b] rec0=14 rec1=00 rec2=17 rec3=016
[0x1c] rec0=09 rec1=00 rec2=18 rec3=000
tail 0x217006b72819782104d87 0x42a00088462063203