github.com/PDP-10.stacken
1
0
Fork 0
mirror of https://github.com/PDP-10/stacken.git synced 2026-03-07 11:17:06 +00:00
Code Issues Projects Releases Wiki Activity
Files
master
PDP-10.stacken/files/stacken-tape-backup/dskb:10_7/decmai/mx/mxport.req
Lars Brinkhoff 6e18f5ebef Extract files from tape images. 
Some tapes could not be extracted.
2021-01-29 10:47:33 +01:00

3646 lines
110 KiB
Plaintext
Raw Permalink Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
!
! COPYRIGHT (c) 1981 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!
!++
! FACILITY:
! XPORT - BLISS Transportability Support Package
!
! ABSTRACT:
! This REQUIRE file defines all XPORT user macros and symbols.
!
! ENVIRONMENT:
! User mode
!
! AUTHOR: Ward Clark, CREATION DATE: 17-Mar-81
!
! MODIFIED BY:
!
!--
!
! XPORT Control Block and Macro Definitions
!
MACRO
$XPO_IDENT = 'V1.1-44' %;
LITERAL
XPO$K_VERSION = 1, ! Current XPORT version
XPO$K_LEVEL = 1, ! and 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 %NULL(linkage_attr)
%THEN
%BLISS16(BLISS) %BLISS32(BLISS) %BLISS36(BLISS36C)
%ELSE
linkage_attr
%FI
%BLISS32( ADDRESSING_MODE(LONG_RELATIVE) ) ; %,
$XPO$EX_FAILURE( failure ) =
%IF $xpo$key_check( failure, (XPO$FAILURE, XPO$IO_FAILURE, XPO$PS_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
%IF %BLISS(BLISS32)
%THEN
COMPILETIME
$xpo$first_$field = 1;
%FI
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)
%IF %BLISS(BLISS32)
%THEN
%IF $xpo$first_$field
%THEN
%ASSIGN( $xpo$first_$field, 0 )
%IF %DECLARED( %QUOTE %QUOTE %QUOTE $DESCRIPTOR )
%THEN
MACRO $xpo$vms_descriptor( string ) =
%QUOTE %EXPAND %QUOTE $DESCRIPTOR( string ) %QUOTE % ;
UNDECLARE %QUOTE %QUOTE %QUOTE $DESCRIPTOR;
MACRO $descriptor( string ) =
%IF %IDENTICAL( string, %STRING(string) )
%THEN
$xpo$vms_descriptor( string )
%ELSE
$xpo$descriptor( string )
%FI %QUOTE % ;
%ELSE
MACRO $descriptor( keyword ) =
$xpo$descriptor( keyword ) %QUOTE % ;
%FI
%FI
%FI
FIELD %,
$UNIT_FIELD =
$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
%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 %,
$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 %,
$xpo$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 %,
%IF %BLISS(BLISS16) OR %BLISS(BLISS36) %THEN
$DESCRIPTOR( keyword ) =
%EXPAND $xpo$descriptor( keyword ) %,
%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_XXX = 0, ! Erroreous XPORT temporary string
STR$K_DTYPE_T = 14; ! ASCII text 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 = 190, ! dynamic bounded string
STR$K_CLASS_XT = 189; ! XPORT temporary string (dynamic)
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
STR$K_XT_BLN = $FIELD_SET_SIZE ; ! Length of an XPORT temporary 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
%FI %FI %,
$str$desc_class( class ) =
%IF %IDENTICAL(class,DYNAMIC_BOUNDED) %THEN STR$K_CLASS_DB %ELSE
%IF %IDENTICAL(class,DYNAMIC_VARYING) %THEN STR$K_CLASS_DB %ELSE ! *** OBSOLETE ***
%IF %IDENTICAL(class,XPORT_TEMPORARY) %THEN STR$K_CLASS_XT
%ELSE
%NAME( %EXACTSTRING( 13, 0, 'STR$K_CLASS_', class ) )
%FI %FI %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 %IDENTICAL( class, XPORT_TEMPORARY )
%THEN
%IF NOT $xpo$key_test( class, (FIXED, DYNAMIC, BOUNDED, DYNAMIC_BOUNDED), 'CLASS=' )
%THEN
%EXITMACRO
%FI
%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
%INFORM( 'TYPE= is obsolete - see current documentation' ) ! *** OBSOLETE ***
%IF NOT $xpo$key_test( type, (CHARACTERS, FULLWORDS, UNITS), 'TYPE=' )
%THEN
%EXITMACRO
%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 %ISSTRING( %REMOVE(string) ) AND NOT %IDENTICAL(class,FIXED)
%THEN
%WARN( 'STRING=literal requires CLASS=FIXED' )
%EXITMACRO
%FI
%IF $xpo$paren_test(string) AND NOT %IDENTICAL( $xpo$arg1(%REMOVE(string)), 0 )
AND NOT ( %IDENTICAL(class,FIXED) OR %IDENTICAL(class,BOUNDED) )
%THEN
%WARN( '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 %IDENTICAL( class, XPORT_TEMPORARY )
%THEN
%IF NOT $xpo$key_test( class, (FIXED, DYNAMIC, BOUNDED, DYNAMIC_BOUNDED), 'CLASS=' )
%THEN
%EXITMACRO
%FI
%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
%INFORM( 'TYPE= is obsolete - see current documentation' ) ! *** OBSOLETE ***
%IF NOT $xpo$key_test( type, (CHARACTERS, FULLWORDS, UNITS), 'TYPE=' )
%THEN
%EXITMACRO
%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 = $STR_FORMAT( string_info );
%ELSE
LOCAL name : %EXPAND $xpo$force( $STR_DESCRIPTOR() VOLATILE );
%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( XST$FREE_TEMP ) )
XST$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 = 190; ! 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() VOLATILE );
%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 %;
!
! TIME_BLOCK - 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_TIME_LEN = $FIELD_SET_SIZE; ! Length of date/time block
$SHOW( INFO ) ! Turn %INFORM messages back on
MACRO
$XPO_TIME_BLOCK =
BLOCK[XPO$K_TIME_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,
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$FILLBIT = [$BIT] , ! reserved for future use
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
IOB$V_CH_ASSIGN = [$BIT] , ! channel has been assigned >open, delete, rename <open, delete, rename
$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$FILLER0 = [$SHORT_INTEGER] , ! Reserved for future use
IOB$H_PAGE_NUMB = [$SHORT_INTEGER] , ! Current page number <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_TIME_LEN)], ! File creation date and time (future)
IOB$Z_REVISED = [$SUB_BLOCK(XPO$K_TIME_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 ! *** OBSOLETE ***
sequence_number, ! record sequence number
record_size, ! maximum record size
block_size, ! physical block size
user ! user-specified value
) =
%IF NOT %NULL( page_number ) ! *** OBSOLETE ***
%THEN ! *** OBSOLETE ***
%INFORM( 'PAGE_NUMBER= parameter is no longer supported' ) ! *** OBSOLETE ***
%FI ! *** OBSOLETE ***
%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,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,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$, %REMOVE(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 ! *** OBSOLETE ***
sequence_number, ! record sequence number
record_size, ! maximum record size
block_size, ! physical block size
user ! user-specified value
) =
%IF NOT %NULL( page_number ) ! *** OBSOLETE ***
%THEN ! *** OBSOLETE ***
%INFORM( 'PAGE_NUMBER= parameter is no longer supported' ) ! *** OBSOLETE ***
%FI ! *** OBSOLETE ***
%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,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$, %REMOVE(option) %REMOVE(options) ) ! OPTION= or OPTIONS=
$xpo$keyword( iob$, %REMOVE(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$, 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 ! *** OBSOLETE ***
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 NOT %NULL( page_number ) ! *** OBSOLETE ***
%THEN ! *** OBSOLETE ***
%INFORM( 'PAGE_NUMBER= parameter is no longer supported' ) ! *** OBSOLETE ***
%FI ! *** OBSOLETE ***
%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,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$, %REMOVE(option) %REMOVE(options) ) ! OPTION= or OPTIONS=
$xpo$keyword( iob$, %REMOVE(attribute) %REMOVE(attributes) ) ! ATTRIBUTE= or ATTRIBUTES=
$iob$get_length( STR$K_DTYPE_T, characters ) ! CHARACTERS=
$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 ! *** OBSOLETE ***
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 NOT %NULL( page_number ) ! *** OBSOLETE ***
%THEN ! *** OBSOLETE ***
%INFORM( 'PAGE_NUMBER= parameter is no longer supported' ) ! *** OBSOLETE ***
%FI ! *** OBSOLETE ***
%IF %EXPAND $xpo$conflict( (string,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$, 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$, %REMOVE(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_SFD = [$BIT] , ! [,,SFD] specified (TOPS-10 only)
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_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
XPO$V_WILD_ATTR = [$BIT] , ! wild-card file attributes
$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 ) %;
MACRO ! *** OBSOLETE ***
XPO$V_WILD_PROJ = ! *** OBSOLETE ***
%WARN( 'XPO$V_WILD_PROJ is no longer defined' ) ! *** OBSOLETE ***
XPO$V_WILD_DIR %, ! *** OBSOLETE ***
XPO$V_WILD_PGMR = ! *** OBSOLETE ***
%WARN( 'XPO$V_WILD_PGMR is no longer defined' ) ! *** OBSOLETE ***
XPO$V_WILD_DIR %; ! *** OBSOLETE ***
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 DYNAMIC or DYNAMIC BOUNDED descriptor
descriptor, ! address of a DYNAMIC or DYNAMIC BOUNDED 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
fill, ! storage fill 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' )
%EXITMACRO
%FI
%IF %EXPAND $xpo$conflict( desc, descriptor )
%THEN
%WARN( 'DESC= and DESCRIPTOR= are mutually exclusive' )
%EXITMACRO
%FI
%IF %EXPAND $xpo$conflict( (desc,descriptor), (result) )
%THEN
%WARN( 'DESC=/DESCRIPTOR= and /RESULT= parameters are mutually exclusive' )
%EXITMACRO
%FI
%IF %NULL( characters, fullwords, units ) ! *** OBSOLETE ***
%THEN ! *** OBSOLETE ***
%INFORM( 'Semantic meaning of DESCRIPTOR= has been changed - see documentation') ! *** OBSOLETE ***
%FI ! *** OBSOLETE ***
! %EXPAND $xpo$required( characters fullwords units,'CHARACTERS=, FULLWORDS= or UNITS=' ) ! *** REMOVE "!" ***
%EXPAND $xpo$required( desc descriptor result, 'DESC=, DESCRIPTOR= or RESULT=' )
BEGIN
%EXPAND $xpo$force( $xpo$ex_routine( XPO$ALLOC_MEM ) )
%EXPAND $xpo$ex_failure( failure )
%IF NOT %NULL( desc, descriptor )
%THEN
BIND $xpo$desc = desc descriptor : %EXPAND $xpo$force( $STR_DESCRIPTOR(CLASS=DYNAMIC_BOUNDED) );
%ELSE
LOCAL
$xpo$status,
$xpo$desc :
%IF NOT %NULL( characters )
%THEN
%EXPAND $xpo$force( $STR_DESCRIPTOR(CLASS=DYNAMIC) );
$str$str_desc( $xpo$desc, DYNAMIC, (0,0) )
%ELSE
%EXPAND $xpo$force( $XPO_DESCRIPTOR(CLASS=DYNAMIC) );
$xpo$bin_desc( $xpo$desc, DYNAMIC, (0,0) )
%FI
$xpo$status =
%FI
XPO$ALLOC_MEM( ! XPO$ALLOC_MEM argument list:
%IF NOT %NULL(characters, fullwords, units) ! *** OBSOLETE ***
%THEN ! *** OBSOLETE ***
characters units ! explicit length
%IF NOT %NULL(fullwords)
%THEN %BLISS32(4 *) %BLISS16(2 *)
( fullwords ) %FI,
%ELSE ! implicit length ! *** OBSOLETE ***
IF .$xpo$desc[STR$B_CLASS] EQL STR$K_CLASS_DB ! *** OBSOLETE ***
THEN ! *** OBSOLETE ***
.$xpo$desc[STR$H_MAXLEN] ! *** OBSOLETE ***
ELSE ! *** OBSOLETE ***
.$xpo$desc[STR$H_LENGTH], ! *** OBSOLETE ***
%FI ! *** OBSOLETE ***
$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 %NULL( desc, descriptor )
%THEN
;
IF .$xpo$status
THEN
%IF NOT %NULL( characters )
%THEN
result = .$xpo$desc[STR$A_POINTER];
%ELSE
result = .$xpo$desc[XPO$A_ADDRESS];
%FI
.$xpo$status
%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) VOLATILE );
%ELSE
%EXPAND $xpo$force( $XPO_DESCRIPTOR(CLASS=DYNAMIC) VOLATILE );
%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 %;
%IF NOT %BLISS(BLISS32) %THEN
$FIELD $xpo$free_element = ! Free storage element descriptor:
SET !
XPO$H_FREE_SIZE = [$BYTES(2)], ! size of the element (addressable units)
XPO$A_FREE_LINK = [$ADDRESS] ! address of the next free element
TES;
LITERAL $xpo$free_elem_len = $FIELD_SET_SIZE;
MACRO
$XPO_FREE_ELEMENT =
BLOCK[ $xpo$free_elem_len ] FIELD( $xpo$free_element ) %;
%FI
!
! XPORT Host System Services Macros
!
KEYWORDMACRO
$XPO_TERMINATE(
code=XPO$_TERMINATE ! termination completion code
) =
BEGIN
%EXPAND $xpo$force( $xpo$ex_routine( XPO$TERMINATE ) )
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$pmsg_init( key_parameter, %REMAINING ) ! Count the number of local descriptors needed.
LOCAL
$xpo$local_desc : BLOCKVECTOR[ $xpo$desc_count, STR$K_F_BLN ] VOLATILE ;
%EXPAND $xpo$force( $xpo$ex_routine( XPO$MESSAGE, FORTRAN_FUNC ) ) ! FORTRAN_FUNC linkage permits
! variable length argument list
%IF $xpo$fail_flag ! See if user specified FAILURE= parameter.
%THEN
%ASSIGN( $xpo$fail_flag, 0 )
%ELSE
%EXPAND $xpo$force( $xpo$ex_routine( XPO$FAILURE ) )
%FI
XPO$MESSAGE( ! Call XPORT message output routine.
! Generate the following fixed arguments:
$xpo$pmsg_fixed( 1, key_parameter, %REMAINING ) ! severity code
$xpo$pmsg_fixed( 2, key_parameter, %REMAINING ) ! address of success action routine
$xpo$pmsg_fixed( 3, key_parameter, %REMAINING ) ! address of failure action routine
$xpo$pmsg_parm( key_parameter, %REMAINING ) ! Generate "n" keyword argument pairs
) ! Trailing right parenthesis
END %;
MACRO
$xpo$pmsg_init( parameter ) [] = ! Count number of local descriptors needed
$xpo$$pmsg_init( parameter )
$xpo$pmsg_init( %REMAINING ) %;
KEYWORDMACRO
$xpo$$pmsg_init( ! 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 NOT %NULL( failure )
%THEN
%EXPAND $xpo$ex_failure( failure )
%ASSIGN( $xpo$fail_flag, 1 )
%FI
%IF %ISSTRING( %REMOVE(string) ) OR $xpo$paren_test(string)
%THEN
%ASSIGN( $xpo$desc_count, $xpo$desc_count + 1 )
%FI %;
MACRO
$xpo$pmsg_fixed( number, parameter ) [] = ! Generated required arguments
$xpo$$pmsg_parm( ARGUMENT=number, parameter )
%IF NOT %NULL(%REMAINING)
%THEN
$xpo$pmsg_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$pmsg_parm( parameter ) [] = ! Generate an argument pair
$xpo$$pmsg_parm( ARGUMENT=0, parameter )
$xpo$pmsg_parm( %REMAINING ) %;
KEYWORDMACRO
$xpo$$pmsg_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, $pmsg$string, string )
$str$local_init( $pmsg$string, string )
$pmsg$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)] , ! $STR_ASCII, $STR_BINARY, $STR_SCAN function code
$OVERLAY( $str$v_option1 ) ! $STR_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( XST$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( XST$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( XST$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( XST$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( XST$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( XST$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( XST$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( XST$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 )
XST$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( XST$APPEND ) )
%EXPAND $xpo$ex_failure( failure )
%EXPAND $str$declare( LOCAL, $str$string, string )
%EXPAND $str$local_init( $str$string, string )
XST$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
!
! $STR_CONCAT, $STR_FORMAT
!
! Binary-to-ASCII String Conversion Function
!
! $STR_ASCII
!
$LITERAL ! $STR_ASCII and $STR_BINARY function codes:
STR$K_DFLT_FUNC = 0, ! default function
STR$K_BASE2 = $DISTINCT, ! $STR_ASCII( value, BASE2 )
STR$K_BASE8 = $DISTINCT, ! $STR_ASCII( value, BASE8 )
STR$K_BASE10 = $DISTINCT, ! $STR_ASCII( value, BASE10 )
STR$K_BASE16 = $DISTINCT, ! $STR_ASCII( value, BASE16 )
STR$K_DATE = $DISTINCT, ! $STR_ASCII( value, DATE )
STR$K_TIME = $DISTINCT, ! $STR_ASCII( value, TIME )
STR$K_DAY = $DISTINCT; ! $STR_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 = ! ***** OBSOLETE *****
%INFORM( '$CONCAT has been renamed to $STR_CONCAT' ) ! ***** OBSOLETE *****
%QUOTE $STR_CONCAT %, ! ***** OBSOLETE *****
$STR_CONCAT [] =
BEGIN
%EXPAND $xpo$force( $xpo$ex_routine( XST$JOIN, FORTRAN_FUNC ) )
$str$con_decl( %REMAINING )
$str$con_init( %REMAINING )
XST$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 = ! ***** OBSOLETE *****
%INFORM( '$FORMAT has been renamed to $STR_FORMAT' ) ! ***** OBSOLETE *****
%QUOTE $STR_FORMAT %, ! ***** OBSOLETE *****
$STR_FORMAT( string ) =
%ASSIGN( $str$options, %EXPAND $str$opt_init )
%ASSIGN( $str$length, 0 )
$str$format_opt( %REMAINING ) ! Scan the $STR_FORMAT option parameters
BEGIN
%EXPAND $xpo$force( $xpo$ex_routine( XST$FORMAT ) )
%EXPAND $str$declare( LOCAL, $str$string, string )
%EXPAND $str$local_init( $str$string, string )
XST$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 = ! ***** OBSOLETE *****
%INFORM( '$ASCII has been renamed to $STR_ASCII' ) ! ***** OBSOLETE *****
%QUOTE $STR_ASCII %, ! ***** OBSOLETE *****
$STR_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 $STR_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( XST$ASCII ) )
XST$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 $STR_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( XST$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
XST$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( XST$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
XST$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' ),
( BAD_ORDER, 'field is misplaced or duplicated' ),
( BAD_SYNTAX, 'invalid syntax' ) %,
$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' ),
( TOO_LONG, 'string is too long' ) %,
$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; ! $STR_ASCII, $STR_CONCAT, $STR_FORMAT (no action routine called)
!
! VAX/VMS-specific Definitions
!
%IF %BLISS(BLISS32) %THEN
UNDECLARE %QUOTE $descriptor; ! Make believe $FIELD has not been used.
%ASSIGN( $xpo$first_$field, 1 )
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 )
Reference in New Issue View Git Blame Copy Permalink