Google
 

Trailing-Edge - PDP-10 Archives - bb-h138f-bm - 7-sources/rmsert.b36
There are 4 other files named rmsert.b36 in the archive. Click here to see a list.
%TITLE 'RMSERT.B36 - Default RMS failure routine and error message printer'
MODULE rmsert (
               IDENT = '3(575)',
               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
!
! 575 -  Add missing error text
! 03 -   RMSify more
! 02 -   Put in ENTRY points
! 01 -   Write the module
!--
!
! INCLUDE FILES:
!
LIBRARY 'RMSINT';                                                      !a572
LIBRARY 'CONDIT';                                                      !a572
LIBRARY 'BLI:XPORT';                                                   !a572
LIBRARY 'BLI:MONSYM';                                                  !a572
!REQUIRE 'RMSREQ';                                                     !d572

!
! LINKAGE DECLARATIONS:
!

LINKAGE RMS$ERCAL=PUSHJ(REGISTER=1): LINKAGE_REGS(15,13,2);

!
! 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 lh = 18, 18, 0 %,
      rh =  0, 18, 0 %;

MACRO
    rms$$canned_msg (text) =
        BEGIN
        $STR_COPY (STRING = text, TARGET = temp_descriptor);
        (.length) = .temp_descriptor[STR$H_LENGTH]
        END %;
!
! 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_DUP, '$PUT or $UPDATE with duplicate key',
	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$_AID, 'Invalid AID field in area XAB',
	RMS$_ALQ, 'Allocation Quantity Incorrect',
	RMS$_ANI, 'Not ANSI ''D'' Format',
        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$_CDR, 'Cannot Disconnect RAB',
        RMS$_CEF, 'Cannot $ERASE file',
        RMS$_CGJ, 'Cannot get a JFN (GTJFN failed)',
        RMS$_CHG, 'Illegal key value change',
        RMS$_CLA, 'Invalid File Class',
        RMS$_COD, 'Invalid COD field in XAB',
        RMS$_COF, 'Cannot open file (OPENF failed)',
        RMS$_CUR, 'No current record',
        RMS$_DAN, 'Invalid DAN field in area XAB',
	RMS$_DEL, 'Record Has Been Deleted',
        RMS$_DCB, 'DECNET Connection Broken',
        RMS$_DCF, 'DECNET Connection Failed',
        RMS$_DEL, 'Attempt to access a deleted record',
        RMS$_DEV, 'Invalid device',
	RMS$_DFL, 'Bad Data-Fill percentage value',
	RMS$_DLK, 'Deadlock Condition Detected',
	RMS$_DME, 'Dynamic Memory Exhausted',
        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$_EXT, 'File Extend Error -- Disk full or quota exceeded',
        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$_FNA, 'Bad FNA value',
        RMS$_FNC, 'Cannot $ERASE because another user has file open',
        RMS$_FNF, 'File not found',
        RMS$_FSI, 'Invalid syntax in file specification',
        RMS$_FSZ, 'Invalid header size for VFC file',
        RMS$_FUL, 'File is full',
        RMS$_IAC, 'Invalid Access Control information',
        RMS$_IAL, 'Illegal argument list',
        RMS$_IAN, 'Invalid IAN field of KEY XAB',
	RMS$_IBC, 'Illegal Block Mode Connection',
	RMS$_IBO, 'Illegal Block Mode Operation',
	RMS$_IBS, 'Illegal Block Mode Sharing',
        RMS$_IFI, 'IFI field of FAB does not identify an internal file block',
	RMS$_IFL, 'Bad Index Fill Percentage',
        RMS$_IMX, 'Conflicting SUMMARY or DATE XABs',
	RMS$_IOP, 'Invalid Operation for this file organization',
	RMS$_IRC, 'Illegal Record Encountered',
        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$_MRN, 'Invalid MRN value',
        RMS$_MRS, 'Invalid MRS value',
        RMS$_NAM, 'Invalid NAM block',
        RMS$_NEF, 'Not at end of file',
!	RMS$_NLG, 'Log File Not Active',
        RMS$_NMF, 'No more files',
        RMS$_NPK, 'No primary key',
        RMS$_NXT, 'Incorrect NXT field',
        RMS$_ONS, 'Operation not supported on target system',
        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$_PLG, 'Error Detected in Files Prologue',
	RMS$_POS, 'Bad Key Position Value',
        RMS$_PRV, 'Protection violation',
	RMS$_QPE, 'Quiet Point Enabled',
        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$_RLK, 'Record already Locked by someone else',
	RMS$_RNL, 'Record Not Locked',
        RMS$_RNF, 'Record not found',
        RMS$_RSZ, 'Invalid RSZ (record size) field',
        RMS$_ROP, 'Invalid Record Options',
        RMS$_RRV, 'Invalid RRV found',
        RMS$_RSA, 'Record Stream Active',
        RMS$_RSD, 'Record Size Discrepancy',
        RMS$_RSZ, 'Bad Record Size Value',
        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$_TRE, 'Index Tree Error Detected',
	RMS$_TRU, 'Cannot Truncate This File',
        RMS$_TYP, 'Invalid TYP Block',
        RMS$_UBF, 'UBF (user buffer address) not set up',
        RMS$_UDF, 'Undefined or Incorrect File Format',
	RMS$_VER, 'Error in Version number',
	RMS$_WER, 'File Processor Write Error',
        RMS$_XAB, 'Invalid BID field in XAB',
        RMS$_XCL, 'File must be open for exclusive access'   ) %;


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);
    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 RMS call that failed
    !
    function = .((.(ercal_addr + 1)) - 2);
    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$, func, _JSYS)] :
                $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)));

%IF %SWITCHES(TOPS20)
%THEN
    IF .function<27,9> EQL %O'104'      ! jsys?
%ELSE
    IF ( .function - %O'26074000000' - RMS$10 )
      LEQ ( RMS$RENAME_JSYS - RMS$K_INITIAL_JSYS )
%FI
    THEN
        BEGIN
        function = .function<0,18>;
%IF %SWITCHES(TOPS20)
%THEN
%ELSE
        function = .function + RMS$K_INITIAL_JSYS - RMS$10;
%FI
        CASE .function FROM RMS$OPEN_JSYS TO RMS$RENAME_JSYS OF
        SET
        rms_pfx_msg (open, close, get, put, update, delete, find, truncate,
                     connect, disconnect, create, debug, release, flush,
                     message, nomessage, display, erase, free, parse,
                     search, rename);
        [INRANGE, OUTRANGE] : $STR_COPY (STRING = 'Invalid RMS function code',
                                         TARGET = prefix_string);
        TES;
        END;

    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