Trailing-Edge
-
PDP-10 Archives
-
BB-FB49A-RM
-
sources/snaxpt.r36
There is 1 other file named snaxpt.r36 in the archive. Click here to see a list.
%title 'SNA XPORT Version 1.00'
! Copyright (c) 1984, 1985 by
! DIGITAL EQUIPMENT CORPORATION, Maynard, Massachusetts
!
! 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: SNA XPORT
!
! ABSTRACT: This require file provides the SNA version of the XPORT
! bliss library. Copied from the X25 XPORT.
!
! ENVIRONMENT: TOPS-20 Operating Systems, user mode.
!
! AUTHOR: Dennis Brannon, CREATION DATE: December 7,1983
!
! MODIFIED BY:
!
! D. Brannon, 10-Oct-84 : VERSION 1.00
!
!--
!
! XPORT Control Block and Macro Definitions
!
literal
XPO$K_VERSION = 0, ! Current XPORT version
XPO$K_LEVEL = 7, ! and base level
XPO$K_FAILURE = ! Standard XPORT failure routine value
%BLISS16 (%X'FFFF')
%BLISS32 (0)
%BLISS36 (%O'777777');
compiletime
$XPO$TEMP = 0, ! Temporary variable
$XPO$TEMP1 = 0,
$XPO$TEMP2 = 0,
$XPO$KEY_OK = 0;
macro
$XPO$FORCE [] =
%quote %expand %remaining %,
$XPO$REQUIRED (VALUE, PARAMETER_NAME) =
%if %null (VALUE)
%then %warn (PARAMETER_NAME, ' parameter must be specified')
%quote %quote %exitmacro
%fi %,
$XPO$CONFLICT (LIST) =
0 %quote %expand $XPO$$CONFLICT (LIST, %remaining) gtr 1 %,
$XPO$$CONFLICT (LIST) [] =
%if not %null (%quote %expand %remove (LIST))
%then + 1 %fi
%quote %expand $XPO$$CONFLICT (%remaining) %,
$XPO$KEY_CHECK (VALUE, KEYWORD_LIST) =
%assign ($XPO$KEY_OK, 0)
$XPO$$KEY_TEST (VALUE, %remove (KEYWORD_LIST))
%number ($XPO$KEY_OK) %,
$XPO$KEY_TEST (VALUE, KEYWORD_LIST, PARAMETER_NAME) =
%assign ($XPO$KEY_OK, 0)
$XPO$$KEY_TEST (VALUE, %remove (KEYWORD_LIST))
%if $XPO$KEY_OK
%then 1
%else %print ('"', VALUE, '" is an invalid ',
PARAMETER_NAME, ' parameter value')
%message ('"', VALUE, '" is an invalid ',
PARAMETER_NAME, ' parameter value')
%warn ('... possible values are ',
$XPO$KEY_WORDS (%remove (KEYWORD_LIST)))
0
%fi %,
$XPO$$KEY_TEST (VALUE, KEYWORD) [] =
%if %identical (VALUE, KEYWORD)
%then %assign ($XPO$KEY_OK, 1)
%else $XPO$$KEY_TEST (VALUE, %remaining)
%fi %,
$XPO$KEY_WORDS [KEYWORD] =
%if %count neq 0
%then ', ', %fi
%string (KEYWORD) %,
$XPO$PAREN_TEST (PARAMETER) =
%if %null (PARAMETER)
%then 0
%else $XPO$$PAREN (%remove (PARAMETER), PARAMETER)
%fi %,
$XPO$$PAREN (NO_PARENS, PARENS) =
%if %length eql 2
%then %if %identical (NO_PARENS, PARENS)
%then 0
%exitmacro
%fi
%fi
1 %,
$XPO$ARG1 (ARG1) =
ARG1 %,
$XPO$ARG2 (ARG1, ARG2) =
ARG2 %,
$XPO$ARG3 (ARG1, ARG2, ARG3) =
ARG3 %,
$XPO$EX_ROUTINE (ROUTINE_NAME, LINKAGE_ATTRIBUTE) =
external routine ROUTINE_NAME ! Declare an external routine
%if %bliss (bliss32) or not %null (LINKAGE_ATTRIBUTE)
%then : %fi
%bliss32 (ADDRESSING_MODE (LONG_RELATIVE))
LINKAGE_ATTRIBUTE; %,
$XPO$EX_FAILURE (FAILURE) =
%if $XPO$KEY_CHECK (FAILURE, (XPO$FAILURE,
XPO$IO_FAILURE,
XPO$GM_FAILURE,
XPO$FM_FAILURE,
STR$FAILURE,
STR$X_FAILURE,
STR$C_FAILURE,
STR$A_FAILURE,
STR$S_FAILURE,
STR$B_FAILURE))
%then %quote %expand $XPO$FORCE ($XPO$EX_ROUTINE (FAILURE))
%fi %,
XPO$I_FAILURE = ! ***** OBSOLETE *****
%inform ('XPO$I_FAILURE has been renamed to XPO$IO_FAILURE')
XPO$IO_FAILURE %,
XPO$F_FAILURE = ! ***** OBSOLETE *****
%inform ('XPO$F_FAILURE has been renamed to XPO$FM_FAILURE')
XPO$FM_FAILURE %,
XPO$G_FAILURE = ! ***** OBSOLETE *****
%inform ('XPO$G_FAILURE has been renamed to XPO$GM_FAILURE')
XPO$GM_FAILURE %,
XPO$P_FAILURE = ! ***** OBSOLETE *****
%inform ('XPO$P_FAILURE has been renamed to XPO$PM_FAILURE')
XPO$PM_FAILURE %,
$XPO$DEFAULT (ARGUMENT, DEFAULT) =
%if %null (ARGUMENT)
%then DEFAULT
%else ARGUMENT
%fi %,
$XPO$NAME15 [] =
%name (%exactstring (min (%charcount (%string (%remaining)), 15),
0,
%remaining)) %,
$XPO$VALUE (BLOCK, FIELD_NAME, VALUE) [] =
block [$XPO$NAME15 (BLOCK, FIELD_NAME)] = VALUE; %,
$XPO$KEY_NAME (BLOCK, KEYWORD) [] =
$XPO$NAME15 (BLOCK, 'K_', KEYWORD) %,
$XPO$KEYWORD (BLOCK) [KEYWORD] =
%if %null (KEYWORD)
%then %warn ('Null keyword specified')
%else block [$XPO$NAME15 (BLOCK, 'V_', KEYWORD)] = 1;
%fi %,
$XPO$SHOW_NUMB (NUMBER, BASE) [] =
%if NUMBER geq BASE
%then %assign ($XPO$TEMP, NUMBER/BASE)
$XPO$SHOW_NUMB (%number ($XPO$TEMP), BASE)
%fi
%assign ($XPO$TEMP, NUMBER mod BASE)
%if $XPO$TEMP leq 9
%then %assign ($XPO$TEMP, %C'0' + $XPO$TEMP)
%else %assign ($XPO$TEMP, %C'A' + $XPO$TEMP - 10)
%fi
, %char ($XPO$TEMP) %;
!
! XPORT Transportable FIELD definition macros
!
literal
$XPO$BITS_BYTE = ! Bits per "byte"
%BLISS16 (8)
%BLISS32 (8)
%BLISS36 (9),
$XPO$BITS_WORD = 2 * $XPO$BITS_BYTE; ! Bits per "word"
compiletime ! Compile-time variables:
$XPO$FULL_BASED = 0, ! fullword-based structure indicator
$XPO$FULL_INDEX = 0, ! fullword index (within block)
$XPO$BIT_INDEX = 0, ! bit index (within fullword)
$XPO$MAX_FULLWD = 0, ! maximum value index in current block
$XPO$MAX_BIT = 0, ! maximum bit index (within maximum value)
$XPO$BITS = 0, ! field size in bits
$XPO$1ST_ACTUAL = 0, ! first calculated access-acutal
$XPO$2ND_ACTUAL = 0, ! second calculated access_actual (bit displacement)
$XPO$UNIT_INDEX = 0, ! addressable unit index (within block)
$XPO$SET_SIZE = 0, ! size of field set in units
$XPO$DISTINCT = 0, ! distinct literal value
$XPO$SHOW_FIELD = 0, ! $SHOW( FIELDS ) indicator
$XPO$SHOW_LIT = 0, ! $SHOW( LITERALS ) indicator
$XPO$SHOW_INFO = 1; ! $SHOW( INFO ) indicator
macro
$FIELD = ! Block initialization:
%assign ($XPO$FULL_BASED, 1) ! fullword-based structure
%assign ($XPO$FULL_INDEX, 0) ! value index (within block)
%assign ($XPO$BIT_INDEX, 0) ! bit index (within value)
%assign ($XPO$MAX_FULLWD, 0) ! maximum value index in current block
%assign ($XPO$MAX_BIT, 0) ! maximum bit index (within maximum value)
field %,
$UNIT_FIELD =
%expand $field
%assign ($XPO$FULL_BASED, 0) %, ! Change to a unit-based structure
$XPO$FIELD (BITS, SIGN, NULL_FIELD) = ! Define a single transportable field
%if BITS gtr %bpval or NULL_FIELD
%then %assign ($XPO$BITS, 0)
%if not NULL_FIELD
%then %assign ($XPO$BITS, %bpval) ! MODIFIED 03-13-81 VoBa
! %if $XPO$SHOW_INFO
! %then %inform ('space reserved for field but null field defined')
! %fi
%fi
%else %assign ($XPO$BITS, BITS)
%fi
%if not %bliss (bliss32)
and $XPO$BITS + $XPO$BIT_INDEX gtr %bpval
%then $align (FULLWORD)
%if $XPO$SHOW_INFO
%then %inform ('BLISS fullword alignment has been assumed')
%fi
%fi
%if $XPO$FULL_BASED
%then %assign ($XPO$1ST_ACTUAL, $XPO$FULL_INDEX)
%assign ($XPO$2ND_ACTUAL, $XPO$BIT_INDEX)
%assign ($XPO$UNIT_INDEX,
$XPO$FULL_INDEX * %upval + $XPO$BIT_INDEX / %bpunit)
%else %assign ($XPO$1ST_ACTUAL,
$XPO$FULL_INDEX * %upval + $XPO$BIT_INDEX / %bpunit)
%assign ($XPO$2ND_ACTUAL, $XPO$BIT_INDEX mod %bpunit)
%assign ($XPO$UNIT_INDEX, $XPO$1ST_ACTUAL)
%fi
! Generate field specification:
$XPO$1ST_ACTUAL, ! fullword index or addressable unit index
$XPO$2ND_ACTUAL, ! bit index within fullword/unit
$XPO$BITS, ! field size in bits
SIGN ! sign extension
%if $XPO$SHOW_FIELD ! Display generated field definition
%then %print (' [',
%number ($XPO$1ST_ACTUAL), ',',
%number ($XPO$2ND_ACTUAL), ',',
%number ($XPO$BITS), ',',
SIGN, '] (+',
%if %bliss (bliss32)
%then '%X''' $XPO$SHOW_NUMB ($XPO$UNIT_INDEX, 16),
%else '%O''' $XPO$SHOW_NUMB ($XPO$UNIT_INDEX, 8),
%fi
''')' )
%fi
%assign ($XPO$FULL_INDEX,
$XPO$FULL_INDEX + (($XPO$BIT_INDEX + BITS) / %bpval))
%assign ($XPO$BIT_INDEX, ($XPO$BIT_INDEX + BITS) mod %bpval)
%if $XPO$FULL_INDEX gtr $XPO$MAX_FULLWD
or ($XPO$FULL_INDEX eql $XPO$MAX_FULLWD and
$XPO$BIT_INDEX gtr $XPO$MAX_BIT)
%then %assign ($XPO$MAX_FULLWD, $XPO$FULL_INDEX)
%assign ($XPO$MAX_BIT, $XPO$BIT_INDEX)
%fi %,
$ALIGN (BOUNDARY) = ! Align next field on a specified boundary
%if not $XPO$KEY_TEST (BOUNDARY, (BYTE, WORD, FULLWORD, UNIT))
%then %exitmacro
%fi
%if %identical (BOUNDARY, FULLWORD)
%then %if $XPO$BIT_INDEX gtr 0
%then %assign ($XPO$FULL_INDEX, $XPO$FULL_INDEX + 1)
%assign ($XPO$BIT_INDEX, 0)
%fi
%exitmacro
%fi
%if %identical (BOUNDARY, BYTE)
%then %if ($XPO$BIT_INDEX mod $XPO$BITS_BYTE) eql 0
%then %exitmacro %fi
%assign ($XPO$BIT_INDEX,
$XPO$BIT_INDEX -
($XPO$BIT_INDEX mod $XPO$BITS_BYTE) +
$XPO$BITS_BYTE)
%fi
%if %identical (BOUNDARY, WORD)
%then %if ($XPO$BIT_INDEX mod $XPO$BITS_WORD) eql 0
%then %exitmacro %fi
%assign ($XPO$BIT_INDEX,
$XPO$BIT_INDEX -
($XPO$BIT_INDEX mod $XPO$BITS_WORD) +
$XPO$BITS_WORD)
%fi
%if %identical (BOUNDARY, UNIT)
%then %if ($XPO$BIT_INDEX mod %BPUNIT) eql 0
%then %exitmacro %fi
%assign ($XPO$BIT_INDEX,
$XPO$BIT_INDEX - ($XPO$BIT_INDEX mod %bpunit) + %bpunit)
%fi
%if $XPO$BIT_INDEX geq %bpval
%then %assign ($XPO$FULL_INDEX, $XPO$FULL_INDEX + 1)
%assign ($XPO$BIT_INDEX, 0)
%fi %,
$OVERLAY (FIELD0, FIELD1) = ! Reset value index, etc. to a previously defined field
%if %length neq 1 and %length neq 4
%then %warn ('Invalid argument list')
%exitmacro
%fi
%if %length eql 4
%then %if $XPO$FULL_BASED
%then %assign ($XPO$FULL_INDEX, FIELD0)
%assign ($XPO$BIT_INDEX, FIELD1)
%else %assign ($XPO$FULL_INDEX, (FIELD0) / %upval)
%assign ($XPO$BIT_INDEX,
(FIELD1) + ((FIELD0) mod %upval) * %bpunit)
%fi
%else %if not %declared (%name (FIELD0))
%then %warn (FIELD0, ' is not defined')
%exitmacro
%fi
%if $XPO$FULL_BASED
%then %assign ($XPO$FULL_INDEX, %fieldexpand (FIELD0,0))
%assign ($XPO$BIT_INDEX, %fieldexpand (FIELD0,1))
%else %assign ($XPO$FULL_INDEX, %fieldexpand (FIELD0,0) / %upval)
%assign ($XPO$BIT_INDEX,
%fieldexpand (FIELD0,1) +
(%fieldexpand (FIELD0,0) mod %upval) * %bpunit)
%fi
%fi %,
$CONTINUE = ! Continue block at high-water-mark
%assign ($XPO$FULL_INDEX, $XPO$MAX_FULLWD)
%assign ($XPO$BIT_INDEX, $XPO$MAX_BIT) %,
$BASE =
%assign ($XPO$FULL_INDEX, 0)
%assign ($XPO$BIT_INDEX, 0)
0,0,0,0 %,
$BYTE = ! A single, unsigned "byte"
$BYTES (1) %,
$BYTES (NUMBER) = ! Any number of unsigned bytes
$XPO$FIELD ((NUMBER) * $XPO$BITS_BYTE, 0, 0) %,
$HALFWORD = ! Unsigned 2-"byte" value
$XPO$FIELD (2 * $XPO$BITS_BYTE, 0, 0) %,
$FULLWORD = ! Unsigned BLISS value (aligned)
$XPO$FIELD (%bpval, 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_BLOCKX (FULLWORDS) = ! Sub-structure
$ALIGN (FULLWORD) ! MODIFIED 03-13-81 VoBa
%if %null (FULLWORDS) ! To declare sub-structure
%then $XPO$FIELD (0, 0, 0) ! with non-null address
%else $XPO$FIELD ((FULLWORDS) * %bpval, 0, 0)
%fi %,
$SUB_BLOCK (FULLWORDS) = ! Sub-structure
$ALIGN (FULLWORD)
%if %null (FULLWORDS)
%then $XPO$FIELD (0, 0, 1)
%else $XPO$FIELD ((FULLWORDS) * %bpval, 0, 1)
%fi %,
$DESCRIPTOR (CLASS) = ! String or binary data descriptor
%if not %null (CLASS) ! sub-block
%then %if not $XPO$KEY_TEST (CLASS, (FIXED,
DYNAMIC,
BOUNDED,
DYNAMIC_BOUNDED,
UNDEFINED,
STATIC,
VARYING,
DYNAMIC_VARYING)) ! OBSOLETE
%then 0, 0, 0, 0
%exitmacro
%fi
%fi
%if %identical (CLASS, BOUNDED)
or %identical (CLASS, DYNAMIC_BOUNDED)
or %identical (CLASS, VARYING)
or %identical (CLASS, DYNAMIC_VARYING) ! *** OBSOLETE ***
%then $SUB_BLOCK (STR$K_B_BLN)
%else $SUB_BLOCK (STR$K_F_BLN)
%fi %,
$REF_DESCRIPTOR =
$ADDRESS %,
%if %bliss (bliss36)
%then
$STRINGX (LENGTH) = ! Character string for BLISS36
$ALIGN (UNIT) ! MODIFIED 03-13-81 VoBa
$XPO$FIELD ((((LENGTH)+4)/5) * %bpval, 0, 0) %,
$STRING (LENGTH) = ! Character string for BLISS36
$ALIGN (UNIT)
$XPO$FIELD ((((LENGTH)+4)/5) * %bpval, 0, 1) %,
%else
$STRINGX (LENGTH) = ! Character string for BLISS16/32
$ALIGN (UNIT) ! MODIFIED 03-13-81 VoBa
$XPO$FIELD ((LENGTH) * %bpunit, 0, 0) %,
$STRING (LENGTH) = ! Character string for BLISS16/32
$ALIGN (UNIT)
$XPO$FIELD ((LENGTH) * %bpunit, 0, 1) %,
%fi
%if %bliss (bliss36)
%then ! Six-bit character string for BLISS36
$SIXBIT (LENGTH) =
%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 ! Six-bit character string for
! BLISS16 and BLISS32
$SIXBIT (LENGTH) =
%warn ('Six-bit strings are not available for this architecture') %,
%fi
$LENGTH = ! *** OBSOLETE ***
%inform ('$LENGTH is obsolete - use $FIELD_SET_SIZE')
$FIELD_SET_SIZE %,
$FIELD_SET_SIZE = ! Length of field set in fullwords
%if not $XPO$FULL_BASED
%then %warn ('$FIELD_SET_SIZE may not be used with $UNIT_FIELD')
%fi
%assign ($XPO$SET_SIZE, $XPO$FULL_INDEX + ($XPO$BIT_INDEX neq 0))
%number ($XPO$SET_SIZE)
%if $XPO$SHOW_LIT
%then %print (' ',
%number ($XPO$SET_SIZE),
' fullwords')
%fi
%assign ($XPO$FULL_BASED, 1) %,
$FIELD_SET_UNITS = ! Length of field set in addressable units
%assign ($XPO$SET_SIZE,
$XPO$FULL_INDEX * %upval +
(($XPO$BIT_INDEX + %bpunit - 1) / %bpunit))
%number ($XPO$SET_SIZE)
%if $XPO$SHOW_LIT
%then %print (' ',
%number ($XPO$SET_SIZE),
' addressable units')
%fi
%assign ($XPO$FULL_BASED, 1) %,
$LITERAL = ! Initialize for constant creation
%assign ($XPO$DISTINCT, 0)
literal %,
$DISTINCT = ! Assign constant value
%assign ($XPO$DISTINCT, $XPO$DISTINCT + 1)
%number ($XPO$DISTINCT)
%if $XPO$SHOW_LIT
%then %print (' ', %number ($XPO$DISTINCT))
%fi %,
$SUB_FIELD (PRIMARY, SUB0, SUB1, SUB2, SUB3) =
%if %length neq 2 and %length neq 5
%then %warn ('Invalid argument list')
0, 0, 0, 0
%exitmacro
%fi
%if not %declared (PRIMARY)
%then %warn ('"', PRIMARY, '" has not been declared')
0, 0, 0, 0
%exitmacro
%fi
%if %length eql 2
%then %if not %declared (SUB0)
%then %warn ('"', SUB0, '" has not been declared')
0, 0, 0, 0
%exitmacro
%fi
! Generate access-actuals from
%if $XPO$FULL_BASED ! two field names:
%then %fieldexpand (PRIMARY,0) +
%fieldexpand (SUB0,0) + ! 1 - fullword index into block
((%fieldexpand (PRIMARY,1) +
%fieldexpand (SUB0,1)) / %bpval),
(%fieldexpand (PRIMARY,1) +
%fieldexpand (SUB0,1)) mod %bpval, ! 2 - bit index into fullword
%else %fieldexpand (PRIMARY,0) +
%fieldexpand (SUB0,0) + ! 1 - unit index into block
((%fieldexpand (PRIMARY,1) +
%fieldexpand (SUB0,1)) / %bpunit),
(%fieldexpand (PRIMARY,1) +
%fieldexpand (SUB0,1)) mod %bpunit, ! 2 - bit index into unit
%fi
%fieldexpand (SUB0,2), ! 3 - field size in bits
%fieldexpand (SUB0,3) ! 4 - sign extension
%else ! Generate access-actuals from a
%if $XPO$FULL_BASED ! field name and 4 access-actuals:
%then %fieldexpand (PRIMARY,0) + SUB0 + ! 1 - fullword index into block
((%fieldexpand (PRIMARY,1) + SUB1) / %bpval),
(%fieldexpand (PRIMARY,1) + SUB1) mod %bpval, ! 2 - bit index into fullword
%else %fieldexpand (PRIMARY,0) + SUB0 + ! 1 - unit index into block
((%fieldexpand (PRIMARY,1) + SUB1) / %bpunit),
(%fieldexpand (PRIMARY,1) + SUB1) mod %bpunit, ! 2 - bit index into unit
%fi
SUB2, ! 3 - field size in bits
SUB3 ! 4 - sign extension
%fi %,
$BLOCK = ! *** OBSOLETE ***
%inform ('The $BLOCK macro is obsolete - use BLOCK')
BLOCK %,
$BLOCKVECTOR = ! *** OBSOLETE ***
%inform ('The $BLOCKVECTOR macro is obsolete - use BLOCKVECTOR')
BLOCKVECTOR %,
$UNIT_BLOCK (ARG1, ARG2) =
%if %length neq 0 and %length neq 1 and %length neq 2
%then %warn ('Invalid number of arguments')
%exitmacro
%fi
block [ARG1
%if %length eql 2
%then , ARG2;
%fi
%if not %bliss (bliss36)
%then , BYTE
%fi
] %,
$UNIT_BLOCKVECTOR (ARG1, ARG2, ARG3, ARG4) =
%if %length neq 1 and %length neq 2 and %length neq 4
%then %warn ('Invalid number of arguments')
%exitmacro
%fi
blockvector [ARG1
%if %length gtr 1
%then , ARG2
%fi
%if %length eql 4
%then , ARG3, ARG4
%fi
%if not %bliss (bliss36)
%then , BYTE
%fi
] %,
$SHOW (KEYWORD) [] =
%if not $XPO$KEY_TEST (KEYWORD, (FIELDS,
LITERALS,
INFO,
ALL,
NOFIELDS,
NOLITERALS,
NOINFO,
NONE))
%then %exitmacro
%fi
%if %identical (KEYWORD, FIELDS)
%then %assign ($XPO$SHOW_FIELD, 1)
$SHOW (%remaining)
%else %if %identical (KEYWORD, NOFIELDS)
%then %assign ($XPO$SHOW_FIELD, 0)
$SHOW (%remaining)
%else %if %identical (KEYWORD, LITERALS)
%then %assign ($XPO$SHOW_LIT, 1)
$SHOW (%remaining)
%else %if %identical (KEYWORD, NOLITERALS)
%then %assign ($XPO$SHOW_LIT, 0)
$SHOW (%remaining)
%else %if %identical (KEYWORD, INFO)
%then %assign ($XPO$SHOW_INFO, 1)
$SHOW (%remaining)
%else %if %identical (KEYWORD, NOINFO)
%then %assign ($XPO$SHOW_INFO, 0)
$SHOW (%remaining)
%else %if %identical (KEYWORD, ALL)
%then %assign ($XPO$SHOW_FIELD, 1)
%assign ($XPO$SHOW_LIT, 1)
%assign ($XPO$SHOW_INFO, 1)
$SHOW (%remaining)
%else %assign ($XPO$SHOW_FIELD, 0)
%assign ($XPO$SHOW_LIT, 0)
%assign ($XPO$SHOW_INFO, 0)
$SHOW (%remaining)
%fi %fi %fi %fi %fi %fi %fi %;
$SHOW (ALL) ! Show everything during XPORT.REQ library pre-compilation
$LITERAL ! XPO$DUMP data type codes
XPO$K_BYTE = $DISTINCT,
XPO$K_BYTES = $DISTINCT,
XPO$K_INTEGER = $DISTINCT,
XPO$K_TINY_INTE = XPO$K_INTEGER,
XPO$K_SHORT_INT = XPO$K_INTEGER,
XPO$K_LONG_INTE = XPO$K_INTEGER,
XPO$K_ADDRESS = $DISTINCT,
XPO$K_POINTER = $DISTINCT,
XPO$K_BIT = $DISTINCT,
XPO$K_BITS = $DISTINCT,
XPO$K_SUB_BLOCK = $DISTINCT,
XPO$K_DESCRIPTO = $DISTINCT,
XPO$K_REF_DESCR = $DISTINCT,
XPO$K_STRING = $DISTINCT;
KEYWORDMACRO
$XPO_DUMP_FIELD (FIELD_NAME, ! name of the field to be dumped
TYPE, ! field data type
VALUE) = ! field value or address
begin
%expand $XPO$FORCE ($XPO$EX_ROUTINE (XPO$DUMP_FIELD));
own $STR$FIELD_NAME : %expand
$STR_DESCRIPTOR (STRING = %string (FIELD_NAME));
XPO$DUMP_FIELD ($STR$FIELD_NAME, $XPO$NAME15 ('XPO$K_', TYPE), VALUE)
end %;
MACRO
$XPO$MASK_SET (PREFIX, FIELD_NAME) [BIT_NAME] =
%if %count eql 0
%then %if not %declared (%name (PREFIX, FIELD_NAME))
%then %warn (PREFIX, FIELD_NAME, ' is not defined')
%exitmacro
%fi
%fi
%if not %declared (%name (PREFIX, BIT_NAME))
%then %warn (PREFIX, BIT_NAME, ' is not defined')
%else %if %fieldexpand (%name (PREFIX, BIT_NAME),2) neq 1
%then %warn (PREFIX, BIT_NAME, ' is not a 1-bit field')
!
! 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, ... ]
!
%else %assign ($XPO$TEMP,
1 ^ (%fieldexpand (%name (PREFIX, BIT_NAME),0) *
%bpunit +
%fieldexpand (%name (PREFIX, BIT_NAME),1) -
%fieldexpand (%name (PREFIX, FIELD_NAME),0) *
%bpunit -
%fieldexpand (%name (PREFIX, FIELD_NAME),1)))
%name (%exactstring (%charcount (PREFIX)-2, 0, prefix),
'M_', BIT_NAME) = %number ($XPO$TEMP)
%if $XPO$SHOW_LIT
%then %print (' ',
%exactstring (%charcount (PREFIX)-2,0,PREFIX),
'M_',
BIT_NAME,
' = ',
%number ($XPO$TEMP))
%fi
%fi
%fi %;
!
! STRDESC - XPORT String Descriptor
!
! This transportable string descriptor is modelled closely after the
! corresponding VAX-11 descriptor.
!
$FIELD STR$H_LENGTH = [$BYTES(2)]; ! Number of characters in the string
field STR$B_DTYPE = [$BYTE]; ! Atomic data type code:
literal STR$K_DTYPE_T = 14, ! ASCII text string
STR$K_DTYPE_X = 190, ! XPORT temporary string
STR$K_DTYPE_XXX = 191; ! Erroreous XPORT temporary string
field STR$B_CLASS = [$BYTE]; ! Descriptor class code:
literal STR$K_CLASS_Z = 0, ! unspecified
STR$K_CLASS_F = 1, ! fixed string
STR$K_CLASS_D = 2, ! dynamic string
STR$K_CLASS_B = 3, ! bounded string
STR$K_CLASS_DB = 99; ! dynamic bounded string
field STR$A_POINTER = [$POINTER]; ! Pointer to the character string
literal STR$K_F_BLN = $FIELD_SET_SIZE, ! Length of a fixed descriptor
STR$K_D_BLN = $FIELD_SET_SIZE; ! Length of a dynamic descriptor
field STR$H_MAXLEN = [$BYTES(2)]; ! Length of the container string
field STR$H_PFXLEN = [$BYTES(2)]; ! Length of the prefix string
literal STR$K_B_BLN = $FIELD_SET_SIZE, ! Length of a bounded descriptor
STR$K_DB_BLN = $FIELD_SET_SIZE, ! Length of a dynamic bounded descriptor
STR$K_Z_BLN = $FIELD_SET_SIZE; ! Maximum length of an undefined descriptor
! End of STRDESC
macro
$STR$F_FIELDS =
STR$H_LENGTH, STR$B_DTYPE, STR$B_CLASS, STR$A_POINTER %,
$STR$B_FIELDS =
%expand $STR$F_FIELDS, STR$H_MAXLEN, STR$H_PFXLEN %;
macro ! *** OBSOLETE ***
STR$K_DTYPE_Z =
%inform ('STR$K_DTYPE_Z is an obsolete name - use $XPO_DESCRIPTOR and XPO$K_DTYPE_BU')
XPO$K_DTYPE_BU %,
STR$K_CLASS_S =
%inform ('STR$K_CLASS_S is an obsolete name - use STR$K_CLASS_F')
STR$K_CLASS_F %,
STR$K_CLASS_V =
%inform ('STR$K_CLASS_V is an obsolete name - use STR$K_CLASS_B')
STR$K_CLASS_B %,
STR$K_CLASS_DV =
%inform ('STR$K_CLASS_DV is an obsolete name - use STR$K_CLASS_DB')
STR$K_CLASS_DB %,
STR$A_ADDRESS =
%inform ('STR$A_ADDRESS is an obsolete field - use $XPO_DESCRIPTOR and XPO$A_ADDRESS')
STR$A_POINTER %,
STR$K_S_BLN =
%inform ('STR$K_S_BLN is an obsolete name - use STR$K_F_BLN')
STR$K_F_BLN %,
STR$K_V_BLN =
%inform ('STR$K_V_BLN is an obsolete name - use STR$K_B_BLN')
STR$K_B_BLN %,
STR$K_DV_BLN =
%inform ('STR$K_DV_BLN is an obsolete name - use STR$K_DB_BLN')
STR$K_DB_BLN %;
!
! String Descriptor Declaration and Initialization Macros
!
macro
$STR$DESC_TYPE (TYPE) =
%if %identical (TYPE, CHARACTERS)
%then STR$K_DTYPE_T
%else %if %identical (TYPE, FULLWORDS)
or %identical (TYPE, UNITS)
%then XPO$K_DTYPE_BU
%else %if %identical (TYPE, XPORT_TEMPORARY)
%then STR$K_DTYPE_X
%else %if %identical (TYPE, XPORT_ERRONEOUS)
%then STR$K_DTYPE_XXX
%fi
%fi
%fi
%fi %,
$STR$DESC_CLASS (CLASS) =
%if %identical (CLASS, DYNAMIC_BOUNDED)
or %identical (CLASS, DYNAMIC_VARYING) ! *** OBSOLETE ***
%then STR$K_CLASS_DB
%else %name (%exactstring (13, 0, 'STR$K_CLASS_', CLASS))
%fi %,
$STR$LITERAL (LITERAL_TEXT) =
ch$ptr (uplit %bliss16 (BYTE) %bliss32 (BYTE) (LITERAL_TEXT)) %;
macro
$STR_DESC = $STR_DESCRIPTOR %;
keywordmacro
$STR_DESCRIPTOR (CLASS = FIXED, ! descriptor class
TYPE, ! data type *** OBSOLETE ***
STRING, ! string descriptor
BINARY_DATA) = ! binary data descriptor *** OBSOLETE ***
%if not $XPO$KEY_CHECK (CLASS, (FIXED, ! *** OBSOLETE ***
DYNAMIC,
BOUNDED,
DYNAMIC_BOUNDED, ! *** OBSOLETE ***
STATIC,
VARYING,
DYNAMIC_VARYING)) ! *** OBSOLETE ***
%then %if not $XPO$KEY_TEST (CLASS, (FIXED, ! *** OBSOLETE ***
DYNAMIC,
BOUNDED,
DYNAMIC_BOUNDED),
'CLASS=')
%then %exitmacro
%fi
%fi
%if $XPO$KEY_CHECK (CLASS, (STATIC, ! *** OBSOLETE ***
VARYING,
DYNAMIC_VARYING))
%then %inform ('CLASS= ', CLASS, ' is obsolete - see current documentation')
%fi
%if not %null (BINARY_DATA) ! *** OBSOLETE ***
%then %inform ('BINARY_DATA= is obsolete - use the $XPO_DESCRIPTOR macro')
%fi
%if not %null (TYPE)
%then %if not %identical (TYPE, XPORT_TEMPORARY) ! *** OBSOLETE ***
and not %identical (TYPE, XPORT_ERRONEOUS)
%then %inform ('TYPE= is obsolete - see current documentation')
%if not $XPO$KEY_TEST (TYPE, (CHARACTERS,
FULLWORDS,
UNITS),
'TYPE=')
%then %exitmacro
%fi
%fi
%fi
%if %expand $XPO$CONFLICT (STRING, BINARY_DATA, TYPE) ! *** OBSOLETE ***
%then %warn ('TYPE=, STRING=, and BINARY_DATA= are mutually exclusive')
%fi
%if not %null (STRING)
and not ($XPO$PAREN_TEST (STRING) or %isstring (%remove (STRING)))
%then %warn ('STRING=descriptor is not permitted')
%exitmacro
%fi
%if not %null (STRING)
and not %identical ($XPO$ARG1 (%remove (STRING)), 0)
and not (%identical (CLASS, FIXED) or %identical (CLASS, BOUNDED))
%then %warn ('STRING=literal or STRING=(len,ptr) requires CLASS=FIXED or CLASS=BOUNDED')
%exitmacro
%fi
%if %identical (CLASS, BOUNDED) ! *** OBSOLETE ***
or %identical (CLASS, DYNAMIC_BOUNDED)
or %identical (CLASS, VARYING)
or %identical (CLASS, DYNAMIC_VARYING)
%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)
%then %exitmacro ! Speedup expansion in most situations.
%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 preset ([STR$B_DTYPE] = XPO$K_DTYPE_BU,
[STR$B_CLASS] = %expand $STR$DESC_CLASS (CLASS),
[STR$A_POINTER] = $XPO$ARG2 (%remove (BINARY_DATA)),
%if %identical (CLASS, FIXED) ! *** OBSOLETE ***
or %identical (CLASS, DYNAMIC)
%then [STR$H_LENGTH] = $XPO$BIN_LEN (%remove (BINARY_DATA))
%else [STR$H_MAXLEN] = $XPO$BIN_LEN (%remove (BINARY_DATA))
%fi) ! End of BINARY_DATA PRESET list
%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 ***
! *** OBSOLETE ***
%if not $XPO$KEY_CHECK (CLASS, (FIXED,
DYNAMIC,
BOUNDED,
DYNAMIC_BOUNDED,
STATIC,
VARYING,
DYNAMIC_VARYING))
%then %if not $XPO$KEY_TEST (CLASS, (FIXED,
DYNAMIC,
BOUNDED,
DYNAMIC_BOUNDED),
'CLASS=')
%then %exitmacro
%fi
%fi
! *** OBSOLETE ***
%if $XPO$KEY_CHECK (CLASS, (STATIC,
VARYING,
DYNAMIC_VARYING))
%then %inform ('CLASS=', class, ' is obsolete - see current documentation')
%fi
%if %expand $XPO$CONFLICT (DESC, DESCRIPTOR)
%then %warn ('DESC= and DESCRIPTOR= are mutually exclusive')
%fi
%if not %null (TYPE)
%then %if not %identical (TYPE, XPORT_TEMPORARY) ! *** OBSOLETE ***
and not %identical (TYPE, XPORT_ERRONEOUS)
%then %inform ('TYPE= is obsolete - see current documentation')
%if not $XPO$KEY_TEST (TYPE, (CHARACTERS,
FULLWORDS,
UNITS),
'TYPE=')
%then %exitmacro
%fi
%fi
%fi
! *** OBSOLETE ***
%if %expand $XPO$CONFLICT (STRING, BINARY_DATA, TYPE)
%then %warn ('TYPE=, STRING=, and BINARY_DATA= are mutually exclusive')
%fi
%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) ! *** OBSOLETE ***
or %identical (CLASS, DYNAMIC_BOUNDED)
or %identical (CLASS, VARYING)
or %identical (CLASS, DYNAMIC_VARYING)
%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) ! *** OBSOLETE ***
or %identical (CLASS, DYNAMIC_BOUNDED)
or %identical (CLASS, VARYING)
or %identical (CLASS, DYNAMIC_VARYING)
%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) ! *** OBSOLETE ***
or %identical (CLASS, DYNAMIC_BOUNDED)
or %identical (CLASS, VARYING)
or %identical (CLASS, DYNAMIC_VARYING)
%then DESC[STR$H_MAXLEN] =.$STR$$DESC[STR$H_LENGTH];
DESC[STR$H_PFXLEN] = 0;
%fi
end;
%else %if %identical (CLASS, BOUNDED) ! *** OBSOLETE ***
or %identical (CLASS, DYNAMIC_BOUNDED)
or %identical (CLASS, VARYING)
or %identical (CLASS, DYNAMIC_VARYING)
%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) ! *** OBSOLETE ***
or %identical (CLASS, DYNAMIC_BOUNDED)
or %identical (CLASS, VARYING)
or %identical (CLASS, DYNAMIC_VARYING)
%then DESC[STR$H_MAXLEN] = $XPO$ARG1 (%remove (STRING_DESC));
DESC[STR$H_PFXLEN] = 0;
%fi
%fi
%fi %,
$str$declare (TYPE, NAME, STRING_INFO) [] =
%if $XPO$KEY_TEST (TYPE, (BIND, LOCAL), 'Type')
%then %if %isstring (%remove (STRING_INFO)) ! STRING = 'literal text'
%then own NAME : %expand $STR_DESCRIPTOR (STRING = %quote %remove (STRING_INFO));
%else %if $XPO$PAREN_TEST (STRING_INFO) ! STRING = (length,pointer)
%then %if %identical (TYPE, BIND)
%then bind NAME = $FORMAT (STRING_INFO);
%else local NAME : %expand $XPO$FORCE ($STR_DESCRIPTOR ());
%fi
%else bind NAME = STRING_INFO; ! STRING = address of a descriptor
%fi
%fi
%fi %,
$STR$LOCAL_INIT (NAME, STRING_INFO) [] =
%if not %isstring (%remove (STRING_INFO))
and $XPO$PAREN_TEST (STRING_INFO)
%then $STR$STR_DESC (NAME, FIXED, STRING_INFO)
%fi %,
$STR_FREE_TEMP (STRING) =
begin
%expand $XPO$FORCE ($XPO$EX_ROUTINE (STR$FREE_TEMP))
STR$FREE_TEMP (STRING)
end %;
!
! BINDESC - XPORT Binary Data Descriptor
!
! This transportable data descriptor is modelled closely after the
! corresponding VAX-11 descriptor.
!
$FIELD XPO$H_LENGTH = [$BYTES(2)]; ! Length of the binary data units
field XPO$B_DTYPE = [$BYTE]; ! Atomic data type code:
literal XPO$K_DTYPE_BU = 2; ! XPORT binary data (binary units)
field XPO$B_CLASS = [$BYTE]; ! Descriptor class code:
literal XPO$K_CLASS_Z = 0, ! unspecified
XPO$K_CLASS_F = 1, ! fixed binary data
XPO$K_CLASS_D = 2, ! dynamic binary data
XPO$K_CLASS_B = 3, ! bounded binary data
XPO$K_CLASS_DB = 99; ! dynamic bounded binary data
field XPO$A_ADDRESS = [$POINTER]; ! Address of the binary data
literal XPO$K_S_BLN = $FIELD_SET_SIZE, ! Length of a static descriptor
XPO$K_D_BLN = $FIELD_SET_SIZE; ! Length of a dynamic descriptor
field XPO$H_MAXLEN = [$BYTES(2)]; ! Maximum length of the binary data
field XPO$H_PFXLEN = [$BYTES(2)]; ! Length of the binary data prefix
literal XPO$K_B_BLN = $FIELD_SET_SIZE, ! Length of a bounded descriptor
XPO$K_DB_BLN = $FIELD_SET_SIZE, ! Length of a dynamic bounded descriptor
XPO$K_Z_BLN = $FIELD_SET_SIZE; ! Maximum length of an undefined descriptor
! End of BINDESC
macro
$XPO$F_FIELDS =
XPO$H_LENGTH, XPO$B_DTYPE, XPO$B_CLASS, XPO$A_ADDRESS %,
$XPO$B_FIELDS =
%expand $XPO$F_FIELDS, XPO$H_MAXLEN, XPO$H_PFXLEN %;
macro ! *** OBSOLETE ***
XPO$K_DTYPE_Z =
%inform ('XPO$K_DTYPE_Z is an obsolete name - use XPO$K_DTYPE_BU') %;
!
! Binary Data Descriptor Declaration and Initialization Macros
!
macro
$XPO$DESC_CLASS (CLASS) =
%if %identical (CLASS, DYNAMIC_BOUNDED)
%then XPO$K_CLASS_DB
%else %name (%exactstring (13, 0, 'XPO$K_CLASS_', CLASS))
%fi %;
macro
$XPO_DESC = $XPO_DESCRIPTOR %;
keywordmacro
$XPO_DESCRIPTOR (CLASS = FIXED, ! descriptor class
BINARY_DATA) = ! binary data descriptor
%if not $XPO$KEY_TEST (CLASS, (FIXED,
DYNAMIC,
BOUNDED,
DYNAMIC_BOUNDED),
'CLASS=')
%then %exitmacro
%fi
%if not %null (BINARY_DATA) and not $XPO$PAREN_TEST (BINARY_DATA)
%then %warn ('BINARY_DATA= descriptor is not permitted')
%exitmacro
%fi
%if %identical (CLASS, BOUNDED) or %identical (CLASS, DYNAMIC_BOUNDED)
%then block [XPO$K_B_BLN] field (%expand $XPO$B_FIELDS)
%else block [XPO$K_S_BLN] field (%expand $XPO$F_FIELDS)
%fi
%if not %null (BINARY_DATA)
%then preset ([XPO$B_DTYPE] = XPO$K_DTYPE_BU,
[XPO$B_CLASS] = %expand $XPO$DESC_CLASS (CLASS),
[XPO$A_ADDRESS] = $XPO$ARG2 (%remove (BINARY_DATA)),
%if %identical (CLASS, FIXED)
or %identical (CLASS, DYNAMIC)
%then [XPO$H_LENGTH] = $XPO$BIN_LEN (%remove (BINARY_DATA))
%else [XPO$H_MAXLEN] = $XPO$BIN_LEN (%remove (BINARY_DATA))
%fi
) ! End of BINARY_DATA PRESET list
%fi %,
$XPO_DESC_INIT (DESC, ! address of descriptor
DESCRIPTOR, ! address of descriptor
CLASS = FIXED, ! descriptor class
BINARY_DATA) = ! binary data descriptor
%if not $XPO$KEY_TEST (CLASS, (FIXED,
DYNAMIC,
BOUNDED,
DYNAMIC_BOUNDED),
'CLASS=')
%then %exitmacro
%fi
%if not %null (BINARY_DATA) and not $XPO$PAREN_TEST (BINARY_DATA)
%then %warn ('BINARY_DATA= descriptor is not permitted')
%exitmacro
%fi
%if $XPO$CONFLICT (DESC, DESCRIPTOR)
%then %warn ('DESC= and DESCRIPTOR= are mutually exclusive')
%fi
%expand $XPO$REQUIRED (DESC DESCRIPTOR, 'DESC= or DESCRIPTOR=')
begin
bind $XPO$DESC = DESCRIPTOR : %expand $XPO$FORCE ($XPO_DESCRIPTOR (%quote CLASS=BOUNDED));
%if %null (BINARY_DATA)
%then $XPO$DESC[XPO$H_LENGTH] = 0;
$XPO$DESC[XPO$B_DTYPE] = XPO$K_DTYPE_BU;
$XPO$DESC[XPO$B_CLASS] = $XPO$DESC_CLASS (CLASS);
$XPO$DESC[XPO$A_ADDRESS] = 0;
%if %identical (CLASS, BOUNDED)
or %identical (CLASS, DYNAMIC_BOUNDED)
%then $XPO$DESC[XPO$H_MAXLEN] = 0;
$XPO$DESC[XPO$H_PFXLEN] = 0;
%fi
%else $XPO$BIN_DESC ($XPO$DESC, CLASS, BINARY_DATA)
%fi
XPO$_NORMAL ! normal completion code
end %;
macro
$XPO$BIN_DESC (DESC, CLASS, DATA_DESC) [] =
%if not %null ($XPO$ARG3 (%remove (DATA_DESC)))
%then %if not $XPO$KEY_TEST ($XPO$ARG3 (%remove (DATA_DESC)),
(FULLWORDS, UNITS))
%then %exitmacro
%fi
%fi
%if not $XPO$PAREN_TEST (DATA_DESC)
%then begin
bind $BIN$$DESC = DATA_DESC : %expand $XPO$FORCE ($XPO_DESCRIPTOR ());
%if %identical (CLASS, BOUNDED)
or %identical (CLASS, DYNAMIC_BOUNDED)
%then DESC[XPO$H_LENGTH] = 0;
%else DESC[XPO$H_LENGTH] = .$BIN$$DESC[XPO$H_LENGTH];
%fi
DESC[XPO$B_DTYPE] = .$BIN$$DESC[XPO$B_DTYPE];
DESC[XPO$B_CLASS] = %expand $XPO$DESC_CLASS (CLASS);
DESC[XPO$A_ADDRESS] = .$BIN$$DESC[XPO$A_ADDRESS];
%if %identical (CLASS, BOUNDED)
or %identical (CLASS, DYNAMIC_BOUNDED)
%then DESC[XPO$H_MAXLEN] =.$BIN$$DESC[XPO$H_LENGTH];
DESC[XPO$H_PFXLEN] = 0;
%fi
end;
%else %if %identical (CLASS, BOUNDED)
or %identical (CLASS, DYNAMIC_BOUNDED)
%then DESC[XPO$H_LENGTH] = 0;
%else DESC[XPO$H_LENGTH] = $XPO$BIN_LEN (%remove (DATA_DESC));
%fi
DESC[XPO$B_DTYPE] = XPO$K_DTYPE_BU;
DESC[XPO$B_CLASS] = %expand $XPO$DESC_CLASS (CLASS);
DESC[XPO$A_ADDRESS] = $XPO$ARG2 (%remove (DATA_DESC));
%if %identical (CLASS, BOUNDED)
or %identical (CLASS, DYNAMIC_BOUNDED)
%then DESC[XPO$H_MAXLEN] = $XPO$BIN_LEN (%remove (DATA_DESC));
DESC[XPO$H_PFXLEN] = 0;
%fi
%fi %,
$XPO$BIN_LEN (LENGTH, ADDRESS, KEYWORD) =
%if %identical (KEYWORD, UNITS)
%then LENGTH
%else %upval * (LENGTH)
%fi %,
$BIN$DECLARE (NAME, BINARY_INFO) [] =
%if $XPO$PAREN_TEST (BINARY_INFO) ! BINARY_DATA = (length,pointer)
%then local NAME : %expand $XPO$FORCE ($XPO_DESCRIPTOR ());
%else bind NAME = BINARY_INFO; ! BINARY_DATA = address of a descriptor
%fi %,
$BIN$LOCAL_INIT (NAME, BINARY_INFO) [] =
%if $XPO$PAREN_TEST (BINARY_INFO)
%then $XPO$BIN_DESC (NAME, FIXED, BINARY_INFO)
%fi %;
!
! DATE_TIME - XPORT Date and Time Block
!
$SHOW (NOINFO) ! Turn off BLISS-16 %INFORM messages
$FIELD $XPO$DT_FIELDS =
set
XPO$G_DATE = [$LONG_INTEGER], ! Day number (0 = ??????)
XPO$B_MONTH = [$BYTE], ! Month number (1 = January, ...)
XPO$B_DAY = [$BYTE], ! Day of month
XPO$B_YEAR = [$BYTES (2)], ! Year (e.g., 1979)
XPO$G_TIME = [$LONG_INTEGER], ! Time of day (100ths of second since midnight)
XPO$B_HOUR = [$BYTE], ! Hours since midnight
XPO$B_MINUTE = [$BYTE], ! Minutes since last hour
XPO$B_100THS = [$BYTES (2)] ! 100ths of second since last minute
tes;
literal
XPO$K_DT_LEN = $FIELD_SET_SIZE; ! Length of date/time block
$SHOW (INFO) ! Turn %INFORM messages back on
macro
$XPO_DATE_TIME =
block [XPO$K_DT_LEN] field ($XPO$DT_FIELDS) %;
!
! XIOB - XPORT File I/O Block
!
! CBDOC: FUNCTION codes in comments
!
$FIELD $IOB$FIELDS_1 =
set
IOB$H_LENGTH = [$SHORT_INTEGER], ! Length of IOB (number of elements) >all <init
IOB$B_VERSION = [$TINY_INTEGER], ! XPORT version number <init
IOB$B_LEVEL = [$TINY_INTEGER], ! XPORT base level number <init
IOB$A_FILE_SPEC = [$REF_DESCRIPTOR], ! Address of primary file specification descriptor >open, delete, rename
IOB$A_DEFAULT = [$REF_DESCRIPTOR], ! Address of default file specification descriptor >open, delete, rename
IOB$A_RELATED = [$REF_DESCRIPTOR], ! Address of related file specification descriptor >open, delete, rename
IOB$T_CONCAT = [$DESCRIPTOR (DYNAMIC_BOUNDED)], ! Concatenated input file specificationdescriptor >open <open
IOB$T_RESULTANT = [$DESCRIPTOR (DYNAMIC)], ! Resultant file specification descriptor >close, backup <open, delete, rename
IOB$A_PROMPT = [$REF_DESCRIPTOR], ! Address of read prompt descriptor >get-char
IOB$A_ASSOC_IOB = [$ADDRESS], ! Address of associated IOB >backup, rename
IOB$B_FUNCTION = [$BYTE] ! I/O function code: >all
tes;
$LITERAL
IOB$K_OPEN = $DISTINCT, ! open file
IOB$K_CLOSE = $DISTINCT, ! close file
IOB$K_DELETE = $DISTINCT, ! delete file
IOB$K_RENAME = $DISTINCT, ! rename file
IOB$K_BACKUP = $DISTINCT, ! create backup copy of input file
IOB$K_GET = $DISTINCT, ! get record (locate mode)
IOB$K_PUT = $DISTINCT; ! put record (move mode)
$ALIGN (WORD)
field $IOB$FIELDS_2 =
set
IOB$V_OPTIONS = [$BITS (16)], ! I/O option flags:
$OVERLAY (IOB$V_OPTIONS)
IOB$V_INPUT = [$BIT], ! open for input >open, get
IOB$V_OUTPUT = [$BIT], ! open for output >open, put
IOB$V_OVERWRITE = [$BIT], ! overwrite existing output file >open-out
IOB$V_APPEND = [$BIT], ! append to existing output file >open-out
IOB$V_REMEMBER = [$BIT], ! file will be reprocessed after close >close
IOB$V_MAX_VERSI = [$BIT], ! maximize file version number (internal) >open, rename
$CONTINUE
$ALIGN (WORD)
IOB$V_ATTRIBUTE = [$BITS(16)], ! File attributes:
$OVERLAY (IOB$V_ATTRIBUTE)
IOB$V_BINARY = [$BIT], ! binary data >open, get, put
IOB$V_CHARACTER = [$BIT], ! character data <open
IOB$V_STREAM = [$BIT], ! stream-oriented character data >open, get, put
IOB$V_RECORD = [$BIT], ! record-oriented character data >open, get, put
IOB$V_SEQUENCED = [$BIT], ! sequence-numbered records >open-out, put <open-in
$CONTINUE
$ALIGN (WORD)
IOB$V_STATUS = [$BITS (16)], ! Current file status:
$OVERLAY (IOB$V_STATUS)
IOB$V_OPEN = [$BIT], ! file is open >all <open
IOB$V_EOF = [$BIT], ! end-of-file detected >get, put <get, put
IOB$V_CLOSED = [$BIT], ! file is closed >open <close
IOB$V_AUTO_CONC = [$BIT], ! input file switching in progress >open <get-conc
IOB$V_TERMINAL = [$BIT], ! I/O device is a terminal >get, put <open
IOB$V_TEMPORARY = [$BIT], ! XPORT temporary file >open, close <open
IOB$V_CONC_SPEC = [$BIT], ! primary file-spec is a concatenated file-spec >close <open
$CONTINUE
IOB$T_STRING = [$DESCRIPTOR (DYNAMIC_BOUNDED)], ! Character input string descriptor:
$OVERLAY ($SUB_FIELD (IOB$T_STRING, STR$H_LENGTH))
IOB$H_STRING = [$BYTES (2)], ! length of the character string >get-stream <get-char
$OVERLAY ($SUB_FIELD (IOB$T_STRING, STR$A_POINTER))
IOB$A_STRING = [$POINTER], ! pointer to the character string <get-char
$CONTINUE
$OVERLAY (IOB$T_STRING)
IOB$T_DATA = [$DESCRIPTOR (DYNAMIC_BOUNDED)], ! Binary input data descriptor (overlays IOB$T_STRING):
$OVERLAY ($SUB_FIELD (IOB$T_DATA, STR$H_LENGTH))
IOB$H_UNITS = [$BYTES (2)], ! length of the data in addressable units >get-bin <get-bin
$OVERLAY ($SUB_FIELD (IOB$T_DATA, XPO$A_ADDRESS))
IOB$A_DATA = [$ADDRESS], ! address of the data <get-bin
$CONTINUE
IOB$H_FULLWORDS = [$BYTES (2)], ! length of the data in BLISS fullwords <get-full
$ALIGN (FULLWORD)
IOB$A_OUTPUT = [$REF_DESCRIPTOR], ! Address of character/binary output descriptor >put
$OVERLAY (IOB$A_OUTPUT)
IOB$A_BACK_TYPE = [$REF_DESCRIPTOR], ! Address of backup file type descriptor (overlays IOB$A_OUTPUT) >backup
IOB$H_PREV_PAGE = [$SHORT_INTEGER], ! Page number of previous output line (internal) >put-seq <put-seq
IOB$H_PAGE_NUMB = [$SHORT_INTEGER], ! Current page number >put-seq <get-seq
$ALIGN (FULLWORD)
IOB$G_SEQ_NUMB = [$INTEGER], ! Sequence number of current record >put-seq <get
IOB$G_PREV_REC = [$INTEGER], ! Number of last direct record read or written (future)
IOB$G_REC_NUMB = [$INTEGER], ! Direct-access record number (future)
IOB$G_REC_SIZE = [$INTEGER], ! Fixed record size (0 = variable length records) >open-out <open
IOB$G_BLK_SIZE = [$INTEGER], ! Block size >open-out <open
IOB$Z_CREATED = [$SUB_BLOCK (XPO$K_DT_LEN)], ! File creation date and time (future)
IOB$Z_REVISED = [$SUB_BLOCK (XPO$K_DT_LEN)], ! File revision date and time (future)
$IOB$FILLER1 = [$SUB_BLOCK (16)], ! Reserved for future use
$IOB$FILLER2 = [$SHORT_INTEGER], ! Reserved for future use
$IOB$FILLER3 = [$SHORT_INTEGER], ! Reserved for future use
$IOB$FILLER4 = [$SHORT_INTEGER], ! Reserved for future use
$IOB$FILLER5 = [$SHORT_INTEGER], ! Reserved for future use
$IOB$FILLER6 = [$INTEGER], ! Reserved for future use
$IOB$FILLER7 = [$INTEGER], ! Reserved for future use
$IOB$FILLER8 = [$INTEGER], ! Reserved for future use
$IOB$FILLER9 = [$INTEGER], ! Reserved for future use
IOB$G_COMP_CODE = [$INTEGER], ! Completion code of current operation <all
IOB$G_2ND_CODE = [$INTEGER], ! Secondary completion code <all
IOB$Z_USER = [$INTEGER], ! User-defined value
IOB$G_USER_CODE = [$INTEGER], ! User-defined completion code
IOB$A_BUFFER_CB = [$ADDRESS], ! Address of TOPS-10 buffer control block >get, put <open
$OVERLAY (IOB$A_BUFFER_CB)
IOB$A_RMS_FAB = [$ADDRESS], ! Address of RMS FAB (system-specific) >close <open
IOB$A_RMS_RAB = [$ADDRESS], ! Address of RMS RAB (system-specific) >get, put <open
$OVERLAY (IOB$A_BUFFER_CB)
IOB$A_FCS_FDB = [$ADDRESS], ! Address of FCS FDB (system-specific) >get put close <open
$CONTINUE
$OVERLAY (IOB$A_BUFFER_CB)
IOB$A_RSTS_CB = [$ADDRESS], ! Address of RSTS control block >get put close <open
$CONTINUE
IOB$H_CHANNEL = [$SHORT_INTEGER] ! I/O channel number (system-specific) >get put close <open
tes;
literal
IOB$K_LENGTH = $FIELD_SET_SIZE; ! Length of standard IOB >init
! End of XIOB
macro
$IOB$FIELDS = ! Define entire IOB field set
$IOB$FIELDS_1, $IOB$FIELDS_2 %;
macro
IOB$T_FILE_SPEC =
%warn ('IOB$T_FILE_SPEC (descriptor) has been replaced by IOB$A_FILE_SPEC (address of descriptor)')
IOB$T_RESULTANT %,
IOB$T_DEFAULT =
%warn ('IOB$T_DEFAULT (descriptor) has been replaced by IOB$A_DEFAULT (address of descriptor)')
IOB$T_RESULTANT %,
IOB$T_RELATED =
%warn ('IOB$T_RELATED (descriptor) has been replaced by IOB$A_RELATED (address of descriptor)')
IOB$T_RESULTANT %,
IOB$T_PROMPT =
%warn ('IOB$T_PROMPT (descriptor) has been replaced by IOB$A_PROMPT (address of descriptor)')
IOB$T_RESULTANT %,
IOB$T_OUTPUT =
%warn ('IOB$T_OUTPUT (descriptor) has been replaced by IOB$A_OUTPUT (address of descriptor)')
IOB$T_RESULTANT %,
IOB$T_BACK_TYPE =
%warn ('IOB$T_BACK_TYPE (descriptor) has been replaced by IOB$A_BACK_TYPE (address of descriptor)')
IOB$T_RESULTANT %;
!
! XPORT I/O Control Block and Interface Macros
!
macro
$IOB$NOT_ALLOWED (KEYWORD, VALUE, FUNCTION) =
%if not %null (VALUE)
%then %warn (KEYWORD, ' may not be specified during IOB ', FUNCTION)
%fi %,
$IOB$STRING (FIELD_NAME, STRING_NAME, STRING_INFO) [] =
IOB$[FIELD_NAME] = STRING_NAME; %,
$IOB$GET_LENGTH (DATA_CODE, VALUE) [] =
IOB$[IOB$H_STRING] = VALUE;
IOB$[%expand $XPO$FORCE ($SUB_FIELD (IOB$T_STRING, STR$B_DTYPE))] = DATA_CODE; %,
$XPO$IO_CALL (FUNCTION, SUCCESS, FAILURE) =
%if %identical (FAILURE, XPO$IO_FAIL_MSG)
%then %warn ('FAILURE=XPO$IO_FAIL_MSG is obsolete - FAILURE=XPO$FAILURE is now the default')
%fi
IOB$[IOB$B_FUNCTION] = %quote %expand %name ('IOB$K_', FUNCTION);
begin
%quote %expand $XPO$FORCE ($XPO$EX_ROUTINE (%quote %expand %name ('XPO$', FUNCTION)))
%expand $XPO$EX_FAILURE (FAILURE)
%quote %expand %name ('XPO$', FUNCTION) (IOB$,
%expand $XPO$DEFAULT (SUCCESS, 0),
%expand $XPO$DEFAULT (FAILURE, 0))
end %;
keywordmacro
$XPO_IOB (FILE_SPEC, ! primary file specification information
DEFAULT, ! default file specification information
RELATED, ! related file specification information
OPTION, ! option keyword
OPTIONS, ! option keywords
ATTRIBUTE, ! file attribute keywords
ATTRIBUTES, ! file attribute keywords
PROMPT, ! read prompt string information
BINARY_DATA, ! binary data information
STRING, ! character string information
CHARACTERS, ! length of I/O request
FULLWORDS, ! length of I/O request
UNITS, ! length of I/O request
PAGE_NUMBER, ! page number
SEQUENCE_NUMBER, ! record sequence number
RECORD_SIZE, ! maximum record size
BLOCK_SIZE, ! physical block size
USER) = ! user-specified value
%if %expand $XPO$CONFLICT (OPTION, OPTIONS)
%then %warn ('OPTION= and OPTIONS= are mutually exclusive')
%fi
%if %expand $XPO$CONFLICT (ATTRIBUTE, ATTRIBUTES)
%then %warn ('ATTRIBUTE= and ATTRIBUTES= are mutually exclusive')
%fi
%if %expand $XPO$CONFLICT ((CHARACTERS, PAGE_NUMBER, SEQUENCE_NUMBER),
(FULLWORDS, UNITS))
%then %warn ('Character and binary parameters are mutually exclusive')
%fi
%if %expand $XPO$CONFLICT ((UNITS), (FULLWORDS))
%then %warn ('FULLWORDS= and UNITS= are mutually exclusive')
%fi
%expand $IOB$NOT_ALLOWED ('STRING=', STRING, 'declaration')
%expand $IOB$NOT_ALLOWED ('BINARY_DATA=', BINARY_DATA, 'declaration')
block [IOB$K_LENGTH] field (%expand $IOB$FIELDS)
%if %expand $XPO$CONFLICT (1, (FILE_SPEC,
DEFAULT,
RELATED,
OPTION,
OPTIONS,
ATTRIBUTE,
ATTRIBUTES,
PROMPT,
CHARACTERS,
FULLWORDS,
UNITS,
PAGE_NUMBER,
SEQUENCE_NUMBER,
RECORD_SIZE,
BLOCK_SIZE,
USER))
%then %warn ('Static IOB initialization not yet supported')
%fi %,
$XPO_BACKUP (OLD_IOB, ! address of the input file IOB
NEW_IOB, ! address of the output file IOB
FILE_TYPE = '.BAK', ! file_type information
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%expand $XPO$REQUIRED (OLD_IOB, 'OLD_IOB=')
%expand $XPO$REQUIRED (NEW_IOB, 'NEW_IOB=')
begin
bind IOB$ = OLD_IOB : %expand $XPO$FORCE ($XPO_IOB ());
$STR$DECLARE (local, $IOB$BACK_TYPE, FILE_TYPE)
$STR$LOCAL_INIT ($IOB$BACK_TYPE, FILE_TYPE)
$IOB$STRING (IOB$A_BACK_TYPE, $IOB$BACK_TYPE, FILE_TYPE) ! FILE_TYPE=
$XPO$VALUE (IOB$, A_ASSOC_IOB, NEW_IOB) ! NEW_IOB=
%expand $XPO$IO_CALL (%quote BACKUP, SUCCESS, FAILURE)
end %,
$XPO_CLOSE (IOB, ! address of IOB
OPTION, ! option keywords
OPTIONS, ! option keywords
USER, ! user-specified value
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%if %expand $XPO$CONFLICT (OPTION, OPTIONS)
%then %warn ('OPTION= and OPTIONS= are mutually exclusive')
%fi
%expand $XPO$REQUIRED (IOB, 'IOB=')
begin
bind IOB$ = IOB : %expand $XPO$FORCE ($XPO_IOB ());
$XPO$KEYWORD (IOB$, OPTION %remove (OPTIONS)) ! OPTION= or OPTIONS=
$XPO$VALUE (IOB$, Z_USER, USER) ! USER=
%expand $XPO$IO_CALL (%quote CLOSE, SUCCESS, FAILURE)
end %,
$XPO_DELETE (IOB, ! address of IOB
FILE_SPEC, ! primary file specification information
DEFAULT, ! default file specification information
RELATED, ! related file specification information
USER, ! user-specified value
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%expand $XPO$REQUIRED (IOB, 'IOB=')
begin
bind IOB$ = IOB : %expand $XPO$FORCE ($XPO_IOB ());
$STR$DECLARE (local, $IOB$FILE_SPEC, FILE_SPEC)
$STR$DECLARE (local, $IOB$DEFAULT, DEFAULT)
$STR$DECLARE (local, $IOB$RELATED, RELATED)
$STR$LOCAL_INIT ($IOB$FILE_SPEC, FILE_SPEC)
$STR$LOCAL_INIT ($IOB$DEFAULT, DEFAULT)
$STR$LOCAL_INIT ($IOB$RELATED, RELATED)
$IOB$STRING (IOB$A_FILE_SPEC, $IOB$FILE_SPEC, FILE_SPEC) ! FILE_SPEC=
$IOB$STRING (IOB$A_DEFAULT, $IOB$DEFAULT, DEFAULT) ! DEFAULT=
$IOB$STRING (IOB$A_RELATED, $IOB$RELATED, RELATED) ! RELATED=
$XPO$VALUE (IOB$, Z_USER, USER) ! USER=
%expand $XPO$IO_CALL (%quote DELETE, SUCCESS, FAILURE)
end %,
$XPO_GET (IOB, ! address of IOB
PROMPT, ! pointer to read prompt string
CHARACTERS, ! length of I/O request
FULLWORDS, ! length of I/O request
UNITS, ! length of I/O request
USER, ! user-specified value
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%if %expand $XPO$CONFLICT (CHARACTERS, FULLWORDS, UNITS)
%then %warn ('CHARACTERS=, FULLWORDS= and UNITS= are mutually exclusive')
%fi
%expand $XPO$REQUIRED (IOB, 'IOB=')
begin
bind IOB$ = IOB : %expand $XPO$FORCE ($XPO_IOB ());
$STR$DECLARE (bind, $IOB$PROMPT, PROMPT)
%if not %null (PROMPT)
%then if .IOB$[IOB$A_PROMPT] neq 0
then $STR_FREE_TEMP (.IOB$[IOB$A_PROMPT]);
%fi
$IOB$STRING (IOB$A_PROMPT, $IOB$PROMPT, PROMPT) ! PROMPT=
$IOB$GET_LENGTH (STR$K_DTYPE_T, CHARACTERS) ! CHARACTERS=
%if not %null (FULLWORDS)
%then $IOB$GET_LENGTH (XPO$K_DTYPE_BU, ! FULLWORDS=
%upval * (FULLWORDS))
%fi
$IOB$GET_LENGTH (XPO$K_DTYPE_BU, UNITS) ! UNITS=
$XPO$VALUE (IOB$, Z_USER, USER) ! USER=
%expand $XPO$IO_CALL (%quote GET, SUCCESS, FAILURE)
end %,
$XPO_IOB_INIT (IOB, ! address of IOB to be initialized
FILE_SPEC, ! primary file specification information
DEFAULT, ! default file specification information
RELATED, ! related file specification information
OPTION, ! option keyword
OPTIONS, ! option keywords
ATTRIBUTE, ! file attribute keywords
ATTRIBUTES, ! file attribute keywords
PROMPT, ! read prompt string information
BINARY_DATA, ! binary data information
STRING, ! character string information
CHARACTERS, ! length of I/O request
FULLWORDS, ! length of I/O request
UNITS, ! length of I/O request
PAGE_NUMBER, ! page number
SEQUENCE_NUMBER, ! record sequence number
RECORD_SIZE, ! maximum record size
BLOCK_SIZE, ! physical block size
USER) = ! user-specified value
%if %expand $XPO$CONFLICT (OPTION, OPTIONS)
%then %warn ('OPTION= and OPTIONS= are mutually exclusive')
%fi
%if %expand $XPO$CONFLICT (ATTRIBUTE, ATTRIBUTES)
%then %warn ('ATTRIBUTE= and ATTRIBUTES= are mutually exclusive')
%fi
%if %expand $XPO$CONFLICT ((STRING,
CHARACTERS,
PAGE_NUMBER,
SEQUENCE_NUMBER),
(BINARY_DATA,
FULLWORDS,
UNITS))
%then %warn ('Character and binary parameters are mutually exclusive')
%fi
%if %expand $XPO$CONFLICT ((UNITS), (FULLWORDS))
%then %warn ('FULLWORDS= and UNITS= are mutually exclusive')
%fi
%expand $XPO$REQUIRED (IOB, 'IOB=')
%expand $IOB$NOT_ALLOWED ('STRING=', STRING, 'initialization')
%expand $IOB$NOT_ALLOWED ('BINARY_DATA=', BINARY_DATA, 'initialization')
begin
bind IOB$ = IOB : %expand $XPO$FORCE ($XPO_IOB ()),
IOB$RESULTANT = IOB$[IOB$T_RESULTANT] : %expand $XPO$FORCE ($STR_DESCRIPTOR ());
$STR$DECLARE (bind, $IOB$FILE_SPEC, FILE_SPEC)
$STR$DECLARE (bind, $IOB$DEFAULT, DEFAULT)
$STR$DECLARE (bind, $IOB$RELATED, RELATED)
$STR$DECLARE (bind, $IOB$PROMPT, PROMPT)
ch$fill (0, IOB$K_LENGTH * %upval, ch$ptr (IOB$,0,%bpunit)); ! Zero the entire IOB.
IOB$[IOB$H_LENGTH] = IOB$K_LENGTH; ! IOB length
IOB$[IOB$B_VERSION] = XPO$K_VERSION; ! XPORT version
IOB$[IOB$B_LEVEL] = XPO$K_LEVEL; ! XPORT level
$IOB$STRING (IOB$A_FILE_SPEC, $IOB$FILE_SPEC, FILE_SPEC) ! FILE_SPEC=
$IOB$STRING (IOB$A_DEFAULT, $IOB$DEFAULT, DEFAULT) ! DEFAULT=
$IOB$STRING (IOB$A_RELATED, $IOB$RELATED, RELATED) ! RELATED=
! Resultant file-spec descriptor:
IOB$RESULTANT[STR$B_DTYPE] = STR$K_DTYPE_T; ! ASCII data type
IOB$RESULTANT[STR$B_CLASS] = STR$K_CLASS_D; ! DYNAMIC descriptor class
$IOB$STRING (IOB$A_PROMPT, $IOB$PROMPT, PROMPT) ! PROMPT=
$XPO$KEYWORD (IOB$, OPTION %remove (OPTIONS)) ! OPTION= or OPTIONS=
$XPO$KEYWORD (IOB$, ATTRIBUTE %remove (ATTRIBUTES)) ! ATTRIBUTE= or ATTRIBUTES=
$IOB$GET_LENGTH (STR$K_DTYPE_T, CHARACTERS) ! CHARACTERS=
%if not %null (FULLWORDS)
%then $IOB$GET_LENGTH (XPO$K_DTYPE_BU, ! FULLWORDS=
%upval * (FULLWORDS))
%fi
$IOB$GET_LENGTH (XPO$K_DTYPE_BU, UNITS) ! UNITS=
$XPO$VALUE (IOB$, H_PAGE_NUMB, PAGE_NUMBER) ! PAGE_NUMBER=
$XPO$VALUE (IOB$, G_SEQ_NUMB, SEQUENCE_NUMBER) ! SEQUENCE_NUMBER=
%if not %identical (RECORD_SIZE, VARIABLE)
%then $XPO$VALUE (IOB$, G_REC_SIZE, RECORD_SIZE) ! RECORD_SIZE=
%fi
$XPO$VALUE (IOB$, G_BLK_SIZE, BLOCK_SIZE) ! BLOCK_SIZE=
$XPO$VALUE (IOB$, Z_USER, USER) ! USER=
XPO$_NORMAL ! normal completion code
end %,
$XPO_OPEN (IOB, ! address of IOB
FILE_SPEC, ! primary file specification information
DEFAULT, ! default file specification information
RELATED, ! related file specification information
OPTION, ! option keyword
OPTIONS, ! option keywords
ATTRIBUTE, ! file attribute keywords
ATTRIBUTES, ! file attribute keywords
PROMPT, ! read prompt string information
BINARY_DATA, ! binary data information
STRING, ! character string information
CHARACTERS, ! length of I/O request
FULLWORDS, ! length of I/O request
UNITS, ! length of I/O request
PAGE_NUMBER, ! page number
SEQUENCE_NUMBER, ! record sequence number
RECORD_SIZE, ! maximum record size
BLOCK_SIZE, ! physical block size
USER, ! user-specified value
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%if %expand $XPO$CONFLICT (OPTION, OPTIONS)
%then %warn ('OPTION= and OPTIONS= are mutually exclusive')
%fi
%if %expand $XPO$CONFLICT (ATTRIBUTE, ATTRIBUTES)
%then %warn ('ATTRIBUTE= and ATTRIBUTES= are mutually exclusive')
%fi
%if %expand $XPO$CONFLICT ((STRING,
CHARACTERS,
PAGE_NUMBER,
SEQUENCE_NUMBER),
(BINARY_DATA,
FULLWORDS,
UNITS))
%then %warn ('Character and binary parameters are mutually exclusive')
%fi
%if %expand $XPO$CONFLICT ((UNITS), (FULLWORDS))
%then %warn ('FULLWORDS= and UNITS= are mutually exclusive')
%fi
%expand $XPO$REQUIRED (IOB, 'IOB=')
%expand $IOB$NOT_ALLOWED ('STRING=', STRING, 'open')
%expand $IOB$NOT_ALLOWED ('BINARY_DATA=', BINARY_DATA, 'open')
begin
bind IOB$ = IOB : %expand $XPO$FORCE ($XPO_IOB ());
$STR$DECLARE (bind, $IOB$FILE_SPEC, FILE_SPEC)
$STR$DECLARE (bind, $IOB$DEFAULT, DEFAULT)
$STR$DECLARE (bind, $IOB$RELATED, RELATED)
$STR$DECLARE (bind, $IOB$PROMPT, PROMPT)
$IOB$STRING (IOB$A_FILE_SPEC, $IOB$FILE_SPEC, FILE_SPEC) ! FILE_SPEC=
$IOB$STRING (IOB$A_DEFAULT, $IOB$DEFAULT, DEFAULT) ! DEFAULT=
$IOB$STRING (IOB$A_RELATED, $IOB$RELATED, RELATED) ! RELATED=
$IOB$STRING (IOB$A_PROMPT, $IOB$PROMPT, PROMPT) ! PROMPT=
$XPO$KEYWORD (IOB$, OPTION %remove (OPTIONS)) ! OPTION= or OPTIONS=
$XPO$KEYWORD (IOB$, ATTRIBUTE %remove (ATTRIBUTES)) ! ATTRIBUTE= or ATTRIBUTES=
$IOB$GET_LENGTH (STR$K_DTYPE_T, CHARACTERS) ! CHARACTERS=
$XPO$VALUE (IOB$, H_PAGE_NUMB, PAGE_NUMBER) ! PAGE_NUMBER=
$XPO$VALUE (IOB$, G_SEQ_NUMB, SEQUENCE_NUMBER) ! SEQUENCE_NUMBER=
%if not %null (FULLWORDS)
%then $IOB$GET_LENGTH (XPO$K_DTYPE_BU, ! FULLWORDS=
%upval * (FULLWORDS))
%fi
$IOB$GET_LENGTH (XPO$K_DTYPE_BU, UNITS) ! UNITS=
%if %identical (RECORD_SIZE, VARIABLE)
%then IOB$[IOB$G_REC_SIZE] = 0; ! RECORD_SIZE=VARIABLE
%else $XPO$VALUE (IOB$, G_REC_SIZE, RECORD_SIZE) ! RECORD_SIZE=value
%fi
$XPO$VALUE (IOB$, G_BLK_SIZE, BLOCK_SIZE) ! BLOCK_SIZE=
$XPO$VALUE (IOB$, Z_USER, USER) ! USER=
%expand $XPO$IO_CALL (%quote OPEN, SUCCESS, FAILURE)
end %,
$XPO_PUT (IOB, ! address of IOB
STRING, ! character string information
PAGE_NUMBER, ! page number
SEQUENCE_NUMBER, ! record sequence number
BINARY_DATA, ! binary data information
USER, ! user-specified value
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%if %expand $XPO$CONFLICT ((STRING,
PAGE_NUMBER,
SEQUENCE_NUMBER),
(BINARY_DATA))
%then %warn ('Character and binary parameters are mutually exclusive')
%fi
%expand $XPO$REQUIRED (IOB, 'IOB=')
begin
bind IOB$ = IOB : %expand $XPO$FORCE ($XPO_IOB ());
$STR$DECLARE (local, $IOB$OUTPUT, STRING)
$BIN$DECLARE ($IOB$OUTPUT, BINARY_DATA)
$STR$LOCAL_INIT ($IOB$OUTPUT, STRING)
$BIN$LOCAL_INIT ($IOB$OUTPUT, BINARY_DATA)
$IOB$STRING (IOB$A_OUTPUT, $IOB$OUTPUT, STRING BINARY_DATA) ! STRING= or BINARY_DATA=
$XPO$VALUE (IOB$, H_PAGE_NUMB, PAGE_NUMBER) ! PAGE_NUMBER=
$XPO$VALUE (IOB$, G_SEQ_NUMB, SEQUENCE_NUMBER) ! SEQUENCE_NUMBER=
$XPO$VALUE (IOB$, Z_USER, USER) ! USER=
%expand $XPO$IO_CALL (%quote PUT, SUCCESS, FAILURE)
end %,
$XPO_RENAME (IOB, ! address of IOB
FILE_SPEC, ! primary file specification information
DEFAULT, ! default file specification information
RELATED, ! related file specification information
NEW_SPEC, ! new primary file specification information
NEW_DEFAULT, ! new default file specification information
NEW_RELATED, ! new related file specification information
OPTION, ! option keywords
OPTIONS, ! option keywords
USER, ! user-specified value
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%if %expand $XPO$CONFLICT (OPTION, OPTIONS)
%then %warn ('OPTION= and OPTIONS= are mutually exclusive')
%fi
%expand $XPO$REQUIRED (IOB, 'IOB=')
%expand $XPO$REQUIRED (NEW_SPEC NEW_DEFAULT NEW_RELATED,
'NEW_SPEC=, NEW_DEFAULT=, or NEW_RELATED=')
begin
bind IOB$ = IOB : %expand $XPO$FORCE ($XPO_IOB ());
local $XPO$NEW_IOB : %expand $XPO$FORCE ($XPO_IOB ());
$STR$DECLARE (local, $IOB$FILE_SPEC, FILE_SPEC)
$STR$DECLARE (local, $IOB$DEFAULT, DEFAULT)
$STR$DECLARE (local, $IOB$RELATED, RELATED)
$STR$DECLARE (local, $IOB$NEW_SPEC, NEW_SPEC)
$STR$DECLARE (local, $IOB$NEW_DEFAULT, NEW_DEFAULT)
$STR$DECLARE (local, $IOB$NEW_RELATED, NEW_RELATED)
$STR$LOCAL_INIT ($IOB$FILE_SPEC, FILE_SPEC)
$STR$LOCAL_INIT ($IOB$DEFAULT, DEFAULT)
$STR$LOCAL_INIT ($IOB$RELATED, RELATED)
$STR$LOCAL_INIT ($IOB$NEW_SPEC, NEW_SPEC)
$STR$LOCAL_INIT ($IOB$NEW_DEFAULT, NEW_DEFAULT)
$STR$LOCAL_INIT ($IOB$NEW_RELATED, NEW_RELATED)
$XPO_IOB_INIT (%quote IOB = $XPO$NEW_IOB,
%quote OPTION = OUTPUT ! force "output" file-spec resolution
%if not %null (NEW_SPEC)
%then , %quote FILE_SPEC = $IOB$NEW_SPEC
%fi
%if not %null (NEW_DEFAULT)
%then , %quote DEFAULT = $IOB$NEW_DEFAULT
%fi
%if not %null (NEW_RELATED)
%then , %quote RELATED = $IOB$NEW_RELATED
%fi);
$IOB$STRING (IOB$A_FILE_SPEC, $IOB$FILE_SPEC, FILE_SPEC) ! FILE_SPEC=
$IOB$STRING (IOB$A_DEFAULT, $IOB$DEFAULT, DEFAULT) ! DEFAULT=
$IOB$STRING (IOB$A_RELATED, $IOB$RELATED, RELATED) ! RELATED=
$XPO$VALUE (IOB$, A_ASSOC_IOB, $XPO$NEW_IOB) ! NEW_SPEC=, NEW_DEFAULT=, NEW_RELATED=
$XPO$KEYWORD (IOB$, OPTION %remove (OPTIONS)) ! OPTION= or OPTIONS=
$XPO$VALUE (IOB$, Z_USER, USER) ! USER=
%expand $XPO$IO_CALL (%quote RENAME, SUCCESS, FAILURE)
end %;
macro
$XPO_INPUT =
%if %bliss (bliss36)
%then 'TTY:'
%else %if %bliss (bliss32)
%then 'SYS$INPUT'
%else 'TI:'
%fi
%fi %,
$XPO_OUTPUT =
%if %bliss (bliss32)
%then 'SYS$OUTPUT'
%else %expand $XPO_INPUT
%fi %,
$XPO_ERROR =
%if %bliss (bliss32)
%then 'SYS$ERROR'
%else %expand $XPO_INPUT
%fi %,
$XPO_TEMPORARY =
'[XPORT Temporary File]' %;
!
! XSPEC - XPORT File Specification Parse Block
!
$FIELD $XPO$SPEC_FIELD =
set
XPO$V_SPEC_STAT = [$BITS (16)], ! File specification indicators:
$OVERLAY (XPO$V_SPEC_STAT)
XPO$V_DIR_NAME = [$BIT], ! <directory-name> specified
XPO$V_PPN = [$BIT], ! [project,programmer] specified
XPO$V_WILD_CARD = [$BIT], ! wild-card somewhere in file-spec
XPO$V_WILD_NODE = [$BIT], ! wild-card node name
XPO$V_WILD_DEV = [$BIT], ! wild-card device name
XPO$V_WILD_DIR = [$BIT], ! wild-card in directory name
XPO$V_WILD_PROJ = [$BIT], ! wild-card project number
XPO$V_WILD_PGMR = [$BIT], ! wild-card programmer number
XPO$V_WILD_NAME = [$BIT], ! wild-card file name
XPO$V_WILD_TYPE = [$BIT], ! wild-card file type (extension)
XPO$V_WILD_VER = [$BIT], ! wild-card file version number
$CONTINUE
XPO$T_NODE = [$DESCRIPTOR (FIXED)], ! Network node name descriptor:
$OVERLAY ($SUB_FIELD(XPO$T_NODE,STR$H_LENGTH))
XPO$H_NODE = [$BYTES (2)], ! length of the node name
$OVERLAY ($SUB_FIELD (XPO$T_NODE, STR$A_POINTER))
XPO$A_NODE = [$POINTER], ! pointer to the node name
$CONTINUE
XPO$T_DEVICE = [$DESCRIPTOR (FIXED)], ! Device name descriptor:
$OVERLAY ($SUB_FIELD (XPO$T_DEVICE, STR$H_LENGTH))
XPO$H_DEVICE = [$BYTES (2)], ! length of the device name
$OVERLAY ($SUB_FIELD (XPO$T_DEVICE, STR$A_POINTER))
XPO$A_DEVICE = [$POINTER], ! pointer to the device name
$CONTINUE
XPO$T_DIRECT = [$DESCRIPTOR (FIXED)], ! Directory specification descriptor:
$OVERLAY ($SUB_FIELD (XPO$T_DIRECT, STR$H_LENGTH))
XPO$H_DIRECT = [$BYTES (2)], ! length of the directory spec
$OVERLAY ($SUB_FIELD (XPO$T_DIRECT, STR$A_POINTER))
XPO$A_DIRECT = [$POINTER], ! pointer to the directory spec
$CONTINUE
XPO$H_PROJ_NUMB = [$BYTES (2)], ! Project number (binary)
XPO$H_PGMR_NUMB = [$BYTES (2)], ! Programmer number (binary)
XPO$T_FILE_NAME = [$DESCRIPTOR (FIXED)], ! File name descriptor:
$OVERLAY ($SUB_FIELD (XPO$T_FILE_NAME, STR$H_LENGTH))
XPO$H_FILE_NAME = [$BYTES (2)], ! length of the file name
$OVERLAY ($SUB_FIELD (XPO$T_FILE_NAME, STR$A_POINTER))
XPO$A_FILE_NAME = [$POINTER], ! pointer to the file name
$CONTINUE
XPO$T_FILE_TYPE = [$DESCRIPTOR (FIXED)], ! File type (extension) descriptor:
$OVERLAY ($SUB_FIELD (XPO$T_FILE_TYPE, STR$H_LENGTH))
XPO$H_FILE_TYPE = [$BYTES (2)], ! length of the file type
$OVERLAY ($SUB_FIELD (XPO$T_FILE_TYPE, STR$A_POINTER))
XPO$A_FILE_TYPE = [$POINTER], ! pointer to the file type
$CONTINUE
XPO$T_FILE_VER = [$DESCRIPTOR (FIXED)], ! File version number descriptor:
$OVERLAY ($SUB_FIELD (XPO$T_FILE_VER, STR$H_LENGTH))
XPO$H_FILE_VER = [$BYTES (2)], ! length of the file version
$OVERLAY ($SUB_FIELD (XPO$T_FILE_VER, STR$A_POINTER))
XPO$A_FILE_VER = [$POINTER], ! pointer to the file version
$CONTINUE
XPO$T_FILE_PROT = [$DESCRIPTOR (FIXED)], ! File protection descriptor (RSTS only):
$OVERLAY ($SUB_FIELD (XPO$T_FILE_PROT, STR$H_LENGTH))
XPO$H_FILE_PROT = [$BYTES (2)], ! length of the protection
$OVERLAY ($SUB_FIELD (XPO$T_FILE_PROT, STR$A_POINTER))
XPO$A_FILE_PROT = [$POINTER], ! pointer to the protection
$CONTINUE
XPO$T_EXTRA = [$DESCRIPTOR (FIXED)], ! File 'EXTRA' information descriptor:
$OVERLAY ($SUB_FIELD (XPO$T_EXTRA, STR$H_LENGTH))
XPO$H_EXTRA = [$BYTES (2)], ! length
$OVERLAY ($SUB_FIELD (XPO$T_EXTRA, STR$A_POINTER))
XPO$A_EXTRA = [$POINTER] ! pointer
$CONTINUE
tes;
literal
XPO$K_SPEC_LEN = $FIELD_SET_SIZE; ! Length of file-spec block
! End of XSPEC
macro
$XPO_SPEC_BLOCK =
block [XPO$K_SPEC_LEN] field ($XPO$SPEC_FIELD) %;
keywordmacro
$XPO_PARSE_SPEC (FILE_SPEC, ! file specification information
SPEC_BLOCK, ! address of file-spec parse block
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%expand $XPO$REQUIRED (FILE_SPEC, 'FILE_SPEC=')
%expand $XPO$REQUIRED (SPEC_BLOCK, 'SPEC_BLOCK=')
begin
%expand $XPO$FORCE ($XPO$EX_ROUTINE (XPO$PARSE_SPEC))
%expand $XPO$EX_FAILURE (FAILURE)
$STR$DECLARE (local, $STR$FILE_SPEC, FILE_SPEC)
$STR$LOCAL_INIT ($STR$FILE_SPEC, FILE_SPEC)
XPO$PARSE_SPEC ($STR$FILE_SPEC,
SPEC_BLOCK,
not %declared ($XPO$INTERNAL),
$XPO$DEFAULT (SUCCESS, 0),
$XPO$DEFAULT (FAILURE, 0))
end %;
!
! XPORT MEMORY Macros
!
literal ! $XPO_GET_MEM fill indicators:
XPO$K_DONT_FILL = -1, ! don't fill element
XPO$K_FILL_FULL = 0, ! fill fullwords if binary data element
XPO$K_FILL_UNIT = 1; ! fill addressable units if binary data element
keywordmacro
$XPO_GET_MEM (DESC, ! address of a partially completed descriptor
DESCRIPTOR, ! address of a partially completed descriptor
CHARACTERS, ! size of element in characters
FULLWORDS, ! size of element in fullwords
UNITS, ! size of element in units
RESULT, ! address of resulting pointer/address
POINTER, ! *** OBSOLETE ***
ADDRESS, ! *** OBSOLETE ***
FILL, ! storage fill value
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%if %expand $XPO$CONFLICT (1, (DESC,
DESCRIPTOR,
RESULT,
POINTER,
ADDRESS))
%then %if %expand $XPO$CONFLICT ((DESC,DESCRIPTOR),
(CHARACTERS,
FULLWORDS,
UNITS,
RESULT,
POINTER,
ADDRESS))
%then %warn ('DESC=/DESCRIPTOR= and non-descriptor parameters are mutually exclusive')
%exitmacro
%fi
%if not %null (POINTER) ! *** OBSOLETE ***
%then %inform ('POINTER= is obsolete - use RESULT=')
%fi ! *** OBSOLETE ***
%if not %null (ADDRESS) ! *** OBSOLETE ***
%then %inform ('ADDRESS= is obsolete - use RESULT=')
%fi
%if %expand $XPO$CONFLICT (DESC, DESCRIPTOR)
%then %warn ('DESC= and DESCRIPTOR= are mutually exclusive')
%exitmacro
%fi
%if %expand $XPO$CONFLICT (CHARACTERS, FULLWORDS, UNITS)
%then %warn ('CHARACTERS=, FULLWORDS= and UNITS= are mutually exclusive')
%exitmacro
%fi
%if %null (DESC DESCRIPTOR)
%then %expand $XPO$REQUIRED (CHARACTERS FULLWORDS UNITS,
'DESCRIPTOR=, DESC=, CHARACTERS=, FULLWORDS=, or UNITS=')
%expand $XPO$REQUIRED (RESULT POINTER ADDRESS, 'RESULT=')
%fi
begin
%if %null (DESC DESCRIPTOR)
%then local $XPO$STATUS,
$XPO$DESC : %if not %null (CHARACTERS)
%then %expand $XPO$FORCE ($STR_DESCRIPTOR(CLASS=DYNAMIC));
%else %expand $XPO$FORCE ($XPO_DESCRIPTOR(CLASS=DYNAMIC));
%fi
%else bind $XPO$DESC = DESC DESCRIPTOR;
%fi
%expand $XPO$FORCE ($XPO$EX_ROUTINE (XPO$ALLOC_MEM))
%expand $XPO$EX_FAILURE (FAILURE)
%if not %null (CHARACTERS)
%then $STR$STR_DESC ($XPO$DESC, DYNAMIC, (CHARACTERS, 0))
%else %if not %null (FULLWORDS)
%then $XPO$BIN_DESC ($XPO$DESC,
DYNAMIC,
(FULLWORDS, 0, %quote FULLWORDS))
%else %if not %null (UNITS)
%then $XPO$BIN_DESC ($XPO$DESC,
DYNAMIC,
(UNITS, 0, %quote UNITS))
%fi
%fi
%fi
%if %null (DESC DESCRIPTOR)
%then $XPO$STATUS =
%fi
XPO$ALLOC_MEM ($XPO$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/yes)
%fi
$XPO$DEFAULT (FILL,0), ! fill value
$XPO$DEFAULT (SUCCESS,0), ! address of success action routine
$XPO$DEFAULT (FAILURE,0)) ! address of failure action routine
%if not %null (CHARACTERS)
%then ; if .$XPO$STATUS
then RESULT POINTER = .$XPO$DESC[STR$A_POINTER];
.$XPO$STATUS
%fi
%if not %null (FULLWORDS UNITS)
%then ; if .$XPO$STATUS
then RESULT ADDRESS = .$XPO$DESC[XPO$A_ADDRESS];
.$XPO$STATUS
%fi
%else ! *** OBSOLETE ***
%inform ('DESCRIPTOR= or RESULT= missing - see new $XPO_GET_MEM documentation')
%if %expand $XPO$CONFLICT (CHARACTERS, FULLWORDS, UNITS)
%then %warn ('CHARACTERS=, FULLWORDS=, and UNITS= are mutually exclusive')
%exitmacro
%fi
%expand $XPO$REQUIRED (CHARACTERS FULLWORDS UNITS,
'CHARACTERS=, FULLWORDS=, or UNITS=')
begin
local $XPO$DESC : %if not %null (CHARACTERS)
%then %expand $XPO$FORCE ($STR_DESCRIPTOR ());
%else %expand $XPO$FORCE ($XPO_DESCRIPTOR ());
%fi
%expand $XPO$FORCE ($XPO$EX_ROUTINE (XPO$ALLOC_MEM))
%expand $XPO$EX_FAILURE (FAILURE)
%if not %null (CHARACTERS)
%then $STR$STR_DESC ($XPO$DESC, DYNAMIC, (CHARACTERS, 0))
%else %if not %null (FULLWORDS)
%then $XPO$BIN_DESC ($XPO$DESC,
DYNAMIC,
(FULLWORDS, 0, %quote FULLWORDS))
%else %if not %null (UNITS)
%then $XPO$BIN_DESC ($XPO$DESC,
DYNAMIC,
(UNITS, 0, %quote UNITS))
%fi
%fi
%fi
XPO$ALLOC_MEM ($XPO$DESC, ! address of request descriptor
%if %null (FILL) ! fill element indicator:
%then XPO$K_DONT_FILL, ! don't fill element
%else %null (FULLWORDS), ! fill fullwords (no/yes)
%fi
$XPO$DEFAULT (FILL,0), ! fill value
$XPO$DEFAULT (SUCCESS,0), ! address of success action routine
$XPO$DEFAULT (FAILURE,0)); ! address of failure action routine
%if not %null (CHARACTERS)
%then .$XPO$DESC[STR$A_POINTER]
%else .$XPO$DESC[XPO$A_ADDRESS]
%fi
%fi
end %,
$XPO_FREE_MEM (STRING, ! character string descriptor
BINARY_DATA, ! binary data descriptor
DESCRIPTOR, ! *** OBSOLETE ***
FILL, ! storage fill value
SUCCESS, ! address of success action routine
FAILURE = XPO$FAILURE) = ! address of failure action routine
%if %expand $XPO$CONFLICT (STRING, BINARY_DATA, DESCRIPTOR)
%then %warn ('STRING=, BINARY_DATA= and DESCRIPTOR= are mutually exclusive')
%exitmacro
%fi
%expand $XPO$REQUIRED (STRING BINARY_DATA DESCRIPTOR,
'STRING= or BINARY_DATA=')
%if not %null (DESCRIPTOR)
%then %inform ('DESCRIPTOR= is obsolete - use STRING= or BINARY=')
%fi
%if %isstring (%remove (STRING))
%then %warn ('Literal STRING= parameter is not permitted')
%exitmacro
%fi
begin
%expand $XPO$FORCE ($XPO$EX_ROUTINE (XPO$FREE_MEM))
%expand $XPO$EX_FAILURE (FAILURE)
%if $XPO$PAREN_TEST (STRING) or $XPO$PAREN_TEST (BINARY_DATA)
%then local $XPO$DESC : %if not %null (STRING)
%then %expand $XPO$FORCE ($STR_DESCRIPTOR (CLASS=DYNAMIC));
%else %expand $XPO$FORCE ($XPO_DESCRIPTOR (CLASS=DYNAMIC));
%fi
$STR$STR_DESC ($XPO$DESC, DYNAMIC, STRING)
$XPO$BIN_DESC ($XPO$DESC, DYNAMIC, BINARY_DATA)
XPO$FREE_MEM ($XPO$DESC, ! address of local string/data descriptor
%else XPO$FREE_MEM (STRING BINARY_DATA DESCRIPTOR, ! address of caller's string/data descriptor
%fi
not %null (FILL), ! fill element indicator
$XPO$DEFAULT (FILL,0), ! fill value
$XPO$DEFAULT (SUCCESS,0), ! address of success action routine
$XPO$DEFAULT (FAILURE,0)) ! address of failure action routine
end %;
!
! XPORT Host System Services Macros
!
KEYWORDMACRO
$XPO_TERMINATE(
code=XPO$_TERMINATE ! termination completion code
) =
BEGIN
%EXPAND $xpo$force ($xpo$ex_routine (XPO$TERMINATE, NOVALUE))
XPO$TERMINATE (code); ! This routine will not return.
RETURN 0; ! This statement keeps the compiler happy.
END %;
!
! XPORT Put-Message Macros and Assorted Definitions
!
LITERAL ! XPO$MESSAGE severity codes:
XPO$_SUCCESS = 1, ! success
XPO$_WARNING = 0, ! warning
XPO$_ERROR = 2, ! error
XPO$_FATAL = 4, ! fatal error
XPO$_NO_SEV = -1; ! no severity code specified
$LITERAL ! XPO$MESSAGE message type codes:
XPO$K_PUT_COD = $DISTINCT, ! CODE=
XPO$K_PUT_STR = $DISTINCT; ! STRING=
MACRO
$XPO_PUT_MSG (key_parameter) =
BEGIN
COMPILETIME
$xpo$desc_count = 0, ! number of local descriptors needed
$xpo$desc_index = 0, ! local descriptor index
$xpo$sev_flag = 0, ! SEVERITY= parameter indicator
$xpo$succ_flag = 0, ! SUCCESS= parameter indicator
$xpo$fail_flag = 0; ! FAILURE= parameter indicator
$XPO$PUT_COUNT (key_parameter, %REMAINING) ! Count the number of local descriptors needed.
LOCAL
$xpo$local_desc : BLOCKVECTOR[$xpo$desc_count,STR$K_F_BLN];
%EXPAND $xpo$force ($xpo$ex_routine (XPO$MESSAGE, FORTRAN_FUNC)) ! FORTRAN_FUNC linkage permits
! variable length argument list
%EXPAND $xpo$force ($xpo$ex_routine (XPO$FAILURE)) ! The default failure action routine may be needed.
%EXPAND $xpo$force ($xpo$ex_routine (XPO$PM_FAILURE)) ! The optional failure action routine may be needed.
XPO$MESSAGE( ! Call XPORT message output routine
! Generate the following fixed arguments:
$XPO$PUT_FIXED (1, key_parameter, %REMAINING) ! severity code
$XPO$PUT_FIXED (2, key_parameter, %REMAINING) ! address of success action routine
$XPO$PUT_FIXED (3, key_parameter, %REMAINING) ! address of failure action routine
$XPO$PUT_PARM (key_parameter, %REMAINING) ! Generate "n" keyword argument pairs
) ! Trailing right parenthesis
END %,
$XPO$PUT_COUNT (parameter) [] = ! Count number of local descriptors needed
$XPO$$PUT_COUNT (parameter)
$XPO$PUT_COUNT (%REMAINING) %,
$XPO$PUT_FIXED (number, parameter) [] = ! Generated required arguments
$XPO$$PUT_PARM (ARGUMENT=number, parameter)
%IF NOT %NULL(%REMAINING)
%THEN
$XPO$PUT_FIXED (number, %REMAINING)
%ELSE
%IF number EQL 1 AND NOT $xpo$sev_flag
%THEN
XPO$_NO_SEV,
%ELSE %IF number EQL 2 AND NOT $xpo$succ_flag
%THEN
0,
%ELSE %IF number EQL 3 AND NOT $xpo$fail_flag
%THEN
XPO$FAILURE
%FI %FI %FI
%FI %,
$XPO$PUT_PARM (parameter) [] = ! Generate an argument pair
$XPO$$PUT_PARM (ARGUMENT=0, parameter)
$XPO$PUT_PARM (%REMAINING) %;
KEYWORDMACRO
$XPO$$PUT_COUNT( ! Count number of local descriptors needed
severity, ! message severity code
success, ! address of success action routine
failure, ! address of failure action routine
code, ! message code
string ! string descriptor
) =
%IF %ISSTRING (%REMOVE(string)) OR $xpo$paren_test(string)
%THEN
%ASSIGN ($xpo$desc_count, $xpo$desc_count + 1)
%FI %,
$XPO$$PUT_PARM( ! Keyword argument decoder
argument, ! positional argument indicator
severity, ! message severity code
success, ! address of success action routine
failure, ! address of failure action routine
code, ! message code
string ! string descriptor
) =
%IF argument EQL 1
%THEN
%IF %NULL(severity)
%THEN
%EXITMACRO
%FI
%IF NOT $xpo$sev_flag
%THEN
%IF $xpo$key_test (severity, (%QUOTE SUCCESS,WARNING,ERROR,FATAL), 'SEVERITY=')
%THEN
%NAME ('XPO$_', severity),
%FI
%ASSIGN ($xpo$sev_flag, 1)
%ELSE
%WARN ('Extraneous SEVERITY= parameter ignored')
%FI
%EXITMACRO
%FI
%IF argument EQL 2
%THEN
%IF %NULL(success)
%THEN
%EXITMACRO
%FI
%IF NOT $xpo$succ_flag
%THEN
success,
%ASSIGN ($xpo$succ_flag, 1)
%ELSE
%WARN ('Extraneous SUCCESS= parameter ignored')
%FI
%EXITMACRO
%FI
%IF argument EQL 3
%THEN
%IF %NULL(failure)
%THEN
%EXITMACRO
%FI
%IF NOT $xpo$fail_flag
%THEN
failure
%ASSIGN ($xpo$fail_flag, 1)
%ELSE
%WARN ('Extraneous FAILURE= parameter ignored')
%FI
%EXITMACRO
%FI
%IF NOT %NULL(code)
%THEN
, XPO$K_PUT_COD, code
%EXITMACRO
%FI
%IF NOT %NULL(string)
%THEN
, XPO$K_PUT_STR, ! generate string element code
BEGIN
$str$declare (LOCAL, $put$string, string)
$str$local_init ($put$string, string)
$put$string
END
%FI %;
!
! String Handling Option Block
!
! NOTE: Do not change the overall format of this option block without carefully checking
! the compiletime creation of this block in all string handling macros. For example,
! these macros all assume that the option block fits in a single BLISS value
! (even for BLISS-16) and that the function code field is at the beginning of the block.
$FIELD $str$opt_fields = SET
STR$V_OPTIONS = [$BITS(16)] ,
$OVERLAY (STR$V_OPTIONS)
$str$v_option1 = [$BITS(8)] ,
$str$v_option2 = [$BITS(8)] ,
$OVERLAY ($str$v_option1)
STR$V_FUNCTION = [$BITS(8)] , ! $ASCII, $STR_BINARY, $STR_SCAN function code
$OVERLAY ($str$v_option1) ! $FORMAT options:
STR$V_LEFT_JUST = [$BIT] , ! LEFT_JUSTIFY
STR$V_RIGHT_JUS = [$BIT] , ! RIGHT_JUSTIFY
STR$V_CENTER = [$BIT] , ! CENTER
$OVERLAY ($str$v_option2) ! Common string function options:
STR$V_SIGNED = [$BIT] , ! SIGNED
STR$V_UNSIGNED = [$BIT] , ! UNSIGNED
STR$V_LEADING_Z = [$BIT] , ! LEADING_ZERO
STR$V_LEADING_B = [$BIT] , ! LEADING_BLANK
STR$V_UP_CASE = [$BIT] , ! UP_CASE
STR$V_TRUNCATE = [$BIT] , ! TRUNCATE
STR$V_NO_FREE_T = [$BIT] , ! don't free temporary string - internal XPORT use only
$OVERLAY ($str$v_option2) ! $STR_SCAN options:
STR$V_REMAINDER = [$BIT] , ! REMAINDER=
STR$V_TARGET = [$BIT] ! TARGET=
TES;
LITERAL
$xpo$mask_set (STR$V_, OPTIONS, ! Define masks for option bits
LEFT_JUST, RIGHT_JUS, CENTER,
SIGNED, UNSIGNED, LEADING_Z, LEADING_B, UP_CASE, TRUNCATE, NO_FREE_T,
REMAINDER, TARGET);
MACRO
$STR_OPTIONS =
BLOCK[] FIELD ($str$opt_fields) %,
$str$opt_init =
%IF %DECLARED ($XPO$INTERNAL)
%THEN
STR$M_NO_FREE_T
%ELSE
0
%FI %;
!
! String Comparison Functions
!
! $STR_EQL, $STR_NEQ, $STR_LSS, $STR_LEQ, $STR_GEQ, $STR_GTR, $STR_COMPARE
!
KEYWORDMACRO
$STR_EQL (string1, string2, fill, success, failure = STR$FAILURE) =
%EXPAND $xpo$required (string1, 'STRING1=')
%EXPAND $xpo$required (string2, 'STRING2=')
$str$compare (STR$EQL, string1, string2, fill, success, failure) %,
$STR_NEQ (string1, string2, fill, success, failure = STR$FAILURE) =
%EXPAND $xpo$required (string1, 'STRING1=')
%EXPAND $xpo$required (string2, 'STRING2=')
$str$compare (STR$NEQ, string1, string2, fill, success, failure) %,
$STR_LSS (string1, string2, fill, success, failure = STR$FAILURE) =
%EXPAND $xpo$required (string1, 'STRING1=')
%EXPAND $xpo$required (string2, 'STRING2=')
$str$compare (STR$LSS, string1, string2, fill, success, failure) %,
$STR_LEQ (string1, string2, fill, success, failure = STR$FAILURE) =
%EXPAND $xpo$required (string1, 'STRING1=')
%EXPAND $xpo$required (string2, 'STRING2=')
$str$compare (STR$LEQ, string1, string2, fill, success, failure) %,
$STR_GEQ (string1, string2, fill, success, failure = STR$FAILURE) =
%EXPAND $xpo$required (string1, 'STRING1=')
%EXPAND $xpo$required (string2, 'STRING2=')
$str$compare (STR$GEQ, string1, string2, fill, success, failure) %,
$STR_GTR (string1, string2, fill, success, failure = STR$FAILURE) =
%EXPAND $xpo$required (string1, 'STRING1=')
%EXPAND $xpo$required (string2, 'STRING2=')
$str$compare (STR$GTR, string1, string2, fill, success, failure) %,
$STR_COMPARE (string1, string2, fill, success, failure = STR$FAILURE) =
%EXPAND $xpo$required (string1, 'STRING1=')
%EXPAND $xpo$required (string2, 'STRING2=')
$str$compare (STR$CMP, string1, string2, fill, success, failure) %;
MACRO
$str$compare (routine_name, string1, string2, fill, success, failure) =
BEGIN
%EXPAND $xpo$ex_routine (routine_name)
%EXPAND $xpo$ex_failure (failure)
%EXPAND $str$declare (LOCAL, $str$string1, string1)
%EXPAND $str$declare (LOCAL, $str$string2, string2)
%EXPAND $str$local_init ($str$string1, string1)
%EXPAND $str$local_init ($str$string2, string2)
routine_name (%EXPAND $str$opt_init,
$str$string1,
$str$string2,
$xpo$default (fill, -1),
$xpo$default (success, 0),
$xpo$default (failure, 0))
END %;
!
! String Modification Functions
!
! $STR_COPY, $STR_APPEND
!
KEYWORDMACRO
$STR_COPY(
string, ! string descriptor
target, ! target buffer descriptor
option, ! option keyword
options, ! options keyword list
success, ! address of success action routine
failure = STR$FAILURE ! address of failure action routine
) =
%EXPAND $xpo$required (string, 'STRING=')
%EXPAND $xpo$required (target, 'TARGET=')
%IF %ISSTRING (%REMOVE(target))
%THEN
%WARN ('TARGET=literal-string is not permitted')
%FI
%IF %EXPAND $xpo$conflict (option, options)
%THEN
%WARN ('OPTION= and OPTIONS= are mutually exclusive')
%FI
%ASSIGN ($str$options, %EXPAND $str$opt_init)
$str$copy_opt (option %REMOVE(options))
BEGIN
%EXPAND $xpo$force ($xpo$ex_routine (STR$COPY))
%EXPAND $xpo$ex_failure (failure)
%EXPAND $str$declare (LOCAL, $str$string, string)
%EXPAND $str$declare (LOCAL, $str$target, target)
%EXPAND $str$local_init ($str$string, string)
%EXPAND $str$local_init ($str$target, target)
STR$COPY (%NUMBER ($str$options),
$str$string,
$str$target,
$xpo$default (success, 0),
$xpo$default (failure, 0))
END %,
$STR_APPEND(
string, ! string descriptor
target, ! target buffer descriptor
option, ! option keyword
options, ! options keyword list
success, ! address of success action routine
failure = STR$FAILURE ! address of failure action routine
) =
%EXPAND $xpo$required (string, 'STRING=')
%EXPAND $xpo$required (target, 'TARGET=')
%IF %ISSTRING (%REMOVE(target))
%THEN
%WARN ('TARGET=literal-string is not permitted')
%FI
%IF $xpo$paren_test (target) AND NOT %ISSTRING (%REMOVE(target))
%THEN
%WARN ('TARGET=(length,pointer) is not permitted')
%FI
%IF %EXPAND $xpo$conflict (option, options)
%THEN
%WARN ('OPTION= and OPTIONS= are mutually exclusive')
%FI
%ASSIGN ($str$options, %EXPAND $str$opt_init)
$str$copy_opt (option %REMOVE(options))
BEGIN
%EXPAND $xpo$force ($xpo$ex_routine (STR$APPEND))
%EXPAND $xpo$ex_failure (failure)
%EXPAND $str$declare (LOCAL, $str$string, string)
%EXPAND $str$local_init ($str$string, string)
STR$APPEND (%NUMBER ($str$options),
$str$string,
target,
$xpo$default (success, 0),
$xpo$default (failure, 0))
END %;
MACRO
$str$copy_opt (option) [] =
%IF NOT $xpo$key_test (option, (UP_CASE, TRUNCATE), 'OPTIONS=')
%THEN
%EXITMACRO
%FI
%ASSIGN ($str$options, $str$options + $xpo$name15 ('STR$M_', option))
$str$copy_opt (%REMAINING) %;
!
! ASCII-to-ASCII String Conversion Functions
!
! $CONCAT, $FORMAT
!
! Binary-to-ASCII String Conversion Function
!
! $ASCII
!
$LITERAL ! $ASCII and $STR_BINARY function codes:
STR$K_DFLT_FUNC = 0, ! default function
STR$K_BASE2 = $DISTINCT, ! $ASCII (value, BASE2)
STR$K_BASE8 = $DISTINCT, ! $ASCII (value, BASE8)
STR$K_BASE10 = $DISTINCT, ! $ASCII (value, BASE10)
STR$K_BASE16 = $DISTINCT, ! $ASCII (value, BASE16)
STR$K_DATE = $DISTINCT, ! $ASCII (value, DATE)
STR$K_TIME = $DISTINCT, ! $ASCII (value, TIME)
STR$K_DAY = $DISTINCT; ! $ASCII (value, DAY)
COMPILETIME
$str$function = 0, ! string function code
$str$options = 0, ! string processing options
$str$length = 0; ! string field length indicator
MACRO
$CONCAT [] =
BEGIN
%EXPAND $xpo$force ($xpo$ex_routine (STR$JOIN, FORTRAN_FUNC))
$str$con_decl (%REMAINING)
$str$con_init (%REMAINING)
STR$JOIN ($str$con_args (%REMAINING))
END %,
$str$con_decl (string_info) [] =
$str$declare (LOCAL, %NAME(%STRING('$str$string',%COUNT)), string_info)
$str$con_decl (%REMAINING) %,
$str$con_init (string_info) [] =
$str$local_init (%NAME(%STRING('$str$string',%COUNT)), string_info)
$str$con_init (%REMAINING) %,
$str$con_args (string_info) [] =
%IF %COUNT NEQ 0 %THEN, %FI
%NAME(%STRING('$str$string',%COUNT))
$str$con_args (%REMAINING) %,
$FORMAT (string) =
%ASSIGN ($str$options, %EXPAND $str$opt_init)
%ASSIGN ($str$length, 0)
$str$format_opt (%REMAINING) ! Scan the $FORMAT option parameters
BEGIN
%EXPAND $xpo$force ($xpo$ex_routine (STR$FORMAT))
%EXPAND $str$declare (LOCAL, $str$string, string)
%EXPAND $str$local_init ($str$string, string)
STR$FORMAT (%NUMBER ($str$options),
$str$string,
$str$len_val(%REMAINING)
%IF NOT $str$length
%THEN
0
%FI)
END %,
$str$format_opt (option) [] =
%IF $xpo$key_check (option, (UP_CASE, LEFT_JUSTIFY, RIGHT_JUSTIFY, CENTER), 'Option')
%THEN
%ASSIGN ($str$options, $str$options OR $xpo$name15 ('STR$M_', option))
%ELSE
$str$format_key (option)
%FI
$str$format_opt (%REMAINING) %;
KEYWORDMACRO
$str$format_key (length) = %;
MACRO
$ASCII (value) =
%ASSIGN ($str$function, STR$K_BASE10)
%ASSIGN ($str$options, %EXPAND $str$opt_init)
%ASSIGN ($str$length, 0)
$str$ascii_opt (%REMAINING) ! Scan the $ASCII option parameters
%IF ($str$options AND (STR$M_LEADING_B OR STR$M_LEADING_Z)) EQL 0
%THEN
%IF $str$function EQL STR$K_BASE10
%THEN
%ASSIGN ($str$options, $str$options OR STR$M_LEADING_B)
%ELSE
%ASSIGN ($str$options, $str$options OR STR$M_LEADING_Z)
%FI
%FI
%IF ($str$options AND (STR$M_SIGNED OR STR$M_UNSIGNED)) EQL 0
%THEN
%IF $str$function EQL STR$K_BASE10
%THEN
%ASSIGN ($str$options, $str$options OR STR$M_SIGNED)
%ELSE
%ASSIGN ($str$options, $str$options OR STR$M_UNSIGNED)
%FI
%FI
BEGIN
%EXPAND $xpo$force ($xpo$ex_routine (STR$ASCII))
STR$ASCII (%NUMBER ($str$options) + %NUMBER ($str$function),
value,
$str$len_val(%REMAINING)
%IF NOT $str$length
%THEN
0
%FI)
END %,
$str$ascii_opt (option) [] =
%IF $xpo$key_check (option, (BASE2, BASE8, BASE10, BASE16,
SIGNED, UNSIGNED,
LEADING_BLANK, LEADING_ZERO,
DATE, TIME, DAY))
%THEN
%IF $xpo$key_check (option, (BASE2, BASE8, BASE10, BASE16, DATE, TIME, DAY))
%THEN
%ASSIGN ($str$function, $xpo$name15 ('STR$K_', option))
%ELSE
%ASSIGN ($str$options, $str$options OR $xpo$name15 ('STR$M_', option))
%FI
%ELSE
$str$ascii_key (option)
%FI
$str$ascii_opt (%REMAINING) %;
KEYWORDMACRO
$str$ascii_key (length) = %;
MACRO
$str$len_val (parameter) [] =
%IF NOT $xpo$key_check (parameter, (BASE2, BASE8, BASE10, BASE16, DATE, TIME, DAY,
SIGNED, UNSIGNED, LEADING_ZERO, LEADING_BLANK, UP_CASE,
LEFT_JUSTIFY, RIGHT_JUSTIFY, CENTER))
%THEN
$str$$len_val (parameter)
%FI
$str$len_val (%REMAINING) %;
KEYWORDMACRO
$str$$len_val (length) =
%IF NOT %NULL (length)
%THEN
%IF $str$length
%THEN
%WARN ('Only one LENGTH= parameter permitted')
%ELSE
length
%ASSIGN ($str$length, 1)
%FI
%FI %;
!
! ASCII-to-binary String Conversion Function
!
! $STR_BINARY
!
COMPILETIME
$str$int_result = 0; ! Integer result indicator
! $STR_BINARY function codes:
! see $ASCII functions codes
KEYWORDMACRO
$STR_BINARY (string, result, option, options, range, success, failure = STR$FAILURE) =
%EXPAND $xpo$required (string, 'STRING=')
%IF %EXPAND $xpo$conflict (option, options)
%THEN
%WARN ('OPTION= and OPTIONS= are mutually exclusive')
%EXITMACRO
%FI
%ASSIGN ($str$function, STR$K_DFLT_FUNC)
$str$binary_opt (option %REMOVE(options))
%IF NOT %NULL(result) AND $str$function LEQ STR$K_BASE16
%THEN
%ASSIGN ($str$int_result, 1)
%ELSE
%ASSIGN ($str$int_result, 0)
%FI
BEGIN
%EXPAND $xpo$force ($xpo$ex_routine (STR$BINARY))
%EXPAND $xpo$ex_failure (failure)
%IF $str$int_result
%THEN
LOCAL
$str$result,
$str$status;
%FI
%EXPAND $str$declare (LOCAL, $str$string, string)
%EXPAND $str$local_init ($str$string, string)
%IF $str$int_result
%THEN
$str$status =
%FI
STR$BINARY (%EXPAND $str$opt_init + %NUMBER ($str$function),
$str$string,
%IF $str$int_result
%THEN
$str$result,
%ELSE
$xpo$default (result, 0),
%FI
%IF %NULL (range)
%THEN
0, 0,
%ELSE
$xpo$arg1 (%REMOVE (range)),
$xpo$arg2 (%REMOVE (range)),
%FI
$xpo$default (success, 0),
$xpo$default (failure, 0))
%IF $str$int_result
%THEN
;
IF .$str$status
THEN
result = .$str$result;
.$str$status
%FI
END %;
MACRO
$str$binary_opt (option) [] =
%IF NOT $xpo$key_test (option, (BASE2, BASE8, BASE10, BASE16, DATE, TIME), 'OPTIONS=')
%THEN
%EXITMACRO
%FI
%IF $str$function NEQ STR$K_DFLT_FUNC
%THEN
%WARN ('Conflicting conversion options')
%EXITMACRO
%FI
%ASSIGN ($str$function, $xpo$name15 ('STR$K_', option))
$str$binary_opt (%REMAINING) %;
!
! String Scanning Functions
!
! $STR_SCAN (FIND = sub-string, ...)
! $STR_SCAN (SPAN = characters, ...)
! $STR_SCAN (STOP = characters, ...)
!
$LITERAL ! String scanning function codes:
STR$K_FIND = $DISTINCT, ! find sub-string
STR$K_SPAN = $DISTINCT, ! match specified characters
STR$K_STOP = $DISTINCT; ! search for specified characters
KEYWORDMACRO
$STR_SCAN (string, remainder, find, span, stop, option, options,
substring, target, delimiter, success, failure = STR$FAILURE) =
%EXPAND $xpo$required (string remainder, 'STRING= or REMAINDER=')
%EXPAND $xpo$required (find span stop, 'FIND=, SPAN= or STOP=')
%IF %EXPAND $xpo$conflict (string, remainder)
%THEN
%WARN ('STRING= and REMAINDER= are mutually exclusive')
%EXITMACRO
%FI
%IF %EXPAND $xpo$conflict (find, span, stop)
%THEN
%WARN ('FIND=, SPAN= and STOP= are mutually exclusive')
%EXITMACRO
%FI
%IF %EXPAND $xpo$conflict (option, options)
%THEN
%WARN ('OPTION= and OPTIONS= are mutually exclusive')
%EXITMACRO
%FI
%IF %EXPAND $xpo$conflict (substring, target)
%THEN
%WARN ('SUBSTRING= and TARGET= are mutually exclusive')
%EXITMACRO
%FI
%ASSIGN ($str$options, %EXPAND $str$opt_init)
%IF NOT %NULL (remainder)
%THEN
%ASSIGN ($str$options, $str$options OR STR$M_REMAINDER)
%FI
%IF NOT %NULL (find)
%THEN
%ASSIGN ($str$function, STR$K_FIND)
%ELSE %IF NOT %NULL (span)
%THEN
%ASSIGN ($str$function, STR$K_SPAN)
%ELSE
%ASSIGN ($str$function, STR$K_STOP)
%FI %FI
%IF NOT %NULL (target)
%THEN
%ASSIGN ($str$options, $str$options OR STR$M_TARGET)
%FI
BEGIN
%EXPAND $xpo$force ($xpo$ex_routine (STR$SCAN))
%EXPAND $xpo$ex_failure (failure)
%IF NOT %NULL (delimiter)
%THEN
LOCAL $str$status,
$str$delimiter;
%ELSE
LITERAL $str$delimiter = 0;
%FI
$str$declare (LOCAL, $str$string, string remainder)
$str$declare (LOCAL, $str$pattern, find span stop)
$str$local_init ($str$string, string remainder)
$str$local_init ($str$pattern, find span stop)
%IF NOT %NULL (delimiter)
%THEN
$str$status =
%FI
STR$SCAN (%NUMBER ($str$options) + %NUMBER ($str$function),
$str$string,
$str$pattern,
$xpo$default (substring target, 0),
$str$delimiter,
$xpo$default (success, 0),
$xpo$default (failure, 0))
%IF NOT %NULL (delimiter)
%THEN
;
IF .$str$status
THEN
delimiter = .$str$delimiter;
.$str$status
%FI
END %;
!
! XPORT Completion Code Definitions
!
%IF %BLISS(BLISS32) %THEN
LITERAL
XPO$K_VMS_CODE = 32, ! VAX/VMS facility code for XPORT
$xpo$k_msg_code = 32^16 + 1^15, ! VAX/VMS message code for XPORT
STR$K_VMS_CODE = 36, ! VAX/VMS facility code for XPORT String Package
$str$k_msg_code = 36^16 + 1^15; ! VAX/VMS message code for XPORT String Package
%FI
COMPILETIME ! Initialize completion code variables
$xpo$ok_val = XPO$_SUCCESS %BLISS32 (+ $xpo$k_msg_code),
$xpo$warn_val = XPO$_WARNING + %X'1000' %BLISS32 (+ $xpo$k_msg_code),
$xpo$error_val = XPO$_ERROR + %X'2000' %BLISS32 (+ $xpo$k_msg_code),
$xpo$fatal_val = XPO$_FATAL + %X'4000' %BLISS32 (+ $xpo$k_msg_code),
$str$ok_val = XPO$_SUCCESS + %X'0800' %BLISS32 (+ $str$k_msg_code),
$str$warn_val = XPO$_WARNING + %X'1800' %BLISS32 (+ $str$k_msg_code),
$str$error_val = XPO$_ERROR + %X'2800' %BLISS32 (+ $str$k_msg_code),
$str$fatal_val = XPO$_FATAL + %X'4800' %BLISS32 (+ $str$k_msg_code);
KEYWORDMACRO
$XPO_COMP_CODES (success, warning, error, fatal) =
LITERAL $xpo$comp_def ($xpo$ok_val, %REMOVE(success));
LITERAL $xpo$comp_def ($xpo$warn_val, %REMOVE(warning));
LITERAL $xpo$comp_def ($xpo$error_val, %REMOVE(error));
LITERAL $xpo$comp_def ($xpo$fatal_val, %REMOVE(fatal)); %,
$STR_COMP_CODES (success, warning, error, fatal) =
LITERAL $str$comp_def ($str$ok_val, %REMOVE(success));
! LITERAL $str$comp_def ($str$warn_val, %REMOVE(warning));
LITERAL $str$comp_def ($str$error_val, %REMOVE(error));
LITERAL $str$comp_def ($str$fatal_val, %REMOVE(fatal)); %;
MACRO
$xpo$comp_def (code_value) [ code_name ] =
%NAME ('XPO$_', $xpo$arg1(%REMOVE(code_name))) = code_value
%IF $xpo$show_lit
%THEN
%PRINT (' XPO$_', $xpo$arg1(%REMOVE(code_name)), ' = ',
%NUMBER(code_value), ' (',
%IF %BLISS(BLISS32)
%THEN
'%X''' $XPO$SHOW_NUMB(code_value,16)
%ELSE
'%O''' $XPO$SHOW_NUMB(code_value,8)
%FI
, ''')')
%FI
%ASSIGN (code_value, code_value + 8) %,
$str$comp_def (code_value) [ code_name ] =
%NAME ('STR$_', $xpo$arg1(%REMOVE(code_name))) = code_value
%IF $xpo$show_lit
%THEN
%PRINT (' STR$_', $xpo$arg1(%REMOVE(code_name)), ' = ',
%NUMBER(code_value), ' (',
%IF %BLISS(BLISS32)
%THEN
'%X''' $XPO$SHOW_NUMB(code_value,16)
%ELSE
'%O''' $XPO$SHOW_NUMB(code_value,8)
%FI
, ''')')
%FI
%ASSIGN (code_value, code_value + 8) %,
$XPO_OK_CODE =
(NORMAL, 'normal completion'),
(CREATED, 'file was successfully created and opened'),
(INCOMPLETE, 'incomplete amount of data read'),
(NEW_FILE, 'first read on concatenated file was successful'),
(NEW_PAGE, 'first read on a new page was successful') %,
$STR_OK_CODE =
(END_STRING, 'end of string reached'),
(TRUNCATED, 'string was truncated'),
(NOT_TEMP, 'not a temporary string') %,
$XPO_WARN_CODE =
(END_FILE, 'end-of-file has been reached') %,
$STR_WARN_CODE = %,
$XPO_ERROR_CODE =
(BAD_ADDR, 'invalid memory address'),
(BAD_ALIGN, 'memory element not on a fullword boundary'),
(BAD_ARGS, 'invalid argument list'),
(BAD_CONCAT, 'invalid concatenated file specification'),
(BAD_DELIM, 'invalid punctuation'),
(BAD_DESC, 'invalid descriptor'),
(BAD_DEVICE, 'invalid device'),
(BAD_DFLT, 'invalid default file specification'),
(BAD_DIRECT, 'invalid directory'),
(BAD_DTYPE, 'invalid data type'),
(BAD_FORMAT, 'invalid record format'),
(BAD_IO_OPT, 'invalid I/O option'),
(BAD_LENGTH, 'invalid length'),
(BAD_NAME, 'invalid file name'),
(BAD_NEW, 'invalid new file'),
(BAD_NODE, 'invalid node'),
(BAD_ORG, 'invalid file organization'),
(BAD_PROMPT, 'invalid prompt'),
(BAD_RECORD, 'invalid record'),
(BAD_REQ, 'invalid request'),
(BAD_RLTD, 'invalid related file specification'),
(BAD_RSLT, 'invalid resultant file specification'),
(BAD_SPEC, 'invalid file specification'),
(BAD_TYPE, 'invalid file type'),
(BAD_VER, 'invalid file version'),
(CHANNEL, 'I/O channel assignment error'),
(CLOSED, 'file is already closed'),
(CONFLICT, 'conflicting options or attributes'),
(CORRUPTED, 'file is corrupted'),
(EXISTS, 'file already exists'),
(FILE_LOCK, 'file is locked'),
(FREE_MEM, 'dynamic memory deallocation error'),
(GET_MEM, 'dynamic memory allocation error'),
(IN_USE, 'file is currently in use'),
(IO_BUFFER, 'I/O buffering error'),
(IO_ERROR, 'I/O error'),
(MISSING, 'required parameter, option or attribute missing'),
(NETWORK, 'network error'),
(NO_ACCESS, 'file cannot be accessed'),
(NO_BACKUP, 'file cannot be backed up'),
(NO_CHANNEL, 'all I/O channels are in use'),
(NO_CLOSE, 'file cannot be closed'),
(NO_CONCAT, 'concatenated file specification not allowed'),
(NO_CREATE, 'file cannot be created'),
(NO_DELETE, 'file cannot be deleted'),
(NO_DIRECT, 'directory does not exist'),
(NO_FILE, 'file does not exist'),
(NO_MEMORY, 'insufficient dynamic memory'),
(NO_OPEN, 'file cannot be opened'),
(NO_READ, 'file cannot be read'),
(NO_RENAME, 'file cannot be renamed'),
(NO_SPACE, 'insufficient space'),
(NO_SUBDIR, 'sub-directory does not exist'),
(NO_SUPPORT, 'requested function not supported'),
(NO_WRITE, 'file cannot be written'),
(NOT_CLOSED, 'file has not been closed'),
(NOT_EXPIRE, 'expiration date has not been reached'),
(NOT_INPUT, 'file is not open for input'),
(NOT_ONLINE, 'device is not online'),
(NOT_OPEN, 'file has not been opened'),
(NOT_OUTPUT, 'file is not open for output'),
(OPEN, 'file is currently open'),
(PREV_ERROR, 'program terminated due to previous error'),
(PRIVILEGED, 'privileged operation'),
(PROTECTED, 'file protection denies access'),
(PUT_MSG, 'message output error'),
(REC_LOCK, 'record is locked'),
(RENAME_NEW, 'new file cannot be renamed'),
(RENAME_OLD, 'old file cannot be renamed'),
(TRUNCATED, 'record was truncated'),
(WILDCARD, 'wildcard error'),
(BAD_ACCT, 'invalid account attribute'),
(BAD_ATTR, 'invalid attribute'),
(BAD_DATA, 'invalid data'),
(BAD_MEDIA, 'disk/tape cannot be read/written'),
(BAD_MEMORY, 'free storage chain is invalid'),
(BAD_PROT, 'invalid protection attribute'),
(BAD_PTR, 'invalid character pointer'),
(BAD_RECNUM, 'invalid record number'),
(BAD_SIZE, 'invalid size'),
(BAD_TEMP, 'invalid temporary file attribute'),
(CHAN_USED, 'I/O channel is currently in use'),
(HOST_ERROR, 'host operating system error'),
(NO_NODE, 'network node does not exist'),
(NO_STACK, 'insufficient stack space'),
(SYS_ERROR, 'unexpected operating system error'),
(BAD_CLASS, 'invalid descriptor class'),
(NO_TEMP, 'temporary file not permitted'),
(FOREGROUND, 'foreground jobs not permitted'),
(NO_APPEND, 'append function not permitted'),
(NO_SEQ, 'sequenced files not permitted') %,
$STR_ERROR_CODE =
(BAD_CHAR, 'invalid character'),
(BAD_CLASS, 'invalid descriptor class'),
(BAD_DESC, 'invalid string descriptor'),
(BAD_DTYPE, 'invalid descriptor data type'),
(BAD_LENGTH, 'invalid string length'),
(BAD_MAXLEN, 'invalid maximum string length'),
(BAD_PATTRN, 'invalid pattern string'),
(BAD_PTR, 'invalid string pointer'),
(BAD_REQ, 'invalid string request'),
(BAD_SOURCE, 'invalid source string'),
(BAD_STRNG1, 'invalid primary string'),
(BAD_STRNG2, 'invalid secondary string'),
(BAD_TARGET, 'invalid target string'),
(CONFLICT, 'conflicting string function arguments'),
(NO_SPACE, 'insufficient space'),
(NO_STRING, 'no string specified'),
(NO_SUPPORT, 'requested function not supported'),
(NO_TEMP, 'temporary string not permitted'),
(NULL_STRNG, 'null string not permitted'),
(OUT_RANGE, 'integer value out of range') %,
$XPO_FATAL_CODE =
(BAD_IOB, 'invalid IOB'),
(BAD_LOGIC, 'XPORT logic error detected'),
(TERMINATE, 'program terminated due to program request') %,
$STR_FATAL_CODE =
(BAD_LOGIC, 'XPORT string logic error detected') %;
LITERAL ! Define special XPORT string completion codes
STR$_NORMAL = 1,
STR$_FAILURE = 0;
$XPO_COMP_CODES( ! Define all XPORT completion codes
SUCCESS = ($XPO_OK_CODE),
WARNING = ($XPO_WARN_CODE),
ERROR = ($XPO_ERROR_CODE),
FATAL = ($XPO_FATAL_CODE))
$STR_COMP_CODES( ! Define all XPORT string completion codes
SUCCESS = ($STR_OK_CODE),
WARNING = ($STR_WARN_CODE),
ERROR = ($STR_ERROR_CODE),
FATAL = ($STR_FATAL_CODE))
$LITERAL ! XPORT action routine function codes:
XPO$K_IO = $DISTINCT, ! I/O
XPO$K_PARSE = $DISTINCT, ! PARSE_SPEC
XPO$K_GET_MEM = $DISTINCT, ! GET_MEMORY
XPO$K_FREE_MEM = $DISTINCT, ! FREE_MEMORY
XPO$K_PUT_MSG = $DISTINCT; ! PUT_MSG
$LITERAL ! XPORT String Package action routine function codes:
STR$K_COMPARE = $DISTINCT, ! string comparison functions
STR$K_COPY = $DISTINCT, ! $STR_COPY
STR$K_APPEND = $DISTINCT, ! $STR_APPEND
STR$K_SCAN = $DISTINCT, ! $STR_SCAN
STR$K_BINARY = $DISTINCT, ! $STR_BINARY
STR$K_PSEUDO = $DISTINCT; ! $ASCII, $CONCAT, $FORMAT (no action routine called)
!
! VAX/VMS-specific Definitions
!
%IF %BLISS(BLISS32) %THEN
MACRO
CLI$_SYNTAX =
SHR$_SYNTAX + 3^16 %, ! CLI-W-SYNTAX error message number
$XPO_CALL_CLI (descriptor, work_area, extra_argument) =
BEGIN
EXTERNAL ROUTINE SYS$CLI : ADDRESSING_MODE (GENERAL);
SYS$CLI (descriptor, work_area, extra_argument)
END %,
$XPO_KEY_TABLE (entry) =
VECTOR[ %LENGTH*2 + 1 ]
INITIAL (%LENGTH*2
$XPO$KEY_TABLE (entry, %REMAINING)
) %,
$XPO$KEY_TABLE (entry) [] =
$XPO$KEY_ENTRY (%REMOVE(entry))
$XPO$KEY_TABLE (%REMAINING) %,
$XPO$KEY_ENTRY (keyword, value) =
, UPLIT (%STRING (%CHAR(%CHARCOUNT(keyword)), keyword))
, value %;
%FI
$SHOW (NONE, INFO)
! Local Modes:
! Mode:BLISS
! Auto Save Mode:2
! Comment Column:40
! Comment Rounding:+1
! End: