Google
 

Trailing-Edge - PDP-10 Archives - walsh_goodStuff_1600 - more-uns/xport.old-req
There are no other files named xport.old-req in the archive.
!
! XPORT Control Block and Macro Definitions
!

LITERAL
    XPO$K_VERSION = 0,					! Current XPORT version
    XPO$K_LEVEL = 7,					!    and base level

    XPO$K_FAILURE =					! Standard XPORT failure routine value
	%BLISS16( %X'FFFF' )
	%BLISS32( 0 )
	%BLISS36( %O'777777' );

COMPILETIME
    $xpo$temp = 0,					! Temporary variable
    $xpo$temp1 = 0,
    $xpo$temp2 = 0,
    $xpo$key_ok = 0;

MACRO
    $XPO$FORCE [] =
	%QUOTE %EXPAND %REMAINING %,


    $XPO$REQUIRED( value, parameter_name ) =
	%IF %NULL(value)
	%THEN
	    %WARN( parameter_name, ' parameter must be specified' )
	    %QUOTE %QUOTE %EXITMACRO
	%FI %,


    $XPO$CONFLICT( list ) =
	0 %QUOTE %EXPAND $xpo$$conflict(list,%REMAINING) GTR 1 %,

    $xpo$$conflict( list ) [] =
	%IF NOT %NULL( %QUOTE %EXPAND %REMOVE(list) )
	%THEN + 1
	%FI
	%QUOTE %EXPAND $xpo$$conflict( %REMAINING ) %,


    $XPO$KEY_CHECK( value, keyword_list ) =
	%ASSIGN( $xpo$key_ok, 0 )
	$xpo$$key_test( value, %REMOVE(keyword_list) )
	%NUMBER( $xpo$key_ok ) %,


    $XPO$KEY_TEST( value, keyword_list, parameter_name ) =
	%ASSIGN( $xpo$key_ok, 0 )
	$xpo$$key_test( value, %REMOVE(keyword_list) )

	%IF $xpo$key_ok
	%THEN
	    1
	%ELSE
	    %PRINT( '"', value, '" is an invalid ', parameter_name, ' parameter value' )
	    %MESSAGE( '"', value, '" is an invalid ', parameter_name, ' parameter value' )
	    %WARN(  '... possible values are ', $xpo$key_words( %REMOVE( keyword_list ) ) )
	    0
	%FI %,


    $xpo$$key_test( value, keyword ) [] =

	%IF %IDENTICAL(value,keyword)
	%THEN
	    %ASSIGN( $xpo$key_ok, 1 )
	%ELSE
	    $xpo$$key_test( value, %REMAINING )
	%FI %,


    $xpo$key_words[ keyword ] =
	%IF %COUNT NEQ 0
	%THEN
	    ', ',
	%FI
	%STRING( keyword ) %,


    $XPO$PAREN_TEST( parameter ) =
	%IF %NULL(parameter)
	%THEN
	    0
	%ELSE
	    $xpo$$paren( %REMOVE(parameter), parameter )
	%FI %,

    $xpo$$paren( no_parens, parens ) =
	%IF %LENGTH EQL 2
	%THEN
	    %IF %IDENTICAL( no_parens, parens )
	    %THEN
		0
		%EXITMACRO
	    %FI
	%FI
	1 %,


    $XPO$ARG1( arg1 ) =
	arg1 %,


    $XPO$ARG2( arg1, arg2 ) =
	arg2 %,


    $XPO$ARG3( arg1, arg2, arg3 ) =
	arg3 %,


    $XPO$EX_ROUTINE( routine_name, linkage_attr ) =	! Declare an external routine
	EXTERNAL ROUTINE routine_name

	%IF %BLISS(BLISS32) OR NOT %NULL(linkage_attr)
	%THEN
	    :
	%FI

	%BLISS32( ADDRESSING_MODE(LONG_RELATIVE) )
	linkage_attr ;  %,


    $XPO$EX_FAILURE( failure ) =
	%IF $xpo$key_check( failure, (XPO$FAILURE, XPO$IO_FAILURE, XPO$GM_FAILURE, XPO$FM_FAILURE,
					STR$FAILURE, STR$X_FAILURE, STR$C_FAILURE, STR$A_FAILURE,
					STR$S_FAILURE, STR$B_FAILURE) )
	%THEN
	    %QUOTE %EXPAND $xpo$force( $xpo$ex_routine( failure ) )
	%FI %,


    XPO$I_FAILURE =					! ***** OBSOLETE *****
	%INFORM( 'XPO$I_FAILURE has been renamed to XPO$IO_FAILURE' )
	XPO$IO_FAILURE %,


    XPO$F_FAILURE =					! ***** OBSOLETE *****
	%INFORM( 'XPO$F_FAILURE has been renamed to XPO$FM_FAILURE' )
	XPO$FM_FAILURE %,


    XPO$G_FAILURE =					! ***** OBSOLETE *****
	%INFORM( 'XPO$G_FAILURE has been renamed to XPO$GM_FAILURE' )
	XPO$GM_FAILURE %,


    XPO$P_FAILURE =					! ***** OBSOLETE *****
	%INFORM( 'XPO$P_FAILURE has been renamed to XPO$PM_FAILURE' )
	XPO$PM_FAILURE %,


    $XPO$DEFAULT( argument, default ) =
	%IF %NULL(argument)
	%THEN
	    default
	%ELSE
	    argument
	%FI %,


    $XPO$NAME15 [] =
	%NAME( %EXACTSTRING( MIN(%CHARCOUNT(%STRING(%REMAINING)),15), 0, %REMAINING ) ) %,


    $XPO$VALUE( block, field_name, value ) [] =
	block[ $XPO$NAME15(block,field_name) ] = value ; %,


    $XPO$KEY_NAME( block, keyword ) [] =
	$XPO$NAME15(block,'K_',keyword) %,


    $XPO$KEYWORD( block ) [ keyword ] =
	%IF %NULL(keyword)
	%THEN
	    %WARN('Null keyword specified')
	%ELSE
	    block[ $XPO$NAME15(block,'V_',keyword) ] = 1 ;
	%FI %,


    $XPO$SHOW_NUMB( number, base ) [] =
	%IF number GEQ base
	%THEN
	    %ASSIGN( $xpo$temp, number/base )
	    $XPO$SHOW_NUMB( %NUMBER($xpo$temp), base )
	%FI

	%ASSIGN( $xpo$temp, number MOD base )
	%IF $xpo$temp LEQ 9
	%THEN
	    %ASSIGN( $xpo$temp, %C'0' + $xpo$temp )
	%ELSE
	    %ASSIGN( $xpo$temp, %C'A' + $xpo$temp - 10 )
	%FI
	, %CHAR( $xpo$temp ) %;
!
! XPORT Transportable FIELD definition macros
!

LITERAL
    $xpo$bits_byte =					! Bits per "byte"
		%BLISS16(8) %BLISS32(8) %BLISS36(9),

    $xpo$bits_word = 2 * $xpo$bits_byte;		! Bits per "word"

COMPILETIME						! Compile-time variables:
    $xpo$full_based = 0,				!    fullword-based structure indicator
    $xpo$full_index = 0,				!    fullword index (within block)
    $xpo$bit_index = 0,					!    bit index (within fullword)
    $xpo$max_fullwd = 0,				!    maximum value index in current block
    $xpo$max_bit = 0,					!    maximum bit index (within maximum value)
    $xpo$bits = 0,					!    field size in bits
    $xpo$1st_actual = 0,				!    first calculated access-acutal
    $xpo$2nd_actual = 0,				!    second calculated access_actual (bit displacement)
    $xpo$unit_index = 0,				!    addressable unit index (within block)
    $xpo$set_size = 0,					!    size of field set in units
    $xpo$distinct = 0,					!    distinct literal value
    $xpo$show_field = 0,				!    $SHOW( FIELDS ) indicator
    $xpo$show_lit = 0,					!    $SHOW( LITERALS ) indicator
    $xpo$show_info = 1;					!    $SHOW( INFO ) indicator

MACRO
    $FIELD =						! Block initialization:
	%ASSIGN( $xpo$full_based, 1 )			!    fullword-based structure
	%ASSIGN( $xpo$full_index, 0 )			!    value index (within block)
	%ASSIGN( $xpo$bit_index, 0 )			!    bit index (within value)
	%ASSIGN( $xpo$max_fullwd, 0 )			!    maximum value index in current block
	%ASSIGN( $xpo$max_bit, 0 )			!    maximum bit index (within maximum value)
	FIELD %,


    $UNIT_FIELD =
	%EXPAND $FIELD
	%ASSIGN( $xpo$full_based, 0 ) %,		! Change to a unit-based structure


    $xpo$field( bits, sign, null_field ) =		! Define a single transportable field
	%IF bits GTR %BPVAL OR null_field
	%THEN
	    %ASSIGN( $xpo$bits, 0 )
	    %IF NOT null_field
	    %THEN
		%IF $xpo$show_info
		%THEN
		    %INFORM( 'space reserved for field but null field defined' )
		%FI
	    %FI
	%ELSE
	    %ASSIGN( $xpo$bits, bits )
	%FI

	%IF NOT %BLISS(BLISS32) AND
	    $xpo$bits + $xpo$bit_index GTR %BPVAL
	%THEN
	    $ALIGN(FULLWORD)
	    %IF $xpo$show_info
	    %THEN
		%INFORM( 'BLISS fullword alignment has been assumed' )
	    %FI
	%FI

	%IF $xpo$full_based
	%THEN
	    %ASSIGN( $xpo$1st_actual, $xpo$full_index )
	    %ASSIGN( $xpo$2nd_actual, $xpo$bit_index )
	    %ASSIGN( $xpo$unit_index, $xpo$full_index * %UPVAL + $xpo$bit_index / %BPUNIT )
	%ELSE
	    %ASSIGN( $xpo$1st_actual, $xpo$full_index * %UPVAL + $xpo$bit_index / %BPUNIT )
	    %ASSIGN( $xpo$2nd_actual, $xpo$bit_index MOD %BPUNIT )
	    %ASSIGN( $xpo$unit_index, $xpo$1st_actual )
	%FI

							! Generate field specification:
	$xpo$1st_actual,				!    fullword index or addressable unit index
	$xpo$2nd_actual,				!    bit index within fullword/unit
	$xpo$bits,					!    field size in bits
	sign						!    sign extension

	%IF $xpo$show_field
	%THEN
	    %PRINT( '			  [',		! Display generated field definition
		%NUMBER($xpo$1st_actual), ',',
		%NUMBER($xpo$2nd_actual), ',',
		%NUMBER($xpo$bits), ',',
		sign, ']   (+',
		%IF %BLISS(BLISS32)
		%THEN
		    '%X''' $XPO$SHOW_NUMB( $xpo$unit_index, 16 ),
		%ELSE
		    '%O''' $XPO$SHOW_NUMB( $xpo$unit_index, 8 ),
		%FI
		''')' )
	%FI

	%ASSIGN( $xpo$full_index, $xpo$full_index + (($xpo$bit_index + bits)/%BPVAL) )
	%ASSIGN( $xpo$bit_index, ($xpo$bit_index + bits) MOD %BPVAL )

	%IF $xpo$full_index GTR $xpo$max_fullwd OR
	    ($xpo$full_index EQL $xpo$max_fullwd AND
		$xpo$bit_index GTR $xpo$max_bit)
	%THEN
	    %ASSIGN( $xpo$max_fullwd, $xpo$full_index )
	    %ASSIGN( $xpo$max_bit, $xpo$bit_index )
	%FI %,


    $ALIGN( boundary ) =				! Align next field on a specified boundary
	%IF NOT $xpo$key_test( boundary, ( BYTE, WORD, FULLWORD, UNIT ) )
	%THEN
	    %EXITMACRO
	%FI

	%IF %IDENTICAL( boundary, FULLWORD )
	%THEN
	    %IF $xpo$bit_index GTR 0
	    %THEN
		%ASSIGN( $xpo$full_index, $xpo$full_index + 1 )
		%ASSIGN( $xpo$bit_index, 0 )
	    %FI

	    %EXITMACRO
	%FI

	%IF %IDENTICAL( boundary, BYTE )
	%THEN
	    %IF ($xpo$bit_index MOD $xpo$bits_byte) EQL 0 %THEN %EXITMACRO %FI

	    %ASSIGN( $xpo$bit_index, $xpo$bit_index - ($xpo$bit_index MOD $xpo$bits_byte) + $xpo$bits_byte )
	%FI

	%IF %IDENTICAL( boundary, WORD )
	%THEN
	    %IF ($xpo$bit_index MOD $xpo$bits_word) EQL 0 %THEN %EXITMACRO %FI

	    %ASSIGN( $xpo$bit_index, $xpo$bit_index - ($xpo$bit_index MOD $xpo$bits_word) + $xpo$bits_word )
	%FI

	%IF %IDENTICAL( boundary, UNIT )
	%THEN
	    %IF ($xpo$bit_index MOD %BPUNIT) EQL 0 %THEN %EXITMACRO %FI

	    %ASSIGN( $xpo$bit_index, $xpo$bit_index - ($xpo$bit_index MOD %BPUNIT) + %BPUNIT )
	%FI

	%IF $xpo$bit_index GEQ %BPVAL
	%THEN
	    %ASSIGN( $xpo$full_index, $xpo$full_index + 1 )
	    %ASSIGN( $xpo$bit_index, 0 )
	%FI %,


    $OVERLAY( field0, field1 ) =			! Reset value index, etc. to a previously defined field
	%IF %LENGTH NEQ 1 AND %LENGTH NEQ 4
	%THEN
	    %WARN( 'Invalid argument list' )
	    %EXITMACRO
	%FI

	%IF %LENGTH EQL 4
	%THEN
	    %IF $xpo$full_based
	    %THEN
		%ASSIGN( $xpo$full_index, field0 )
		%ASSIGN( $xpo$bit_index, field1 )
	    %ELSE
		%ASSIGN( $xpo$full_index, (field0) / %UPVAL )
		%ASSIGN( $xpo$bit_index, (field1) + ((field0) MOD %UPVAL) * %BPUNIT )
	    %FI
	%ELSE
	    %IF NOT %DECLARED( %NAME(field0) )
	    %THEN
		%WARN( field0, ' is not defined' )
		%EXITMACRO
	    %FI

	    %IF $xpo$full_based
	    %THEN
		%ASSIGN( $xpo$full_index, %FIELDEXPAND(field0,0) )
		%ASSIGN( $xpo$bit_index, %FIELDEXPAND(field0,1) )
	    %ELSE
		%ASSIGN( $xpo$full_index, %FIELDEXPAND(field0,0) / %UPVAL )
		%ASSIGN( $xpo$bit_index, %FIELDEXPAND(field0,1) + (%FIELDEXPAND(field0,0) MOD %UPVAL) * %BPUNIT )
	    %FI
	%FI %,


    $CONTINUE =						! Continue block at high-water-mark
	%ASSIGN( $xpo$full_index, $xpo$max_fullwd )
	%ASSIGN( $xpo$bit_index, $xpo$max_bit ) %,


    $BASE =
	%ASSIGN( $xpo$full_index, 0 )
	%ASSIGN( $xpo$bit_index, 0 )
	0,0,0,0 %,


    $BYTE =						! A single, unsigned "byte"
	$BYTES(1) %,


    $BYTES( number ) =					! Any number of unsigned bytes
	$xpo$field( (number) * $xpo$bits_byte, 0, 0 ) %,


    $INTEGER =						! Signed BLISS value (aligned)
	$xpo$field( %BPVAL, 1, 0 ) %,


    $TINY_INTEGER =					! Signed 1-"byte" value
	$xpo$field( $xpo$bits_byte, 1, 0 ) %,


    $SHORT_INTEGER =					! Signed 2-"byte" value
	$xpo$field( 2 * $xpo$bits_byte, 1, 0 ) %,


    $LONG_INTEGER =					! Signed 4-"byte" value
	$xpo$field( 4 * $xpo$bits_byte, 1, 0 ) %,


    $ADDRESS =						! Unsigned address
	$xpo$field( %BPADDR , 0, 0 ) %,


    $POINTER =						! Unsigned character pointer
	$xpo$field( %BPVAL, 0, 0 ) %,


    $BIT =						! Single bit
	$BITS(1) %,


    $BITS( number ) =					! Collection of bits
	$xpo$field( (number), 0, 0 ) %,


    $SUB_BLOCK( fullwords ) =				! Sub-structure
	$ALIGN(FULLWORD)
	%IF %NULL(fullwords)
	%THEN
	    $xpo$field( 0, 0, 1 )
	%ELSE
	    $xpo$field( (fullwords) * %BPVAL, 0, 1 )
	%FI %,

    $DESCRIPTOR( class ) =				! String or binary data descriptor sub-block
	%IF NOT %NULL(class)
	%THEN
	    %IF NOT $xpo$key_test( class, (FIXED, DYNAMIC, BOUNDED, DYNAMIC_BOUNDED, UNDEFINED
						, STATIC, VARYING, DYNAMIC_VARYING) )	! *** OBSOLETE ***
	    %THEN
		0,0,0,0
		%EXITMACRO
	    %FI
	%FI

	%IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
		OR %IDENTICAL(class,VARYING) OR %IDENTICAL(class,DYNAMIC_VARYING)	! *** OBSOLETE ***
	%THEN
	    $SUB_BLOCK( STR$K_B_BLN )
	%ELSE
	    $SUB_BLOCK( STR$K_F_BLN )
	%FI %,


    $REF_DESCRIPTOR =
	$ADDRESS %,


%IF %BLISS(BLISS36)
%THEN

    $STRING( length ) =					! Character string for BLISS36
	$ALIGN(UNIT)
	$xpo$field( (((length)+4)/5) * %BPVAL, 0, 1 ) %,

%ELSE

    $STRING( length ) =					! Character string for BLISS16 and BLISS32
	$ALIGN(UNIT)
	$xpo$field( (length) * %BPUNIT, 0, 1 ) %,

%FI


%IF %BLISS(BLISS36)
%THEN

    $SIXBIT( length ) =					! Six-bit character string for BLISS36
	%IF (length) MOD 3 NEQ 0
	%THEN
	    %WARN( 'A six-bit string must be in units of 3 characters' )
	%FI
	%IF $xpo$bit_index MOD (%BPVAL/2) NEQ 0
	%THEN
	    %WARN( 'A six-bit string must be half-word aligned' )
	%FI

	$xpo$field( (((length)+2)/3)*(%BPVAL/2), 0, 0 ) %,

%ELSE

    $SIXBIT( length ) =					! Six-bit character string for BLISS16 and BLISS32
	%WARN( 'Six-bit strings are not available for this architecture' ) %,

%FI


    $LENGTH =										! *** OBSOLETE ***
	%INFORM( '$LENGTH is obsolete - use $FIELD_SET_SIZE' )				! *** OBSOLETE ***
	$FIELD_SET_SIZE %,								! *** OBSOLETE ***


    $FIELD_SET_SIZE =					! Length of field set in fullwords
	%IF NOT $xpo$full_based
	%THEN
	    %WARN( '$FIELD_SET_SIZE may not be used with $UNIT_FIELD' )
	%FI

	%ASSIGN( $xpo$set_size, $xpo$full_index + ($xpo$bit_index NEQ 0) )
	%NUMBER( $xpo$set_size )

	%IF $xpo$show_lit
	%THEN
	    %PRINT( '			  ', %NUMBER($xpo$set_size), ' fullwords' )
	%FI

	%ASSIGN( $xpo$full_based, 1 ) %,


    $FIELD_SET_UNITS =					! Length of field set in addressable units
	%ASSIGN( $xpo$set_size,  $xpo$full_index * %UPVAL + ( ($xpo$bit_index + %BPUNIT - 1) / %BPUNIT )  )
	%NUMBER( $xpo$set_size )

	%IF $xpo$show_lit
	%THEN
	    %PRINT( '			  ', %NUMBER($xpo$set_size), ' addressable units' )
	%FI

	%ASSIGN( $xpo$full_based, 1 ) %,


    $LITERAL =						! Initialize for constant creation
	%ASSIGN( $xpo$distinct, 0 )
	LITERAL %,


    $DISTINCT =						! Assign constant value
	%ASSIGN( $xpo$distinct, $xpo$distinct + 1 )
	%NUMBER( $xpo$distinct )

	%IF $xpo$show_lit
	%THEN
	    %PRINT( '			  ', %NUMBER($xpo$distinct) )
	%FI %,


    $SUB_FIELD( primary, sub0, sub1, sub2, sub3 ) =
	%IF %LENGTH NEQ 2 AND %LENGTH NEQ 5
	%THEN
	    %WARN( 'Invalid argument list' )
	    0,0,0,0
	    %EXITMACRO
	%FI

	%IF NOT %DECLARED( primary )
	%THEN
	    %WARN( '"', primary, '" has not been declared' )
	    0,0,0,0
	    %EXITMACRO
	%FI

	%IF %LENGTH EQL 2
	%THEN
	    %IF NOT %DECLARED( sub0 )
	    %THEN
		%WARN( '"', sub0, '" has not been declared' )
		0,0,0,0
		%EXITMACRO
	    %FI
										! Generate access-actuals from
	    %IF $xpo$full_based							! two field names:
	    %THEN
		%FIELDEXPAND(primary,0) + %FIELDEXPAND(sub0,0) +		! 1 - fullword index into block
		    ((%FIELDEXPAND(primary,1) + %FIELDEXPAND(sub0,1)) / %BPVAL ),
		(%FIELDEXPAND(primary,1) + %FIELDEXPAND(sub0,1)) MOD %BPVAL,	! 2 - bit index into fullword
	    %ELSE
		%FIELDEXPAND(primary,0) + %FIELDEXPAND(sub0,0) +		! 1 - unit index into block
		    ((%FIELDEXPAND(primary,1) + %FIELDEXPAND(sub0,1)) / %BPUNIT ),
		(%FIELDEXPAND(primary,1) + %FIELDEXPAND(sub0,1)) MOD %BPUNIT,	! 2 - bit index into unit
	    %FI
	    %FIELDEXPAND(sub0,2),						! 3 - field size in bits
	    %FIELDEXPAND(sub0,3)						! 4 - sign extension

	%ELSE									! Generate access-actuals from a
	    %IF $xpo$full_based							! field name and 4 access-actuals:
	    %THEN
		%FIELDEXPAND(primary,0) + sub0 +				! 1 - fullword index into block
		    ((%FIELDEXPAND(primary,1) + sub1) / %BPVAL ),
		(%FIELDEXPAND(primary,1) + sub1) MOD %BPVAL,			! 2 - bit index into fullword
	    %ELSE
		%FIELDEXPAND(primary,0) + sub0 +				! 1 - unit index into block
		    ((%FIELDEXPAND(primary,1) + sub1) / %BPUNIT ),
		(%FIELDEXPAND(primary,1) + sub1) MOD %BPUNIT,			! 2 - bit index into unit
	    %FI
	    sub2,								! 3 - field size in bits
	    sub3								! 4 - sign extension
	%FI %,


    $BLOCK =										! *** OBSOLETE ***
	%INFORM( 'The $BLOCK macro is obsolete - use BLOCK' )				! *** OBSOLETE ***
	BLOCK %,									! *** OBSOLETE ***


    $BLOCKVECTOR =									! *** OBSOLETE ***
	%INFORM( 'The $BLOCKVECTOR macro is obsolete - use BLOCKVECTOR' )		! *** OBSOLETE ***
	BLOCKVECTOR %,									! *** OBSOLETE ***


    $UNIT_BLOCK( arg1, arg2 ) =
	%IF %LENGTH NEQ 0 AND %LENGTH NEQ 1 AND %LENGTH NEQ 2
	%THEN
	    %WARN( 'Invalid number of arguments' )
	    %EXITMACRO
	%FI

	BLOCK[ arg1

	%IF %LENGTH EQL 2
	%THEN
	    , arg2 ;
	%FI

	%IF NOT %BLISS(BLISS36)
	%THEN
	    , BYTE
	%FI
	] %,


    $UNIT_BLOCKVECTOR( arg1, arg2, arg3, arg4 ) =
	%IF %LENGTH NEQ 1 AND %LENGTH NEQ 2 AND %LENGTH NEQ 4
	%THEN
	    %WARN( 'Invalid number of arguments' )
	    %EXITMACRO
	%FI

	BLOCKVECTOR[ arg1

	%IF %LENGTH GTR 1
	%THEN
	    , arg2
	%FI

	%IF %LENGTH EQL 4
	%THEN
	    , arg3, arg4
	%FI

	%IF NOT %BLISS(BLISS36)
	%THEN
	    , BYTE
	%FI
	] %,


    $SHOW( keyword ) [] =
	%IF NOT $xpo$key_test( keyword, (FIELDS, LITERALS, INFO, ALL, NOFIELDS, NOLITERALS, NOINFO, NONE) )
	%THEN
	    %EXITMACRO
	%FI

	%IF %IDENTICAL( keyword, FIELDS )
	%THEN
	    %ASSIGN( $xpo$show_field, 1 )
	%ELSE %IF %IDENTICAL( keyword, NOFIELDS )
	%THEN
	    %ASSIGN( $xpo$show_field, 0 )
	%ELSE %IF %IDENTICAL( keyword, LITERALS )
	%THEN
	    %ASSIGN( $xpo$show_lit, 1 )
	%ELSE %IF %IDENTICAL( keyword, NOLITERALS )
	%THEN
	    %ASSIGN( $xpo$show_lit, 0 )
	%ELSE %IF %IDENTICAL( keyword, INFO )
	%THEN
	    %ASSIGN( $xpo$show_info, 1 )
	%ELSE %IF %IDENTICAL( keyword, NOINFO )
	%THEN
	    %ASSIGN( $xpo$show_info, 0 )
	%ELSE %IF %IDENTICAL( keyword, ALL )
	%THEN
	    %ASSIGN( $xpo$show_field, 1 )
	    %ASSIGN( $xpo$show_lit, 1 )
	    %ASSIGN( $xpo$show_info, 1 )
	%ELSE
	    %ASSIGN( $xpo$show_field, 0 )
	    %ASSIGN( $xpo$show_lit, 0 )
	    %ASSIGN( $xpo$show_info, 0 )
	%FI %FI %FI %FI %FI %FI %FI %;

	$SHOW( ALL )					! Show everything during XPORT.REQ library pre-compilation


$LITERAL						! XPO$DUMP data type codes
	XPO$K_BYTE	= $DISTINCT,
	XPO$K_BYTES	= $DISTINCT,
	XPO$K_INTEGER	= $DISTINCT,
	XPO$K_TINY_INTE	= XPO$K_INTEGER,
	XPO$K_SHORT_INT	= XPO$K_INTEGER,
	XPO$K_LONG_INTE	= XPO$K_INTEGER,
	XPO$K_ADDRESS	= $DISTINCT,
	XPO$K_POINTER	= $DISTINCT,
	XPO$K_BIT	= $DISTINCT,
	XPO$K_BITS	= $DISTINCT,
	XPO$K_SUB_BLOCK	= $DISTINCT,
	XPO$K_DESCRIPTO	= $DISTINCT,
	XPO$K_REF_DESCR	= $DISTINCT,
	XPO$K_STRING	= $DISTINCT;


KEYWORDMACRO
    $XPO_DUMP_FIELD(
	field_name,					! name of the field to be dumped
	type,						! field data type
	value						! field value or address
	) =

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( XPO$DUMP_FIELD ) );

	OWN $str$field_name :  %EXPAND $STR_DESCRIPTOR( STRING = %STRING(field_name) );

	XPO$DUMP_FIELD( $str$field_name,  $xpo$name15('XPO$K_',type), value )
	END %;


MACRO
    $XPO$MASK_SET( prefix, field_name ) [ bit_name ] =
	%IF %COUNT EQL 0
	%THEN
	    %IF NOT %DECLARED(%NAME(prefix,field_name))
	    %THEN
		%WARN( prefix, field_name, ' is not defined' )
		%EXITMACRO
	    %FI
	%FI

	%IF NOT %DECLARED(%NAME(prefix,bit_name))
	%THEN
	    %WARN( prefix, bit_name, ' is not defined' )
	%ELSE
	    %IF %FIELDEXPAND(%NAME(prefix,bit_name),2) NEQ 1
	    %THEN
		%WARN( prefix, bit_name, ' is not a 1-bit field' )
	    %ELSE
		! The following statements generate a mask declaration similar to the following:
		!
		!	mask_name = 1 ^ ( B0 * %BPUNIT + B1 - F0 * %BPUNIT - F1 )
		!
		! where the field and bit definition are as follows:
		!
		!	field = [ F0, F1, ... ]
		!	bit   = [ B0, B1, ... ]
		!
		%ASSIGN( $xpo$temp,
			1 ^ ( %FIELDEXPAND(%NAME(prefix,bit_name),0) * %BPUNIT +
				%FIELDEXPAND(%NAME(prefix,bit_name),1) -
				%FIELDEXPAND(%NAME(prefix,field_name),0) * %BPUNIT -
				%FIELDEXPAND(%NAME(prefix,field_name),1) ) )

		%NAME(%EXACTSTRING(%CHARCOUNT(prefix)-2,0,prefix),'M_',bit_name) = %NUMBER( $xpo$temp )

		%IF $xpo$show_lit
		%THEN
		    %PRINT( '	',
			    %EXACTSTRING(%CHARCOUNT(prefix)-2,0,prefix),'M_',bit_name,
			    '	= ',
			    %NUMBER( $xpo$temp ) )
		%FI
	    %FI
	%FI %;
!
! STRDESC - XPORT String Descriptor
!
! This transportable string descriptor is modelled closely after the
! corresponding VAX-11 descriptor.
!

$FIELD	STR$H_LENGTH	= [$BYTES(2)] ;			! Number of characters in the string

FIELD	STR$B_DTYPE	= [$BYTE] ;			! Atomic data type code:
LITERAL	STR$K_DTYPE_T	= 14,				!    ASCII text string
	STR$K_DTYPE_X	= 190,				!    XPORT temporary string
	STR$K_DTYPE_XXX	= 191;				!    Erroreous XPORT temporary string

FIELD	STR$B_CLASS	= [$BYTE] ;			! Descriptor class code:
LITERAL	STR$K_CLASS_Z	= 0,				!    unspecified
	STR$K_CLASS_F	= 1,				!    fixed string
	STR$K_CLASS_D	= 2,				!    dynamic string
	STR$K_CLASS_B	= 3,				!    bounded string
	STR$K_CLASS_DB	= 99;				!    dynamic bounded string

FIELD	STR$A_POINTER	= [$POINTER] ;			! Pointer to the character string

LITERAL	STR$K_F_BLN	= $FIELD_SET_SIZE ,		! Length of a fixed descriptor
	STR$K_D_BLN	= $FIELD_SET_SIZE ;		! Length of a dynamic descriptor

FIELD	STR$H_MAXLEN	= [$BYTES(2)] ;			! Length of the container string
FIELD	STR$H_PFXLEN	= [$BYTES(2)] ;			! Length of the prefix string

LITERAL	STR$K_B_BLN	= $FIELD_SET_SIZE ,		! Length of a bounded descriptor
	STR$K_DB_BLN	= $FIELD_SET_SIZE ,		! Length of a dynamic bounded descriptor
	STR$K_Z_BLN	= $FIELD_SET_SIZE ;		! Maximum length of an undefined descriptor

! End of STRDESC

MACRO
    $str$f_fields =
	STR$H_LENGTH, STR$B_DTYPE, STR$B_CLASS, STR$A_POINTER %,

    $str$b_fields =
	%EXPAND $str$f_fields, STR$H_MAXLEN, STR$H_PFXLEN %;


MACRO												! *** OBSOLETE ***
    STR$K_DTYPE_Z =
	%INFORM( 'STR$K_DTYPE_Z is an obsolete name - use $XPO_DESCRIPTOR and XPO$K_DTYPE_BU' )
	XPO$K_DTYPE_BU %,

    STR$K_CLASS_S =
	%INFORM( 'STR$K_CLASS_S is an obsolete name - use STR$K_CLASS_F' )
	STR$K_CLASS_F %,

    STR$K_CLASS_V =
	%INFORM( 'STR$K_CLASS_V is an obsolete name - use STR$K_CLASS_B' )
	STR$K_CLASS_B %,

    STR$K_CLASS_DV =
	%INFORM( 'STR$K_CLASS_DV is an obsolete name - use STR$K_CLASS_DB' )
	STR$K_CLASS_DB %,

    STR$A_ADDRESS =
	%INFORM( 'STR$A_ADDRESS is an obsolete field - use $XPO_DESCRIPTOR and XPO$A_ADDRESS' )
	STR$A_POINTER %,

    STR$K_S_BLN =
	%INFORM( 'STR$K_S_BLN is an obsolete name - use STR$K_F_BLN' )
	STR$K_F_BLN %,

    STR$K_V_BLN =
	%INFORM( 'STR$K_V_BLN is an obsolete name - use STR$K_B_BLN' )
	STR$K_B_BLN %,

    STR$K_DV_BLN =
	%INFORM( 'STR$K_DV_BLN is an obsolete name - use STR$K_DB_BLN' )
	STR$K_DB_BLN %;
!
! String Descriptor Declaration and Initialization Macros
!

MACRO
    $str$desc_type( type ) =
	%IF %IDENTICAL(type,CHARACTERS) %THEN		STR$K_DTYPE_T	%ELSE
	%IF %IDENTICAL(type,FULLWORDS) OR
	    %IDENTICAL(type,UNITS) %THEN		XPO$K_DTYPE_BU	%ELSE
	%IF %IDENTICAL(type,XPORT_TEMPORARY) %THEN	STR$K_DTYPE_X	%ELSE
	%IF %IDENTICAL(type,XPORT_ERRONEOUS) %THEN	STR$K_DTYPE_XXX
	%FI %FI %FI %FI %,


    $str$desc_class( class ) =
	%IF %IDENTICAL(class,DYNAMIC_BOUNDED)
		OR %IDENTICAL(class,DYNAMIC_VARYING)						! *** OBSOLETE ***
	%THEN
	    STR$K_CLASS_DB
	%ELSE
	    %NAME( %EXACTSTRING( 13, 0, 'STR$K_CLASS_', class ) )
	%FI %,


    $str$literal( literal_text ) =
	CH$PTR( UPLIT  %BLISS16( BYTE )  %BLISS32( BYTE )  ( literal_text ) )%;


MACRO
    $STR_DESC = $STR_DESCRIPTOR %;


KEYWORDMACRO
    $STR_DESCRIPTOR(
	class=FIXED,					! descriptor class
	type,						! data type				! *** OBSOLETE ***
	string,						! string descriptor
	binary_data					! binary data descriptor		! *** OBSOLETE ***
	) =

	%IF NOT $xpo$key_check( class, (FIXED, DYNAMIC, BOUNDED, DYNAMIC_BOUNDED,		! *** OBSOLETE ***
					STATIC, VARYING, DYNAMIC_VARYING) )			! *** OBSOLETE ***
	%THEN											! *** OBSOLETE ***
	%IF NOT $xpo$key_test( class, (FIXED, DYNAMIC, BOUNDED, DYNAMIC_BOUNDED), 'CLASS=' )
	%THEN
	    %EXITMACRO
	%FI
	%FI											! *** OBSOLETE ***

	%IF $xpo$key_check( class, (STATIC, VARYING, DYNAMIC_VARYING) )				! *** OBSOLETE ***
	%THEN											! *** OBSOLETE ***
	    %INFORM( 'CLASS=', class, ' is obsolete - see current documentation' )		! *** OBSOLETE ***
	%FI											! *** OBSOLETE ***

	%IF NOT %NULL( binary_data )								! *** OBSOLETE ***
	%THEN											! *** OBSOLETE ***
	    %INFORM( 'BINARY_DATA= is obsolete - use the $XPO_DESCRIPTOR macro' )		! *** OBSOLETE ***
	%FI											! *** OBSOLETE ***

	%IF NOT %NULL(type)
	%THEN
	    %IF NOT %IDENTICAL(type,XPORT_TEMPORARY) AND NOT %IDENTICAL(type,XPORT_ERRONEOUS)
	    %THEN
		%INFORM( 'TYPE= is obsolete - see current documentation' )			! *** OBSOLETE ***
		%IF NOT $xpo$key_test( type, (CHARACTERS, FULLWORDS, UNITS), 'TYPE=' )
		%THEN
		    %EXITMACRO
		%FI
	    %FI
	%FI

	%IF %EXPAND $xpo$conflict( string, binary_data, type )					! *** OBSOLETE ***
	%THEN											! *** OBSOLETE ***
	    %WARN( 'TYPE=, STRING=, and BINARY_DATA= are mutually exclusive' )			! *** OBSOLETE ***
	%FI											! *** OBSOLETE ***

	%IF NOT %NULL(string) AND NOT ( $xpo$paren_test(string) OR %ISSTRING(%REMOVE(string)) )
	%THEN
	    %WARN( 'STRING=descriptor is not permitted' )
	    %EXITMACRO
	%FI

	%IF NOT %NULL(string) AND NOT %IDENTICAL( $xpo$arg1(%REMOVE(string)), 0 )
	    AND NOT ( %IDENTICAL(class,FIXED) OR %IDENTICAL(class,BOUNDED) )
	%THEN
	    %WARN( 'STRING=literal or STRING=(len,ptr) requires CLASS=FIXED or CLASS=BOUNDED' )
	    %EXITMACRO
	%FI

	%IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
		OR %IDENTICAL(class,VARYING) OR %IDENTICAL(class,DYNAMIC_VARYING)		! *** OBSOLETE ***
	%THEN
	    BLOCK[STR$K_B_BLN]  FIELD( %EXPAND $str$b_fields )
	%ELSE
	    BLOCK[STR$K_F_BLN]  FIELD( %EXPAND $str$f_fields )
	%FI

	%IF %NULL( type string binary_data )		! Speedup expansion in most situations.
	%THEN
	    %EXITMACRO
	%FI

	%IF NOT %NULL(type)
	%THEN
	    PRESET( [STR$B_DTYPE] = %EXPAND $str$desc_type( type ),
		    [STR$B_CLASS] = %EXPAND $str$desc_class( class ) )
	%FI

	%IF NOT %NULL(string)
	%THEN
	    PRESET( [STR$B_DTYPE] = STR$K_DTYPE_T,
		    [STR$B_CLASS] = %EXPAND $str$desc_class( class ),
	    %IF %ISSTRING( %REMOVE(string) )
	    %THEN
		    [STR$H_LENGTH] = %CHARCOUNT( %REMOVE(string) ),
		    [STR$A_POINTER] = %EXPAND $str$literal( %QUOTE %REMOVE(string) )
	    %ELSE
		    [STR$A_POINTER] = $xpo$arg2( %REMOVE(string) ),
		%IF %IDENTICAL(class,FIXED) OR %IDENTICAL(class,DYNAMIC)
		%THEN
		    [STR$H_LENGTH] = $xpo$arg1( %REMOVE(string) )
		%ELSE
		    [STR$H_MAXLEN] = $xpo$arg1( %REMOVE(string) )
		%FI
	    %FI
	    )						! End of STRING PRESET list
	%FI

	%IF NOT %NULL(binary_data)								! *** OBSOLETE ***
	%THEN											! *** OBSOLETE ***
	    PRESET( [STR$B_DTYPE] = XPO$K_DTYPE_BU,						! *** OBSOLETE ***
		    [STR$B_CLASS] = %EXPAND $str$desc_class(class),				! *** OBSOLETE ***
		    [STR$A_POINTER] = $xpo$arg2( %REMOVE(binary_data) ),			! *** OBSOLETE ***
	    %IF %IDENTICAL(class,FIXED) OR %IDENTICAL(class,DYNAMIC)				! *** OBSOLETE ***
	    %THEN										! *** OBSOLETE ***
		    [STR$H_LENGTH] = $xpo$bin_len( %REMOVE(binary_data) )			! *** OBSOLETE ***
	    %ELSE										! *** OBSOLETE ***
		    [STR$H_MAXLEN] = $xpo$bin_len( %REMOVE(binary_data) )			! *** OBSOLETE ***
	    %FI											! *** OBSOLETE ***
	    )						! End of BINARY_DATA PRESET list	! *** OBSOLETE ***
	%FI %,


    $STR_DESC_INIT(
	desc,						! address of descriptor
	descriptor,					! address of descriptor
	class=FIXED,					! descriptor class
	type,						! data type				! *** OBSOLETE ***
	string,						! string descriptor
	binary_data					! binary data descriptor		! *** OBSOLETE ***
	) =

	%IF NOT $xpo$key_check( class, (FIXED, DYNAMIC, BOUNDED, DYNAMIC_BOUNDED,		! *** OBSOLETE ***
					STATIC, VARYING, DYNAMIC_VARYING) )			! *** OBSOLETE ***
	%THEN											! *** OBSOLETE ***
	%IF NOT $xpo$key_test( class, (FIXED, DYNAMIC, BOUNDED, DYNAMIC_BOUNDED), 'CLASS=' )
	%THEN
	    %EXITMACRO
	%FI
	%FI											! *** OBSOLETE ***

	%IF $xpo$key_check( class, (STATIC, VARYING, DYNAMIC_VARYING) )				! *** OBSOLETE ***
	%THEN											! *** OBSOLETE ***
	    %INFORM( 'CLASS=', class, ' is obsolete - see current documentation' )		! *** OBSOLETE ***
	%FI											! *** OBSOLETE ***

	%IF %EXPAND $xpo$conflict( desc, descriptor )
	%THEN
	    %WARN( 'DESC= and DESCRIPTOR= are mutually exclusive' )
	%FI

	%IF NOT %NULL(type)
	%THEN
	    %IF NOT %IDENTICAL(type,XPORT_TEMPORARY) AND NOT %IDENTICAL(type,XPORT_ERRONEOUS)
	    %THEN
		%INFORM( 'TYPE= is obsolete - see current documentation' )			! *** OBSOLETE ***
		%IF NOT $xpo$key_test( type, (CHARACTERS, FULLWORDS, UNITS), 'TYPE=' )
		%THEN
		    %EXITMACRO
		%FI
	    %FI
	%FI

	%IF %EXPAND $xpo$conflict( string, binary_data, type )					! *** OBSOLETE ***
	%THEN											! *** OBSOLETE ***
	    %WARN( 'TYPE=, STRING=, and BINARY_DATA= are mutually exclusive' )			! *** OBSOLETE ***
	%FI											! *** OBSOLETE ***

	%IF %ISSTRING( %REMOVE(string) ) AND NOT %IDENTICAL(class,FIXED)
	%THEN
	    %WARN( 'STRING=literal requires CLASS=FIXED' )
	    %EXITMACRO
	%FI

	%EXPAND $xpo$required( desc descriptor, 'DESC= or DESCRIPTOR=' )

	BEGIN
	BIND $str$desc = desc descriptor :  %EXPAND $xpo$force( $STR_DESCRIPTOR( %QUOTE CLASS=BOUNDED ) );
	BIND $str$bin_desc = desc descriptor :  $XPO_DESCRIPTOR( %QUOTE CLASS=BOUNDED );	! *** OBSOLETE ***

	%IF NOT %NULL(type)
	%THEN
	    $str$desc[STR$H_LENGTH] = 0;
	    $str$desc[STR$B_DTYPE] = %EXPAND $str$desc_type( type );
	    $str$desc[STR$B_CLASS] = %EXPAND $str$desc_class( class );
	    $str$desc[STR$A_POINTER] = 0;
	    %IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
		OR %IDENTICAL(class,VARYING) OR %IDENTICAL(class,DYNAMIC_VARYING)		! *** OBSOLETE ***
	    %THEN
		$str$desc[STR$H_MAXLEN] = 0;
		$str$desc[STR$H_PFXLEN] = 0;
	    %FI
	%ELSE %IF %NULL(string)
			AND %NULL(binary_data)							! *** OBSOLETE ***
	%THEN
	    $str$desc[STR$H_LENGTH] = 0;
	    $str$desc[STR$B_DTYPE] = STR$K_DTYPE_T;
	    $str$desc[STR$B_CLASS] = %EXPAND $str$desc_class( class );
	    $str$desc[STR$A_POINTER] = 0;
	    %IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
		OR %IDENTICAL(class,VARYING) OR %IDENTICAL(class,DYNAMIC_VARYING)		! *** OBSOLETE ***
	    %THEN
		$str$desc[STR$H_MAXLEN] = 0;
		$str$desc[STR$H_PFXLEN] = 0;
	    %FI
	%ELSE
	    $str$str_desc( $str$desc, class, string )
	    $xpo$bin_desc( $str$bin_desc, class, binary_data )					! *** OBSOLETE ***
	%FI %FI

	XPO$_NORMAL					! normal completion code
	END %;


MACRO
    $STR$STR_DESC( desc, class, string_desc ) [] =
	%IF %ISSTRING( %REMOVE(string_desc) )
	%THEN
	    desc[STR$H_LENGTH] = %CHARCOUNT( %REMOVE(string_desc) );
	    desc[STR$B_DTYPE] = STR$K_DTYPE_T;
	    desc[STR$B_CLASS] = %EXPAND $str$desc_class( class );
	    desc[STR$A_POINTER] = %EXPAND $str$literal( %QUOTE %REMOVE(string_desc) );
	%ELSE
	    %IF NOT $xpo$paren_test( string_desc )
	    %THEN
		BEGIN
		BIND $str$$desc = string_desc :  %EXPAND $xpo$force( $STR_DESCRIPTOR() );
		%IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
			OR %IDENTICAL(class,VARYING) OR %IDENTICAL(class,DYNAMIC_VARYING)	! *** OBSOLETE ***
		%THEN
		    desc[STR$H_LENGTH] = 0;
		%ELSE
		    desc[STR$H_LENGTH] = .$str$$desc[STR$H_LENGTH];
		%FI
		desc[STR$B_DTYPE] = .$str$$desc[STR$B_DTYPE];
		desc[STR$B_CLASS] = %EXPAND $str$desc_class( class );
		desc[STR$A_POINTER] = .$str$$desc[STR$A_POINTER];
		%IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
			OR %IDENTICAL(class,VARYING) OR %IDENTICAL(class,DYNAMIC_VARYING)	! *** OBSOLETE ***
		%THEN
		    desc[STR$H_MAXLEN] =.$str$$desc[STR$H_LENGTH];
		    desc[STR$H_PFXLEN] = 0;
		%FI
		END;
	    %ELSE
		%IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
			OR %IDENTICAL(class,VARYING) OR %IDENTICAL(class,DYNAMIC_VARYING)	! *** OBSOLETE ***
		%THEN
		    desc[STR$H_LENGTH] = 0;
		%ELSE
		    desc[STR$H_LENGTH] = $xpo$arg1( %REMOVE(string_desc) );
		%FI
		desc[STR$B_DTYPE] = STR$K_DTYPE_T;
		desc[STR$B_CLASS] = %EXPAND $str$desc_class( class );
		desc[STR$A_POINTER] = $xpo$arg2( %REMOVE(string_desc) );
		%IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
			OR %IDENTICAL(class,VARYING) OR %IDENTICAL(class,DYNAMIC_VARYING)	! *** OBSOLETE ***
		%THEN
		    desc[STR$H_MAXLEN] = $xpo$arg1( %REMOVE(string_desc) );
		    desc[STR$H_PFXLEN] = 0;
		%FI
	    %FI
	%FI %,


    $STR$DECLARE( type, name, string_info ) [] =
	%IF $xpo$key_test( type, (BIND, LOCAL), 'Type' )
	%THEN
	    %IF %ISSTRING( %REMOVE(string_info) )	! STRING = 'literal text'
	    %THEN
		OWN name :  %EXPAND $STR_DESCRIPTOR( STRING = %QUOTE %REMOVE(string_info) );
	    %ELSE
		%IF $xpo$paren_test( string_info )	! STRING = (length,pointer)
		%THEN
		    %IF %IDENTICAL(type,BIND)
		    %THEN
			BIND name = $FORMAT( string_info );
		    %ELSE
			LOCAL name :  %EXPAND $xpo$force( $STR_DESCRIPTOR() );
		    %FI
		%ELSE
		    BIND name = string_info;		! STRING = address of a descriptor
		%FI
	    %FI
	%FI %,


    $STR$LOCAL_INIT( name, string_info ) [] =
	%IF NOT %ISSTRING( %REMOVE(string_info) ) AND $xpo$paren_test( string_info )
	%THEN
	    $str$str_desc( name, FIXED, string_info )
	%FI %,


    $STR_FREE_TEMP( string ) =
	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( STR$FREE_TEMP ) )

	STR$FREE_TEMP( string )
	END %;
!
! BINDESC - XPORT Binary Data Descriptor
!
! This transportable data descriptor is modelled closely after the
! corresponding VAX-11 descriptor.
!

$FIELD	XPO$H_LENGTH	= [$BYTES(2)] ;			! Length of the binary data units

FIELD	XPO$B_DTYPE	= [$BYTE] ;			! Atomic data type code:
LITERAL	XPO$K_DTYPE_BU	= 2;				!    XPORT binary data (binary units)

FIELD	XPO$B_CLASS	= [$BYTE] ;			! Descriptor class code:
LITERAL	XPO$K_CLASS_Z	= 0,				!    unspecified
	XPO$K_CLASS_F	= 1,				!    fixed binary data
	XPO$K_CLASS_D	= 2,				!    dynamic binary data
	XPO$K_CLASS_B	= 3,				!    bounded binary data
	XPO$K_CLASS_DB	= 99;				!    dynamic bounded binary data

FIELD	XPO$A_ADDRESS	= [$POINTER] ;			! Address of the binary data

LITERAL	XPO$K_S_BLN	= $FIELD_SET_SIZE ,		! Length of a static descriptor
	XPO$K_D_BLN	= $FIELD_SET_SIZE ;		! Length of a dynamic descriptor

FIELD	XPO$H_MAXLEN	= [$BYTES(2)] ;			! Maximum length of the binary data
FIELD	XPO$H_PFXLEN	= [$BYTES(2)] ;			! Length of the binary data prefix

LITERAL	XPO$K_B_BLN	= $FIELD_SET_SIZE ,		! Length of a bounded descriptor
	XPO$K_DB_BLN	= $FIELD_SET_SIZE ,		! Length of a dynamic bounded descriptor
	XPO$K_Z_BLN	= $FIELD_SET_SIZE ;		! Maximum length of an undefined descriptor

! End of BINDESC

MACRO
    $xpo$f_fields =
	XPO$H_LENGTH, XPO$B_DTYPE, XPO$B_CLASS, XPO$A_ADDRESS %,

    $xpo$b_fields =
	%EXPAND $xpo$f_fields, XPO$H_MAXLEN, XPO$H_PFXLEN %;

MACRO												! *** OBSOLETE ***
    XPO$K_DTYPE_Z =
	%INFORM( 'XPO$K_DTYPE_Z is an obsolete name - use XPO$K_DTYPE_BU' ) %;
!
! Binary Data Descriptor Declaration and Initialization Macros
!

MACRO
    $xpo$desc_class( class ) =
	%IF %IDENTICAL(class,DYNAMIC_BOUNDED)
	%THEN
	    XPO$K_CLASS_DB
	%ELSE
	    %NAME( %EXACTSTRING( 13, 0, 'XPO$K_CLASS_', class ) )
	%FI %;


MACRO
    $XPO_DESC = $XPO_DESCRIPTOR %;


KEYWORDMACRO
    $XPO_DESCRIPTOR(
	class=FIXED,					! descriptor class
	binary_data					! binary data descriptor
	) =

	%IF NOT $xpo$key_test( class, (FIXED, DYNAMIC, BOUNDED, DYNAMIC_BOUNDED), 'CLASS=' )
	%THEN
	    %EXITMACRO
	%FI

	%IF NOT %NULL(binary_data) AND NOT $xpo$paren_test(binary_data)
	%THEN
	    %WARN( 'BINARY_DATA=descriptor is not permitted' )
	    %EXITMACRO
	%FI

	%IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
	%THEN
	    BLOCK[XPO$K_B_BLN]  FIELD( %EXPAND $xpo$b_fields )
	%ELSE
	    BLOCK[XPO$K_S_BLN]  FIELD( %EXPAND $xpo$f_fields )
	%FI

	%IF NOT %NULL(binary_data)
	%THEN
	    PRESET( [XPO$B_DTYPE] = XPO$K_DTYPE_BU,
		    [XPO$B_CLASS] = %EXPAND $xpo$desc_class(class),
		    [XPO$A_ADDRESS] = $xpo$arg2( %REMOVE(binary_data) ),
	    %IF %IDENTICAL(class,FIXED) OR %IDENTICAL(class,DYNAMIC)
	    %THEN
		    [XPO$H_LENGTH] = $xpo$bin_len( %REMOVE(binary_data) )
	    %ELSE
		    [XPO$H_MAXLEN] = $xpo$bin_len( %REMOVE(binary_data) )
	    %FI
	    )						! End of BINARY_DATA PRESET list
	%FI %,


    $XPO_DESC_INIT(
	desc,						! address of descriptor
	descriptor,					! address of descriptor
	class=FIXED,					! descriptor class
	binary_data					! binary data descriptor
	) =

	%IF NOT $xpo$key_test( class, (FIXED, DYNAMIC, BOUNDED, DYNAMIC_BOUNDED), 'CLASS=' )
	%THEN
	    %EXITMACRO
	%FI

	%IF NOT %NULL(binary_data) AND NOT $xpo$paren_test(binary_data)
	%THEN
	    %WARN( 'BINARY_DATA=descriptor is not permitted' )
	    %EXITMACRO
	%FI

	%IF $xpo$conflict( desc, descriptor )
	%THEN
	    %WARN( 'DESC= and DESCRIPTOR= are mutually exclusive' )
	%FI

	%EXPAND $xpo$required( desc descriptor, 'DESC= or DESCRIPTOR=' )

	BEGIN
	BIND $xpo$desc = descriptor :  %EXPAND $xpo$force( $XPO_DESCRIPTOR( %QUOTE CLASS=BOUNDED ) );

	%IF %NULL( binary_data )
	%THEN
	    $xpo$desc[XPO$H_LENGTH] = 0;
	    $xpo$desc[XPO$B_DTYPE] = XPO$K_DTYPE_BU;
	    $xpo$desc[XPO$B_CLASS] = $xpo$desc_class( class );
	    $xpo$desc[XPO$A_ADDRESS] = 0;
	    %IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
	    %THEN
		$xpo$desc[XPO$H_MAXLEN] = 0;
		$xpo$desc[XPO$H_PFXLEN] = 0;
	    %FI
	%ELSE
	    $xpo$bin_desc( $xpo$desc, class, binary_data )
	%FI

	XPO$_NORMAL					! normal completion code
	END %;

MACRO
    $XPO$BIN_DESC( desc, class, data_desc ) [] =

	%IF NOT %NULL( $xpo$arg3( %REMOVE(data_desc) ) )
	%THEN
	    %IF NOT $xpo$key_test( $xpo$arg3( %REMOVE(data_desc) ), (FULLWORDS, UNITS) )
	    %THEN
		%EXITMACRO
	    %FI
	%FI

	%IF NOT $xpo$paren_test( data_desc )
	%THEN
	    BEGIN
	    BIND $bin$$desc = data_desc :  %EXPAND $xpo$force( $XPO_DESCRIPTOR() );
		%IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
		%THEN
		    desc[XPO$H_LENGTH] = 0;
		%ELSE
		    desc[XPO$H_LENGTH] = .$bin$$desc[XPO$H_LENGTH];
		%FI
	    desc[XPO$B_DTYPE] = .$bin$$desc[XPO$B_DTYPE];
	    desc[XPO$B_CLASS] = %EXPAND $xpo$desc_class( class );
	    desc[XPO$A_ADDRESS] = .$bin$$desc[XPO$A_ADDRESS];
		%IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
		%THEN
		    desc[XPO$H_MAXLEN] =.$bin$$desc[XPO$H_LENGTH];
		    desc[XPO$H_PFXLEN] = 0;
		%FI
	    END;
	%ELSE
	    %IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
	    %THEN
		desc[XPO$H_LENGTH] = 0;
	    %ELSE
		desc[XPO$H_LENGTH] = $xpo$bin_len( %REMOVE(data_desc) );
	    %FI
	    desc[XPO$B_DTYPE] = XPO$K_DTYPE_BU;
	    desc[XPO$B_CLASS] = %EXPAND $xpo$desc_class( class );
	    desc[XPO$A_ADDRESS] = $xpo$arg2( %REMOVE(data_desc) );
	    %IF %IDENTICAL(class,BOUNDED) OR %IDENTICAL(class,DYNAMIC_BOUNDED)
	    %THEN
		desc[XPO$H_MAXLEN] = $xpo$bin_len( %REMOVE(data_desc) );
		desc[XPO$H_PFXLEN] = 0;
	    %FI
	%FI %,


    $xpo$bin_len( length, address, keyword ) =
	%IF %IDENTICAL( keyword, UNITS )
	%THEN
	    length
	%ELSE
	    %UPVAL * (length)
	%FI %,


    $BIN$DECLARE( name, binary_info ) [] =
	%IF $xpo$paren_test( binary_info )		! BINARY_DATA = (length,pointer)
	%THEN
	    LOCAL name :  %EXPAND $xpo$force( $XPO_DESCRIPTOR() );
	%ELSE
	    BIND name = binary_info;			! BINARY_DATA = address of a descriptor
	%FI %,


    $BIN$LOCAL_INIT( name, binary_info ) [] =
	%IF $xpo$paren_test( binary_info )
	%THEN
	    $xpo$bin_desc( name, FIXED, binary_info )
	%FI %;
!
! DATE_TIME - XPORT Date and Time Block
!

	    $SHOW( NOINFO )				! Turn off BLISS-16 %INFORM messages

$FIELD	$xpo$dt_fields = SET
	XPO$G_DATE	= [$LONG_INTEGER] ,		! Day number (0 = ??????)
	XPO$B_MONTH	= [$BYTE] ,			! Month number (1 = January, ...)
	XPO$B_DAY	= [$BYTE] ,			! Day of month
	XPO$B_YEAR	= [$BYTES(2)] ,			! Year (e.g., 1979)

	XPO$G_TIME	= [$LONG_INTEGER] ,		! Time of day (100ths of second since midnight)
	XPO$B_HOUR	= [$BYTE] ,			! Hours since midnight
	XPO$B_MINUTE	= [$BYTE] ,			! Minutes since last hour
	XPO$B_100THS	= [$BYTES(2)]			! 100ths of second since last minute
	TES;
LITERAL	XPO$K_DT_LEN	= $FIELD_SET_SIZE;		! Length of date/time block

	    $SHOW( INFO )				! Turn %INFORM messages back on


MACRO
    $XPO_DATE_TIME =
	BLOCK[XPO$K_DT_LEN]  FIELD( $xpo$dt_fields ) %;
!
! XIOB - XPORT File I/O Block
!
!	CBDOC: FUNCTION codes in comments
!

$FIELD	$iob$fields_1 = SET
	IOB$H_LENGTH	= [$SHORT_INTEGER] ,		! Length of IOB (number of elements) >all <init
	IOB$B_VERSION	= [$TINY_INTEGER] ,		! XPORT version number <init
	IOB$B_LEVEL	= [$TINY_INTEGER] ,		! XPORT base level number <init
	IOB$A_FILE_SPEC	= [$REF_DESCRIPTOR] ,		! Address of primary file specification descriptor >open, delete, rename
	IOB$A_DEFAULT	= [$REF_DESCRIPTOR] ,		! Address of default file specification descriptor >open, delete, rename
	IOB$A_RELATED	= [$REF_DESCRIPTOR] ,		! Address of related file specification descriptor >open, delete, rename
	IOB$T_CONCAT	= [$DESCRIPTOR(DYNAMIC_BOUNDED)],	! Concatenated input file specificationdescriptor >open <open
	IOB$T_RESULTANT	= [$DESCRIPTOR(DYNAMIC)] ,	! Resultant file specification descriptor >close, backup <open, delete, rename
	IOB$A_PROMPT	= [$REF_DESCRIPTOR] ,		! Address of read prompt descriptor >get-char

	IOB$A_ASSOC_IOB	= [$ADDRESS] ,			! Address of associated IOB >backup, rename

	IOB$B_FUNCTION	= [$BYTE]			! I/O function code: >all
	TES;						!
$LITERAL
	IOB$K_OPEN	= $DISTINCT ,			!    open file
	IOB$K_CLOSE	= $DISTINCT ,			!    close file
	IOB$K_DELETE	= $DISTINCT ,			!    delete file
	IOB$K_RENAME	= $DISTINCT ,			!    rename file
	IOB$K_BACKUP	= $DISTINCT ,			!    create backup copy of input file
	IOB$K_GET	= $DISTINCT ,			!    get record (locate mode)
	IOB$K_PUT	= $DISTINCT ;			!    put record (move mode)

	    $ALIGN( WORD )
FIELD	$iob$fields_2 = SET
	IOB$V_OPTIONS	= [$BITS(16)] ,			! I/O option flags:
	    $OVERLAY( IOB$V_OPTIONS )			!
	IOB$V_INPUT	= [$BIT] ,			!    open for input >open, get
	IOB$V_OUTPUT	= [$BIT] ,			!    open for output >open, put
	IOB$V_OVERWRITE	= [$BIT] ,			!    overwrite existing output file >open-out
	IOB$V_APPEND	= [$BIT] ,			!    append to existing output file >open-out
	IOB$V_REMEMBER	= [$BIT] ,			!    file will be reprocessed after close >close
	IOB$V_MAX_VERSI	= [$BIT] ,			!    maximize file version number (internal) >open, rename
	    $CONTINUE

	    $ALIGN( WORD )
	IOB$V_ATTRIBUTE	= [$BITS(16)] ,			! File attributes:
	    $OVERLAY( IOB$V_ATTRIBUTE )			!
	IOB$V_BINARY	= [$BIT] ,			!    binary data >open, get, put
	IOB$V_CHARACTER	= [$BIT] ,			!    character data <open
	IOB$V_STREAM	= [$BIT] ,			!    stream-oriented character data >open, get, put
	IOB$V_RECORD	= [$BIT] ,			!    record-oriented character data >open, get, put
	IOB$V_SEQUENCED	= [$BIT] ,			!    sequence-numbered records >open-out, put <open-in
	    $CONTINUE

	    $ALIGN( WORD )
	IOB$V_STATUS	= [$BITS(16)] ,			! Current file status:
	    $OVERLAY( IOB$V_STATUS )			!
	IOB$V_OPEN	= [$BIT] ,			!    file is open >all <open
	IOB$V_EOF	= [$BIT] ,			!    end-of-file detected >get, put <get, put
	IOB$V_CLOSED	= [$BIT] ,			!    file is closed >open <close
	IOB$V_AUTO_CONC	= [$BIT] ,			!    input file switching in progress >open <get-conc
	IOB$V_TERMINAL	= [$BIT] ,			!    I/O device is a terminal >get, put <open
	IOB$V_TEMPORARY	= [$BIT] ,			!    XPORT temporary file >open, close <open
	IOB$V_CONC_SPEC	= [$BIT] ,			!    primary file-spec is a concatenated file-spec >close <open
	    $CONTINUE

	IOB$T_STRING	= [$DESCRIPTOR(DYNAMIC_BOUNDED)] ,	! Character input string descriptor:
	    $OVERLAY( $SUB_FIELD(IOB$T_STRING,STR$H_LENGTH) )
	IOB$H_STRING	= [$BYTES(2)] ,			!    length of the character string >get-stream <get-char
	    $OVERLAY( $SUB_FIELD(IOB$T_STRING,STR$A_POINTER) )
	IOB$A_STRING	= [$POINTER] ,			!    pointer to the character string <get-char
	    $CONTINUE

	    $OVERLAY( IOB$T_STRING )
	IOB$T_DATA	= [$DESCRIPTOR(DYNAMIC_BOUNDED)] ,	! Binary input data descriptor (overlays IOB$T_STRING):
	    $OVERLAY( $SUB_FIELD(IOB$T_DATA,STR$H_LENGTH) )
	IOB$H_UNITS	= [$BYTES(2)] ,			!    length of the data in addressable units >get-bin <get-bin
	    $OVERLAY( $SUB_FIELD(IOB$T_DATA,XPO$A_ADDRESS) )
	IOB$A_DATA	= [$ADDRESS] ,			!    address of the data <get-bin
	    $CONTINUE

	IOB$H_FULLWORDS	= [$BYTES(2)] ,			!    length of the data in BLISS fullwords <get-full

	    $ALIGN( FULLWORD )
	IOB$A_OUTPUT	= [$REF_DESCRIPTOR] ,		! Address of character/binary output descriptor >put

	    $OVERLAY( IOB$A_OUTPUT )
	IOB$A_BACK_TYPE	= [$REF_DESCRIPTOR] ,		! Address of backup file type descriptor (overlays IOB$A_OUTPUT) >backup

	IOB$H_PREV_PAGE	= [$SHORT_INTEGER] ,		! Page number of previous output line (internal) >put-seq <put-seq
	IOB$H_PAGE_NUMB	= [$SHORT_INTEGER] ,		! Current page number >put-seq <get-seq
	    $ALIGN( FULLWORD )
	IOB$G_SEQ_NUMB	= [$INTEGER] ,			! Sequence number of current record >put-seq <get
	IOB$G_PREV_REC	= [$INTEGER] ,			! Number of last direct record read or written (future)
	IOB$G_REC_NUMB	= [$INTEGER] ,			! Direct-access record number (future)
	IOB$G_REC_SIZE	= [$INTEGER] ,			! Fixed record size (0 = variable length records) >open-out <open
	IOB$G_BLK_SIZE	= [$INTEGER] ,			! Block size >open-out <open

	IOB$Z_CREATED	= [$SUB_BLOCK(XPO$K_DT_LEN)] ,	! File creation date and time (future)
	IOB$Z_REVISED	= [$SUB_BLOCK(XPO$K_DT_LEN)] ,	! File revision date and time (future)

	$IOB$FILLER1	= [$SUB_BLOCK(16)] ,		! Reserved for future use
	$IOB$FILLER2	= [$SHORT_INTEGER] ,		! Reserved for future use
	$IOB$FILLER3	= [$SHORT_INTEGER] ,		! Reserved for future use
	$IOB$FILLER4	= [$SHORT_INTEGER] ,		! Reserved for future use
	$IOB$FILLER5	= [$SHORT_INTEGER] ,		! Reserved for future use
	$IOB$FILLER6	= [$INTEGER] ,			! Reserved for future use
	$IOB$FILLER7	= [$INTEGER] ,			! Reserved for future use
	$IOB$FILLER8	= [$INTEGER] ,			! Reserved for future use
	$IOB$FILLER9	= [$INTEGER] ,			! Reserved for future use

	IOB$G_COMP_CODE	= [$INTEGER] ,			! Completion code of current operation <all
	IOB$G_2ND_CODE	= [$INTEGER] ,			! Secondary completion code <all

	IOB$Z_USER	= [$INTEGER] ,			! User-defined value
	IOB$G_USER_CODE	= [$INTEGER] ,			! User-defined completion code

	IOB$A_BUFFER_CB	= [$ADDRESS] ,			! Address of TOPS-10 buffer control block >get, put <open
	    $OVERLAY( IOB$A_BUFFER_CB )
	IOB$A_RMS_FAB	= [$ADDRESS] ,			! Address of RMS FAB (system-specific) >close <open
	IOB$A_RMS_RAB	= [$ADDRESS] ,			! Address of RMS RAB (system-specific) >get, put <open
	    $OVERLAY( IOB$A_BUFFER_CB )
	IOB$A_FCS_FDB	= [$ADDRESS] ,			! Address of FCS FDB (system-specific) >get put close <open
	    $CONTINUE
	    $OVERLAY( IOB$A_BUFFER_CB )
	IOB$A_RSTS_CB	= [$ADDRESS] ,			! Address of RSTS control block >get put close <open
	    $CONTINUE
	IOB$H_CHANNEL	= [$SHORT_INTEGER]		! I/O channel number (system-specific) >get put close <open
	TES;
LITERAL	IOB$K_LENGTH	= $FIELD_SET_SIZE ;		! Length of standard IOB >init

! End of XIOB

MACRO	$iob$fields =					! Define entire IOB field set
		$iob$fields_1, $iob$fields_2 %;

MACRO
    IOB$T_FILE_SPEC =
	%WARN( 'IOB$T_FILE_SPEC (descriptor) has been replaced by IOB$A_FILE_SPEC (address of descriptor)' )
	IOB$T_RESULTANT %,

    IOB$T_DEFAULT =
	%WARN( 'IOB$T_DEFAULT (descriptor) has been replaced by IOB$A_DEFAULT (address of descriptor)' )
	IOB$T_RESULTANT %,

    IOB$T_RELATED =
	%WARN( 'IOB$T_RELATED (descriptor) has been replaced by IOB$A_RELATED (address of descriptor)' )
	IOB$T_RESULTANT %,

    IOB$T_PROMPT =
	%WARN( 'IOB$T_PROMPT (descriptor) has been replaced by IOB$A_PROMPT (address of descriptor)' )
	IOB$T_RESULTANT %,

    IOB$T_OUTPUT =
	%WARN( 'IOB$T_OUTPUT (descriptor) has been replaced by IOB$A_OUTPUT (address of descriptor)' )
	IOB$T_RESULTANT %,

    IOB$T_BACK_TYPE =
	%WARN( 'IOB$T_BACK_TYPE (descriptor) has been replaced by IOB$A_BACK_TYPE (address of descriptor)' )
	IOB$T_RESULTANT %;
!
! XPORT I/O Control Block and Interface Macros
!

MACRO
    $IOB$NOT_ALLOWED( keyword, value, function ) =
	%IF NOT %NULL( value )
	%THEN
	    %WARN( keyword, ' may not be specified during IOB ', function )
	%FI %,

    $IOB$STRING( field_name, string_name, string_info ) [] =
	iob$[ field_name ] = string_name; %,


    $IOB$GET_LENGTH( data_code, value ) [] =
	iob$[IOB$H_STRING] = value;
	iob$[ %EXPAND $xpo$force( $SUB_FIELD(IOB$T_STRING,STR$B_DTYPE) ) ] = data_code; %,


    $XPO$IO_CALL( function, success, failure ) =

	%IF %IDENTICAL( failure, XPO$IO_FAIL_MSG )
	%THEN
	    %WARN( 'FAILURE=XPO$IO_FAIL_MSG is obsolete - FAILURE=XPO$FAILURE is now the default' )
	%FI

	iob$[IOB$B_FUNCTION] = %QUOTE %EXPAND %NAME( 'IOB$K_', function );

	BEGIN

	%QUOTE %EXPAND $xpo$force( $xpo$ex_routine( %QUOTE %EXPAND %NAME('XPO$',function) ) )

	%EXPAND $xpo$ex_failure( failure )

	%QUOTE %EXPAND %NAME('XPO$',function)( iob$,
						%EXPAND $XPO$DEFAULT(success,0),
						%EXPAND $XPO$DEFAULT(failure,0) )

	END %;


KEYWORDMACRO
    $XPO_IOB(
	file_spec,					! primary file specification information
	default,					! default file specification information
	related,					! related file specification information
	option,						! option keyword
	options,					! option keywords
	attribute,					! file attribute keywords
	attributes,					! file attribute keywords
	prompt,						! read prompt string information
	binary_data,					! binary data information
	string,						! character string information
	characters,					! length of I/O request
	fullwords,					! length of I/O request
	units,						! length of I/O request
	page_number,					! page number
	sequence_number,				! record sequence number
	record_size,					! maximum record size
	block_size,					! physical block size
	user						! user-specified value
	) =

	%IF %EXPAND $xpo$conflict( option, options )
	%THEN
	    %WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
	%FI

	%IF %EXPAND $xpo$conflict( attribute, attributes )
	%THEN
	    %WARN( 'ATTRIBUTE= and ATTRIBUTES= are mutually exclusive' )
	%FI

	%IF %EXPAND $xpo$conflict( (characters,page_number,sequence_number), (fullwords,units) )
	%THEN
	    %WARN( 'Character and binary parameters are mutually exclusive' )
	%FI

	%IF %EXPAND $xpo$conflict( (units), (fullwords) )
	%THEN
	    %WARN( 'FULLWORDS= and UNITS= are mutually exclusive' )
	%FI

	%EXPAND $iob$not_allowed( 'STRING=', string, 'declaration' )
	%EXPAND $iob$not_allowed( 'BINARY_DATA=', binary_data, 'declaration' )

	BLOCK[IOB$K_LENGTH]  FIELD( %EXPAND $iob$fields )

	%IF %EXPAND $xpo$conflict( 1, (file_spec,default,related,option,options,attribute,attributes,prompt,
			characters,fullwords,units,page_number,sequence_number,
			record_size,block_size,user) )
	%THEN
	    %WARN( 'Static IOB initialization not yet supported' )
	%FI %,


    $XPO_BACKUP(
	old_iob,					! address of the input file IOB
	new_iob,					! address of the output file IOB
	file_type='.BAK',				! file_type information
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =

	%EXPAND $xpo$required( old_iob, 'OLD_IOB=' )
	%EXPAND $xpo$required( new_iob, 'NEW_IOB=' )

	BEGIN
	BIND iob$ = old_iob :  %EXPAND $xpo$force( $XPO_IOB() );

	$str$declare( LOCAL, $iob$back_type, file_type )
	$str$local_init( $iob$back_type, file_type )

	$iob$string( IOB$A_BACK_TYPE, $iob$back_type, file_type )	! FILE_TYPE=
	$xpo$value( iob$, A_ASSOC_IOB, new_iob )			! NEW_IOB=

	%EXPAND $xpo$io_call( %QUOTE BACKUP, success, failure )
	END %,


    $XPO_CLOSE(
	iob,						! address of IOB
	option,						! option keywords
	options,					! option keywords
	user,						! user-specified value
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =

	%IF %EXPAND $xpo$conflict( option, options )
	%THEN
	    %WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
	%FI

	%EXPAND $xpo$required( iob, 'IOB=' )

	BEGIN
	BIND iob$ = iob :  %EXPAND $xpo$force( $XPO_IOB() );

	$xpo$keyword( iob$, option %REMOVE(options) )			! OPTION= or OPTIONS=
	$xpo$value( iob$, Z_USER, user )				! USER=

	%EXPAND $xpo$io_call( %QUOTE CLOSE, success, failure )
	END %,


    $XPO_DELETE(
	iob,						! address of IOB
	file_spec,					! primary file specification information
	default,					! default file specification information
	related,					! related file specification information
	user,						! user-specified value
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =

	%EXPAND $xpo$required( iob, 'IOB=' )

	BEGIN
	BIND iob$ = iob :  %EXPAND $xpo$force( $XPO_IOB() );

	$str$declare( LOCAL, $iob$file_spec, file_spec )
	$str$declare( LOCAL, $iob$default, default )
	$str$declare( LOCAL, $iob$related, related )

	$str$local_init( $iob$file_spec, file_spec )
	$str$local_init( $iob$default, default )
	$str$local_init( $iob$related, related )

	$iob$string( IOB$A_FILE_SPEC, $iob$file_spec, file_spec )	! FILE_SPEC=
	$iob$string( IOB$A_DEFAULT, $iob$default, default )		! DEFAULT=
	$iob$string( IOB$A_RELATED, $iob$related, related )		! RELATED=
	$xpo$value( iob$, Z_USER, user )				! USER=

	%EXPAND $xpo$io_call( %QUOTE DELETE, success, failure )
	END %,


    $XPO_GET(
	iob,						! address of IOB
	prompt,						! pointer to read prompt string
	characters,					! length of I/O request
	fullwords,					! length of I/O request
	units,						! length of I/O request
	user,						! user-specified value
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =

	%IF %EXPAND $xpo$conflict( characters, fullwords, units )
	%THEN
	    %WARN( 'CHARACTERS=, FULLWORDS= and UNITS= are mutually exclusive' )
	%FI

	%EXPAND $xpo$required( iob, 'IOB=' )

	BEGIN
	BIND iob$ = iob :  %EXPAND $xpo$force( $XPO_IOB() );

	$str$declare( BIND, $iob$prompt, prompt )

	%IF NOT %NULL( prompt )
	%THEN
	    IF .iob$[IOB$A_PROMPT] NEQ 0
	    THEN
		$STR_FREE_TEMP( .iob$[IOB$A_PROMPT] );
	%FI

	$iob$string( IOB$A_PROMPT, $iob$prompt, prompt )		! PROMPT=
	$iob$get_length( STR$K_DTYPE_T, characters )			! CHARACTERS=
	%IF NOT %NULL(fullwords)
	%THEN
	    $iob$get_length( XPO$K_DTYPE_BU,				! FULLWORDS=
				%UPVAL * (fullwords) )
	%FI
	$iob$get_length( XPO$K_DTYPE_BU, units )			! UNITS=
	$xpo$value( iob$, Z_USER, user )				! USER=

	%EXPAND $xpo$io_call( %QUOTE GET, success, failure )
	END %,


    $XPO_IOB_INIT(
	iob,						! address of IOB to be initialized
	file_spec,					! primary file specification information
	default,					! default file specification information
	related,					! related file specification information
	option,						! option keyword
	options,					! option keywords
	attribute,					! file attribute keywords
	attributes,					! file attribute keywords
	prompt,						! read prompt string information
	binary_data,					! binary data information
	string,						! character string information
	characters,					! length of I/O request
	fullwords,					! length of I/O request
	units,						! length of I/O request
	page_number,					! page number
	sequence_number,				! record sequence number
	record_size,					! maximum record size
	block_size,					! physical block size
	user						! user-specified value
	) =

	%IF %EXPAND $xpo$conflict( option, options )
	%THEN
	    %WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
	%FI

	%IF %EXPAND $xpo$conflict( attribute, attributes )
	%THEN
	    %WARN( 'ATTRIBUTE= and ATTRIBUTES= are mutually exclusive' )
	%FI

	%IF %EXPAND $xpo$conflict( (string,characters,page_number,sequence_number), (binary_data,fullwords,units) )
	%THEN
	    %WARN( 'Character and binary parameters are mutually exclusive' )
	%FI

	%IF %EXPAND $xpo$conflict( (units), (fullwords) )
	%THEN
	    %WARN( 'FULLWORDS= and UNITS= are mutually exclusive' )
	%FI

	%EXPAND $xpo$required( iob, 'IOB=' )

	%EXPAND $iob$not_allowed( 'STRING=', string, 'initialization' )
	%EXPAND $iob$not_allowed( 'BINARY_DATA=', binary_data, 'initialization' )

	BEGIN
	BIND iob$ = iob :  %EXPAND $xpo$force( $XPO_IOB() ),
	    iob$resultant = iob$[IOB$T_RESULTANT] :  %EXPAND $xpo$force( $STR_DESCRIPTOR() );

	$str$declare( BIND, $iob$file_spec, file_spec )
	$str$declare( BIND, $iob$default, default )
	$str$declare( BIND, $iob$related, related )
	$str$declare( BIND, $iob$prompt, prompt )

	CH$FILL( 0, IOB$K_LENGTH * %UPVAL, CH$PTR(iob$,0,%BPUNIT) );	! Zero the entire IOB.

	iob$[IOB$H_LENGTH] = IOB$K_LENGTH;				! IOB length
	iob$[IOB$B_VERSION] = XPO$K_VERSION;				! XPORT version
	iob$[IOB$B_LEVEL] = XPO$K_LEVEL;				! XPORT level
	$iob$string( IOB$A_FILE_SPEC, $iob$file_spec, file_spec )	! FILE_SPEC=
	$iob$string( IOB$A_DEFAULT, $iob$default, default )		! DEFAULT=
	$iob$string( IOB$A_RELATED, $iob$related, related )		! RELATED=
									! Resultant file-spec descriptor:
	iob$resultant[STR$B_DTYPE] = STR$K_DTYPE_T;			!    ASCII data type
	iob$resultant[STR$B_CLASS] = STR$K_CLASS_D;			!    DYNAMIC descriptor class
	$iob$string( IOB$A_PROMPT, $iob$prompt, prompt )		! PROMPT=
	$xpo$keyword( iob$, option %REMOVE(options) )			! OPTION= or OPTIONS=
	$xpo$keyword( iob$, attribute %REMOVE(attributes) )		! ATTRIBUTE= or ATTRIBUTES=
	$iob$get_length( STR$K_DTYPE_T, characters )			! CHARACTERS=
	%IF NOT %NULL(fullwords)
	%THEN
	    $iob$get_length( XPO$K_DTYPE_BU,				! FULLWORDS=
				%UPVAL * (fullwords) )
	%FI
	$iob$get_length( XPO$K_DTYPE_BU, units )			! UNITS=
	$xpo$value( iob$, H_PAGE_NUMB, page_number )			! PAGE_NUMBER=
	$xpo$value( iob$, G_SEQ_NUMB, sequence_number )			! SEQUENCE_NUMBER=
	%IF NOT %IDENTICAL( record_size, VARIABLE )
	%THEN
	    $xpo$value( iob$, G_REC_SIZE, record_size )			! RECORD_SIZE=
	%FI
	$xpo$value( iob$, G_BLK_SIZE, block_size )			! BLOCK_SIZE=
	$xpo$value( iob$, Z_USER, user )				! USER=

	XPO$_NORMAL					! normal completion code
	END %,


    $XPO_OPEN(
	iob,						! address of IOB
	file_spec,					! primary file specification information
	default,					! default file specification information
	related,					! related file specification information
	option,						! option keyword
	options,					! option keywords
	attribute,					! file attribute keywords
	attributes,					! file attribute keywords
	prompt,						! read prompt string information
	binary_data,					! binary data information
	string,						! character string information
	characters,					! length of I/O request
	fullwords,					! length of I/O request
	units,						! length of I/O request
	page_number,					! page number
	sequence_number,				! record sequence number
	record_size,					! maximum record size
	block_size,					! physical block size
	user,						! user-specified value
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =

	%IF %EXPAND $xpo$conflict( option, options )
	%THEN
	    %WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
	%FI

	%IF %EXPAND $xpo$conflict( attribute, attributes )
	%THEN
	    %WARN( 'ATTRIBUTE= and ATTRIBUTES= are mutually exclusive' )
	%FI

	%IF %EXPAND $xpo$conflict( (string,characters,page_number,sequence_number), (binary_data,fullwords,units) )
	%THEN
	    %WARN( 'Character and binary parameters are mutually exclusive' )
	%FI

	%IF %EXPAND $xpo$conflict( (units), (fullwords) )
	%THEN
	    %WARN( 'FULLWORDS= and UNITS= are mutually exclusive' )
	%FI

	%EXPAND $xpo$required( iob, 'IOB=' )

	%EXPAND $iob$not_allowed( 'STRING=', string, 'open' )
	%EXPAND $iob$not_allowed( 'BINARY_DATA=', binary_data, 'open' )

	BEGIN
	BIND iob$ = iob :  %EXPAND $xpo$force( $XPO_IOB() );

	$str$declare( BIND, $iob$file_spec, file_spec )
	$str$declare( BIND, $iob$default, default )
	$str$declare( BIND, $iob$related, related )
	$str$declare( BIND, $iob$prompt, prompt )

	$iob$string( IOB$A_FILE_SPEC, $iob$file_spec, file_spec )	! FILE_SPEC=
	$iob$string( IOB$A_DEFAULT, $iob$default, default )		! DEFAULT=
	$iob$string( IOB$A_RELATED, $iob$related, related )		! RELATED=
	$iob$string( IOB$A_PROMPT, $iob$prompt, prompt )		! PROMPT=
	$xpo$keyword( iob$, option %REMOVE(options) )			! OPTION= or OPTIONS=
	$xpo$keyword( iob$, attribute %REMOVE(attributes) )		! ATTRIBUTE= or ATTRIBUTES=
	$iob$get_length( STR$K_DTYPE_T, characters )			! CHARACTERS=
	$xpo$value( iob$, H_PAGE_NUMB, page_number )			! PAGE_NUMBER=
	$xpo$value( iob$, G_SEQ_NUMB, sequence_number )			! SEQUENCE_NUMBER=
	%IF NOT %NULL(fullwords)
	%THEN
	    $iob$get_length( XPO$K_DTYPE_BU,				! FULLWORDS=
				%UPVAL * (fullwords) )
	%FI
	$iob$get_length( XPO$K_DTYPE_BU, units )			! UNITS=
	%IF %IDENTICAL( record_size, VARIABLE )
	%THEN
	    iob$[IOB$G_REC_SIZE] = 0;					! RECORD_SIZE=VARIABLE
	%ELSE
	    $xpo$value( iob$, G_REC_SIZE, record_size )			! RECORD_SIZE=value
	%FI
	$xpo$value( iob$, G_BLK_SIZE, block_size )			! BLOCK_SIZE=
	$xpo$value( iob$, Z_USER, user )				! USER=

	%EXPAND $xpo$io_call( %QUOTE OPEN, success, failure )
	END %,


    $XPO_PUT(
	iob,						! address of IOB
	string,						! character string information
	page_number,					! page number
	sequence_number,				! record sequence number
	binary_data,					! binary data information
	user,						! user-specified value
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =

	%IF %EXPAND $xpo$conflict( (string,page_number,sequence_number),
			(binary_data) )
	%THEN
	    %WARN( 'Character and binary parameters are mutually exclusive' )
	%FI

	%EXPAND $xpo$required( iob, 'IOB=' )

	BEGIN
	BIND iob$ = iob :  %EXPAND $xpo$force( $XPO_IOB() );

	$str$declare( LOCAL, $iob$output, string )
	$bin$declare( $iob$output, binary_data )

	$str$local_init( $iob$output, string )
	$bin$local_init( $iob$output, binary_data )

	$iob$string( IOB$A_OUTPUT, $iob$output, string binary_data )	! STRING= or BINARY_DATA=
	$xpo$value( iob$, H_PAGE_NUMB, page_number )			! PAGE_NUMBER=
	$xpo$value( iob$, G_SEQ_NUMB, sequence_number )			! SEQUENCE_NUMBER=
	$xpo$value( iob$, Z_USER, user )				! USER=

	%EXPAND $xpo$io_call( %QUOTE PUT, success, failure )
	END %,


    $XPO_RENAME(
	iob,						! address of IOB
	file_spec,					! primary file specification information
	default,					! default file specification information
	related,					! related file specification information
	new_spec,					! new primary file specification information
	new_default,					! new default file specification information
	new_related,					! new related file specification information
	option,						! option keywords
	options,					! option keywords
	user,						! user-specified value
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =

	%IF %EXPAND $xpo$conflict( option, options )
	%THEN
	    %WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
	%FI

	%EXPAND $xpo$required( iob, 'IOB=' )
	%EXPAND $xpo$required( new_spec new_default new_related, 'NEW_SPEC=, NEW_DEFAULT=, or NEW_RELATED=' )

	BEGIN
	BIND iob$ = iob :  %EXPAND $xpo$force( $XPO_IOB() );

	LOCAL
	    $xpo$new_iob :  %EXPAND $xpo$force( $XPO_IOB() );

	$str$declare( LOCAL, $iob$file_spec, file_spec )
	$str$declare( LOCAL, $iob$default, default )
	$str$declare( LOCAL, $iob$related, related )
	$str$declare( LOCAL, $iob$new_spec, new_spec )
	$str$declare( LOCAL, $iob$new_default, new_default )
	$str$declare( LOCAL, $iob$new_related, new_related )

	$str$local_init( $iob$file_spec, file_spec )
	$str$local_init( $iob$default, default )
	$str$local_init( $iob$related, related )
	$str$local_init( $iob$new_spec, new_spec )
	$str$local_init( $iob$new_default, new_default )
	$str$local_init( $iob$new_related, new_related )

	$XPO_IOB_INIT( %QUOTE IOB = $xpo$new_iob
			, %QUOTE OPTION = OUTPUT			! force "output" file-spec resolution
		%IF NOT %NULL(new_spec) %THEN
			, %QUOTE FILE_SPEC = $iob$new_spec
		%FI
		%IF NOT %NULL(new_default) %THEN
			, %QUOTE DEFAULT = $iob$new_default
		%FI
		%IF NOT %NULL(new_related) %THEN
			, %QUOTE RELATED = $iob$new_related
		%FI );

	$iob$string( IOB$A_FILE_SPEC, $iob$file_spec, file_spec )	! FILE_SPEC=
	$iob$string( IOB$A_DEFAULT, $iob$default, default )		! DEFAULT=
	$iob$string( IOB$A_RELATED, $iob$related, related )		! RELATED=
	$xpo$value( iob$, A_ASSOC_IOB, $xpo$new_iob )			! NEW_SPEC=, NEW_DEFAULT=, NEW_RELATED=
	$xpo$keyword( iob$, option %REMOVE(options) )			! OPTION= or OPTIONS=
	$xpo$value( iob$, Z_USER, user )				! USER=

	%EXPAND $xpo$io_call( %QUOTE RENAME, success, failure )
	END %;


MACRO
    $XPO_INPUT =
	%IF %BLISS(BLISS36)
	%THEN
	    'TTY:'
	%ELSE %IF %BLISS(BLISS32)
	%THEN
	    'SYS$INPUT'
	%ELSE
	    'TI:'
	%FI %FI %,


    $XPO_OUTPUT =
	%IF %BLISS(BLISS32)
	%THEN
	    'SYS$OUTPUT'
	%ELSE
	    %EXPAND $XPO_INPUT
	%FI %,


    $XPO_ERROR =
	%IF %BLISS(BLISS32)
	%THEN
	    'SYS$ERROR'
	%ELSE
	    %EXPAND $XPO_INPUT
	%FI %,


    $XPO_TEMPORARY =
	'[XPORT Temporary File]' %;
!
! XSPEC - XPORT File Specification Parse Block
!

$FIELD	$XPO$SPEC_FIELD	= SET
	XPO$V_SPEC_STAT	= [$BITS(16)] ,			! File specification indicators:
	    $OVERLAY( XPO$V_SPEC_STAT )
	XPO$V_DIR_NAME	= [$BIT] ,			!    <directory-name> specified
	XPO$V_PPN	= [$BIT] ,			!    [project,programmer] specified
	XPO$V_WILD_CARD	= [$BIT] ,			!    wild-card somewhere in file-spec
	XPO$V_WILD_NODE	= [$BIT] ,			!    wild-card node name
	XPO$V_WILD_DEV	= [$BIT] ,			!    wild-card device name
	XPO$V_WILD_DIR	= [$BIT] ,			!    wild-card in directory name
	XPO$V_WILD_PROJ	= [$BIT] ,			!    wild-card project number
	XPO$V_WILD_PGMR	= [$BIT] ,			!    wild-card programmer number
	XPO$V_WILD_NAME	= [$BIT] ,			!    wild-card file name
	XPO$V_WILD_TYPE	= [$BIT] ,			!    wild-card file type (extension)
	XPO$V_WILD_VER	= [$BIT] ,			!    wild-card file version number
	    $CONTINUE

	XPO$T_NODE	= [$DESCRIPTOR(FIXED)] ,	! Network node name descriptor:
	    $OVERLAY( $SUB_FIELD(XPO$T_NODE,STR$H_LENGTH) )
	XPO$H_NODE	= [$BYTES(2)] ,			!    length of the node name
	    $OVERLAY( $SUB_FIELD(XPO$T_NODE,STR$A_POINTER) )
	XPO$A_NODE	= [$POINTER] ,			!    pointer to the node name
	    $CONTINUE

	XPO$T_DEVICE	= [$DESCRIPTOR(FIXED)] ,	! Device name descriptor:
	    $OVERLAY( $SUB_FIELD(XPO$T_DEVICE,STR$H_LENGTH) )
	XPO$H_DEVICE	= [$BYTES(2)] ,			!    length of the device name
	    $OVERLAY( $SUB_FIELD(XPO$T_DEVICE,STR$A_POINTER) )
	XPO$A_DEVICE	= [$POINTER] ,			!    pointer to the device name
	    $CONTINUE

	XPO$T_DIRECT	= [$DESCRIPTOR(FIXED)] ,	! Directory specification descriptor:
	    $OVERLAY( $SUB_FIELD(XPO$T_DIRECT,STR$H_LENGTH) )
	XPO$H_DIRECT	= [$BYTES(2)] ,			!    length of the directory spec
	    $OVERLAY( $SUB_FIELD(XPO$T_DIRECT,STR$A_POINTER) )
	XPO$A_DIRECT	= [$POINTER] ,			!    pointer to the directory spec
	    $CONTINUE

	XPO$H_PROJ_NUMB	= [$BYTES(2)] ,			! Project number (binary)
	XPO$H_PGMR_NUMB	= [$BYTES(2)] ,			! Programmer number (binary)

	XPO$T_FILE_NAME	= [$DESCRIPTOR(FIXED)] ,	! File name descriptor:
	    $OVERLAY( $SUB_FIELD(XPO$T_FILE_NAME,STR$H_LENGTH) )
	XPO$H_FILE_NAME	= [$BYTES(2)] ,			!    length of the file name
	    $OVERLAY( $SUB_FIELD(XPO$T_FILE_NAME,STR$A_POINTER) )
	XPO$A_FILE_NAME	= [$POINTER] ,			!    pointer to the file name
	    $CONTINUE

	XPO$T_FILE_TYPE	= [$DESCRIPTOR(FIXED)] ,	! File type (extension) descriptor:
	    $OVERLAY( $SUB_FIELD(XPO$T_FILE_TYPE,STR$H_LENGTH) )
	XPO$H_FILE_TYPE	= [$BYTES(2)] ,			!    length of the file type
	    $OVERLAY( $SUB_FIELD(XPO$T_FILE_TYPE,STR$A_POINTER) )
	XPO$A_FILE_TYPE	= [$POINTER] ,			!    pointer to the file type
	    $CONTINUE

	XPO$T_FILE_VER	= [$DESCRIPTOR(FIXED)] ,	! File version number descriptor:
	    $OVERLAY( $SUB_FIELD(XPO$T_FILE_VER,STR$H_LENGTH) )
	XPO$H_FILE_VER	= [$BYTES(2)] ,			!    length of the file version
	    $OVERLAY( $SUB_FIELD(XPO$T_FILE_VER,STR$A_POINTER) )
	XPO$A_FILE_VER	= [$POINTER] ,			!    pointer to the file version
	    $CONTINUE

	XPO$T_FILE_PROT	= [$DESCRIPTOR(FIXED)] ,	! File protection descriptor (RSTS only):
	    $OVERLAY( $SUB_FIELD(XPO$T_FILE_PROT,STR$H_LENGTH) )
	XPO$H_FILE_PROT	= [$BYTES(2)] ,			!    length of the protection
	    $OVERLAY( $SUB_FIELD(XPO$T_FILE_PROT,STR$A_POINTER) )
	XPO$A_FILE_PROT	= [$POINTER] ,			!    pointer to the protection
	    $CONTINUE

	XPO$T_EXTRA	= [$DESCRIPTOR(FIXED)] ,	! File 'EXTRA' information descriptor:
	    $OVERLAY( $SUB_FIELD(XPO$T_EXTRA,STR$H_LENGTH) )
	XPO$H_EXTRA	= [$BYTES(2)] ,			!    length
	    $OVERLAY( $SUB_FIELD(XPO$T_EXTRA,STR$A_POINTER) )
	XPO$A_EXTRA	= [$POINTER]  			!    pointer
	    $CONTINUE

	TES;
LITERAL	XPO$K_SPEC_LEN	= $FIELD_SET_SIZE ;		! Length of file-spec block

! End of XSPEC


MACRO
    $XPO_SPEC_BLOCK =
	BLOCK[XPO$K_SPEC_LEN]  FIELD( $XPO$SPEC_FIELD ) %;


KEYWORDMACRO
    $XPO_PARSE_SPEC(
	file_spec,					! file specification information
	spec_block,					! address of file-spec parse block
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =

	%EXPAND $xpo$required( file_spec, 'FILE_SPEC=' )
	%EXPAND $xpo$required( spec_block, 'SPEC_BLOCK=' )

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( XPO$PARSE_SPEC ) )
	%EXPAND $xpo$ex_failure( failure )

	$str$declare( LOCAL, $str$file_spec, file_spec )
	$str$local_init( $str$file_spec, file_spec )

	XPO$PARSE_SPEC( $str$file_spec,
			spec_block,
			NOT %DECLARED($xpo$internal),
			$xpo$default(success,0),
			$xpo$default(failure,0) )
	END %;
!
! XPORT MEMORY Macros
!

LITERAL							! $XPO_GET_MEM fill indicators:
    XPO$K_DONT_FILL = -1,				!    don't fill element
    XPO$K_FILL_FULL = 0,				!    fill fullwords if binary data element
    XPO$K_FILL_UNIT = 1;				!    fill addressable units if binary data element

KEYWORDMACRO
    $XPO_GET_MEM(
	desc,						! address of a partially completed descriptor
	descriptor,					! address of a partially completed descriptor
	characters,					! size of element in characters
	fullwords,					! size of element in fullwords
	units,						! size of element in units
	result,						! address of resulting pointer/address
	pointer,									! *** OBSOLETE ***
	address,									! *** OBSOLETE ***
	fill,						! storage fill value
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =
%IF %EXPAND $xpo$conflict( 1, (desc,descriptor,result,pointer,address) )
%THEN

	%IF %EXPAND $xpo$conflict( (desc,descriptor), (characters,fullwords,units,result,pointer,address) )
	%THEN
	    %WARN( 'DESC=/DESCRIPTOR= and non-descriptor parameters are mutually exclusive' )
	    %EXITMACRO
	%FI

	%IF NOT %NULL( pointer )							! *** OBSOLETE ***
	%THEN										! *** OBSOLETE ***
	    %INFORM( 'POINTER= is obsolete - use RESULT=' )				! *** OBSOLETE ***
	%FI										! *** OBSOLETE ***

	%IF NOT %NULL( address )							! *** OBSOLETE ***
	%THEN										! *** OBSOLETE ***
	    %INFORM( 'ADDRESS= is obsolete - use RESULT=' )				! *** OBSOLETE ***
	%FI										! *** OBSOLETE ***

	%IF %EXPAND $xpo$conflict( desc, descriptor )
	%THEN
	    %WARN( 'DESC= and DESCRIPTOR= are mutually exclusive' )
	    %EXITMACRO
	%FI

	%IF %EXPAND $xpo$conflict( characters, fullwords, units )
	%THEN
	    %WARN( 'CHARACTERS=, FULLWORDS= and UNITS= are mutually exclusive' )
	    %EXITMACRO
	%FI

	%IF %NULL( desc descriptor )
	%THEN
	    %EXPAND $xpo$required( characters fullwords units,
				'DESCRIPTOR=, DESC=, CHARACTERS=, FULLWORDS=, or UNITS=' )
	    %EXPAND $xpo$required( result pointer address, 'RESULT=' )
	%FI

	BEGIN
	%IF %NULL( desc descriptor )
	%THEN
	    LOCAL
		$xpo$status,
		$xpo$desc :
		    %IF NOT %NULL( characters )
		    %THEN
			%EXPAND $xpo$force( $STR_DESCRIPTOR(CLASS=DYNAMIC) );
		    %ELSE
			%EXPAND $xpo$force( $XPO_DESCRIPTOR(CLASS=DYNAMIC) );
		    %FI
	%ELSE
	    BIND $xpo$desc = desc descriptor;
	%FI

	%EXPAND $xpo$force( $xpo$ex_routine( XPO$ALLOC_MEM ) )

	%EXPAND $xpo$ex_failure( failure )
	
	%IF NOT %NULL(characters)
	%THEN
	    $str$str_desc( $xpo$desc, DYNAMIC, (characters, 0) )
	%ELSE %IF NOT %NULL(fullwords)
	%THEN
	    $xpo$bin_desc( $xpo$desc, DYNAMIC, (fullwords, 0, %QUOTE FULLWORDS) )
	%ELSE %IF NOT %NULL(units)
	%THEN
	    $xpo$bin_desc( $xpo$desc, DYNAMIC, (units, 0, %QUOTE UNITS) )
	%FI %FI %FI

	%IF %NULL( desc descriptor )
	%THEN
	    $xpo$status =
	%FI

	XPO$ALLOC_MEM(					! XPO$ALLOC_MEM argument list:
		$xpo$desc,				!    address of local descriptor or caller's descriptor
	    %IF %NULL(fill)				!    fill element indicator:
	    %THEN					!
		XPO$K_DONT_FILL,			!	don't fill element
	    %ELSE					!
		%NULL(fullwords),			!	fill fullwords (no or yes)
	    %FI						!
		$XPO$DEFAULT(fill,0),			!    fill value
		$XPO$DEFAULT(success,0),		!    address of success action routine
		$XPO$DEFAULT(failure,0) )		!    address of failure action routine

	%IF NOT %NULL( characters )
	%THEN
	    ;
	    IF .$xpo$status
	    THEN
		result pointer = .$xpo$desc[STR$A_POINTER];
	    .$xpo$status
	%FI

	%IF NOT %NULL( fullwords units )
	%THEN
	    ;
	    IF .$xpo$status
	    THEN
		result address = .$xpo$desc[XPO$A_ADDRESS];
	    .$xpo$status
	%FI

%ELSE												! *** OBSOLETE ***
	%INFORM( 'DESCRIPTOR= or RESULT= missing - see new $XPO_GET_MEM documentation' )	! *** OBSOLETE ***

	%IF %EXPAND $xpo$conflict( characters, fullwords, units )
	%THEN
	    %WARN( 'CHARACTERS=, FULLWORDS=, and UNITS= are mutually exclusive' )
	    %EXITMACRO
	%FI

	%EXPAND $xpo$required( characters fullwords units, 'CHARACTERS=, FULLWORDS=, or UNITS=' )

	BEGIN
	LOCAL
	    $xpo$desc :
		%IF NOT %NULL( characters )
		%THEN
		    %EXPAND $xpo$force( $STR_DESCRIPTOR() );
		%ELSE
		    %EXPAND $xpo$force( $XPO_DESCRIPTOR() );
		%FI

	%EXPAND $xpo$force( $xpo$ex_routine( XPO$ALLOC_MEM ) )

	%EXPAND $xpo$ex_failure( failure )
	
	%IF NOT %NULL(characters)
	%THEN
	    $str$str_desc( $xpo$desc, DYNAMIC, (characters, 0) )
	%ELSE %IF NOT %NULL(fullwords)
	%THEN
	    $xpo$bin_desc( $xpo$desc, DYNAMIC, (fullwords, 0, %QUOTE FULLWORDS) )
	%ELSE %IF NOT %NULL(units)
	%THEN
	    $xpo$bin_desc( $xpo$desc, DYNAMIC, (units, 0, %QUOTE UNITS) )
	%FI %FI %FI

	XPO$ALLOC_MEM(					! XPO$ALLOC_MEM argument list:
		$xpo$desc,				!    address of request descriptor
	    %IF %NULL(fill)				!    fill element indicator:
	    %THEN					!
		XPO$K_DONT_FILL,			!	don't fill element
	    %ELSE
		%NULL(fullwords),			!	fill fullwords (no or yes)
	    %FI
		$XPO$DEFAULT(fill,0),			!    fill value
		$XPO$DEFAULT(success,0),		!    address of success action routine
		$XPO$DEFAULT(failure,0) );		!    address of failure action routine
	%IF NOT %NULL( characters )
	%THEN
	    .$xpo$desc[STR$A_POINTER]
	%ELSE
	    .$xpo$desc[XPO$A_ADDRESS]
	%FI
%FI
	END %,


    $XPO_FREE_MEM(
	string,						! character string descriptor
	binary_data,					! binary data descriptor
	descriptor,									! *** OBSOLETE ***
	fill,						! storage fill value
	success,					! address of success action routine
	failure=XPO$FAILURE				! address of failure action routine
	) =

	%IF %EXPAND $xpo$conflict( string, binary_data, descriptor )
	%THEN
	    %WARN( 'STRING=, BINARY_DATA= and DESCRIPTOR= are mutually exclusive' )
	    %EXITMACRO
	%FI

	%EXPAND $xpo$required( string binary_data descriptor, 'STRING= or BINARY_DATA=' )

	%IF NOT %NULL(descriptor)
	%THEN
	    %INFORM( 'DESCRIPTOR= is obsolete - use STRING= or BINARY=' )
	%FI

	%IF %ISSTRING( %REMOVE(string) )
	%THEN
	    %WARN( 'Literal STRING= parameter is not permitted' )
	    %EXITMACRO
	%FI

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( XPO$FREE_MEM ) )

	%EXPAND $xpo$ex_failure( failure )

	%IF $xpo$paren_test(string) OR $xpo$paren_test(binary_data)
	%THEN
	    LOCAL $xpo$desc :
		%IF NOT %NULL( string )
		%THEN
		    %EXPAND $xpo$force( $STR_DESCRIPTOR(CLASS=DYNAMIC) );
		%ELSE
		    %EXPAND $xpo$force( $XPO_DESCRIPTOR(CLASS=DYNAMIC) );
		%FI

	    $str$str_desc( $xpo$desc, DYNAMIC, string )
	    $xpo$bin_desc( $xpo$desc, DYNAMIC, binary_data )

	    XPO$FREE_MEM(				! XPO$FREE_MEM arguments:
		$xpo$desc,				!    address of local string/data descriptor
	%ELSE
	    XPO$FREE_MEM(				! XPO$FREE_MEM arguments:
		string binary_data descriptor,		!    address of caller's string/data descriptor
	%FI
		NOT %NULL(fill),			!    fill element indicator
		$XPO$DEFAULT(fill,0),			!    fill value
		$XPO$DEFAULT(success,0),		!    address of success action routine
		$XPO$DEFAULT(failure,0) )		!    address of failure action routine
	END %;
!
! XPORT Host System Services Macros
!

KEYWORDMACRO
    $XPO_TERMINATE(
	code=XPO$_TERMINATE				! termination completion code
	) =

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( XPO$TERMINATE, NOVALUE ) )

	XPO$TERMINATE( code );				! This routine will not return.

	RETURN 0;					! This statement keeps the compiler happy.
	END %;
!
! XPORT Put-Message Macros and Assorted Definitions
!

LITERAL							! XPO$MESSAGE severity codes:
    XPO$_SUCCESS = 1,					!    success
    XPO$_WARNING = 0,					!    warning
    XPO$_ERROR = 2,					!    error
    XPO$_FATAL = 4,					!    fatal error
    XPO$_NO_SEV = -1;					!    no severity code specified

$LITERAL						! XPO$MESSAGE message type codes:
    XPO$K_PUT_COD = $DISTINCT ,				!    CODE=
    XPO$K_PUT_STR = $DISTINCT ;				!    STRING=


MACRO
    $XPO_PUT_MSG( key_parameter ) =
	BEGIN
	COMPILETIME
	    $xpo$desc_count = 0,			! number of local descriptors needed
	    $xpo$desc_index = 0,			! local descriptor index
	    $xpo$sev_flag = 0,				! SEVERITY= parameter indicator
	    $xpo$succ_flag = 0,				! SUCCESS= parameter indicator
	    $xpo$fail_flag = 0;				! FAILURE= parameter indicator

	$XPO$PUT_COUNT( key_parameter, %REMAINING )	! Count the number of local descriptors needed.

	LOCAL
	    $xpo$local_desc :  BLOCKVECTOR[$xpo$desc_count,STR$K_F_BLN];

	%EXPAND $xpo$force( $xpo$ex_routine( XPO$MESSAGE, FORTRAN_FUNC ) )	! FORTRAN_FUNC linkage permits
										! variable length argument list

	%EXPAND $xpo$force( $xpo$ex_routine( XPO$FAILURE ) )	! The default failure action routine may be needed.

	%EXPAND $xpo$force( $xpo$ex_routine( XPO$PM_FAILURE ) )	! The optional failure action routine may be needed.

	XPO$MESSAGE(					! Call XPORT message output routine

							! Generate the following fixed arguments:
	$XPO$PUT_FIXED( 1, key_parameter, %REMAINING )	!    severity code
	$XPO$PUT_FIXED( 2, key_parameter, %REMAINING )	!    address of success action routine
	$XPO$PUT_FIXED( 3, key_parameter, %REMAINING )	!    address of failure action routine

	$XPO$PUT_PARM( key_parameter, %REMAINING )	! Generate "n" keyword argument pairs

	)						! Trailing right parenthesis
	END %,


    $XPO$PUT_COUNT( parameter ) [] =			! Count number of local descriptors needed
	$XPO$$PUT_COUNT( parameter )
	$XPO$PUT_COUNT( %REMAINING ) %,


    $XPO$PUT_FIXED( number, parameter ) [] =		! Generated required arguments
	$XPO$$PUT_PARM( ARGUMENT=number, parameter )

	%IF NOT %NULL(%REMAINING)
	%THEN
	    $XPO$PUT_FIXED( number, %REMAINING )
	%ELSE
	    %IF number EQL 1 AND NOT $xpo$sev_flag
	    %THEN
		XPO$_NO_SEV,
	    %ELSE %IF number EQL 2 AND NOT $xpo$succ_flag
	    %THEN
		0,
	    %ELSE %IF number EQL 3 AND NOT $xpo$fail_flag
	    %THEN
		XPO$FAILURE
	    %FI %FI %FI
	%FI %,


    $XPO$PUT_PARM( parameter ) [] =			! Generate an argument pair
	$XPO$$PUT_PARM( ARGUMENT=0, parameter )

	$XPO$PUT_PARM( %REMAINING ) %;


KEYWORDMACRO
    $XPO$$PUT_COUNT(					! Count number of local descriptors needed
	severity,					! message severity code
	success,					! address of success action routine
	failure,					! address of failure action routine
	code,						! message code
	string						! string descriptor
	) =

	%IF %ISSTRING( %REMOVE(string) ) OR $xpo$paren_test(string)
	%THEN
	    %ASSIGN( $xpo$desc_count, $xpo$desc_count + 1 )
	%FI %,


    $XPO$$PUT_PARM(					! Keyword argument decoder
	argument,					! positional argument indicator
	severity,					! message severity code
	success,					! address of success action routine
	failure,					! address of failure action routine
	code,						! message code
	string						! string descriptor
	) =

	%IF argument EQL 1
	%THEN
	    %IF %NULL(severity)
	    %THEN
		%EXITMACRO
	    %FI
	    %IF NOT $xpo$sev_flag
	    %THEN
		%IF $xpo$key_test( severity, (%QUOTE SUCCESS,WARNING,ERROR,FATAL), 'SEVERITY=' )
		%THEN
		    %NAME( 'XPO$_', severity ),
		%FI
		%ASSIGN( $xpo$sev_flag, 1 )
	    %ELSE
		%WARN( 'Extraneous SEVERITY= parameter ignored' )
	    %FI
	    %EXITMACRO
	%FI

	%IF argument EQL 2
	%THEN
	    %IF %NULL(success)
	    %THEN
		%EXITMACRO
	    %FI
	    %IF NOT $xpo$succ_flag
	    %THEN
		success,
		%ASSIGN( $xpo$succ_flag, 1 )
	    %ELSE
		%WARN( 'Extraneous SUCCESS= parameter ignored' )
	    %FI
	    %EXITMACRO
	%FI

	%IF argument EQL 3
	%THEN
	    %IF %NULL(failure)
	    %THEN
		%EXITMACRO
	    %FI
	    %IF NOT $xpo$fail_flag
	    %THEN
		failure
		%ASSIGN( $xpo$fail_flag, 1 )
	    %ELSE
		%WARN( 'Extraneous FAILURE= parameter ignored' )
	    %FI
	    %EXITMACRO
	%FI

	%IF NOT %NULL(code)
	%THEN
	    , XPO$K_PUT_COD, code
	    %EXITMACRO
	%FI

	%IF NOT %NULL(string)
	%THEN
	    , XPO$K_PUT_STR,				! generate string element code
	    BEGIN
	    $str$declare( LOCAL, $put$string, string )
	    $str$local_init( $put$string, string )
	    $put$string
	    END
	%FI %;
!
! String Handling Option Block
!
! NOTE:  Do not change the overall format of this option block without carefully checking
!	 the compiletime creation of this block in all string handling macros.  For example,
!	 these macros all assume that the option block fits in a single BLISS value
!	 (even for BLISS-16) and that the function code field is at the beginning of the block.

$FIELD	$str$opt_fields	= SET
	STR$V_OPTIONS	= [$BITS(16)] ,
	    $OVERLAY( STR$V_OPTIONS )
	$str$v_option1	= [$BITS(8)] ,
	$str$v_option2	= [$BITS(8)] ,

	    $OVERLAY( $str$v_option1 )
	STR$V_FUNCTION	= [$BITS(8)] ,			! $ASCII, $STR_BINARY, $STR_SCAN function code

	    $OVERLAY( $str$v_option1 )			! $FORMAT options:
	STR$V_LEFT_JUST	= [$BIT] ,			!    LEFT_JUSTIFY
	STR$V_RIGHT_JUS	= [$BIT] ,			!    RIGHT_JUSTIFY
	STR$V_CENTER	= [$BIT] ,			!    CENTER

	    $OVERLAY( $str$v_option2 )			! Common string function options:
	STR$V_SIGNED	= [$BIT] ,			!    SIGNED
	STR$V_UNSIGNED	= [$BIT] ,			!    UNSIGNED
	STR$V_LEADING_Z	= [$BIT] ,			!    LEADING_ZERO
	STR$V_LEADING_B	= [$BIT] ,			!    LEADING_BLANK
	STR$V_UP_CASE	= [$BIT] ,			!    UP_CASE
	STR$V_TRUNCATE	= [$BIT] ,			!    TRUNCATE
	STR$V_NO_FREE_T	= [$BIT] ,			!    don't free temporary string - internal XPORT use only

	    $OVERLAY( $str$v_option2 )			! $STR_SCAN options:
	STR$V_REMAINDER	= [$BIT] ,			!    REMAINDER=
	STR$V_TARGET	= [$BIT]			!    TARGET=
	TES;

LITERAL
    $xpo$mask_set( STR$V_, OPTIONS,			! Define masks for option bits
		LEFT_JUST, RIGHT_JUS, CENTER,
		SIGNED, UNSIGNED, LEADING_Z, LEADING_B, UP_CASE, TRUNCATE, NO_FREE_T,
		REMAINDER, TARGET );

MACRO
    $STR_OPTIONS =
	BLOCK[]  FIELD( $str$opt_fields ) %,


    $str$opt_init =
	%IF %DECLARED( $XPO$INTERNAL )
	%THEN
	    STR$M_NO_FREE_T
	%ELSE
	    0
	%FI %;
!
! String Comparison Functions
!
!	$STR_EQL, $STR_NEQ, $STR_LSS, $STR_LEQ, $STR_GEQ, $STR_GTR, $STR_COMPARE
!

KEYWORDMACRO
    $STR_EQL( string1, string2, fill, success, failure = STR$FAILURE ) =
	%EXPAND $xpo$required( string1, 'STRING1=' )
	%EXPAND $xpo$required( string2, 'STRING2=' )
	$str$compare( STR$EQL, string1, string2, fill, success, failure ) %,

    $STR_NEQ( string1, string2, fill, success, failure = STR$FAILURE ) =
	%EXPAND $xpo$required( string1, 'STRING1=' )
	%EXPAND $xpo$required( string2, 'STRING2=' )
	$str$compare( STR$NEQ, string1, string2, fill, success, failure ) %,

    $STR_LSS( string1, string2, fill, success, failure = STR$FAILURE ) =
	%EXPAND $xpo$required( string1, 'STRING1=' )
	%EXPAND $xpo$required( string2, 'STRING2=' )
	$str$compare( STR$LSS, string1, string2, fill, success, failure ) %,

    $STR_LEQ( string1, string2, fill, success, failure = STR$FAILURE ) =
	%EXPAND $xpo$required( string1, 'STRING1=' )
	%EXPAND $xpo$required( string2, 'STRING2=' )
	$str$compare( STR$LEQ, string1, string2, fill, success, failure ) %,

    $STR_GEQ( string1, string2, fill, success, failure = STR$FAILURE ) =
	%EXPAND $xpo$required( string1, 'STRING1=' )
	%EXPAND $xpo$required( string2, 'STRING2=' )
	$str$compare( STR$GEQ, string1, string2, fill, success, failure ) %,

    $STR_GTR( string1, string2, fill, success, failure = STR$FAILURE ) =
	%EXPAND $xpo$required( string1, 'STRING1=' )
	%EXPAND $xpo$required( string2, 'STRING2=' )
	$str$compare( STR$GTR, string1, string2, fill, success, failure ) %,

    $STR_COMPARE( string1, string2, fill, success, failure = STR$FAILURE ) =
	%EXPAND $xpo$required( string1, 'STRING1=' )
	%EXPAND $xpo$required( string2, 'STRING2=' )
	$str$compare( STR$CMP, string1, string2, fill, success, failure ) %;

MACRO
    $str$compare( routine_name, string1, string2, fill, success, failure ) =
	BEGIN
	%EXPAND $xpo$ex_routine( routine_name )
	%EXPAND $xpo$ex_failure( failure )

	%EXPAND $str$declare( LOCAL, $str$string1, string1 )
	%EXPAND $str$declare( LOCAL, $str$string2, string2 )

	%EXPAND $str$local_init( $str$string1, string1 )
	%EXPAND $str$local_init( $str$string2, string2 )

	routine_name( %EXPAND $str$opt_init,
			$str$string1,
			$str$string2,
			$xpo$default( fill, -1 ),
			$xpo$default( success, 0 ),
			$xpo$default( failure, 0 ) )
	END %;
!
! String Modification Functions
!
!	$STR_COPY, $STR_APPEND
!

KEYWORDMACRO
    $STR_COPY(
	string,						! string descriptor
	target,						! target buffer descriptor
	option,						! option keyword
	options,					! options keyword list
	success,					! address of success action routine
	failure = STR$FAILURE				! address of failure action routine
	) =

	%EXPAND $xpo$required( string, 'STRING=' )
	%EXPAND $xpo$required( target, 'TARGET=' )

	%IF %ISSTRING( %REMOVE(target) )
	%THEN
	    %WARN( 'TARGET=literal-string is not permitted' )
	%FI

	%IF %EXPAND $xpo$conflict( option, options )
	%THEN
	    %WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
	%FI

	%ASSIGN( $str$options, %EXPAND $str$opt_init )
	$str$copy_opt( option %REMOVE(options) )

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( STR$COPY ) )
	%EXPAND $xpo$ex_failure( failure )

	%EXPAND $str$declare( LOCAL, $str$string, string )
	%EXPAND $str$declare( LOCAL, $str$target, target )

	%EXPAND $str$local_init( $str$string, string )
	%EXPAND $str$local_init( $str$target, target )

	STR$COPY( %NUMBER( $str$options ),
		$str$string,
		$str$target,
		$xpo$default( success, 0 ),
		$xpo$default( failure, 0 ) )
	END %,


    $STR_APPEND(
	string,						! string descriptor
	target,						! target buffer descriptor
	option,						! option keyword
	options,					! options keyword list
	success,					! address of success action routine
	failure = STR$FAILURE				! address of failure action routine
	) =

	%EXPAND $xpo$required( string, 'STRING=' )
	%EXPAND $xpo$required( target, 'TARGET=' )

	%IF %ISSTRING( %REMOVE(target) )
	%THEN
	    %WARN( 'TARGET=literal-string is not permitted' )
	%FI

	%IF $xpo$paren_test( target ) AND NOT %ISSTRING( %REMOVE(target) )
	%THEN
	    %WARN( 'TARGET=(length,pointer) is not permitted' )
	%FI

	%IF %EXPAND $xpo$conflict( option, options )
	%THEN
	    %WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
	%FI

	%ASSIGN( $str$options, %EXPAND $str$opt_init )
	$str$copy_opt( option %REMOVE(options) )

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( STR$APPEND ) )
	%EXPAND $xpo$ex_failure( failure )

	%EXPAND $str$declare( LOCAL, $str$string, string )
	%EXPAND $str$local_init( $str$string, string )

	STR$APPEND( %NUMBER( $str$options ),
		$str$string,
		target,
		$xpo$default( success, 0 ),
		$xpo$default( failure, 0 ) )
	END %;


MACRO
    $str$copy_opt( option ) [] =
	%IF NOT $xpo$key_test( option, (UP_CASE, TRUNCATE), 'OPTIONS=' )
	%THEN
	    %EXITMACRO
	%FI

	%ASSIGN( $str$options, $str$options + $xpo$name15( 'STR$M_', option ) )
	
	$str$copy_opt( %REMAINING ) %;
!
! ASCII-to-ASCII String Conversion Functions
!
!	$CONCAT, $FORMAT
!
! Binary-to-ASCII String Conversion Function
!
!	$ASCII
!

$LITERAL						! $ASCII and $STR_BINARY function codes:
	STR$K_DFLT_FUNC	= 0,				!    default function
	STR$K_BASE2	= $DISTINCT,			!    $ASCII( value, BASE2 )
	STR$K_BASE8	= $DISTINCT,			!    $ASCII( value, BASE8 )
	STR$K_BASE10	= $DISTINCT,			!    $ASCII( value, BASE10 )
	STR$K_BASE16	= $DISTINCT,			!    $ASCII( value, BASE16 )
	STR$K_DATE	= $DISTINCT,			!    $ASCII( value, DATE )
	STR$K_TIME	= $DISTINCT,			!    $ASCII( value, TIME )
	STR$K_DAY	= $DISTINCT;			!    $ASCII( value, DAY )

COMPILETIME
    $str$function = 0,					! string function code
    $str$options = 0,					! string processing options
    $str$length = 0;					! string field length indicator

MACRO
    $CONCAT [] =
	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( STR$JOIN, FORTRAN_FUNC ) )

	$str$con_decl( %REMAINING )

	$str$con_init( %REMAINING )

	STR$JOIN( $str$con_args( %REMAINING ) )
	END %,


    $str$con_decl( string_info ) [] =
	$str$declare( LOCAL, %NAME(%STRING('$str$string',%COUNT)), string_info )

	$str$con_decl( %REMAINING ) %,


    $str$con_init( string_info ) [] =
	$str$local_init( %NAME(%STRING('$str$string',%COUNT)), string_info )

	$str$con_init( %REMAINING ) %,


    $str$con_args( string_info ) [] =
	%IF %COUNT NEQ 0 %THEN , %FI

	%NAME(%STRING('$str$string',%COUNT))

	$str$con_args( %REMAINING ) %,


    $FORMAT( string ) =
	%ASSIGN( $str$options, %EXPAND $str$opt_init )
	%ASSIGN( $str$length, 0 )

	$str$format_opt( %REMAINING )			! Scan the $FORMAT option parameters

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( STR$FORMAT ) )

	%EXPAND $str$declare( LOCAL, $str$string, string )
	%EXPAND $str$local_init( $str$string, string )

	STR$FORMAT( %NUMBER( $str$options ),
		$str$string,
		$str$len_val(%REMAINING)
		%IF NOT $str$length
		%THEN
		    0
		%FI )
	END %,


    $str$format_opt( option ) [] =
	%IF $xpo$key_check( option, (UP_CASE, LEFT_JUSTIFY, RIGHT_JUSTIFY, CENTER), 'Option' )
	%THEN
	    %ASSIGN( $str$options, $str$options OR $xpo$name15( 'STR$M_', option ) )
	%ELSE
	    $str$format_key( option )
	%FI
	
	$str$format_opt( %REMAINING ) %;


KEYWORDMACRO
    $str$format_key( length ) = %;


MACRO
    $ASCII( value ) =
	%ASSIGN( $str$function, STR$K_BASE10 )
	%ASSIGN( $str$options, %EXPAND $str$opt_init )
	%ASSIGN( $str$length, 0 )

	$str$ascii_opt( %REMAINING )			! Scan the $ASCII option parameters

	%IF ( $str$options AND ( STR$M_LEADING_B OR STR$M_LEADING_Z ) ) EQL 0
	%THEN
	    %IF $str$function EQL STR$K_BASE10
	    %THEN
		%ASSIGN( $str$options, $str$options OR STR$M_LEADING_B )
	    %ELSE
		%ASSIGN( $str$options, $str$options OR STR$M_LEADING_Z )
	    %FI
	%FI

	%IF ( $str$options AND ( STR$M_SIGNED OR STR$M_UNSIGNED ) ) EQL 0
	%THEN
	    %IF $str$function EQL STR$K_BASE10
	    %THEN
		%ASSIGN( $str$options, $str$options OR STR$M_SIGNED )
	    %ELSE
		%ASSIGN( $str$options, $str$options OR STR$M_UNSIGNED )
	    %FI
	%FI

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( STR$ASCII ) )

	STR$ASCII( %NUMBER( $str$options ) + %NUMBER( $str$function ),
		value,
		$str$len_val(%REMAINING)
		%IF NOT $str$length
		%THEN
		    0
		%FI )
	END %,


    $str$ascii_opt( option ) [] =
	%IF $xpo$key_check( option, ( BASE2, BASE8, BASE10, BASE16,
					SIGNED, UNSIGNED,
					LEADING_BLANK, LEADING_ZERO,
					DATE, TIME, DAY ) )
	%THEN
	    %IF $xpo$key_check( option, ( BASE2, BASE8, BASE10, BASE16, DATE, TIME, DAY ) )
	    %THEN
		%ASSIGN( $str$function, $xpo$name15( 'STR$K_', option ) )
	    %ELSE
		%ASSIGN( $str$options, $str$options OR $xpo$name15( 'STR$M_', option ) )
	    %FI
	%ELSE
	    $str$ascii_key( option )
	%FI
	
	$str$ascii_opt( %REMAINING ) %;


KEYWORDMACRO
    $str$ascii_key( length ) = %;


MACRO
    $str$len_val( parameter ) [] =
	%IF NOT $xpo$key_check( parameter, ( BASE2, BASE8, BASE10, BASE16, DATE, TIME, DAY,
						SIGNED, UNSIGNED, LEADING_ZERO, LEADING_BLANK, UP_CASE,
						LEFT_JUSTIFY, RIGHT_JUSTIFY, CENTER ) )
	%THEN
	    $str$$len_val( parameter )
	%FI

	$str$len_val( %REMAINING ) %;

KEYWORDMACRO
    $str$$len_val( length ) =
	%IF NOT %NULL( length )
	%THEN
	    %IF $str$length
	    %THEN
		%WARN( 'Only one LENGTH= parameter permitted' )
	    %ELSE
		length
		%ASSIGN( $str$length, 1 )
	    %FI
	%FI %;
!
! ASCII-to-binary String Conversion Function
!
!	$STR_BINARY
!

COMPILETIME
    $str$int_result = 0;				! Integer result indicator

							! $STR_BINARY function codes:
							!     see $ASCII functions codes

KEYWORDMACRO
    $STR_BINARY( string, result, option, options, range, success, failure = STR$FAILURE ) =

	%EXPAND $xpo$required( string, 'STRING=' )

	%IF %EXPAND $xpo$conflict( option, options )
	%THEN
	    %WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
	    %EXITMACRO
	%FI

	%ASSIGN( $str$function, STR$K_DFLT_FUNC )

	$str$binary_opt( option %REMOVE(options) )

	%IF NOT %NULL(result) AND $str$function LEQ STR$K_BASE16
	%THEN
	    %ASSIGN( $str$int_result, 1 )
	%ELSE
	    %ASSIGN( $str$int_result, 0 )
	%FI

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( STR$BINARY ) )
	%EXPAND $xpo$ex_failure( failure )

	%IF $str$int_result
	%THEN
	    LOCAL
		$str$result,
		$str$status;
	%FI

	%EXPAND $str$declare( LOCAL, $str$string, string )
	%EXPAND $str$local_init( $str$string, string )

	%IF $str$int_result
	%THEN
	    $str$status =
	%FI

	STR$BINARY( %EXPAND $str$opt_init + %NUMBER( $str$function ),
		$str$string,
		%IF $str$int_result
		%THEN
		    $str$result,
		%ELSE
		    $xpo$default( result, 0 ),
		%FI
		%IF %NULL( range )
		%THEN
		    0, 0,
		%ELSE
		    $xpo$arg1( %REMOVE( range ) ),
		    $xpo$arg2( %REMOVE( range ) ),
		%FI
		$xpo$default( success, 0 ),
		$xpo$default( failure, 0 ) )

	%IF $str$int_result
	%THEN
	    ;
	    IF .$str$status
	    THEN
		result = .$str$result;
	    .$str$status
	%FI
	END %;


MACRO
    $str$binary_opt( option ) [] =
	%IF NOT $xpo$key_test( option, (BASE2, BASE8, BASE10, BASE16, DATE, TIME), 'OPTIONS=' )
	%THEN
	    %EXITMACRO
	%FI

	%IF $str$function NEQ STR$K_DFLT_FUNC
	%THEN
	    %WARN( 'Conflicting conversion options' )
	    %EXITMACRO
	%FI

	%ASSIGN( $str$function,  $xpo$name15( 'STR$K_', option ) )
	
	$str$binary_opt( %REMAINING ) %;
!
! String Scanning Functions
!
!	$STR_SCAN( FIND = sub-string, ... )
!	$STR_SCAN( SPAN = characters, ... )
!	$STR_SCAN( STOP = characters, ... )
!

$LITERAL						! String scanning function codes:
	STR$K_FIND	= $DISTINCT,			!    find sub-string
	STR$K_SPAN	= $DISTINCT,			!    match specified characters
	STR$K_STOP	= $DISTINCT;			!    search for specified characters

KEYWORDMACRO
    $STR_SCAN( string, remainder, find, span, stop, option, options,
		substring, target, delimiter, success, failure = STR$FAILURE ) =

	%EXPAND $xpo$required( string remainder, 'STRING= or REMAINDER=' )
	%EXPAND $xpo$required( find span stop, 'FIND=, SPAN= or STOP=' )

	%IF %EXPAND $xpo$conflict( string, remainder )
	%THEN
	    %WARN( 'STRING= and REMAINDER= are mutually exclusive' )
	    %EXITMACRO
	%FI

	%IF %EXPAND $xpo$conflict( find, span, stop )
	%THEN
	    %WARN( 'FIND=, SPAN= and STOP= are mutually exclusive' )
	    %EXITMACRO
	%FI

	%IF %EXPAND $xpo$conflict( option, options )
	%THEN
	    %WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
	    %EXITMACRO
	%FI

	%IF %EXPAND $xpo$conflict( substring, target )
	%THEN
	    %WARN( 'SUBSTRING= and TARGET= are mutually exclusive' )
	    %EXITMACRO
	%FI

	%ASSIGN( $str$options, %EXPAND $str$opt_init )

	%IF NOT %NULL( remainder )
	%THEN
	    %ASSIGN( $str$options, $str$options OR STR$M_REMAINDER )
	%FI

	%IF NOT %NULL( find )
	%THEN
	    %ASSIGN( $str$function, STR$K_FIND )
	%ELSE %IF NOT %NULL( span )
	%THEN
	    %ASSIGN( $str$function, STR$K_SPAN )
	%ELSE
	    %ASSIGN( $str$function, STR$K_STOP )
	%FI %FI

	%IF NOT %NULL( target )
	%THEN
	    %ASSIGN( $str$options, $str$options OR STR$M_TARGET )
	%FI

	BEGIN
	%EXPAND $xpo$force( $xpo$ex_routine( STR$SCAN ) )
	%EXPAND $xpo$ex_failure( failure )

	%IF NOT %NULL( delimiter )
	%THEN
	    LOCAL $str$status,
		$str$delimiter;
	%ELSE
	    LITERAL $str$delimiter = 0;
	%FI

	$str$declare( LOCAL, $str$string, string remainder )
	$str$declare( LOCAL, $str$pattern, find span stop )

	$str$local_init( $str$string, string remainder )
	$str$local_init( $str$pattern, find span stop )

	%IF NOT %NULL( delimiter )
	%THEN
	    $str$status =
	%FI

	STR$SCAN( %NUMBER( $str$options ) + %NUMBER( $str$function ),
		$str$string,
		$str$pattern,
		$xpo$default( substring target, 0 ),
		$str$delimiter,
		$xpo$default( success, 0 ),
		$xpo$default( failure, 0 ) )

	%IF NOT %NULL( delimiter )
	%THEN
	    ;
	    IF .$str$status
	    THEN
		delimiter = .$str$delimiter;
	    .$str$status
	%FI
	END %;
!
! XPORT Completion Code Definitions
!

%IF %BLISS(BLISS32) %THEN
LITERAL
    XPO$K_VMS_CODE = 32,				! VAX/VMS facility code for XPORT
    $xpo$k_msg_code = 32^16 + 1^15,			! VAX/VMS message code for XPORT
    STR$K_VMS_CODE = 36,				! VAX/VMS facility code for XPORT String Package
    $str$k_msg_code = 36^16 + 1^15;			! VAX/VMS message code for XPORT String Package
%FI

COMPILETIME						! Initialize completion code variables
    $xpo$ok_val = XPO$_SUCCESS %BLISS32( + $xpo$k_msg_code ),
    $xpo$warn_val = XPO$_WARNING + %X'1000' %BLISS32( + $xpo$k_msg_code ),
    $xpo$error_val = XPO$_ERROR + %X'2000' %BLISS32( + $xpo$k_msg_code ),
    $xpo$fatal_val = XPO$_FATAL + %X'4000' %BLISS32( + $xpo$k_msg_code ),
    $str$ok_val = XPO$_SUCCESS + %X'0800' %BLISS32( + $str$k_msg_code ),
    $str$warn_val = XPO$_WARNING + %X'1800' %BLISS32( + $str$k_msg_code ),
    $str$error_val = XPO$_ERROR + %X'2800' %BLISS32( + $str$k_msg_code ),
    $str$fatal_val = XPO$_FATAL + %X'4800' %BLISS32( + $str$k_msg_code );

KEYWORDMACRO
    $XPO_COMP_CODES( success, warning, error, fatal ) =
	LITERAL $xpo$comp_def( $xpo$ok_val, %REMOVE(success) );
	LITERAL $xpo$comp_def( $xpo$warn_val, %REMOVE(warning) );
	LITERAL $xpo$comp_def( $xpo$error_val, %REMOVE(error) );
	LITERAL $xpo$comp_def( $xpo$fatal_val, %REMOVE(fatal) ); %,

    $STR_COMP_CODES( success, warning, error, fatal ) =
	LITERAL $str$comp_def( $str$ok_val, %REMOVE(success) );
!	LITERAL $str$comp_def( $str$warn_val, %REMOVE(warning) );
	LITERAL $str$comp_def( $str$error_val, %REMOVE(error) );
	LITERAL $str$comp_def( $str$fatal_val, %REMOVE(fatal) ); %;

MACRO
    $xpo$comp_def( code_value ) [ code_name ] =
	%NAME( 'XPO$_', $xpo$arg1(%REMOVE(code_name)) ) = code_value

	%IF $xpo$show_lit
	%THEN
	    %PRINT( '	XPO$_', $xpo$arg1(%REMOVE(code_name)), '	= ',
		%NUMBER(code_value), '   (',
		%IF %BLISS(BLISS32)
		%THEN
		    '%X'''  $XPO$SHOW_NUMB(code_value,16)
		%ELSE
		    '%O'''  $XPO$SHOW_NUMB(code_value,8)
		%FI
		, ''')' )
	%FI

	%ASSIGN( code_value, code_value + 8 ) %,


    $str$comp_def( code_value ) [ code_name ] =
	%NAME( 'STR$_', $xpo$arg1(%REMOVE(code_name)) ) = code_value

	%IF $xpo$show_lit
	%THEN
	    %PRINT( '	STR$_', $xpo$arg1(%REMOVE(code_name)), '	= ',
		%NUMBER(code_value), '   (',
		%IF %BLISS(BLISS32)
		%THEN
		    '%X'''  $XPO$SHOW_NUMB(code_value,16)
		%ELSE
		    '%O'''  $XPO$SHOW_NUMB(code_value,8)
		%FI
		, ''')' )
	%FI

	%ASSIGN( code_value, code_value + 8 ) %,


    $XPO_OK_CODE =
	( NORMAL, 'normal completion' ),
	( CREATED, 'file was successfully created and opened' ),
	( INCOMPLETE, 'incomplete amount of data read' ),
	( NEW_FILE, 'first read on concatenated file was successful' ),
	( NEW_PAGE, 'first read on a new page was successful' ) %,

    $STR_OK_CODE =
	( END_STRING, 'end of string reached' ),
	( TRUNCATED, 'string was truncated' ),
	( NOT_TEMP, 'not a temporary string' ) %,


    $XPO_WARN_CODE =
	( END_FILE, 'end-of-file has been reached' ) %,


    $STR_WARN_CODE = %,


    $XPO_ERROR_CODE =
	( BAD_ADDR, 'invalid memory address' ),
	( BAD_ALIGN, 'memory element not on a fullword boundary' ),
	( BAD_ARGS, 'invalid argument list' ),
	( BAD_CONCAT, 'invalid concatenated file specification' ),
	( BAD_DELIM, 'invalid punctuation' ),
	( BAD_DESC, 'invalid descriptor' ),
	( BAD_DEVICE, 'invalid device' ),
	( BAD_DFLT, 'invalid default file specification' ),
	( BAD_DIRECT, 'invalid directory' ),
	( BAD_DTYPE, 'invalid data type' ),
	( BAD_FORMAT, 'invalid record format' ),
	( BAD_IO_OPT, 'invalid I/O option' ),
	( BAD_LENGTH, 'invalid length' ),
	( BAD_NAME, 'invalid file name' ),
	( BAD_NEW, 'invalid new file' ),
	( BAD_NODE, 'invalid node' ),
	( BAD_ORG, 'invalid file organization' ),
	( BAD_PROMPT, 'invalid prompt' ),
	( BAD_RECORD, 'invalid record' ),
	( BAD_REQ, 'invalid request' ),
	( BAD_RLTD, 'invalid related file specification' ),
	( BAD_RSLT, 'invalid resultant file specification' ),
	( BAD_SPEC, 'invalid file specification' ),
	( BAD_TYPE, 'invalid file type' ),
	( BAD_VER, 'invalid file version' ),
	( CHANNEL, 'I/O channel assignment error' ),
	( CLOSED, 'file is already closed' ),
	( CONFLICT, 'conflicting options or attributes' ),
	( CORRUPTED, 'file is corrupted' ),
	( EXISTS, 'file already exists' ),
	( FILE_LOCK, 'file is locked' ),
	( FREE_MEM, 'dynamic memory deallocation error' ),
	( GET_MEM, 'dynamic memory allocation error' ),
	( IN_USE, 'file is currently in use' ),
	( IO_BUFFER, 'I/O buffering error' ),
	( IO_ERROR, 'I/O error' ),
	( MISSING, 'required parameter, option or attribute missing' ),
	( NETWORK, 'network error' ),
	( NO_ACCESS, 'file cannot be accessed' ),
	( NO_BACKUP, 'file cannot be backed up' ),
	( NO_CHANNEL, 'all I/O channels are in use' ),
	( NO_CLOSE, 'file cannot be closed' ),
	( NO_CONCAT, 'concatenated file specification not allowed' ),
	( NO_CREATE, 'file cannot be created' ),
	( NO_DELETE, 'file cannot be deleted' ),
	( NO_DIRECT, 'directory does not exist' ),
	( NO_FILE, 'file does not exist' ),
	( NO_MEMORY, 'insufficient dynamic memory' ),
	( NO_OPEN, 'file cannot be opened' ),
	( NO_READ, 'file cannot be read' ),
	( NO_RENAME, 'file cannot be renamed' ),
	( NO_SPACE, 'insufficient space' ),
	( NO_SUBDIR, 'sub-directory does not exist' ),
	( NO_SUPPORT, 'requested function not supported' ),
	( NO_WRITE, 'file cannot be written' ),
	( NOT_CLOSED, 'file has not been closed' ),
	( NOT_EXPIRE, 'expiration date has not been reached' ),
	( NOT_INPUT, 'file is not open for input' ),
	( NOT_ONLINE, 'device is not online' ),
	( NOT_OPEN, 'file has not been opened' ),
	( NOT_OUTPUT, 'file is not open for output' ),
	( OPEN, 'file is currently open' ),
	( PREV_ERROR, 'program terminated due to previous error' ),
	( PRIVILEGED, 'privileged operation' ),
	( PROTECTED, 'file protection denies access' ),
	( PUT_MSG, 'message output error' ),
	( REC_LOCK, 'record is locked' ),
	( RENAME_NEW, 'new file cannot be renamed' ),
	( RENAME_OLD, 'old file cannot be renamed' ),
	( TRUNCATED, 'record was truncated' ),
	( WILDCARD, 'wildcard error' ),
	( BAD_ACCT, 'invalid account attribute' ),
	( BAD_ATTR, 'invalid attribute' ),
	( BAD_DATA, 'invalid data' ),
	( BAD_MEDIA, 'disk/tape cannot be read/written' ),
	( BAD_MEMORY, 'free storage chain is invalid' ),
	( BAD_PROT, 'invalid protection attribute' ),
	( BAD_PTR, 'invalid character pointer' ),
	( BAD_RECNUM, 'invalid record number' ),
	( BAD_SIZE, 'invalid size' ),
	( BAD_TEMP, 'invalid temporary file attribute' ),
	( CHAN_USED, 'I/O channel is currently in use' ),
	( HOST_ERROR, 'host operating system error' ),
	( NO_NODE, 'network node does not exist' ),
	( NO_STACK, 'insufficient stack space' ),
	( SYS_ERROR, 'unexpected operating system error' ),
	( BAD_CLASS, 'invalid descriptor class' ),
	( NO_TEMP, 'temporary file not permitted' ),
    	( FOREGROUND, 'foreground jobs not permitted' ),
    	( NO_APPEND, 'append function not permitted' ),
    	( NO_SEQ, 'sequenced files not permitted' ) %,


    $STR_ERROR_CODE =
	( BAD_CHAR, 'invalid character' ),
	( BAD_CLASS, 'invalid descriptor class' ),
	( BAD_DESC, 'invalid string descriptor' ),
	( BAD_DTYPE, 'invalid descriptor data type' ),
	( BAD_LENGTH, 'invalid string length' ),
	( BAD_MAXLEN, 'invalid maximum string length' ),
	( BAD_PATTRN, 'invalid pattern string' ),
	( BAD_PTR, 'invalid string pointer' ),
	( BAD_REQ, 'invalid string request' ),
	( BAD_SOURCE, 'invalid source string' ),
	( BAD_STRNG1, 'invalid primary string' ),
	( BAD_STRNG2, 'invalid secondary string' ),
	( BAD_TARGET, 'invalid target string' ),
	( CONFLICT, 'conflicting string function arguments' ),
	( NO_SPACE, 'insufficient space' ),
	( NO_STRING, 'no string specified' ),
	( NO_SUPPORT, 'requested function not supported' ),
	( NO_TEMP, 'temporary string not permitted' ),
	( NULL_STRNG, 'null string not permitted' ),
	( OUT_RANGE, 'integer value out of range' ) %,


    $XPO_FATAL_CODE =
	( BAD_IOB, 'invalid IOB' ),
	( BAD_LOGIC, 'XPORT logic error detected' ),
	( TERMINATE, 'program terminated due to program request' ) %,


    $STR_FATAL_CODE = 
	( BAD_LOGIC, 'XPORT string logic error detected' ) %;


LITERAL							! Define special XPORT string completion codes
    STR$_NORMAL = 1,
    STR$_FAILURE = 0;

    $XPO_COMP_CODES(					! Define all XPORT completion codes
	SUCCESS = ( $XPO_OK_CODE ),
	WARNING = ( $XPO_WARN_CODE ),
	ERROR = ( $XPO_ERROR_CODE ),
	FATAL = ( $XPO_FATAL_CODE ) )

    $STR_COMP_CODES(					! Define all XPORT string completion codes
	SUCCESS = ( $STR_OK_CODE ),
	WARNING = ( $STR_WARN_CODE ),
	ERROR = ( $STR_ERROR_CODE ),
	FATAL = ( $STR_FATAL_CODE ) )


$LITERAL						! XPORT action routine function codes:
    XPO$K_IO = $DISTINCT,				!    I/O
    XPO$K_PARSE = $DISTINCT,				!    PARSE_SPEC
    XPO$K_GET_MEM = $DISTINCT,				!    GET_MEMORY
    XPO$K_FREE_MEM = $DISTINCT,				!    FREE_MEMORY
    XPO$K_PUT_MSG = $DISTINCT;				!    PUT_MSG

$LITERAL						! XPORT String Package action routine function codes:
    STR$K_COMPARE = $DISTINCT,				!    string comparison functions
    STR$K_COPY = $DISTINCT,				!    $STR_COPY
    STR$K_APPEND = $DISTINCT,				!    $STR_APPEND
    STR$K_SCAN = $DISTINCT,				!    $STR_SCAN
    STR$K_BINARY = $DISTINCT,				!    $STR_BINARY
    STR$K_PSEUDO = $DISTINCT;				!    $ASCII, $CONCAT, $FORMAT  (no action routine called)
!
! VAX/VMS-specific Definitions
!

%IF %BLISS(BLISS32) %THEN

MACRO
    CLI$_SYNTAX =
	SHR$_SYNTAX + 3^16 %,				! CLI-W-SYNTAX error message number


    $XPO_CALL_CLI( descriptor, work_area, extra_argument ) =
	BEGIN
	EXTERNAL ROUTINE SYS$CLI :  ADDRESSING_MODE( GENERAL );
	SYS$CLI( descriptor, work_area, extra_argument )
	END %,


    $XPO_KEY_TABLE( entry ) =
	VECTOR[ %LENGTH*2 + 1 ]
	INITIAL( %LENGTH*2

	$XPO$KEY_TABLE( entry, %REMAINING )

	) %,


    $XPO$KEY_TABLE( entry ) [] =
	$XPO$KEY_ENTRY( %REMOVE(entry) )
	$XPO$KEY_TABLE( %REMAINING ) %,


    $XPO$KEY_ENTRY( keyword, value ) =
	, UPLIT( %STRING( %CHAR(%CHARCOUNT(keyword)), keyword ) )
	    , value %;

%FI

	$SHOW( NONE, INFO )