|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 14920 (0x3a48)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
--/ if R1000 then
with Debug_Tools;
with Log;
with Profile;
--/ else
--// with Calendar;
--// with Text_Io;
--/ end if;
--/ if TeleGen2 then
--// with Integer_Text_Io;
--/ end if;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Rm;
use Xlbt_Rm;
with Xlbt_String;
use Xlbt_String;
with Xlbp_Error;
use Xlbp_Error;
with Xlbp_Rm;
use Xlbp_Rm;
with Xlbp_Rm_Name;
use Xlbp_Rm_Name;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbit_Library3;
use Xlbit_Library3;
with Xlbmt_Error_Log;
use Xlbmt_Error_Log;
with Xlbmt_Network_Types;
use Xlbmt_Network_Types;
with Xlbmt_Parameters;
use Xlbmt_Parameters;
package body Xlbmp_Error_Log is
------------------------------------------------------------------------------
-- X Library Error Log
--
-- Xlbp_Error_Log - Used internally by the X Library to "log" error messages.
-- Each target machine/operating-system will have it's own conventions
-- so these are isolated to this package.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the name of Rational not be used in
-- advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- Rational disclaims all warranties with regard to this software, including
-- all implied warranties of merchantability and fitness, in no event shall
-- Rational be liable for any special, indirect or consequential damages or
-- any damages whatsoever resulting from loss of use, data or profits, whether
-- in an action of contract, negligence or other tortious action, arising out
-- of or in connection with the use or performance of this software.
------------------------------------------------------------------------------
--\f
--/ if R1000 then
function X_Exception_Name return X_String is
begin
return To_X_String (Debug_Tools.Get_Exception_Name (True, True));
end X_Exception_Name;
--/ else
--//
--// function X_Exception_Name return X_String is
--// begin
--// return "";
--// end X_Exception_Name;
--//
--/ end if;
--\f
--/ if R1000 then
procedure Shoot (Kind : X_Report_Message_Kind;
Msg : X_String) is
------------------------------------------------------------------------------
-- Kind - Specifies the kind of message to put out
-- Msg - Specifies the message to put out
--
-- Put out a line of the form "*** <date> <msg>".
------------------------------------------------------------------------------
K : Profile.Msg_Kind;
begin
case Kind is
when Report_Information =>
K := Profile.Note_Msg;
when Report_Warning =>
K := Profile.Warning_Msg;
when Report_Error =>
K := Profile.Error_Msg;
when Report_Exception =>
K := Profile.Exception_Msg;
when Report_Fatal =>
K := Profile.Error_Msg;
end case;
Log.Put_Line (To_String (Msg), K, Profile.Get);
end Shoot;
--/ else
--//
--// procedure Shoot (Kind : X_Report_Message_Kind;
--// Msg : X_String) is
--// ------------------------------------------------------------------------------
--// -- Kind - Specifies the kind of message to put out
--// -- Msg - Specifies the message to put out
--// --
--// -- Put out a line of the form "<prefix> <date> <msg>".
--// ------------------------------------------------------------------------------
--// use Calendar;
--//
--// Dur : Day_Duration := Seconds (Clock);
--// Hrs : S_Natural := S_Natural (Dur / Duration (3600.0));
--// Dur_Hrs : Day_Duration :=
--// Day_Duration (Day_Duration (Hrs) * Day_Duration (3600.0));
--// Mins : S_Natural := S_Natural ((Dur - Dur_Hrs) / Day_Duration (60.0));
--// Dur_Mins : Day_Duration :=
--// Day_Duration (Day_Duration (Mins) * Day_Duration (60.0));
--// Secs : S_Natural := S_Natural (Dur - Dur_Hrs - Dur_Mins);
--// begin
--//
--// case Kind is
--// when Report_Information =>
--// Text_Io.Put (Text_Io.Standard_Output, "---");
--// when Report_Warning =>
--// Text_Io.Put (Text_Io.Standard_Output, "!!!");
--// when Report_Error =>
--// Text_Io.Put (Text_Io.Standard_Output, "***");
--// when Report_Exception =>
--// Text_Io.Put (Text_Io.Standard_Output, "%%%");
--// when Report_Fatal =>
--// Text_Io.Put (Text_Io.Standard_Output, "***");
--// end case;
--// Text_Io.Put (Text_Io.Standard_Output, ' ');
--// if Hrs < 10 then
--// Text_Io.Put (Text_Io.Standard_Output, '0');
--// end if;
--// S_Long_Io.Put (Text_Io.Standard_Output, Hrs, Width => 0);
--// Text_Io.Put (Text_Io.Standard_Output, ':');
--// if Mins < 10 then
--// Text_Io.Put (Text_Io.Standard_Output, '0');
--// end if;
--// S_Long_Io.Put (Text_Io.Standard_Output, Mins, Width => 0);
--// Text_Io.Put (Text_Io.Standard_Output, ':');
--// if Secs < 10 then
--// Text_Io.Put (Text_Io.Standard_Output, '0');
--// end if;
--// S_Long_Io.Put (Text_Io.Standard_Output, Secs, Width => 0);
--// Text_Io.Put (Text_Io.Standard_Output, ' ');
--// Text_Io.Put_Line (Text_Io.Standard_Output, To_String (Msg));
--//
--// end Shoot;
--//
--/ end if; -- not R1000
--\f
-- generic
-- with procedure Put_Line (Kind : X_Report_Message_Kind;
-- Msg : X_String);
procedure X_Format_Error_String (Error : X_String;
Arg1 : X_String;
Arg2 : X_String;
Arg3 : X_String;
Arg4 : X_String;
Arg5 : X_String;
Arg6 : X_String;
Kind : X_Report_Message_Kind) is
------------------------------------------------------------------------------
-- The message is scanned for two things. Any Lf character found is taken as
-- a "start a new line here" command. Thus a message can span multiple lines
-- in the error output. A single preceding Lf character on a message is
-- ignored. The other trigger is the '%' character. "%%" will produce a
-- single '%' in the output. "%n" where n is 1..6 will introduce the contents
-- of Argn in that place. "%.n" will simply use up argument n without
-- producing any output; this can be useful when you want to "use" an argument
-- without actually doing so.
------------------------------------------------------------------------------
Buffer : X_String (1 .. 128);
Bufferi : S_Natural;
I : S_Natural;
Flag1 : Boolean := Arg1 /= "";
Flag2 : Boolean := Arg2 /= "";
Flag3 : Boolean := Arg3 /= "";
Flag4 : Boolean := Arg4 /= "";
Flag5 : Boolean := Arg5 /= "";
Flag6 : Boolean := Arg6 /= "";
procedure Append (C : X_Character) is
begin
if Bufferi >= Buffer'Last then
Put_Line (Kind, Buffer);
Bufferi := 0;
end if;
Bufferi := Bufferi + 1;
Buffer (Bufferi) := C;
end Append;
procedure Append (S : X_String) is
begin
if Bufferi + S'Length > Buffer'Last then
for I in S'Range loop
Append (S (I));
end loop;
return;
end if;
Buffer (Bufferi + 1 .. Bufferi + S'Length) := S;
Bufferi := Bufferi + S'Length;
end Append;
begin
----Process the error message as usual.
Bufferi := 0;
I := Error'First;
loop
----If we have reached an Lf or end-of-string (logical-Lf) then put out the
-- contents of the buffer. Exit the loop on end-of-string.
if I > Error'Last or else
Error (I) = Lf then
if Bufferi > 0 then
Put_Line (Kind, Buffer (1 .. Bufferi));
Bufferi := 0;
end if;
if I > Error'Last then
exit;
end if;
----See if we have a '%'.
elsif Error (I) = '%' and then I < Error'Last then
----%% is the same as %.
if Error (I + 1) = '%' then
Append ('%');
----If we have found a %.1 then mark that argument as used.
elsif Error (I + 1) = '.' and then
I + 1 < Error'Last and then
Error (I + 2) in '1' .. '6' then
case Natural'(X_Character'Pos (Error (I + 2)) -
X_Character'Pos ('0')) is
when 1 =>
Flag1 := False;
when 2 =>
Flag2 := False;
when 3 =>
Flag3 := False;
when 4 =>
Flag4 := False;
when 5 =>
Flag5 := False;
when 6 =>
Flag6 := False;
when others =>
raise Program_Error;
end case;
I := I + 2;
----If we have found a %1 then put that argument into the buffer.
elsif Error (I + 1) in '1' .. '6' then
case Natural'(X_Character'Pos (Error (I + 1)) -
X_Character'Pos ('0')) is
when 1 =>
Append (Arg1);
Flag1 := False;
when 2 =>
Append (Arg2);
Flag2 := False;
when 3 =>
Append (Arg3);
Flag3 := False;
when 4 =>
Append (Arg4);
Flag4 := False;
when 5 =>
Append (Arg5);
Flag5 := False;
when 6 =>
Append (Arg6);
Flag6 := False;
when others =>
raise Program_Error;
end case;
I := I + 1;
----% and anything else is an error.
else
Append ('?');
Append (Error (I));
Append (Error (I + 1));
Append ('?');
I := I + 1;
end if;
----All other characters go into the buffer.
else
Append (Error (I));
end if;
I := I + 1;
end loop;
----If we have any non-"" arguments left unused then put them onto a separate
-- *** error line.
Bufferi := 0;
if Flag1 then
Append (" {1:" & Arg1 & '}');
end if;
if Flag2 then
Append (" {2:" & Arg2 & '}');
end if;
if Flag3 then
Append (" {3:" & Arg3 & '}');
end if;
if Flag4 then
Append (" {4:" & Arg4 & '}');
end if;
if Flag5 then
Append (" {5:" & Arg5 & '}');
end if;
if Flag6 then
Append (" {6:" & Arg6 & '}');
end if;
if Bufferi > 0 then
Put_Line (Kind, Buffer (1 .. Bufferi));
end if;
end X_Format_Error_String;
--\f
procedure Default_X_Report_Error_Worker is
new X_Format_Error_String (Shoot);
procedure Default_X_Report_Error (Name1 : X_String;
Name2 : X_String;
Default : X_String;
Arg1 : X_String;
Arg2 : X_String;
Arg3 : X_String;
Arg4 : X_String;
Arg5 : X_String;
Arg6 : X_String;
Kind : X_Report_Message_Kind) is
------------------------------------------------------------------------------
-- Extract the correct error message string from the database (using the
-- X_Get_Error_String subprogram), format it with X_Format_Error_String,
-- and print it using Shoot.
------------------------------------------------------------------------------
begin
Default_X_Report_Error_Worker
(X_Get_Error_String (Name1, Name2, Default),
Arg1, Arg2, Arg3, Arg4, Arg5, Arg6, Kind);
end Default_X_Report_Error;
--\f
procedure X_Report (Name1 : X_String;
Name2 : X_String;
Default : X_String;
Arg1 : X_String;
Arg2 : X_String;
Arg3 : X_String;
Arg4 : X_String;
Arg5 : X_String;
Arg6 : X_String;
Kind : X_Report_Message_Kind) is
------------------------------------------------------------------------------
-- Invoke the current X_Lib.Report_Error procedure.
------------------------------------------------------------------------------
use Proc_Var_X_Report_Error;
Proc : X_Procedure_Variable;
begin
X_Lib.Get_Report_Error (Proc);
Call (To_Pv (Proc), Name1, Name2, Default, Arg1,
Arg2, Arg3, Arg4, Arg5, Arg6, Kind);
end X_Report;
--\f
end Xlbmp_Error_Log;