! ! COPYRIGHT (c) 1983, 1984 BY ! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS. ! ! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED ! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE ! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER ! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY ! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY ! TRANSFERRED. ! ! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE ! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT ! CORPORATION. ! ! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL. ! !++ ! FACILITY: ! 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: Edward G. Freedman ! ! REVISION HISTORY: ! ! 3-Apr-84 LYS Change $XPO_IDENT and XPO$K_LEVEL ! for version 1.3. ! ! 10-May-84 LYS Fixed $ALIGN macro so that it updates ! $XPO_MAX_BIT and $XPO_MAX_FULLWD if ! necessary. ! ! 24-Aug-84 LYS Update $XPO_IDENT ! ! END OF REVISION HISTORY !-- ! ! XPORT.REQ Version Identifiers ! ! This macro should be updated with every change to XPORT.REQ. ! See the corresponding macro in XPOSYS.REQ ($XPO$SYS_IDENT) for ! the definition of the format. ! MACRO $XPO_IDENT = 'V1.3-52' %; ! Update this with every change to XPORT.REQ LITERAL XPO$K_VERSION = 1, ! Current XPORT version XPO$K_LEVEL = 3; ! and level ! ! XPORT Control Block and Macro Definitions ! LITERAL 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 ) %, $XPO$POSITION ( position ) [] = %IF NOT $xpo$paren_test( position ) %THEN %UPVAL * (position) ! assume fullwords %ELSE %IF %NULL ( $xpo$arg2( %REMOVE(position) ) ) %THEN %UPVAL * (position) ! assume fullwords %ELSE %IF $xpo$key_test( $xpo$arg2( %REMOVE(position) ), (FULLWORDS, UNITS), 'POSITION=' ) %THEN %IF %IDENTICAL ( $xpo$arg2( %REMOVE(position) ), FULLWORDS ) %THEN %UPVAL * ($xpo$arg1( %REMOVE(position) ) ) %ELSE $xpo$arg1( %REMOVE(position) ) %FI %ELSE ! return null %FI %FI %FI %; ! ! 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 = 0; ! $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 ! generate field specs based on current indices %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) ) ! update current indices %ASSIGN( $xpo$bit_index, ($xpo$bit_index + bits) MOD %BPVAL ) %IF $xpo$full_index GTR $xpo$max_fullwd OR ! update high-water mark ($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 %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 %IF $xpo$full_index GTR $xpo$max_fullwd OR ! if we've passed the high-water mark, update it ($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 %, $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 ! if we've passed the high-water mark, update it ($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, 0 ) %, %ELSE $STRING( length ) = ! Character string for BLISS16 and BLISS32 $ALIGN(UNIT) $xpo$field( (length) * %BPUNIT, 0, 0 ) %, %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 %EXPAND $CONTINUE %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 %EXPAND $CONTINUE %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, (VERSION, FIELDS, LITERALS, INFO, ALL, NOFIELDS, NOLITERALS, NOINFO, NONE) ) %THEN %EXITMACRO %FI %IF %IDENTICAL( keyword, VERSION ) %THEN %print ('XPORT ', $xpo_ident, ' XPO$K_VERSION = ', %NUMBER (xpo$k_version), ' XPO$K_LEVEL = ', %NUMBER (xpo$k_level) ) %ELSE %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 %FI $SHOW (%REMAINING) %; $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 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 close, backup get-char IOB$A_ASSOC_IOB = [$ADDRESS] , ! Address of associated IOB >backup, rename IOB$B_FUNCTION = [$BYTE] ! I/O function code: >all TES; ! $LITERAL IOB$K_OPEN = $DISTINCT , ! open file IOB$K_CLOSE = $DISTINCT , ! close file IOB$K_DELETE = $DISTINCT , ! delete file IOB$K_RENAME = $DISTINCT , ! rename file IOB$K_BACKUP = $DISTINCT , ! create backup copy of input file IOB$K_GET = $DISTINCT , ! get record (locate mode) IOB$K_PUT = $DISTINCT ; ! put record (move mode) $ALIGN( WORD ) FIELD $iob$fields_2 = SET IOB$V_OPTIONS = [$BITS(16)] , ! I/O option flags: $OVERLAY( IOB$V_OPTIONS ) ! IOB$V_INPUT = [$BIT] , ! open for input >open, get IOB$V_OUTPUT = [$BIT] , ! open for output >open, put IOB$V_OVERWRITE = [$BIT] , ! overwrite existing output file >open-out IOB$V_APPEND = [$BIT] , ! append to existing output file >open-out IOB$V_REMEMBER = [$BIT] , ! file will be reprocessed after close >close IOB$V_MAX_VERSI = [$BIT] , ! maximize file version number (internal) >open, rename $CONTINUE $ALIGN( WORD ) IOB$V_ATTRIBUTE = [$BITS(16)] , ! File attributes: $OVERLAY( IOB$V_ATTRIBUTE ) ! IOB$V_BINARY = [$BIT] , ! binary data >open, get, put IOB$V_RANDOM = [$BIT] , ! random access data >open, get, put 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 all get, put open open get, put open, close close open, delete, rename get-stream get-bin 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 put-seq get, put open-out open-out get, put close get, put get put close get put close get put close 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 position, ! position in file 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,position) ) %THEN %WARN( 'Character and binary or random 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,position,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 position, ! position in file 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 %IF %EXPAND $xpo$conflict( (characters), (fullwords,units,position) ) %THEN %WARN( 'Character and binary or random parameters 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$, G_NEXT_POS, $XPO$POSITION (position) ) ! POSITION= $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 position, ! position in file 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,position) ) %THEN %WARN( 'Character and binary or random 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_NEXT_POS, $XPO$POSITION (position) ) ! POSITION= $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 position, ! position in file 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,position) ) %THEN %WARN( 'Character and binary or random 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' ) !+ ! Random access i/o has been implemented for VMS only for V1.2. ! See also: ! XPORT.REQ - $XPO_OPEN definition. ! XOPEN.BLI - $IOB initialization. ! XGET.BLI - comments in 'TOPS-10/TOPS-20 Stream-mode and Binary-mode GET' ! XPUT.BLI - comments in 'TOPS-10/TOPS-20/RT-11 File PUT' !- %IF NOT %BLISS(BLISS32) %THEN %IF $xpo$key_check( RANDOM, attribute attributes ) %THEN %WARN ( '"ATTRIBUTE= RANDOM" is not implemented for this architecture' ) %FI %FI 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= $xpo$value( iob$, G_NEXT_POS, $XPO$POSITION (position) ) ! POSITION= %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 position, ! position in file of I/O request 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,position) ) %THEN %WARN( 'Character and binary or random 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$, G_NEXT_POS, $XPO$POSITION (position) ) ! POSITION= $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] , ! 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. %IF $xpo$desc_count NEQ 0 %THEN LOCAL $xpo$local_desc : BLOCKVECTOR[ $xpo$desc_count, STR$K_F_BLN ] VOLATILE ; %FI %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 )