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 )