github.com/PDP-10.stacken
1
0
Fork 0
mirror of https://github.com/PDP-10/stacken.git synced 2026-04-20 00:43:22 +00:00
Code Issues Projects Releases Wiki Activity
Files
master
PDP-10.stacken/files/stacken-tape-backup/dskb:10_7/dil/dilsrc/rmserr.b36
Lars Brinkhoff 6e18f5ebef Extract files from tape images. 
Some tapes could not be extracted.
2021-01-29 10:47:33 +01:00

564 lines
18 KiB
Plaintext
Raw Permalink Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
%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, 1986.
! 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
Reference in New Issue View Git Blame Copy Permalink