MODULE XVMS (	IDENT = 'V1.3-08',		%TITLE 'VAX/VMS-specific XPORT Routines'
		ADDRESSING_MODE( EXTERNAL=LONG_RELATIVE )
		) =
BEGIN

!
!			  COPYRIGHT (c) 1980, 1984 BY
!	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! 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 WHICH IS NOT SUPPLIED BY DIGITAL.
!

!++
!
! FACILITY:  BLISS Library
!
! ABSTRACT:
!
!	This module contains all VAX/VMS-specific routines.
!
! ENVIRONMENT:  User mode - multiple host operating/file systems
!
! AUTHOR:  Ward Clark,	CREATION DATE:  13 March 1979
!
! REVISION HISTORY:
!
!	2-Apr-1984	LYS	In XPO$RMS_CLEANUP the macro FREE_BLOCK
!				always calls $XPO_FREE_MEM with BINARY_DATA.
!				This means that LIB$FREE_VM is always called
!				to free descriptors even if they had been
!				allocated with LIB$SGET1_DD!  Changed FREE_BLOCK
!				to accept BINARY_DATA or STRING as a parameter,
!				and modified the uses of FREE_BLOCK accordingly.
!
!--

!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
    XPO$RMS_ERROR :  NOVALUE,				! RMS error handing routine
    XPO$RMS_PARSE,					! RMS file-spec resolution routine
    XPO$XLATE_LOGICAL,					! Fully-translate logical name routine
    XPO$RMS_CLEANUP;					! RMS control block cleanup routine

!
! INCLUDE FILES:
!

LIBRARY  'XPORT' ;					! Public XPORT control block and macro definitions
LIBRARY  'XPOSYS' ;					! Internal XPORT macro definitions

    $XPO_SYS_TEST( $VMS )

REQUIRE  'XVMS' ;					! XPORT-specific VAX/VMS interface definitions

!
! MACROS:
!

MACRO
    code_table[] =
	VECTOR[ (3 * %LENGTH) + 1 ]
	INITIAL( 3*%LENGTH, code_entry(%REMAINING) ) %,

    code_entry[ code_set ] =
	decode_entry( %REMOVE(code_set) ) %,

    decode_entry( rms_code, xport_code, secondary ) =
	rms_code, xport_code,
	%IF %NULL(secondary)
	%THEN 0
	%ELSE secondary
	%FI %;

!
! EQUATED SYMBOLS:
!

LITERAL
    yes = 1,						! Used to turn an indicator on
    no = 0,						! Used to turn an indicator off

    max_file_spec = 255,				! Maximum length of a file specification

    use_stv = XPO$_NORMAL;				! RMS$L_STV usage indicator

!
! PSECT DECLARATIONS:
!

    $XPO_PSECTS						! Declare XPORT PSECT names and attributes
!
! OWN STORAGE:
!

							! XPORT Functions (Open,Close,Delete,Rename,Get,Put)
OWN							!   |
    rms_to_xport :  PSECT(_XPO$CODE) code_table(	!   V    Meaning of RMS completion codes:
	( RMS$_ACC, XPO$_NO_ACCESS, use_stv ),		! O        file cannot be accessed
	( RMS$_ACT, XPO$_IN_USE ),			! O        file activity precludes operation
	( RMS$_ANI, XPO$_BAD_RECORD ),			!     G    mag tape records not ANSI D format
	( RMS$_ATR, XPO$_IO_ERROR, use_stv ),		! OCDRGP   read error on file header
	( RMS$_ATW, XPO$_IO_ERROR, use_stv ),		! OCDRGP   write error on file header
	( RMS$_CHN, XPO$_CHANNEL, use_stv ),		! O DR     channel assignment failure
	( RMS$_CRE, XPO$_NO_CREATE, use_stv ),		! O        file create error
	( RMS$_DEV, XPO$_BAD_DEVICE ),			! O DR     bad device or inappropriate device type
	( RMS$_DIR, XPO$_BAD_SPEC, XPO$_BAD_DIRECT ),	! O DR     error in directory name
	( RMS$_DME, XPO$_NO_MEMORY ),			! OCDRGP   dynamic memory exhausted
	( RMS$_DNA, XPO$_BAD_DFLT ),			! O DR     invalid default file specification string address
	( RMS$_DNF, XPO$_NO_DIRECT ),			! O DR     directory not found
	( RMS$_DNR, XPO$_NOT_ONLINE ),			! OCDRGP   device not ready
	( RMS$_ENT, XPO$_BAD_DIRECT, use_stv ),		!    R     error entering file name in directory
	( RMS$_ENV, XPO$_NO_SUPPORT ),			! O        environment error
	( RMS$_EXP, XPO$_NOT_EXPIRE ),			! OC       file expiration date not yet reached
	( RMS$_EXT, XPO$_NO_SPACE ),			!      P   file extend error
	( RMS$_FEX, XPO$_EXISTS ),			! O        file already exists
	( RMS$_FLK, XPO$_FILE_LOCK ),			! O        file is locked
	( RMS$_FNA, XPO$_BAD_SPEC ),			! O DR     invalid file specification string address
	( RMS$_FNF, XPO$_NO_FILE ),			! O DR     file not found
	( RMS$_FNM, XPO$_BAD_SPEC, XPO$_BAD_NAME ),	! O DR     syntax error in file name
	( RMS$_FUL, XPO$_NO_SPACE ),			! O    P   device full
	( RMS$_IFA, XPO$_CORRUPTED, use_stv ),		! O        illegal file attributes, file header corrupted
	( RMS$_IOP, XPO$_BAD_REQ ),			!   D GP   illegal operation attempted
	( RMS$_IRC, XPO$_BAD_RECORD ),			! O        illegal record encountered in file
	( RMS$_LNE, XPO$_BAD_SPEC ),			! O DR     logical name error
	( RMS$_MKD, XPO$_NO_DELETE ),			!   D      could not mark file for deletion
	( RMS$_NET, XPO$_NETWORK, use_stv ),		! OCD GP   network operation failed
	( RMS$_NOD, XPO$_BAD_SPEC, XPO$_BAD_NODE ),	! O DR     node name error
	( RMS$_ORG, XPO$_BAD_ORG ),			! O        illegal file organization
	( RMS$_PLG, XPO$_CORRUPTED ),			! O    P   error in file prologue
	( RMS$_PRV, XPO$_NO_ACCESS, XPO$_PRIVILEGED ),	! OCDR P   privilege violation; access denied
	( RMS$_QUO, XPO$_BAD_DELIM ),			! O DR     error in quoted string
	( RMS$_RBF, XPO$_BAD_REQ, XPO$_BAD_ADDR ),	!      P   invalid record address
	( RMS$_RER, XPO$_IO_ERROR, use_stv ),		!     GP   file read error
	( RMS$_RFM, XPO$_BAD_FORMAT ),			! O        illegal record format
	( RMS$_RLF, XPO$_BAD_RLTD ),			! O DR     invalid related file
	( RMS$_RLK, XPO$_REC_LOCK ),			!     GP   record locked by another task
	( RMS$_RMV, XPO$_NO_RENAME, use_stv ),		!    R     remove function failed
	( RMS$_RPL, XPO$_IO_ERROR, use_stv ),		! O    P   error reading prologue
	( RMS$_RSZ, XPO$_BAD_RECORD, XPO$_BAD_LENGTH ),	!      P   illegal record size
	( RMS$_RTB, XPO$_BAD_RECORD, XPO$_BAD_LENGTH ),	!     G    record too big for user buffer
	( RMS$_SUP, XPO$_NO_SUPPORT, use_stv ),		! OCDRGP   operation not supported
	( RMS$_SYN, XPO$_BAD_SPEC ),			! O DR     syntax error in file specification
	( RMS$_SYS, XPO$_IO_ERROR, use_stv ),		! OCDRGP   error in system QIO directive
	( RMS$_TYP, XPO$_BAD_SPEC, XPO$_BAD_TYPE ),	! O DR     error in file type
	( RMS$_VER, XPO$_BAD_SPEC, XPO$_BAD_VER ),	! O DR     error in version number
	( RMS$_WBE, XPO$_IO_ERROR, use_stv ),		!  C  GP   error writing behind
	( RMS$_WER, XPO$_IO_ERROR, use_stv ),		!  C  GP   file write error
	( RMS$_WLD, XPO$_BAD_REQ, XPO$_WILDCARD ),	! O DR     wildcard error
	( RMS$_WLK, XPO$_NO_WRITE ),			! OCDRGP   device is write-locked
	( RMS$_WPL, XPO$_IO_ERROR, use_stv ) );		! O    P   error writing prologue

!
! EXTERNAL REFERENCES:
!

%TITLE 'XPO$RMS_ERROR - RMS-to-XPORT Code Conversion'

GLOBAL ROUTINE XPO$RMS_ERROR( iob, rms_sts, rms_stv ) : NOVALUE =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine converts an RMS failure completion code into an
!	equivalent XPORT completion code.
!
! FORMAL PARAMETERS:
!
!	iob - address of an IOB
!	rms_sts - primary RMS completion code (FAB$L_STS or RAB$L_STS)
!	rms_stv - secondary RMS completion code (FAB$L_STV or RAB$L_STV)
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	iob[IOB$G_COMP_CODE] = XPORT completion code
!	iob[IOB$G_2ND_CODE] = RMS completion code (in some cases)
!
! COMPLETION CODES:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    MAP
	iob :  REF $XPO_IOB();				! Redefine the IOB parameter

!
! Convert the RMS primary completion code into equivalent XPORT completion codes.
!

    INCR index FROM 1 TO .rms_to_xport[0] BY 3 DO	! Loop through the conversion table.

	IF .rms_sts EQL .rms_to_xport[.index]		! If the RMS code is found,
	THEN						!
	    BEGIN					!
	    iob[IOB$G_COMP_CODE] =			! use the equivalent XPORT completion code
			.rms_to_xport[.index+1];	! as the primary IOB completion code
	    IF .rms_to_xport[.index+2] EQL use_stv	! and set the IOB secondary code to be
	    THEN					!
		iob[IOB$G_2ND_CODE] = .rms_stv		! the RMS secondary completion code
	    ELSE					!
		iob[IOB$G_2ND_CODE] =			! or an XPORT completion code.
			.rms_to_xport[.index+2];
	    RETURN					! Return to the caller after code translation.
	    END;

!
! Return a logic error completion code if an unexpected RMS error occurs.
!

    iob[IOB$G_COMP_CODE] = XPO$_SYS_ERROR;		! Indicate an XPORT logic error
    iob[IOB$G_2ND_CODE] = .rms_sts;			! and save the primary RMS completion code.

    RETURN						! Return to the caller.

    END;

%TITLE 'XPO$RMS_PARSE - RMS File-spec Resolution'

GLOBAL ROUTINE XPO$RMS_PARSE( iob ) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine performs RMS file specification resolution.
!
! FORMAL PARAMETERS:
!
!	iob - address of an IOB
!
! IMPLICIT INPUTS:
!
!	iob[IOB$A_RMS_FAB] points to an initialized RMS FAB
!
! IMPLICIT OUTPUTS:
!
!	iob[IOB$G_COMP_CODE] = XPORT completion code
!	iob[IOB$G_2ND_CODE] = secondary completion code (see below)
!
! COMPLETION CODES:
!
!	XPO$_NORMAL - file-spec resolution was successful
!
!	XPO$_BAD_DFLT - invalid default file-spec
!	    (IOB$G_2ND_CODE = $STR_COPY completion code)
!	XPO$_BAD_RLTD - invalid related file-spec
!	    (IOB$G_2ND_CODE = $STR_COPY completion code)
!	XPO$_BAD_RSLT - invalid resultant file-spec
!	    (IOB$G_2ND_CODE = $STR_COPY completion code)
!	XPO$_BAD_SPEC - invalid primary file-spec
!	    (IOB$G_2ND_CODE = $STR_COPY completion code)
!	failure completion code from $XPO_GET_MEM
!	failure completion codes from XPO$RMS_ERROR
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    MAP
	iob :  REF $XPO_IOB();				! Redefine the IOB parameter.

    BIND
	fab = .iob[IOB$A_RMS_FAB] :  $FAB_DECL,		! Define the caller's FAB.

	file_spec = iob[IOB$A_FILE_SPEC] :  REF $STR_DESCRIPTOR(),
	default = iob[IOB$A_DEFAULT] :  REF $STR_DESCRIPTOR(),
	related = iob[IOB$A_RELATED] :  REF $STR_DESCRIPTOR(),
	resultant = iob[IOB$T_RESULTANT] :  $STR_DESCRIPTOR();

    LOCAL						! Dynamic file-spec descriptors:
	dyna_file_spec :  $STR_DESCRIPTOR( CLASS=DYNAMIC ),
	dyna_default :  $STR_DESCRIPTOR( CLASS=DYNAMIC ),
	dyna_related :  $STR_DESCRIPTOR( CLASS=DYNAMIC ),

	name_block :  REF $NAM_DECL,			! Address of dynamic RMS Name Block
	related_block :  REF $NAM_DECL,			! Address of dummy RMS Name Block
	expanded_spec :					! Expanded file-spec buffer
	    VECTOR[ CH$ALLOCATION(max_file_spec) ];

!
! Initialization.
!

    $XPO_MAIN_BEGIN( IO )				! Define the MAIN_BLOCK code block.

    $STR_DESC_INIT( DESCRIPTOR = dyna_file_spec,	! Initialize the local file-spec descriptors.
		    CLASS = DYNAMIC );

    $STR_DESC_INIT( DESCRIPTOR = dyna_default,
		    CLASS = DYNAMIC );

    $STR_DESC_INIT( DESCRIPTOR = dyna_related,
		    CLASS = DYNAMIC );

    name_block = 0;					! Indicate that no RMS Name Block has been allocated.

!
! Setup the primary and default file-spec information in the FAB.
!

    IF .resultant[STR$H_LENGTH] NEQ 0			! If a resultant file-spec already exists,
    THEN						!
	BEGIN						!
	$XPO_IF_NOT( $STR_COPY(				! move it into dynamic memory.
			STRING = resultant,
			TARGET = dyna_file_spec,
			FAILURE = 0 ) )
	THEN
	    $XPO_QUIT( BAD_RSLT, (.$XPO_STATUS) );
	END
    ELSE
	IF $STR_EQL( STRING1 = .file_spec,		! If FILE_SPEC=$XPO_TEMPORARY was specified,
		    STRING2 = $XPO_TEMPORARY,		!
		    FAILURE = 0 )			!
	THEN						!
	    BEGIN					!
	    iob[IOB$V_TEMPORARY] = yes;			! indicate a temporary file
	    $XPO_IF_NOT( $STR_COPY(			! and move a temporary file-spec into dynamic memory.
			    STRING = 'XPORT.TMP',
			    TARGET = dyna_file_spec,
			    FAILURE = 0 ) )
	    THEN
		$XPO_QUIT( BAD_RSLT, (.$XPO_STATUS) );
	    END
	ELSE
	    BEGIN
	    $XPO_IF_NOT( $STR_COPY(			! Otherwise, move uppercase versions of the primary and
			STRING = .file_spec,		! default file specifications into dynamic memory.
			TARGET = dyna_file_spec,
			OPTION = UP_CASE,
			FAILURE = 0 ) )
	    THEN
		$XPO_QUIT( BAD_SPEC, (.$XPO_STATUS) );

	    $XPO_IF_NOT( $STR_COPY(
			STRING = .default,
			TARGET = dyna_default,
			OPTION = UP_CASE,
			FAILURE = 0 ) )
	    THEN
		$XPO_QUIT( BAD_DFLT, (.$XPO_STATUS) );

	    fab[FAB$L_DNA] =				! Setup the default file-spec fields in the FAB.
		.dyna_default[STR$A_POINTER];
	    fab[FAB$B_DNS] = .dyna_default[STR$H_LENGTH];
	    END;

    fab[FAB$L_FNA] = .dyna_file_spec[STR$A_POINTER];	! Then setup the primary file-spec fields in the FAB.
    fab[FAB$B_FNS] = .dyna_file_spec[STR$H_LENGTH];

!
! Build a standard RMS Name Block.
!

    $XPO_IF_NOT( $XPO_GET_MEM( UNITS = NAM$C_BLN,	! Get dynamic memory for a Name Block.
				RESULT = name_block,
				FAILURE = 0 ) )
    THEN
	$XPO_QUIT( (.$XPO_STATUS) );

    fab[FAB$L_NAM] = .name_block;			! Save the address of the Name Block.

    $NAM_INIT( NAM = .name_block,			! Initialize the Name Block:
		ESA = expanded_spec,			!    pointer to expanded file-spec buffer
		ESS = max_file_spec );			!    length of expanded file-spec buffer

!
! Build a dummy related file RMS Name Block.
!

    IF .related[STR$H_LENGTH] NEQ 0 AND			! If a related file-spec was specified
	.resultant[STR$H_LENGTH] EQL 0			! and a resultant file-spec was not specified,
    THEN						! a dummy related file Name Block must be built.
	BEGIN
	$XPO_IF_NOT( $STR_COPY(				! First, move an uppercase version of the related
			STRING = .related,		! file-spec into dynamic memory.
			TARGET = dyna_related,
			OPTION = UP_CASE,
			FAILURE = 0 ) )
	THEN
	    $XPO_QUIT( BAD_RLTD, (.$XPO_STATUS) );

	$XPO_IF_NOT( $XPO_GET_MEM( UNITS = NAM$C_BLN,	! Then get dynamic memory for a Name Block.
				RESULT = related_block,
				FAILURE = 0 ) )
	THEN
	    $XPO_QUIT( (.$XPO_STATUS) );

	name_block[NAM$L_RLF] = .related_block;		! Save the address of the Name Block.

	$NAM_INIT( NAM = .related_block,		! Initialize the Name Block:
		RSA = .dyna_related[STR$A_POINTER] );	!    pointer to related file-spec
	related_block[NAM$B_RSL] =			!    length of related file-spec
			.dyna_related[STR$H_LENGTH];
	END;

!
! Use RMS PARSE to build an expanded file specification.
!

    $RMS_PARSE( FAB = fab );

!
! Save the expanded file specification.
!

    $XPO_IF_NOT( $STR_COPY( STRING = (.name_block[NAM$B_ESL], .name_block[NAM$L_ESA]),
			    TARGET = resultant,
			    FAILURE = 0 ) )
    THEN
	$XPO_QUIT( BAD_RSLT, (.$XPO_STATUS) );

!
! Interpret the RMS PARSE completion code.
!

    IF NOT .fab[FAB$L_STS]				! If the PARSE was unsuccessful,
    THEN						!
	BEGIN						!
	XPO$RMS_ERROR( .iob,				! convert the RMS completion codes into
			.fab[FAB$L_STS],		! equivalent XPORT completion codes.
			.fab[FAB$L_STV] );		!
	$XPO_QUIT();					! and then jump to return to the caller.
	END;

!
! Setup for an "open by file ID" after a successful PARSE.
!

    fab[FAB$V_NAM] = yes;				! Indicate that the Name Block has already been set up.

!
! Test whether the device is a terminal.
!

    BEGIN
    LOCAL
	spec_parse :  $XPO_SPEC_BLOCK,
	device_name :  $STR_DESCRIPTOR( CLASS = DYNAMIC ),
	device_info :  BLOCK[ DIB$K_LENGTH, BYTE ],
	info_desc :  $STR_DESCRIPTOR();

    $STR_DESC_INIT( DESCRIPTOR = device_name, CLASS = dynamic );
    $STR_DESC_INIT( DESCRIPTOR = info_desc, STRING = ( DIB$K_LENGTH, device_info ) );

    $XPO_PARSE_SPEC( FILE_SPEC = resultant, SPEC_BLOCK = spec_parse, FAILURE = 0 );

    IF .spec_parse[XPO$H_NODE] EQL 0
    THEN
	BEGIN
	spec_parse[XPO$H_DEVICE] = .spec_parse[XPO$H_DEVICE] - 1;

	xpo$xlate_logical( spec_parse[XPO$T_DEVICE], device_name );

	IF $GETDEV( DEVNAM = device_name, PRIBUF = info_desc ) EQL SS$_NORMAL
	THEN
	    IF (.device_info[DIB$L_DEVCHAR] AND DEV$M_TRM) NEQ 0
	    THEN
		BEGIN
		iob[IOB$V_TERMINAL] = yes;

		! Use the actual terminal device name since RMS won't allow a
		! "user file open" on a process permanent file (e.g., SYS$INPUT).

		$XPO_IF_NOT( $STR_COPY( STRING = device_name, TARGET = dyna_file_spec, FAILURE = 0 ) )
		THEN
		    $XPO_QUIT( BAD_RSLT, (.$XPO_STATUS) );
		IF CH$RCHAR( .dyna_file_spec[STR$A_POINTER] + .dyna_file_spec[STR$H_LENGTH] - 1 ) NEQ %C':'
		THEN
		    $XPO_IF_NOT( $STR_APPEND( STRING = ':', TARGET = dyna_file_spec, FAILURE = 0 ) )
		    THEN
			$XPO_QUIT( BAD_RSLT, (.$XPO_STATUS) );

		$XPO_IF_NOT( $STR_COPY( STRING = dyna_file_spec, TARGET = resultant, FAILURE = 0 ) )
		THEN
		    $XPO_QUIT( BAD_RSLT, (.$XPO_STATUS) );

		! Update the FAB and Name Block to force a regular open (i.e., not "open by file name block").

		fab[FAB$V_NAM] = no;
		fab[FAB$B_FNS] = .dyna_file_spec[STR$H_LENGTH];
		fab[FAB$L_FNA] = .dyna_file_spec[STR$A_POINTER];

		name_block[NAM$B_ESS] = 0;
		name_block[NAM$B_ESL] = 0;
		name_block[NAM$L_ESA] = 0;
		END;

	$XPO_FREE_MEM( STRING = device_name, FAILURE = 0 );
	END;
    END;

    $XPO_QUIT( NORMAL );				! Return a success code to the caller.

!
! Update the expanded string fields in the Name Block.
!

    $XPO_MAIN_END;					! Terminate the MAIN_BLOCK code block.

    IF .fab[FAB$V_NAM]					! If "open by file name block" will follow,
    THEN						!
	BEGIN						! update the expanded file-spec fields.
	name_block[NAM$B_ESS] = .resultant[STR$H_LENGTH];
	name_block[NAM$B_ESL] = .resultant[STR$H_LENGTH];
	name_block[NAM$L_ESA] = .resultant[STR$A_POINTER];
	END;

!
! Return the final XPORT completion code to the caller.
!

    RETURN .iob[IOB$G_COMP_CODE]			! Return the final completion code to the caller.

    END;

%TITLE 'XPO$XLATE_LOGICAL - Fully Translate Logical Name'

GLOBAL ROUTINE xpo$xlate_logical( logical_name, result_name ) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine translates a logical name to its equivalence name,
!	repeating this translation until the logical name is fully resolved.
!
! FORMAL PARAMETERS:
!
!	logical_name - address of a logical name string descriptor
!	result_name - address of an initialized result string descriptor
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! COMPLETION CODES:
!
!	completion code from $STR_COPY
!		or
!	failure completion code from $TRNLOG
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    MAP
	logical_name :  REF $STR_DESCRIPTOR(),
	result_name :  REF $STR_DESCRIPTOR();

    LITERAL
	max_equiv_name = 63;				! Maximum length of an equivalence name

    LOCAL
	current_name :  $STR_DESCRIPTOR(),		! Descriptor of name to be translated
	equiv_buffer :  VECTOR[ max_equiv_name, BYTE ],	! Equivalence name buffer
	equiv_name :  $STR_DESCRIPTOR(),		! Equivalence buffer descriptor
	status;						! Temporary completion code

    ! Initialize the local string descriptors.

    $STR_DESC_INIT( DESCRIPTOR = current_name, STRING = logical_name[$BASE] );
    $STR_DESC_INIT( DESCRIPTOR = equiv_name, STRING = ( max_equiv_name, equiv_buffer ) );

    ! Translate the current name as many times as necessary.

    WHILE 1 DO
	BEGIN

	! Remove the first 4 characters from an equivalence name which
	! begins with an escape character (i.e., process-permanent file-spec).

	IF CH$RCHAR( .current_name[STR$A_POINTER] ) EQL esc AND
	    .current_name[STR$H_LENGTH] GTRU 4
	THEN
	    BEGIN
	    current_name[STR$H_LENGTH] = .current_name[STR$H_LENGTH] - 4;
	    current_name[STR$A_POINTER] = .current_name[STR$A_POINTER] + 4;
	    END;

	! A logical name which begins with an underscore should not be translated.

	IF CH$RCHAR( .current_name[STR$A_POINTER] ) EQL %C'_'
	THEN
	    EXITLOOP;

	! Attempt to translate the current name.

	status = $TRNLOG( LOGNAM = current_name[$BASE],
			RSLBUF = equiv_name[$BASE],
			RSLLEN = current_name[STR$H_LENGTH] );

	! Exit the translation loop if translation is complete.

	IF .status EQL SS$_NOTRAN  OR  .status EQL SS$_IVLOGNAM
	THEN
	    EXITLOOP;

	! Return to the caller on other translation failures.

	IF NOT .status THEN RETURN .status;

	! Make the translated name the current name and loop back.

	current_name[STR$A_POINTER] = equiv_buffer;
	END;

    ! Return the fully translated name to the caller.

    RETURN $STR_COPY( STRING = current_name[$BASE], TARGET = result_name[$BASE] );
    END;

%TITLE 'XPO$RMS_CLEANUP - RMS Control Block Cleanup'

GLOBAL ROUTINE XPO$RMS_CLEANUP( iob ) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine closes an IOB's FAB (if it is open) and then frees
!	all of the RMS control blocks which relate to the IOB.
!
! FORMAL PARAMETERS:
!
!	iob - address of an IOB
!
! IMPLICIT INPUTS:
!
!	iob[IOB$A_RMS_FAB] points to an initialized RMS FAB
!
! IMPLICIT OUTPUTS:
!
!	None
!
! COMPLETION CODES:
!
!	XPO$_NORMAL - RMS cleanup was successful
!
!	failure completion code from $XPO_FREE_MEM
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    MAP
	iob :  REF $XPO_IOB();				! Redefine the IOB parameter.

    BIND
	fab = .iob[IOB$A_RMS_FAB] :  $FAB_DECL,		! Define the IOB's FAB
	rab = .iob[IOB$A_RMS_RAB] :  $RAB_DECL;		! and RAB.

    MACRO
	free_block( bytes, address ) =

	! bytes	=  Length in number of bytes
	! address = Address of the descriptor

	    BEGIN
	    LOCAL status;

	    status = $XPO_FREE_MEM( BINARY_DATA=(bytes,address,UNITS),
				    FAILURE = 0 );

	    IF NOT .status
	    THEN
		RETURN .status
	    END %,

	free_string ( bytes, address ) =

	! bytes	=  Length in number of bytes
	! address = Address of the descriptor

	    BEGIN
	    LOCAL status;

	    status = $XPO_FREE_MEM( STRING=(bytes,address),
				    FAILURE = 0 );

	    IF NOT .status
	    THEN
		RETURN .status
	    END %;

!
! Close the FAB if it is open.
!

    IF fab EQL 0					! If no FAB exists,
    THEN						!
	RETURN XPO$_NORMAL;				! return a success code to the caller.

    $RMS_CLOSE( FAB = fab );				! Close the FAB in case it is open.

    free_string( .fab[FAB$B_FNS], .fab[FAB$L_FNA] );	! Free the upper-case versions of the primary
    free_string( .fab[FAB$B_DNS], .fab[FAB$L_DNA] );	! and default file specifications.

!
! Free any RMS Name Blocks.
!

    IF .fab[FAB$L_NAM] NEQ 0				! If a Name Block exists,
    THEN						! it and the related Name Block must be freed.
	BEGIN
	BIND
	    name_block = .fab[FAB$L_NAM] :  $NAM_DECL,
	    related_block = .name_block[NAM$L_RLF] :
					    $NAM_DECL;

	IF related_block NEQ 0				! If a related Name Block exists,
	THEN						!
	    BEGIN					!
	    free_string( .related_block[NAM$B_RSL],	! free the upper-case version of the
			.related_block[NAM$L_RSA] );		! related file specification
	    free_block( NAM$C_BLN, related_block );! and then free the dummy Name Block.
	    END;

	free_block( NAM$C_BLN, name_block );	! Then free the standard Name Block.
	END;

!
! Free the FAB.
!

    free_block( FAB$C_BLN, fab );		! Free the IOB's FAB.

    iob[IOB$A_RMS_FAB] = 0;				! Indicate that the FAB no longer exists.

!
! Free the RAB and its associated I/O buffer.
!

    IF rab NEQ 0					! If a RAB exists,
    THEN						! the RAB and its I/O buffer must be freed.
	BEGIN
	free_block( .rab[RAB$W_USZ], .rab[RAB$L_UBF] );	! Free the I/O buffer (if any).

	free_block( RAB$C_BLN, rab );			! Free the RAB.

	iob[IOB$A_RMS_RAB] = 0;				! Indicate that the RAB no longer exists.
	END;

!
! Return to the caller.
!

    RETURN XPO$_NORMAL					! Return a success code to the caller.

    END;
END
ELUDOM