Trailing-Edge
-
PDP-10 Archives
-
BB-R775C-BM
-
sources/rmserr.b36
There are 28 other files named rmserr.b36 in the archive. Click here to see a list.
%TITLE 'RMSERR.B36 - Default RMS failure routine and error message printer'
MODULE rmserr (
IDENT = '2',
ENTRY(
rms$failure, ! RMS Error routine to print message
rms$signal, ! RMS Error routine to SIGNAL error
rms$efail, ! Print RMS error message
rms$errmsg ! return RMS error message string
)
) =
BEGIN
!
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1985.
! ALL RIGHTS RESERVED.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND
! COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
! THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR
! ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
! AVAILABLE TO ANY OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE
! SOFTWARE IS HEREBY TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
! NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
! EQUIPMENT CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF
! ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!++
! FACILITY:
! RMS-20.
!
! ABSTRACT:
! This module contains three global routines:
!
! RMS$FAILURE is a routine which is called by the ERCAL following the
! RMS JSYS generated by the BLISS/RMS calling sequence, to handle
! failures.
! RMS$EFAIL is a routine which can be called by the user in the event
! of a failure of an RMS call to type out the default error message.
! RMS$FAILURE calls RMS$EFAIL.
! RMS$ERRMSG is called by RMS$EFAIL or the user to convert
! an RMS error code into a "meaningful" text string.
!
! ENVIRONMENT:
! TOPS-20 user mode, RMS, XPORT.
!
! AUTHOR: Larry Campbell, CREATION DATE: January 27, 1982
!
! MODIFIED BY: Andrew Nourse
!
! 02 - Put in ENTRY points
! 01 - Write the module
!--
!
! INCLUDE FILES:
!
LIBRARY 'RMS';
%IF %SWITCHES (TOPS20)
%THEN
LIBRARY 'BLI:MONSYM';
%FI
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
rms$failure : RMS$ERCAL NOVALUE,
rms$signal : RMS$ERCAL NOVALUE,
rms$efail : NOVALUE,
rms$errmsg;
%IF %SWITCHES (TOPS20)
%THEN
FORWARD ROUTINE
rms$$tops20_error : NOVALUE;
%FI
!
! MACROS:
!
MACRO
rms$$canned_msg (text) =
BEGIN
$STR_COPY (STRING = text, TARGET = temp_descriptor);
(.length) = .temp_descriptor[STR$H_LENGTH]
END %,
lh = 18, 18, 0 %,
rh = 0, 18, 0 %;
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
!
! This macro contains an invocation of an iterative macro that defines
! the correspondence between RMS error codes and their associated text
! messages. The iterative macro will be defined twice later, once to
! count the number of entries and once to generate a PRESET list to initialize
! the error text table.
!
MACRO
$rms$define_error_text =
$rms$define_each_string (
RMS$_NORMAL, 'Operation was successful',
RMS$_OK_IDX, 'Unexpected error updating index',
RMS$_OK_REO, 'Bucket full, file should be reorganized',
RMS$_OK_RRV, 'Could not update internal record pointer, file should be reorganized',
RMS$_OK_DUP, '$PUT or $UPDATE with duplicate key',
RMS$_AID, 'Invalid AID field in area XAB',
RMS$_BKZ, 'Invalid BKZ field in area XAB',
RMS$_BLN, 'Invalid BLN field for specified BID',
RMS$_BSZ, 'Invalid BSZ (byte size)',
RMS$_BUG, 'Internal RMS error',
RMS$_CCF, 'Cannot $CLOSE file',
RMS$_CCR, 'Cannot $CONNECT RAB because another RAB already connected',
RMS$_CEF, 'Cannot $ERASE file',
RMS$_CGJ, 'Cannot get a JFN (GTJFN failed)',
RMS$_CHG, 'Illegal key value change',
RMS$_COD, 'Invalid COD field in XAB',
RMS$_COF, 'Cannot open file (OPENF failed)',
RMS$_CON, 'Cannot open network connection',
RMS$_CUR, 'No current record',
RMS$_DAN, 'Invalid DAN field in area XAB',
RMS$_DEL, 'Attempt to access a deleted record',
RMS$_DEV, 'Invalid device',
RMS$_DME, 'Dynamic memory exhausted (MBF might be too large)',
RMS$_DPE, 'DAP Protocol error',
RMS$_DTP, 'Invalid DTP field in key XAB, or BSZ in FAB not 6, 7, or 9',
RMS$_DUP, '$PUT or $UPDATE with duplicate key',
RMS$_EDQ, 'Unexpected ENQ/DEQ error',
RMS$_EOF, 'Attempt to read past end-of-file',
RMS$_FAB, 'Invalid BID field in FAB',
RMS$_FAC, 'Invalid file access option (FAC)',
RMS$_FEX, 'Attempt to $CREATE an existing file',
RMS$_FLG, 'XB$CHG was set for primary key',
RMS$_FLK, 'File is locked',
RMS$_FNC, 'Cannot $ERASE because another user has file open',
RMS$_FNF, 'File not found',
RMS$_FSI, 'Invalid syntax in file specification',
RMS$_FUL, 'File is full',
RMS$_IAL, 'Illegal argument',
RMS$_IAN, 'Invalid IAN field of KEY XAB',
RMS$_IFI, 'IFI field of FAB does not identify an internal file block',
RMS$_IMX, 'Conflicting SUMMARY or DATE XABs',
RMS$_ISI, 'ISI field of RAB does not identify an internal record block',
RMS$_JFN, 'Invalid JFN supplied',
RMS$_KBF, 'RAC = RB$KEY, but KBF not set',
RMS$_KEY, 'Invalid key for relative file',
RMS$_KRF, 'Incorrect key of reference for indexed file',
RMS$_KSZ, 'Invalid KSZ (key size)',
RMS$_LSN, 'Line Sequence Number (LSN) error',
RMS$_MRS, 'Invalid MRS value',
RMS$_NAM, 'Invalid NAM block',
RMS$_NEF, 'Not at end of file',
RMS$_NLB, 'Network link broken',
RMS$_NMF, 'No more files',
RMS$_NPK, 'No primary key',
RMS$_NXT, 'Incorrect NXT field',
RMS$_ORD, 'Either KEY or AREA XABs are not in ascending order',
RMS$_ORG, 'Invalid file organization specified',
RMS$_PEF, 'Cannot position to EOF',
RMS$_PRV, 'Protection violation',
RMS$_RAB, 'Invalid BID field in RAB',
RMS$_RAC, 'Invalid RAC field in RAB',
RMS$_RAT, 'Invalid RAT field',
RMS$_RBF, 'RBF not set',
RMS$_REF, 'Invalid REF field in KEY XAB',
RMS$_REX, 'Record already exists',
RMS$_RFA, 'Zero or invalid RFA',
RMS$_RFM, 'Invalid RFM field',
RMS$_FLK, 'Record is locked',
RMS$_RNF, 'Record not found',
RMS$_RSZ, 'Invalid RSZ (record size) field',
RMS$_RTB, 'Record too big to fit in buffer supplied',
RMS$_RTD, 'Rename -- Two different devices',
RMS$_RTN, 'Rename -- Two different nodes',
RMS$_SEQ, 'Keys out of sequence',
RMS$_SIZ, 'Invalid key size',
RMS$_SUP, 'Operation not supported on target system',
RMS$_UBF, 'UBF (user buffer address) not set up',
RMS$_UDF, 'Undefined or Incorrect File Format',
!!!!! RMS$_UDF, 'File is in an undefined state and should be reorganized',
RMS$_XAB, 'Invalid BID field in XAB') %;
COMPILETIME
$rms$index = 0,
$rms$error_count = 0;
!
! Define the fields in the RMS error table.
!
$FIELD
$rms$error_table_fields =
SET
rms$h_code = [$INTEGER],
rms$t_error_descr = [$DESCRIPTOR()]
TES;
LITERAL
$rms$error_table_block_size = $FIELD_SET_SIZE;
!
! Count the number of error codes we have definitions for.
!
MACRO
$rms$define_each_string [code, string] =
%ASSIGN ($rms$error_count, $rms$error_count + 1) %;
$rms$define_error_text
!
! Define the macro to generate the PRESETs for the error table.
!
UNDECLARE
%QUOTE $rms$define_each_string;
MACRO
$rms$define_each_string [code, string] =
[$rms$index, rms$h_code] = code,
[$rms$index, $SUB_FIELD (rms$t_error_descr, STR$A_POINTER)] = CH$PTR (UPLIT (string)),
[$rms$index, $SUB_FIELD (rms$t_error_descr, STR$H_LENGTH)] = %CHARCOUNT (string),
[$rms$index, $SUB_FIELD (rms$t_error_descr, STR$B_DTYPE)] = STR$K_DTYPE_T,
[$rms$index, $SUB_FIELD (rms$t_error_descr, STR$B_CLASS)] = STR$K_CLASS_F
%ASSIGN ($rms$index, $rms$index + 1) %;
!
! Generate the error table in the high segment
!
PSECT
OWN = $HIGH$;
OWN
$rms$error_table : BLOCKVECTOR [$rms$error_count, $rms$error_table_block_size]
FIELD ($rms$error_table_fields)
PRESET ($rms$define_error_text);
!
! EXTERNAL REFERENCES:
!
GLOBAL ROUTINE rms$failure (arg_blk, ercal_addr) : RMS$ERCAL NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
! This routine is called by the ERCAL after an RMS call if the call fails.
! It calls rms$efail to print the default error message (which calls
! the XPORT facility $XPO_PUT_MSG).
!
! FORMAL PARAMETERS:
! arg_blk - address of the FAB, RAB, or XAB involved in the failure
! ercal_addr - address of a nonexistent stack argument which is used
! to fetch the return address of the ERCAL.
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! NONE
!
! SIDE EFFECTS:
! NONE
!
!--
BEGIN
MAP
arg_blk : REF $FAB_DECL;
LOCAL
function;
!
! Get the right half of the RMS call that failed
!
function = .((.(ercal_addr + 1)) - 2);
function = .function<rh>;
!
! Now subtract the magic offset to get an RMS function code
!
function = .function
%IF %SWITCHES (TOPS10)
%THEN - RMS$10
%ELSE - RMS$K_INITIAL_JSYS
%FI ;
rms$efail (.function, .arg_blk)
END; !End of rms$failure
GLOBAL ROUTINE rms$signal (arg_blk, ercal_addr) : RMS$ERCAL NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called by the ERCAL after an RMS call if the call fails.
! It calls rms$efail to print the default error message (which calls
! the XPORT facility $XPO_PUT_MSG).
!
! FORMAL PARAMETERS:
!
! arg_blk - address of the FAB, RAB, or XAB involved in the failure
! ercal_addr - address of a nonexistent stack argument which is used
! to fetch the return address of the ERCAL.
!
! SIDE EFFECTS:
!
! The condition indicated in the block is SIGNAL'ed
!
!--
BEGIN
MAP
arg_blk : REF $FAB_DECL;
LOCAL
function;
!
! Get the right half of the RMS call that failed
!
function = .((.(ercal_addr + 1)) - 2);
function = .function<rh>;
!
! Now subtract the magic offset to get an RMS function code
!
function = .function
%IF %SWITCHES (TOPS10)
%THEN - RMS$10
%ELSE - RMS$K_INITIAL_JSYS
%FI ;
SIGNAL (.arg_blk[fab$h_sts], .arg_blk[fab$h_stv], .arg_blk, 0, .function)
END; !End of rms$signal
GLOBAL ROUTINE rms$efail (function, arg_blk) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
! This routine prints the default error message associated with a failure
! to a call to RMS.
!
! FORMAL PARAMETERS:
! function - RMS function code which failed
! arg_blk - address of RMS block involved (FAB, RAB, or XAB)
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! NONE
!
! SIDE EFFECTS:
! NONE
!
!--
BEGIN
MACRO
rms_pfx_msg [func] =
[%NAME (RMS$K_, func, _VALUE)] :
$STR_COPY (STRING = $STR_CONCAT ('RMS ',
%STRING (func),
' failed'),
TARGET = prefix_string) %;
MAP
arg_blk : REF $FAB_DECL;
LOCAL
ecode,
ecode2,
prefix_string : $STR_DESCRIPTOR (CLASS = DYNAMIC),
msg_length,
msg_buffer : VECTOR [CH$ALLOCATION (256)],
msg_descriptor : $STR_DESCRIPTOR (CLASS = FIXED),
msg2_length,
msg2_buffer : VECTOR [CH$ALLOCATION (256)],
msg2_descriptor : $STR_DESCRIPTOR (CLASS = FIXED);
$STR_DESC_INIT (DESCRIPTOR = prefix_string, CLASS = DYNAMIC);
$STR_DESC_INIT (DESCRIPTOR = msg_descriptor, CLASS = FIXED,
STRING = (256, CH$PTR (msg_buffer)));
$STR_DESC_INIT (DESCRIPTOR = msg2_descriptor, CLASS = FIXED,
STRING = (256, CH$PTR (msg2_buffer)));
CASE .function FROM RMS$K_OPEN_VALUE TO RMS$K_FREE_VALUE OF
SET
rms_pfx_msg (open, close, get, put, update, delete, find, truncate,
connect, disconnect, create, debug, release, flush,
message, nomessage, display, erase, free);
[INRANGE, OUTRANGE] : $STR_COPY (STRING = 'Invalid RMS function code',
TARGET = prefix_string);
TES;
ecode = .arg_blk[FAB$H_STS];
ecode2 = .arg_blk[FAB$H_STV];
rms$errmsg (.ecode, msg_descriptor, msg_length);
msg_descriptor[STR$H_LENGTH] = .msg_length;
%IF %SWITCHES (TOPS20)
%THEN
IF .ecode2 GTR 600010
AND .ecode2 LEQ 677777
THEN
BEGIN
rms$$tops20_error (.ecode2,
msg2_descriptor,
msg2_length);
msg2_descriptor[STR$H_LENGTH] = .msg2_length;
$XPO_PUT_MSG (STRING = prefix_string,
STRING = msg_descriptor,
STRING = msg2_descriptor)
END
ELSE
%FI
$XPO_PUT_MSG (STRING = prefix_string,
STRING = msg_descriptor);
END; !End of rms$efail
GLOBAL ROUTINE rms$errmsg (code, buffer_descriptor, length) =
!++
! FUNCTIONAL DESCRIPTION:
! Return the error message for an RMS-10/20 error code.
!
! FORMAL PARAMETERS:
! code - RMS error code
! buffer_descriptor - address of descriptor of string to receive error msg
! length - address of where to return length of error msg
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! .code
!
! SIDE EFFECTS:
! The error message is copied to the buffer described by buffer_descriptor.
! The length of the message is copied to the location pointed to by length.
!
!--
BEGIN
MAP
buffer_descriptor : REF $STR_DESCRIPTOR();
LOCAL
temp_descriptor : $STR_DESCRIPTOR (CLASS = DYNAMIC),
msg_index;
$STR_DESC_INIT (DESCRIPTOR = temp_descriptor, CLASS = DYNAMIC);
msg_index =
(INCR index FROM 0 TO $rms$error_count DO
IF .$rms$error_table[.index, rms$h_code] EQL .code
THEN EXITLOOP (msg_index = .index));
IF .msg_index EQL -1
THEN
rms$$canned_msg ($STR_CONCAT ('Undefined RMS error code ',
$STR_ASCII (.code, BASE8, LENGTH = 6)))
ELSE
BEGIN
$STR_COPY (STRING =
$STR_CONCAT ('RMS event ',
$STR_ASCII (.code, BASE8, LENGTH = 6),
': ',
$rms$error_table[.msg_index,
rms$t_error_descr]),
TARGET = temp_descriptor);
(.length) = .temp_descriptor[STR$H_LENGTH];
END;
$STR_COPY (STRING = temp_descriptor, TARGET = .buffer_descriptor);
$XPO_FREE_MEM (STRING = temp_descriptor);
RETURN (.code)
END; !End of rms$errmsg
%IF %SWITCHES (TOPS20)
%THEN
ROUTINE rms$$tops20_error (code, buffer_descriptor, length) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
! Returns the error message associated with a TOPS-20 error code.
!
! FORMAL PARAMETERS:
! code - TOPS20 error code
! buffer_descriptor - address of descriptor of string to receive error msg
! length - address of where to return length of error msg
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! NONE
!
! SIDE EFFECTS:
! The error message is copied to the buffer described by buffer_descriptor.
! The length of the message is copied to the location pointed to by length.
!
!--
BEGIN
MAP
buffer_descriptor : REF $STR_DESCRIPTOR();
LOCAL
retval,
temp_descriptor : $STR_DESCRIPTOR (CLASS = DYNAMIC),
erstr_buffer : VECTOR [CH$ALLOCATION (132)];
BUILTIN
JSYS;
REGISTER
a = 1,
b = 2,
c = 3;
$STR_DESC_INIT (DESCRIPTOR = temp_descriptor, CLASS = DYNAMIC);
a = CH$PTR (erstr_buffer);
b<lh> = $FHSLF;
b<rh> = .code;
c<lh> = -132;
c<rh> = 0;
retval = JSYS (2, ERSTR_, a, b, c);
CASE .retval FROM 0 TO 2 OF
SET
[0] : rms$$canned_msg ($STR_CONCAT ('Undefined TOPS-20 error code ',
$STR_ASCII (.code,
BASE8,
LENGTH = 6)));
[1] : rms$$canned_msg ('Bad args to ERSTR% in RMS$$TOPS20_ERROR');
[2] :
BEGIN
LOCAL
ptr,
byte_count;
ptr = CH$PTR (erstr_buffer);
byte_count = 0;
WHILE (CH$RCHAR_A (ptr) NEQ 0) DO byte_count = .byte_count + 1;
$STR_COPY (STRING =
$STR_CONCAT ('TOPS20 event ',
$STR_ASCII (.code, BASE8, LENGTH = 6),
': ',
(.byte_count, CH$PTR (erstr_buffer))),
TARGET = temp_descriptor);
(.length) = .temp_descriptor[STR$H_LENGTH];
END;
TES;
$STR_COPY (STRING = temp_descriptor, TARGET = .buffer_descriptor);
$XPO_FREE_MEM (STRING = temp_descriptor);
END; !End of rms$$tops20_error
%FI
END !End of module
ELUDOM