Trailing-Edge
-
PDP-10 Archives
-
SRI_NIC_PERM_SRC_1_19910112
-
6-1/language-sources/dixlib.bli
There are 21 other files named dixlib.bli in the archive. Click here to see a list.
%TITLE 'Library of definitions for the DIX'
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983, 1985.
! ALL RIGHTS RESERVED.
!
! 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 THAT IS NOT SUPPLIED BY DIGITAL.
!++
! .Chapter DIXLIB
! The module DIXLIB defines global data structures and code values for
! the DIX package.
!
! This was done for two reasons: The obvious one of isolating such
! definitions to one module, and a secondary one. The secondary reason
! is that, by placing code value definitions in a library file, it is
! possible to write programs which, by calling that library file, get
! lists of code values which they write out to files in various ways.
! This allows you to implement automatic generation of interface support
! files.
!--
!++
! .HL 1 Library files used
!--
%BLISS32 ( ! ; .P;If we're BLISS 32, then
LIBRARY 'SYS$LIBRARY:XPORT'; ! \\ and
LIBRARY 'SYS$LIBRARY:STARLET'; ! \\
)
%BLISS36 ( ! ; .p;If we're BLISS 36 then
LIBRARY 'BLI:XPORT'; ! \\ and
LIBRARY 'STAR36'; ! \\
)
! ; .P;In either case,
LIBRARY 'FIELDS'; ! \\
MACRO
blf$comma =
%; ! Hack to format $OVERLAY right
%sbttl 'Edit History' ! [7] Add this entire subsection
!++
! .hl 1 Edit History
!
! The edit history/version number information in this file is used
! to build a literal, dix$k_library_version, giving the full version
! information. The history modules that use this library make an OWN
! location called dix$g_library_version and initialize it to
! dix$k_library_version. This makes it possible to tell at debug time
! what version of the library was actually compiled against.
!--
LIBRARY 'VERSION';
! ; .autotable
!++ COPY
new_version (1, 0)
edit (7, '23-Aug-82', 'David Dyer-Bennet')
%( Change version and revision standards everywhere.
Files: All. )%
edit (8, '15-Sep-82', 'David Dyer-Bennet')
%( Definition of XCGEN as pseudonym for DIX$BY_DIX_DES was missing from
DIXLIB.
Files: DIXLIB.BLI )%
Edit (%O'26', '17-Jan-83', 'David Dyer-Bennet')
%( Change error message for DIX$_IMPOSSIBLE.
Files: DIXLIB.BLI
)%
Edit (%O'30', '19-Jan-83', 'David Dyer-Bennet')
%( Update copyright notices, add mark at end of edit histories.
)%
Edit (%O'35', '7-June-83', 'Charlotte L. Richardson')
%( Declare version 1 complete. All modules.
)%
new_version (1, 1)
new_version (2, 0)
Edit (%O'36', '11-Apr-84', 'Sandy Clemens')
%( Put all Version 2 DIX development files under edit control. Some of
the files listed below have major code edits, or are new modules. Others
have relatively minor changes, such as cleaning up a comment.
FILES: COMDIX.VAX-COM, COMPDX.CTL, DIXCST.BLI, DIXDEB.BLI,
DIXDN.BLI (NEW), DIXFBN.BLI, DIXFP.BLI, DIXGBL.BLI, DIXGEN.BLI,
DIXHST.BLI, DIXINT.PR1, DIXINT.PR2, DIXLIB.BLI, DIXPD.BLI (NEW),
DIXREQ.REQ, DIXSTR.BLI, DIXUTL.BLI, DXCM10.10-CTL, MAKDIXMSG.BLI,
STAR36.BLI, VERSION.REQ.
)%
Edit (%O'50', '8-Oct-84', 'Sandy Clemens')
%( Add new format of COPYRIGHT notice. FILES: ALL )%
! **EDIT**
!-- .autoparagraph
%BLISS36 (
MACRO
dix$k_library_version = %NAME ('lib%ve') %;
)
LITERAL
dix$k_library_version = version_number
(major = major_version,
minor = minor_version,
edit_no = edit_number);
UNDECLARE
major_version, minor_version, edit_number, sequence_check_edits;
%SBTTL 'Debugging Declarations'
!++
! .HL 1 Debugging Declarations
!
! There is extensive debugging code and many special definitions in
! the DIX code. All of it is conditional (at compiletime) on a literal.
! Further, if that literal is set, there are run-time variables
! defined in each module and routine that control whether any special
! debugging code actually executes. These may be poked with a debugger
! to give you dynamic control of debugging prints.
!
! >DIX$K_DEBUG controls compiletime generation of all this debugging
! code.
!
! >DIX$GG_DEBUG controls run-time debugging for the entire package.
! If this is false, no debugging prints or other code will execute.
!
! >MODULE_DEBUG (defined in each module) must be true for any debugging
! code in the module to execute. Note that, if DIX$GG_DEBUG is not true,
! the setting of MODULE_DEBUG is irrelevant.
!
! >ROUTINE_DEBUG (defined in each routine) must be true for any
! debugging code in the routine to execute. Note that, if DIX$GG_DEBUG or
! MODULE_DEBUG is not true, the setting of ROUTINE_DEBUG is irrelevant.
!
! >DEBUG_FLAG is dynamically bound at the start of each routine to
! be the logical AND of the above three flags. This is the flag that
! actual debugging code checks.
!--
!++
! The require file >DIXDEB.REQ does nothing but define a value for
! >dix$k_debug>, a literal. By doing the require within the library file,
! debugging/non-debugging becomes an attribute of the version of DIXLIB
! with which other modules are compiled.
!--
REQUIRE 'DIXDEB';
!++
! .hl 2 Debugging macros
!
! Described below are macros which help set up and use the debugging
! control fields:
!--
MACRO
DIX$DEBUG ! \.HL 3 >\
!++
! This macro expands to its arguments (%REMAINING) if
! dix$k_debug is true, to null otherwise.
!--
[] = ! ; This is a conditional macro with no arguements.
%IF dix$k_debug %THEN %REMAINING %FI %,
DIX$module_debug ! \.hl 3 >\
!++
! This macro defines MODULE_DEBUG as its argument. It should
! be called at the start of every module. It should not be followed
! by a semi-colon.
!
! Arguments:
!--
( ! ; .s 1.list 1
module_debug_flag ! \.le;\: True if debugging wanted
) = ! ; .end list
DIX$DEBUG (OWN module_debug: INITIAL (module_debug_flag) VOLATILE;
EXTERNAL dix$GG_debug;)
% ,
dix$routine_debug ! \.hl 3 >\
!++
! This macro defines ROUTINE_DEBUG as its argument. It should be
! called at the start of every routine. It should not be followed
! by a semi-colon.
!
! Arguments:
!--
( ! ; .s 1.list 1
routine_debug_flag ! \.le;\: True if debugging wanted
) = ! ; .end list
DIX$DEBUG (OWN routine_debug: INITIAL (routine_debug_flag);
BIND debug_flag = .DIX$GG_DEBUG AND .module_debug AND .routine_debug;
) %,
debug_code ! \.hl 3 >\
!++
! This macro expands to its arguments if dix$k_debug is set at
! compile time. It executes the code generated if debug_flag is
! set at run-time. Executable debugging code should be included
! within a call to debug-code.
!
! This macro expands to an expression that performs the indicated
! tasks. It may be used without bracketing in contexts where a
! single expression/statement is required. Where it is not being
! used as an expression, it should be followed by a semi-colon.
! This may result in null expressions when debugging is turned
! off at compiletime.
!--
[] = ! ; This is a conditional macro with no arguements.
dix$debug (IF debug_flag THEN BEGIN %REMAINING END) % ;
!++
! .HL 2 Terminal I/O macros
! These macros look and perform like the macros defined in TUTIO, but
! they function by calling external routines defined in DIXDEB. (The
! routines called perform their functions by calling TUTIO).
!
! The Terminal Output Macros are intended to make it easier to
! print on the terminal, especially during debugging.
!
! >TUTIO does various system-dependent things including searching
! libraries and defining globals. I'm having enough trouble balancing
! that sort of thing across systems that I don't need somebody else
! helping, so I isolated that stuff to DIXDEB. Note that DIXDEB must
! also search DIXLIB. To avoid having these definitions conflict with
! the definitions in TUTIO, I did some undeclaring in DIXDEB (q.v.).
!
! The macros defined here are:
!--
MACRO ! ;.s 1 .list 1, "o"
tty_put_quo (str_lit) = ! \.le;MACRO >\ Type quoted string literal.
typasz (UPLIT (%ASCIZ str_lit)) %,
tty_put_crlf (dummy) = ! \.le;MACRO >\ Type a cr/lf.
typnel () %,
tty_put_integer (int, rad, lng) = ! \.le;MACRO >\ Type value of integer.
typint (int, rad, lng) %,
tty_get_integer (rad) = ! \.le;MACRO >\ Get integer from terminal.
ttygin (rad) %;
MACRO
dtype (crlf) [] = ! \.le;MACRO >\Type if DEBUG_FLAG set.
!++
! If debug_code (defined above) is satisfied,
! this types a mixed bag of quoted string and integer
! items on the terminal (it uses the standard tty_put_quo and
! tty_put_integer macros to get to the terminal). The first actual
! controls whether a crlf is put out at the end of the line -- 1 means
! yes, 0 means no.
!
! To type a quoted string, simply place the string in the argument
! list. To type the value of an expression, put the expression in the
! argument list. The default radix is decimal, the default field
! width is 11. To override these, specify (exp, length, radix) (the
! parens are vital). The radix may be omitted to override just
! the length.
!
! Both this and TERMO (below) produce an expression. You supply your
! own semi-colon if that's what you want.
!--
debug_code (termo (crlf, %REMAINING))
% ,
termo (crlf) [] = ! \.le;MACRO >\Type mixed quoted strings and integers.
!++
! This is exactly like dtype above, except for the dependency on
! debugging flags.
!--
BEGIN ! This provides left context for iterative macro pr1
pr1 (%REMAINING) ;
%IF crlf %THEN
tty_put_crlf ()
%FI
END
% ,
pr1 [item] = ! \.le;MACRO >\Type n generic items.
!++
! Type out an arbitrary number of generic items (this is an iterative
! macro with no fixed parameters).
!--
pr2 (%REMOVE (item)) %, !
pr2 (item, length, base) = ! \.le;MACRO >\Type one generic item.
!++
! Type exactly one generic item. This is a simple macro except
! for the kludge to supply default values for missing arguments.
!
!.end list
!--
%IF %ISSTRING (item) %THEN
tty_put_quo (item)
%ELSE
tty_put_integer ((item),
(%IF %LENGTH GTR 2 %THEN ! Fudge a default value
base
%ELSE
10 ! Default base is 10
%FI)
,
(%IF %LENGTH GTR 1 %THEN ! Fudge a default value
length
%ELSE
11 ! Default length is 11
%FI)
)
%FI
%;
%SBTTL 'Misc declarations'
!++
! .HL 1 Miscellaneous declarations
! These assorted declarations go here so that they can be referred to
! later in the file. A few more miscellaneous declarations
! (system-dependent) are put in the require file >DIXREQ.REQ>. They
! are there only when BLISS or system restrictions force that for one
! system or another.
! .s1
!--
LITERAL
unit_offset_size = %BLISS16 (3) %BLISS32 (3) %BLISS36 (6); ! \ >\ This is the number of bits required
! ;to represent the maximum bit offset within an addressable unit on the
! ;current host system. It is used for optimizing structure declarations on
! ;each system.
!++
! Small-integer codes for the various types of systems which the DIX
! must know about:
! .list 0, " "
!--
$literal
sys_lcg = $distinct, ! \.le;>\ (36-bit addressable systems),
sys_8bit = $distinct, ! \.le;>\ (8-bit addressable systems),
sys_ult = $distinct; ! \.le;>\ (for hackery),
LITERAL
sys_max = sys_ult - 1; ! \.le;>\ (max sys code assigned).
! ;.end list
!++
! Define macro >readonly_psect which expands to the name of a
! write-protected psect on whatever system we are compiling on. This
! lets me put static data tables into the sharable part of the image
! in a manner that looks system-independent in the later code.
!--
MACRO
readonly_psect = %BLISS36 ($HIGH$) %BLISS32 ($PLIT$) % ;
!++
! Convenience names for booleans:
! .list 0, " "
!--
LITERAL
true = 1, false = 0, ! \.le;
on = 1, off = 0; ! \.le;
! ;.end list
%SBTTL 'Array structure'
!++
! .HL 1 Array structure
! The structure >ARRAY is defined as a two-dimensional array of
! fullwords with minimum and maximum subscript bounds for each dimension
! specified by the user. This was implemented for the table
! >gen_dispatch_tbl in module DIXGEN, which lets you look up a routine
! address given a source and destination data-type.
!--
STRUCTURE array [row, col; row_min, row_max, col_min, col_max] =
[(row_max - row_min + 1) * (col_max - col_min + 1) * %UPVAL]
(array + ((col - col_min) + (row - row_min) * (row_max - row_min + 1)) * %UPVAL);
%SBTTL 'Foreign Field Descriptor (FFD)'
!++
! .HL 1 The Foreign Field Descriptor (FFD)
!
! This structure is the descriptor used to describe a foreign field
! anywhere within the DIX package. The structure code is >FFD.
!
! A single occurrence of an FFD points to and identifies a (foreign
! or local) field somewhere in local memory. This is the structure
! used to identify a field to the conversion routines (below the user
! interface level).
!
! .index data type codes
! A data type code has two parts: a data class code, and a
! within-class type code. The classes are as described in the
! functional specification: string, fixed binary, floating point,
! boolean, complex, display-numeric, packed decimal, etc. The sizes
! of the fields are controlled by the following parameters:
!--
LITERAL
class_code_bits = 4, ! \.P;\Size of data class code
type_code_bits = 8; ! \.P;\Size of within-class type code
!++
! Here are the field definitions for the FFD:
! .s 1
! .literal
!--
!++ copy
$field
ffd_fields =
SET
ffd$v_unit = [$address], ! Address of lowest unit
! containing some bit of the
! field
ffd$v_length = [$bits (16)], ! Length of field in "natural"
! units (listed explicitly
! with data type definitions)
ffd$v_scale = [$short_integer], ! Scale factor for fixed-point
! decimal-based data types
ffd$v_offset = [$bits (unit_offset_size)], ! Bit offset within
! addressable unit to
! low-order bit of
! field
ffd$v_type = [$bits (class_code_bits + type_code_bits)],
! Data type code
$overlay (ffd$v_type) blf$comma
ffd$v_dt_type = [$bits (type_code_bits)], ! Type subfield
ffd$v_dt_class = [$bits (class_code_bits)], ! Class subfield
$continue
ffd$v_align = [$bits (6)], ! Bit offset within original
! system addressable unit to
! low-order bit of field
ffd$v_sys_orig = [$bits (2)] ! system of origin code
TES;
LITERAL
ffd$k_size = $field_set_size;
!-- .END LITERAL
!++
! To declare a data segment to be of type FFD, use the >forgn_descr
! macro in place of the structure and field attributes in the data
! declaration. It works with both immediate and REF structures.
!--
MACRO
forgn_descr =
BLOCK [ffd$k_size]
FIELD
(ffd_fields) %;
!++
! .hl 2 Data type codes
!
! Data type codes are sometimes accessed outside of an FFD. These
! definitions give you access to the fields from a fullword value.
!--
FIELD
dt_fields =
SET ! ;.list 0, "o"
dt_class_sep = ! \.le;>\Data class code only
[0, type_code_bits, %BPVAL - type_code_bits, 0],
! Make sure def looks at whole word,
! or garbage may sneak through
dt_code_sep = ! \.le;>\With-in class type code only
[0, 0, type_code_bits, 0]
TES; ! ;.end list
MACRO
data_type_sep = BLOCK [1] FIELD (dt_fields) % ;
%SBTTL 'DEC-10/20 standard calling sequence'
!++
! .hl 1 DEC-10/20 Standard Calling Sequence
!
! Define symbolic names for various fields used in processing
! routine calls made through the standard calling sequence on tens and
! twenties.
!--
!++
! First, entries in the standard calling sequence argument list have
! various fields within them:
! .list 1, "o"
!--
FIELD
scs_arg_fields =
SET
scs$v_type = [0, 23, 4, 0], ! \.le;\Type of argument
scs$v_adr = [0, 0, 23, 0] ! \.le;\Address of argument or descriptor
TES;
! ;.end list
!++
! To declare a data-segment to be of type scs_arg, use the macro
! >scs_arg in place of the structure and field attributes in the data
! declaration. This is useful for code which must see inside the
! structure of the standard calling sequence, such as routines that
! interpret descriptors.
!--
MACRO
scs_arg =
BLOCK [1]
FIELD
(scs_arg_fields) %;
!++
! The type code field in a data-segment of type scs_arg has the
! following possible meanings:
! .list 1, "o"
!--
LITERAL
!++ copy /strip .le;>
scs$k_unspecified = 0, ! [2] Unspecified type (assume its right)
scs$k_for36_bool = 1, ! FORTRAN-10/20 Boolean
scs$k_sbf36 = 2, ! DEC-10/20 one-word integer
scs$k_float36 = 4, ! DEC-10/20 one-word floating
scs$k_rtnadr = 7, ! The address of a routine
scs$k_float72 = %O'10', ! DEC-10/20 two-word floating (not G)
scs$k_sbf72 = %O'11', ! DEC-10/20 two-word integer
scs$k_fcmplx36 = %O'14', ! DEC-10/20 single-precision complex
scs$k_display = %O'15', ! 'address' points to descriptor
scs$k_asciz = %O'17'; ! DEC-10/20 ASCII string terminated by NUL
!-- .END LIST
!++
! And now, the fields of the full SCS descriptor. See the COBOL-74
! Language Reference Manual for the official definition of this
! descriptor:
!
! .s 1.literal
!--
!++ copy
FIELD
scs_descriptor_fields =
SET
scs$v_bytpntr = [0, 0, 36, 0],
scs$v_bytsiz = [0, 24, 6, 0],
scs$v_numflg = [1, 35, 1, 0],
scs$v_pscalflg = [1, 23, 1, 0],
scs$v_scalfac = [1, 18, 5, 1],
scs$v_lng = [1, 0, 18, 0]
TES;
!-- .end literal
!++
! To declare a data-segment as type SCS descriptor, use the
! >scs_descr macro in place of the structure and field attributes in
! the data declaration.
!--
MACRO
scs_descr =
BLOCK [2]
FIELD
(scs_descriptor_fields) %;
!++
! To get at unit-aligned data passed using the SCS without knowing its type,
! use argadr (.foo) instead of .foo and .(argadr (.foo)) instead of ..foo.
!
! The macro for BLISS32 is defined simply for compatibility.
! The BLISS36 variant does more -- it calls dix$$get_argadr, which returns
! the address of the unit in which the field starts, regardless of the type
! of the field. Remember, this works only for unit-aligned data.
!--
%BLISS36 (
MACRO
argadr (foo) = dix$$get_argadr (foo) % ;
)
%BLISS32 (
MACRO
argadr (foo) = foo % ; ! [3]
)
%SBTTL 'MACRO36 linkage declaration'
%IF %BLISS (BLISS36)
%THEN
!++
! .HL 1 MACRO36 linkage declaration
! .index macro36 linkage
! This linkage is particularly convenient for calling MACRO subroutines from
! BLISS36.
!
! The standard stack (17) and frame pointers (15) are used. Register
! 0 is the value return register. The first five parameters are
! passed in registers 1 through 5. Further parameters would be passed
! on the stack, in the "standard" way for PUSHJ linkage. If you have
! that many parameters to a MACRO subroutine, think about changing
! something.
!--
LINKAGE
macro36 = PUSHJ (REGISTER = 1, REGISTER = 2, REGISTER = 3, REGISTER = 4, REGISTER = 5) : !
LINKAGE_REGS (15, 13, 0) ! 17, 15, 0 in decimal
PRESERVE (6, 7, 8, 9, 10);
%FI
%sbttl 'Intermediate Forms'
!++
! .HL 1 Intermediate Forms
!--
!++
! .HL 2 CANONICAL BINARY (CB)
! .INDEX CANONICAL BINARY
! .index cb -- canonical binary
!
! The CB (canonical binary) format represents an arbitrary precision
! binary integer as a multi-digit number in some large base which fits
! comfortably into a BLISS fullword value on the system compiled for.
!--
LITERAL
cb$k_precision = 128, ! \.p;\Constant precision, in bits of
! ; twos-complement precision.
cb$k_base_bits = %BPVAL - 6, ! \.p;\Largest calculation that must
! ; be done on a CB segment is seg * 10 + carry, where carry is
! ; no larger than a segment in practical cases. Thus, this segment
! ; size lets the largest calculation done from segments fit in a
! ; fullword without using the sign bit.
cb$k_base = 1^cb$k_base_bits, ! ;.p;cb$k_base = 1`^cb$k_base_bits, The actual base.
cb$k_segments = cb$k_precision / cb$k_base_bits + 1; ! \.p;\Number of digits needed
! ; in selected base to represent the
! ; required precision.
%PRINT (cb$k_precision , '=', %NUMBER (cb$k_precision ))
%PRINT (cb$k_base_bits , '=', %NUMBER (cb$k_base_bits ))
%PRINT (cb$k_base , '=', %NUMBER (cb$k_base ))
%PRINT (cb$k_segments , '=', %NUMBER (cb$k_segments ))
$show (fields)
$field
cb_fields =
SET
cb$v_dig = [$bits (cb$k_base_bits)],
cb$v_oflo = [$bit],
$overlay (cb$v_dig)
cb$v_fill = [$bits (cb$k_base_bits - 1)],
cb$v_sign = [$bit],
$continue
$overlay (cb$v_dig)
cb$v_all = [$integer]
$continue
TES;
MACRO
cb = BLOCKVECTOR [cb$k_segments, 1] FIELD (cb_fields) % ;
!++
! .HL 2 Fixed Intermediate Form (XI)
! .INDEX FIXED INTERMEDIATE FORM
! .INDEX XI -- fixed intermediate form
! This is the internal intermediate form used for all decimal-based types.
! It will also be used for floating-binary to decimal based, when that is
! implemented.
! A number in fixed intermediate form consists of a signed binary scale
! factor, a sign, and an unsigned decimal integer. The actual value can be
! computed as (sign * integer * 10 ** scale).
! Parameters are as follows:
!--
LITERAL ! ;.s1 .list 0, "o"
xi$k_digits = 39, ! \.le;>\(number of digits to store)
xi$k_scale_bits = 16; ! \.le;>\(number of bits for scale factor)
! ;.end list
STRUCTURE
xi_structure ! \.hl 3 Structure >
!++
! This structure is used to represent a number in fixed intermediate form.
!
! Access formals:
!--
[ ! ; .s 1.list 1
type, ! \.le;\: 0 = scale, 1 = sign, 2 = digit
digit_number ! \.le;\: selects digit 0 thru max (max is xi$k_digits)
; ! ; .end list
! ; .P;Allocation formals:
! ; .s 1.list 1
digits, ! \.le;\: Number of digits of precision
scale_bits ! \.le;\: Number of bits for scale factor
] = ! ; .end list
! ; .P;Size of space to allocate (in addressable units):
[(scale_bits + 1) / %BPUNIT + SIGN ((scale_bits + 1) MOD %BPUNIT) +
! ; Scale + sign are in one set of units,
digits / (%BPUNIT / 4) + SIGN (digits MOD (%BPUNIT / 4))]
! ; the digits are in another.
! ; .P;Field reference actually made is complicated. Note that the whole
! ; mess is a compile-time constant expression if the actuals are (which they
! ; often will be, particularly the first one).
(xi_structure + (CASE type FROM 0 TO 2 OF
SET
[0]: 0; ! Scale
[1]: scale_bits / %BPUNIT; ! Sign
[2]: (scale_bits + 1) / %BPUNIT +
SIGN ((scale_bits + 1) MOD %BPUNIT) +
digit_number * 4 / %BPUNIT;
TES)
) <(CASE type FROM 0 TO 2 OF
SET
[0]: 0; ! Scale
[1]: scale_bits MOD %BPUNIT; ! Sign is past scale
[2]: (digit_number * 4) MOD %BPUNIT;
TES),
(CASE type FROM 0 TO 2 OF
SET
[0]: scale_bits; ! Scale
[1]: 1; ! Sign
[2]: 4; ! Digit
TES),
(CASE type FROM 0 TO 2 OF
SET
[0]: 1; ! Scale is signed
[1, 2]: 0; ! Others are unsigned
TES)
>;
FIELD
xi_fields = ! ;.hl 2 Field Set XI_fields
!++
! These fields allow the user to refer to the parts of an XI field
! conveniently.
!--
SET
xi$v_scale = [0, 0], ! \.p;>\Scale factor.
xi$v_sign = [1, 0], ! \.p;>\Sign.
xi$v_digit = [2] ! \.p;>\A digit. User supplies digit number following.
TES;
MACRO
xi = xi_structure [xi$k_digits, xi$k_scale_bits] FIELD (xi_fields) % ;
!++
! .hl 2 Canonical Floating point (CF)
! .index canonical floating point
! .entry cf -- canonical floating point
!
! The Canonical Floating point (CF) form represents a number as a sort of
! generic binary floating point. The relatively large mantissa is represented
! as a series of segments of some convenient size (i.e. a compile-time
! parameter).
!
! This form is used in internal processing of floating point numbers being
! converted. By converting all specific forms to this canonical form before
! processing, the need to implement all needed operations on all needed
! representations is avoided.
!
! A number in CF form consists of three pieces: A three-valued sign
! (positive, zero, and negative), a large binary mantissa, and a large
! signed (twos-complement) exponent.
!
! The exponent occupies a fullword. Each segment of the mantissa
! occupies a fullword. Thus, unfortunately, the sign occupies a
! fullword. There is no point in attempting to minimize space used,
! since only one of these things will be allocated at any given time
! anyway. Speed of access is much more important.
!
! The mantissa segment of index 0 is considered the highest order
! segment. Segments of increasing index contain bits of decreasing
! significance. This ordering, which the opposite of the way significance
! goes everywhere else, is used because the mantissa is normally processed from
! high order to low order, and in fact the uncertainty in its length
! is at the low order, not the high order, end.
!
! Parameters are as follows:
! .list 0, "o"
!--
LITERAL
! ;.no justify
cf$k_mantissa_bits = 113, ! \.le;\Minimum mantissa bits
cf$k_mantissa_seg_bits = %BPVAL - 2, ! \.le;\Segment size
cf$k_mantissa_segs = (cf$k_mantissa_bits - 1) / cf$k_mantissa_seg_bits + 1, ! \.le;\Number of segments
! ;.justify
! ;.end list
! ; Sign values are
! ;.list 0, "o"
cf$k_sign_pos = 1, ! \.le;\: positive,
cf$k_sign_zero = 2, ! \.le;\: zero,
cf$k_sign_neg = 3; ! \.le;\: negative.
! ;.end list
! ; The order of the sign values is important to the continued well-being
! ; of the code that uses them.
STRUCTURE
cf_structure ! \.hl 3 structure >
!++
! The cf_structure (canonical floating point structure) is used to
! represent a number in canonical binary form.
!
! Access formals:
!--
[ ! ; .s 1.list 1
type, ! \.le;\: 0 = sign, 1 = exponent, 2 = mantissa
seg_ndx ! \.le;\: Select segs 0 to max if type is mantissa.
; ! ; .end list
! ; Allocation formals:
! ;.s 1.list 1
segments ! \.le;\: Number of segments
] = ! ;.end list
! ; Size of space to allocate (in addressable units):
[(segments + 2) * %UPVAL] ! ; specified number of segments + 2.
! ; Field reference actually made is relatively complicated. Note that the
! ; first case, at least, is a compile-time constant. If all the actuals are
! ; compile-time constants, the result full reference is.
(cf_structure + ! unit address
( ! offset from structure start
CASE type FROM 0 TO 2 OF
SET
[0]: 0; ! Sign
[1]: 1 * %UPVAL; ! Exponent
[2]: (2 + seg_ndx) * %UPVAL;! Segment
TES) ! offset from structure start
) ! unit address
< ! Field reference
0, ! Bit offset
%BPVAL, ! Field width,
( ! Sign
CASE type FROM 0 TO 2 OF
SET
[0,2]: 0; ! Sign and segments are unsigned
[1]: 1; ! Exponent is signed
TES
) ! Sign
>; ! Field reference
FIELD
cf_fields = ! ;.hl 2 Field Set CF_fields
!++
! These fields allow the user to refer to the parts of a CF field
! conveniently.
!--
SET
cf$v_sign = [0,0], ! \.p;>\Sign.
cf$v_exponent = [1,0], ! \.p;>\Exponent.
cf$v_mantissa = [2] ! \.p;>\Mantissa segment. User
! ; supplies segment index following.
TES;
MACRO
cf = cf_structure [cf$k_mantissa_segs] FIELD (cf_fields) % ;
%SBTTL 'Condition handling and status values'
!++
! .hl 1 Condition handling and status values
! Define general condition handling and status value structures and literals.
! We use the VAX-based status-value (condition-value) concept
! described in the BLISS language manual chapter on condition handling.
! >STS is the standard naming-prefix for the status-code facility.
! Specific values for conditions are defined in another section.
!--
!++
! .hl 2 Facility Name
! The macro >DIX$facility_name expands to the facility prefix for the
! DIX. This is used within macros that construct names from their
! parameters.
!--
MACRO
DIX$facility_name =
'DIX' %;
LITERAL
!
! ;.hl 2 Facility code
!
dix$k_facility = 232; ! \.P;>\This is the formally registered
! ; DIX facility code (registered in
! ; VAX-land).
!++
! To declare a data segment to be of type condition_value, use the
! >condition_value macro instead of the structure and field attributes
! in the data declaration.
!--
MACRO
condition_value =
BLOCK [1]
! STARLET avoids the need to declare these fields, so we have to follow suit.
! FIELD
! (
! sts$v_severity,
! sts$v_success,
! sts$v_cond_id,
! sts$v_msg_no,
! sts$v_fac_sp,
! sts$v_code,
! sts$v_fac_no,
! sts$v_cust_def
! )
% ;
!++
! The keyword macro >sts$value generates a numeric condition value
! in the format suitable for the system on which it was compiled. The
! keywords and defaults are as follows:
! .list 0, "o"
!--
KEYWORDMACRO
sts$value (
!++ copy /strip .le;
severity = sts$k_severe,
CODE,
fac_sp = 1, ! Default is facility specific
fac_no = 0, ! Customer use desires this default
cust_def = 0 ! Default is Digital defined
!-- .end list
) =
(
position_field (sts$m_severity, severity) OR
position_field (sts$m_CODE, CODE) OR
position_field (sts$m_fac_sp, fac_sp) OR
position_field (sts$m_fac_no, fac_no) OR
position_field (sts$m_cust_def, cust_def)
)
%;
%SBTTL 'Define conditions used by the DIX'
!++
!
! .hl 1 Conditions used by the DIX
!
! All the conditions used by the DIX are defined here.
!
! Each definition results in a literal of the form DIX$_name whose
! value is the condition with the default severity. The message
! numbers are assigned sequentially using the compiletime variable
! >cnd_seq>.
!
! The macro >DIX$DEF_CONS is also defined. When expanded, it
! generates calls to a user-defined macro >COND_DAT, passing the
! full condition name as a string literal ('DIX$_name'), the
! FORTRAN pseudonym (6 chars) as a string literal, the
! condition value as a numeric literal, and the text of the standard
! message as a string literal.
!
! To make a list of condition names and messages, for example, you
! would do the following: Write a program that searched this library.
! Define COND_DAT to build the data structures you want containing
! selected condition information. Then call DIX$DEF_CONS. You now
! have your data structures containing everything you wanted to print.
! It should be a simple problem to print it out.
!--
COMPILETIME
cnd_seq = 0;
MACRO
! ; Macro information:
DIX$def_con (cond_nam, fort_pseud, default_severity, msg_txt) = ! \ .P;>\
%QUOTE %EXPAND %ASSIGN (cnd_seq, cnd_seq + 1) !
%QUOTE %EXPAND %PRINT !
( ! Begin %PRINT actuals
cond_nam, ! %PRINT actual
' code is ', ! %PRINT actual
%QUOTE %EXPAND %NUMBER (cnd_seq) ! %PRINT actual
) ! End %PRINT actuals
cond_dat !
( ! Begin cond_dat actuals
%QUOTE %EXPAND %NAME ! cond_dat actual
( ! Begin %NAME actuals
%QUOTE %EXPAND DIX$facility_name, ! %NAME actual
'$_', ! %NAME actual
cond_nam ! %NAME actual
), ! End %NAME actuals
fort_pseud, ! cond_dat actual
%QUOTE %EXPAND sts$value ! cond_dat actual
( ! Begin sts$value actuals
fac_no = DIX$k_facility, ! sts$value actual
CODE = %QUOTE %EXPAND %NUMBER(cnd_seq), ! sts$value actual
severity = (default_severity) ! sts$value actual
), ! End sts$value actuals
msg_txt ! cond_dat actual
) ! End cond_dat actuals
%, ! end DIX$def_con definition
!++
! .hl 2 >DIX$def_cons details
! Definitions of new conditions should be put into the macro definition
! in a manner consistent with the existing entries:
! .i 5;%EXPAND DIX$def_con ('name', 'fortpseud', default-severity, 'message text')
! In particular, note the absence of commas and semicolons at the end of
! the macro call to DIX$def_con.
! The "%EXPAND" is necessary to cause the generation of message
! codes to occur at library compile time. It is necessary that
! literal values be contained in the defined DIX$def_cons so that
! all calls to it are guaranteed of getting the same values.
!--
DIX$def_cons =
%EXPAND DIX$def_con('rounded', 'rnded', sts$k_info,
'Result is rounded')
%EXPAND DIX$def_con ('toobig', 'toobig', sts$k_severe,
'Converted source field too large for destination field')
%EXPAND DIX$def_con ('invdattyp', 'dattyp', sts$k_severe,
'Invalid data type code')
%EXPAND DIX$def_con ('unkargtyp', 'argtyp', sts$k_severe,
'Argument passed by descriptor is unknown type')
%EXPAND DIX$def_con ('unksys', 'unksys', sts$k_severe,
'Unknown system of origin specified')
%EXPAND DIX$def_con ('invlng', 'invlng', sts$k_severe,
'Length invalid or unspecified')
%EXPAND DIX$def_con ('invscal', 'invscl', sts$k_severe,
'Scale factor invalid or unspecified')
%EXPAND DIX$def_con ('graphic', 'graphc', sts$k_warning,
'Graphic character changed in conversion')
%EXPAND DIX$def_con ('fmtlost', 'fmtlst', sts$k_warning,
'Format effector gained or lost in conversion')
%EXPAND DIX$def_con ('nonprint', 'nonprn', sts$k_warning,
'Non-printing character gained or lost in conversion')
%EXPAND DIX$def_con ('trunc', 'trunc', sts$k_info,
'String too long for destination -- truncated')
%EXPAND DIX$def_con ('unimp', 'unimp', sts$k_severe,
'Unimplemented conversion')
%EXPAND DIX$def_con ('invalchar', 'invchr', sts$k_error,
'Invalid character in source field or conversion table')
%EXPAND DIX$def_con ('align', 'align', sts$k_severe,
'Invalid alignment for data type')
%EXPAND DIX$def_con ('unnorm', 'unnorm', sts$k_severe,
'Floating point number improperly normalized')
%EXPAND DIX$def_con ('impossible', 'imposs', sts$k_severe,
'Severe internal error') ! [%O'26']
%EXPAND DIX$def_con ('unsigned', 'unsign', sts$k_error,
'Negative value moved to unsigned field')
%EXPAND dix$def_con ('invbytsiz', 'bytsiz', sts$k_severe,
'Invalid byte size specified')
%EXPAND dix$def_con ('invdnumchr','dnmchr',sts$k_severe,
'Invalid source display numeric character')
%EXPAND dix$def_con ('invdnumsgn','dnmsgn',sts$k_severe,
'Invalid source display numeric sign character')
%EXPAND dix$def_con ('invpddgt', 'pddgt', sts$k_severe,
'Invalid source packed decimal digit')
%EXPAND dix$def_con ('invpdsgn', 'pdsgn', sts$k_severe,
'Invalid source packed decimal sign')
%, ! End DIX$def_cons definition
!++
! .hl 2 Literals for status codes
! Now that DIX$def_cons is defined, we can construct the
! literals for the status codes by creating a local definition of
! >cond_dat (which is undeclared after use) and expanding
! DIX$def_cons.
!
! [5] In BLISS32, the literals declared are external literal declarations.
! The actual message definitions come from the >DIX.MSG file, produced
! by the >dixmsg program from the other info in def_cons.
!--
cond_dat (cond_nam, fort_pseud, cond_value, cond_msg_txt) = ! \.P;>\
cond_nam %BLISS36 ( = cond_value) , %; ! [5]
%BLISS32 (EXTERNAL) LITERAL ! [5]
dix$def_cons ! Expand above cond_dat for each dix$def_con
! call above, thus defining literals for
! all conditions
dix$$foo %BLISS36 ( = 0) ; ! [5]
LITERAL ! [5]
max_condition = %NUMBER (cnd_seq);
UNDECLARE ! This stuff is too wierd for the public
cnd_seq,
dix$$foo, ! [5]
%QUOTE cond_dat,
%QUOTE dix$def_con;
%SBTTL 'Macros for data type declarations'
!++
! .hl 1 Macros for data type declaration
!
! All the information about each data type will be embedded in a macro
! declaration below.
!
! A macro called >dt_class_`<class name`>_def will be defined for each
! class which, when expanded, calls the locally-defined macro
! >decl_`<class name`>_item once for each data item in the class,
! passing all the information provided in the initial definition.
!
! This approach centralizes all the data type characteristics in a
! single place, making them easy to change and to find.
!
! There are some special macros used here to set up the macros
! described above. First, an example:
! .s 1
! .index declare_class
! .index dt_class
! .index dt_code
! .index data_type
! .index end_class
! .index dix$k_max_class
! .index dt_class_`<name`>_max
! .index dt_`<name`>
! .literal
! COMPILETIME
! dt_class = 0,
! dt_code = 0;
!
! declare_class (class_name);
! %EXPAND data_type (type_name, short_name);
! .
! .
! .
! %EXPAND end_class;
! declare_class (class_name);
! %EXPAND data_type (type_name, short_name);
! .
! .
! .
! %EXPAND end_class;
! .
! .
! .
!
! This produces the following literal declarations:
! DT_class Class number for each class
! DT_CLASS_class_MAX Max data type code assigned in that class
! (min is always 1)
! DIX$K_MAX_CLASS Highest class code assigned
!
! It also declares the macro DT_CLASS_class_DEF, described below.
!
! Then, when you want to build a table (or whatever) based on the
! information you gave for each data type:
!
! MACRO
! DECL_class_name_ITEM (class_code, item_name, short_name, type_code,
! user_specified ...) =
! Appropriate_code; %;
!
! DT_CLASS_class_name_DEF;
! .end literal
!--
MACRO
!++
! .hl 2 >declare_class macro
! Call the declare_class macro at the start of the list of
! items for each class:
!--
!++ NO
! ; The MACRO declare_class basically does the following:
! ; 1) Define the MACRO current_class (which is undeclared
! ; in the MACRO end_class.
! ; 2) %ASSIGN dt_code = 0.
! ; 3) %ASSIGN dt_class = dt_class + 1.
! ; 4) Define the LITERAL dt_<class_name> = dt_class.
! ; 5) Define the MACRO dt_class_<class_name>_def. This is a little
! ; unusual because the definition is left open-ended. The MACRO
! ; declare_class is defined such that it expands to the following
! ; definition of dt_class_<class_name>_def ==>
! ;
! ; MACRO %NAME ('dt_class', class_name, '_def') =
! ; %, ! End declare_class
! ; This means that when declare_class is invoked, the call must be
! ; followed by the code that the user wishes to be the body of the
! ; MACRO dt_class_<class_name>_def.
! ;
!--
declare_class (class_name) = ! \ .p;>\
MACRO
current_class =
class_name %QUOTE %;
%ASSIGN (dt_code, 0) ! Initialize type code
%ASSIGN (dt_class, dt_class + 1)
LITERAL
%NAME ('dt_', class_name) = %NUMBER (dt_class);
!
! ; At compile time, prints the number assigned to this class.
!
%PRINT (%NAME ('dt_', class_name), '=', %NUMBER (%NAME ('dt_', class_name)))
! Define the name of the MACRO whose body directly follows the call
! to declare_class (class_name). The name is built using the parameter
! "class_name" and is the following: dt_class_<class_name>_def.
! NOTE: The body of this MACRO does not appear here, but rather
! appears in the code directly after the call to declare_class.
MACRO
%NAME ('dt_class_', class_name, '_def') =
%, ! End declare_class
!++
! .hl 2 >data_type
! The data_type macro is used to declare a specific data type
! within a class declaration. It assigns the within-class type
! code from compiletime variable >dt_code>, which is incremented.
!--
data_type (item_name, short_name) = ! \.P;>\
%QUOTE %EXPAND %ASSIGN (dt_code, dt_code + 1)
!++
! Expansion calls macro >decl_`<class name`>_item (which the user
! must define) to do whatever is wanted for each item in the class.
!--
%QUOTE %EXPAND %NAME ('decl_', current_class, '_item') ! Name of macro to invoke
( ! MACRO-actuals enclosed
%QUOTE %EXPAND %NAME ('dt_', current_class), ! MACRO actual
item_name, ! Macro actual
short_name, ! Macro actual
%QUOTE %EXPAND %NUMBER(dt_code), ! Macro actual
%QUOTE %EXPAND %REMAINING ! Macro actual
) ! End of MACRO-actuals
!
! ; At compile-time, data_type prints the within-class code assigned
! ; to each data type.
!
%QUOTE %EXPAND %PRINT !
( ! %PRINT actuals enclosed
item_name, ! %PRINT actual
' type code=', ! %PRINT actual
%QUOTE %EXPAND %NUMBER(dt_code) ! %PRINT actual
) ! End %PRINT actuals
%, ! End data_type definition
!++
! .hl 2 >end_class
! The macro end_class handles termination of the declarations for a
! class of data items.
!--
end_class =
%QUOTE %;
LITERAL ! ; The literal >dt_class_`<name`>_max> is
! ; defined as the maximum code in the class.
%QUOTE %EXPAND %NAME
( ! %NAME actuals enclosed
'dt_class_', ! %NAME actual
current_class, ! %NAME actual
'_max' ! %NAME actual
) ! End %NAME actuals
= !
%QUOTE %EXPAND %NUMBER (dt_code);
!
! ; At compile-time, print the max code in the class from the
! ; literal just defined.
!
%QUOTE %EXPAND %PRINT ( ! Begin actuals to %PRINT
%QUOTE %EXPAND %NAME ! Actual to %PRINT
( ! Begin actuals to %NAME
'dt_class_', ! Actual to %NAME
current_class, ! Actual to %NAME
'_max' ! Actual to %NAME
), ! End actuals to %NAME
'=', ! Actual to %PRINT
%QUOTE %EXPAND %NUMBER ! Actual to %PRINT
( ! Begin actuals to %NUMBER
%QUOTE %EXPAND %NAME ! Actual to %NUMBER
( ! Begin actuals to %NAME
'dt_class_', ! Actual to %NAME
current_class, ! Actual to %NAME
'_max' ! Actual to %NAME
) ! End of actuals to %NAME
) ! End of actuals to %NUMBER
) ! End of actuals to %PRINT
UNDECLARE ! Get rid of one-shot variables
%QUOTE %QUOTE current_class;
%; ! End definition of end_class
%SBTTL 'Data type definitions'
!++
! .hl 1 Data type definitions
!
! The characteristics of all data types in all classes will be defined
! here.
!
! The resulting information will be stored mostly as macro
! definitions (described above) and will be expanded into tables as
! necessary in the general and type-specific conversion modules.
!--
COMPILETIME
dt_class = 0,
dt_code = 0;
%sbttl 'Class String data type definitions'
!++
! .hl 2 Class string
! .index class string
!
! Information to be provided for each data type:
! .list 1, "o"
! .le;Name as quoted string
! .le;Short name as quoted string
! .le;Byte size
! .le;System of origin
! .le;Length indicating technique (value indicating whether a length must
! be given or if a null length is expected)
! .le;Name of character set as quoted string. Since the build_cst macro
! (defined and used in DIXSTR) names everything consistently based on
! the character set name, this is all that is needed to find everything.
! .le;Fill character to use (numeric)
! .le;Character to substitute if no matching char in set (numeric)
! .end list
!--
!
! ; Names for methods of indicating length:
! ;.list 0, "o"
$literal
std$k_lng_spec = $distinct, ! \.le;>\
std$k_lng_nul = $distinct, ! \.le;>\
std$k_lng_ult = $distinct; ! \.le;>\
LITERAL
std$k_max_lng_indic = %NUMBER (std$k_lng_ult) - 1 ; !\.le;>\
! ;.end list
UNDECLARE std$k_lng_ult;
declare_class ('string') ! call declare_class
!
! The code following the call to declare_class is actually the body of the
! MACRO dt_class_string_def.
!
%EXPAND
data_type ('ASCII_7', 'ASCII7', 7, sys_lcg, std$k_lng_spec, 'ascii', 32, 92)
%EXPAND
data_type ('ASCII_8', 'ASCII8', 8, sys_8bit, std$k_lng_spec, 'ascii', 32, 92)
%EXPAND
data_type ('ASCIZ', 'ASCIZ', 7, sys_lcg, std$k_lng_nul, 'ascii', 0, 92)
%EXPAND
data_type ('EBCDIC_8', 'EBCDC8', 8, sys_8bit, std$k_lng_spec, 'ebcdic', 64, 224)
%EXPAND
data_type ('EBCDIC_9', 'EBCDC9', 9, sys_lcg, std$k_lng_spec, 'ebcdic', 64, 224)
%EXPAND
data_type ('SIXBIT', 'SIXBIT', 6, sys_lcg, std$k_lng_spec, 'sixbit', 0, 60)
!
%EXPAND
end_class
%SBTTL 'String data table (STD)'
!++
! .hl 3 String data table (>std>)
! Format for the alphanumeric string data table.
! This table is indexed by data subtype (within its class).
! .literal
!--
$field
std_fields =
SET
!++ copy
std$v_byt_siz = [$bits (6)], ! Byte size of string
std$v_sys_orig = [$bits (3)], ! Code for system of origin
std$v_lng_indic = [$bits (2)] ! Length indication
! (values std$k_lng_<something> defined above)
!-- .end literal
TES;
LITERAL
std$k_size = $field_set_size;
!++
! To declare a data segment to be of type std, use the macro dtt_st
! in place of the structure and field attributes in the data item
! declaration.
!--
MACRO
dtt_st = BLOCKVECTOR [dt_class_string_max + 1, std$k_size] FIELD (std_fields) % ;
%sbttl 'Class fixed binary data type definitions'
!++
! .hl 2 Class fixed binary
!
! Information to be provided for each data type:
!
! .list 1
! .le;Name as quoted string
! .le;Short name as quoted string
! .le;Fixed or variable length (use literals)
! .le;Signed or unsigned (use literals)
! .le;Minimum length if variable (unsigned) (zero if not variable)
! .le;Maximum length if variable (unsigned)
! .le;Minimum scale factor (signed)
! .le;Maximum scale factor (signed)
! .le;Program for BPM/BIM
! .end list
!--
!++
! Literals for specifying above parameters:
! .list 0, "o"
!--
LITERAL
fbd$k_lng_fixed = 1, ! \.le;\ Type is fixed-length
fbd$k_lng_variable = 2, ! \.le;\ Type is variable-length
fbd$k_signed = 3, ! \.le;\ Type is signed
fbd$k_unsigned = 4; ! \.le;\ Type is unsigned
! ; .end list
!++
! .hl 3 Binary pseudo-machine (BPM)
! .index pseudo-machine BPM
! .index binary pseudo-machine BPM
! .index bpm
! Define the pseudo-machine to run (in different directions) in the
! routines that convert FB to CB and vs.
!
! Each pseudo-instruction has an op code and two signed integer (small)
! operands. The structure to represent a single instruction is defined as a
! block with the following fields:
!--
$field ! ; .s 1.list 0, "o"
bpm_fields =
SET
!++ copy /strip .le;>
bpm$v_opcode = [$byte], ! Op code is this size for VAX alignment
bpm$v_op_1 = [$tiny_integer], ! Must be signed, at least +/- 128
bpm$v_op_2 = [$tiny_integer] ! Must be signed, at least +/- 128
!-- .end list
TES;
LITERAL
bpm$k_size = $field_set_size,
bpm$b_opcode = 0, ! OFFSET
bpm$s_opcode = %BLISS36 (9) %BLISS32 (8), ! Size of field
bpm$b_op_1 = %BLISS36 (9) %BLISS32 (8), ! These fields depend on the
bpm$s_op_1 = %BLISS36 (9) %BLISS32 (8), ! way XPORT processes the
bpm$b_op_2 = %BLISS36 (18) %BLISS32 (16), ! definitions above!!!
bpm$s_op_2 = %BLISS36 (9) %BLISS32 (8); ! Watch out!!!
!++
! The op-codes for the pseudo-machine are as follows:
!--
$literal ! ; .s 1.list 1
!++ copy /strip .le;>
bpm$k_op_move = $distinct, ! Move contiguous bits
bpm$k_op_move_var = $distinct, ! Move contiguous bits with variable length
bpm$k_op_sign = $distinct, ! Process sign
bpm$k_op_sign_var = $distinct, ! Process sign in variable length
bpm$k_op_done = $distinct; ! Do cleanup and terminate.
!--
! ; Must be last in list!!
! ; .END LIST
LITERAL
bpm$k_op_max = bpm$k_op_done - 1; ! \.p;Largest bpm opcode is \
!++
! .hl 3 Building BPM instructions
! Macros to build pseudo-machine instructions:
!--
MACRO
bpm_any ! \.hl 4 \
!++
! builds any pseudo-machine instruction.
!
! Formal arguments:
!--
( ! ; .list 1
op_code, ! \.le;\: opcode for instruction
op_1, ! \.le;\: signed value for first op
op_2 ! \.le;\: signed value for second op
) = ! ; .end list
op_code OR
(op_1 AND (1^bpm$s_op_1 - 1))^bpm$b_op_1 OR
(op_2 AND (1^bpm$s_op_2 - 1))^bpm$b_op_2 %,
bpm_move ! \.hl 4\
!++
! builds the pseudo-machine instruction to move continuous bits
! between FB and CB fields.
!
! Formal arguments:
!--
( ! ; .list 1
Offset, ! \.le;\: from LO bit of FB
length ! \.le;\: number of bits to move
) = ! ; .end list
bpm_any (bpm$k_op_move, offset, length) %,
bpm_move_var ! \.hl 4\
!++
! builds the pseudo-machine instruction to move continuous bits
! between FB and CB variable length fields.
!
! Formal arguments:
!--
( ! ; .list 1
Offset, ! \.le;\: from LO bit of FB
length ! \.le;\: number of bits to move - length
) = ! ; .end list
bpm_any (bpm$k_op_move_var, offset, length) %,
bpm_sign ! \.hl 4\
!++
! builds the pseudo-machine instruction to move sign information
! between FB and CB fields.
!
! Formal arguments:
!--
( ! ; .list 1
Offset ! \.le;\: from LO bit of FB
) = ! ; .end list
bpm_any (bpm$k_op_sign, offset, 0) %,
bpm_sign_var ! \.hl 4\
!++
! builds the pseudo-machine instruction to move sign information
! between FB and CB variable length fields.
!
! Formal arguments:
!--
( ! ; .list 1
Offset ! \.le;\: from LO bit of FB - length
) = ! ; .end list
bpm_any (bpm$k_op_sign_var, offset, 0) %,
bpm_done ! \.hl 4\
!++
! builds the pseudo-machine instruction to terminate a pseudo-program.
!
! Formal arguments: none.
!--
=
bpm_any (bpm$k_op_done, 0, 0) % ;
!
! And now, the real class fixed binary definitions in terms of this glop.
!
declare_class ('fbin') ! call declare_class
!
! The code following the call to declare_class is actually the body of the
! MACRO dt_class_fbin_def.
!
%EXPAND data_type ('SBF128', 'SBF128', fbd$k_lng_fixed, fbd$k_signed,0,0,0,0,
(bpm_move (0, 127), bpm_sign (127), bpm_done))
%EXPAND data_type ('SBF16', 'SBF16', fbd$k_lng_fixed, fbd$k_signed,0,0,-18,18,
(bpm_move (0, 15), bpm_sign (15), bpm_done))
%EXPAND data_type ('SBF32', 'SBF32', fbd$k_lng_fixed, fbd$k_signed,0,0,-18,18,
(bpm_move (0, 31), bpm_sign (31), bpm_done))
%EXPAND data_type ('SBF36', 'SBF36', fbd$k_lng_fixed, fbd$k_signed,0,0,-18,18,
(bpm_move (0, 35), bpm_sign (35), bpm_done))
%EXPAND data_type ('SBF48', 'SBF48', fbd$k_lng_fixed, fbd$k_signed,0,0,0,0,
(bpm_move (0, 47), bpm_sign (47), bpm_done))
%EXPAND data_type ('SBF64', 'SBF64', fbd$k_lng_fixed, fbd$k_signed,0,0,-18,18,
(bpm_move (0, 63), bpm_sign (63), bpm_done))
%EXPAND data_type ('SBF72', 'SBF72', fbd$k_lng_fixed, fbd$k_signed,0,0,-18,18,
(bpm_move (0, 35), bpm_move (-36, 35), bpm_sign (-1), bpm_done))
%EXPAND data_type ('SBF8', 'SBF8', fbd$k_lng_fixed, fbd$k_signed,0,0,0,0,
(bpm_move (0, 7), bpm_sign (7), bpm_done))
%EXPAND data_type ('SBFVAR', 'SBFVAR', fbd$k_lng_variable, fbd$k_signed,0,36,0,0,
(bpm_move_var (0, -1), bpm_sign_var (-1), bpm_done))
%EXPAND data_type ('UBF16', 'UBF16', fbd$k_lng_fixed, fbd$k_unsigned,0,0,0,0,
(bpm_move (0, 16), bpm_done))
%EXPAND data_type ('UBF32', 'UBF32', fbd$k_lng_fixed, fbd$k_unsigned,0,0,0,0,
(bpm_move (0, 32), bpm_done))
%EXPAND data_type ('UBF8', 'UBF8', fbd$k_lng_fixed, fbd$k_unsigned,0,0,0,0,
(bpm_move (0, 8), bpm_done))
%EXPAND data_type ('UBFVAR', 'UBFVAR', fbd$k_lng_variable, fbd$k_unsigned,0,36,0,0,
(bpm_move_var (0, 0), bpm_done))
%EXPAND end_class
%sbttl 'Fixed Binary data table (FBD)'
!++
! .hl 3 Fixed binary data table (>fbd>)
! Format for the fixed binary data table. This table is indexed by
! data subtype (within class).
! .s 1
! .literal
!--
$field
fbd_fields =
SET
!++ copy
fbd$v_bpm_program = [$address], ! Address of BPM program
! These two bits occupy HO part of word on 36-bit
fbd$v_signed = [$bit], ! Bit set if field is signed
fbd$v_variable = [$bit], ! Bit set if field length variable
$align (byte) ! Align remaining fields
fbd$v_min_lng = [$byte], ! Minimum length (unsigned field)
fbd$v_max_lng = [$byte], ! Maximum length (unsigned)
fbd$v_min_scale = [$tiny_integer], ! Signed minimum scale
fbd$v_max_scale = [$tiny_integer] ! Signed maximum scale
!-- .end literal
TES;
LITERAL
fbd$k_size = $field_set_size;
MACRO
dtt_fbin ! \.p;Macro >\
!++
! declares an item to have the right structure and field attributes for
! the fixed binary data table.
!--
= BLOCKVECTOR [dt_class_fbin_max + 1, fbd$k_size] FIELD (fbd_fields) % ;
%SBTTL 'Class floating point data type definitions'
!++
! .hl 2 Class floating point
!
! Information to be provided for each data type:
!
! .list 1
! .le;Name as quoted string
! .le;Short name as quoted string
! .le;Representation (use literals)
! .le;Exponent offset
! .le;Number of significant bits in mantissa (including hidden high-order
! bit if there is one)
! .le;Program for FPM/FIM
! .end list
!
! Literals for specifying above:
! .list 0, "o"
!--
$literal
!++ copy /strip .le;
fpd$k_lcg = $distinct, ! Number is in LCG representation
fpd$k_vax = $distinct, ! Number is in VAX/PDP-11 representation
fpd$k_rep_ult = $distinct;
!-- .end list
LITERAL
fpd$k_rep_max = fpd$k_rep_ult - 1; ! \.p;Max representation value is \
UNDECLARE
fpd$k_rep_ult;
!++
! .hl 3 Floating point pseudo-machine FPM
! .index pseudo-machine FPM
! .index floating point pseudo-machine FPM
! .index fpm
!
! Define the pseudo-machine used to convert fp to cf and vs (the programs
! are also run to convert cf to fp; of course the interpretation
! of the instructions changes).
!
! Each instruction has an op code and two signed small integer operands.
! The structure to represent a single instruction is defined as a block with
! the following fields:
!--
$field
fpm_fields = ! ; .s 1 .list 0, "o"
SET
!++ copy /strip .le;>
fpm$v_opcode = [$byte], ! Op code is large for alignment on vax
fpm$v_op_1 = [$tiny_integer], ! Must be signed, +/- 128
fpm$v_op_2 = [$tiny_integer] ! Must be signed, +/- 128
!-- .end list
TES;
LITERAL
fpm$k_size = $field_set_size,
!++
! Create names for bit positions of above fields. These definitions depend
! on how XPORT process the above stuff, so be extremely careful whem
! mucking about with either one!!!
!--
!++ copy /strip .i 5;
fpm$b_opcode = 0, ! Offset
fpm$s_opcode = %BLISS36 (9) %BLISS32 (8), ! Size of field
fpm$b_op_1 = %BLISS36 (9) %BLISS32 (8),
fpm$s_op_1 = %BLISS36 (9) %BLISS32 (8),
fpm$b_op_2 = %BLISS36 (18) %BLISS32 (16),
fpm$s_op_2 = %BLISS36 (9) %BLISS32 (8);
!--
!++
! Op-codes for the FPM:
!--
$literal ! ;.list 1
!++ copy /strip .le;>
fpm$k_op_sign = $distinct, ! Set sign to pos or neg
fpm$k_op_exp = $distinct, ! Move exponent bits
fpm$k_op_mant = $distinct, ! Move mantissa bits
fpm$k_op_mant1 = $distinct, ! Create hidden leading mantissa bit
fpm$k_op_done = $distinct; ! Do cleanup and terminate.
!--
! ; "done" must be last!!!
! ; .end list
!++
! .hl 3 Building FPM instructions
! Macros to build pseudo-machine instructions:
!--
MACRO
fpm_any ! \.hl 4 \
!++
! builds any pseudo-machine instruction.
!
! Formal arguments:
!--
( ! ; .list 1
op_code, ! \.le;\: opcode for instruction
op_1, ! \.le;\: signed value for first op
op_2 ! \.le;\: signed value for second op
) = ! ; .end list
op_code OR
(op_1 AND (1^fpm$s_op_1 - 1))^fpm$b_op_1 OR
(op_2 AND (1^fpm$s_op_2 - 1))^fpm$b_op_2 %,
fpm_sign ! \.hl 4\
!++
! builds the pseudo-machine instruction to set the CF sign to positive or
! negative (zero is handled in the done routine).
!
! Formal arguments:
!--
( ! ;.s 1.list 1
offset ! \.le;\: Offset from low order bit of FP
) = ! ;.end list
fpm_any (fpm$k_op_sign, offset, 0) % ,
fpm_exp ! \.hl 4\
!++
! builds the pseudo-machine instruction to move exponent bits.
! Exponent bits are moved from low order to high order. No sign
! extension is done -- this must be handled by the done routine.
! This instruction may only be called once -- segmented exponents
! are not supported. Exponents larger than a fullword are not
! supported.
!
! Formal arguments:
!--
( ! ;.s 1.list 1
offset, ! \.le;\: Offset from low order bit of FP
length ! \.le;\: Number of bits to move
) = ! ;.end list
fpm_any (fpm$k_op_exp, offset, length) % ,
fpm_mant ! \.hl 4\
!++
! builds the psedo-machine instruction to move mantissa bits.
!
! Mantissa bits are moved from high order to low order. Therefore
! the offset specified is to the highest-order bit to be moved.
!
! This instruction may be used several times to move non-contiguous
! mantissa fields.
!
! Formal arguments:
!--
( ! ;.s 1.list 1
offset, ! \.le;\: Offset from LO bit of FP
! ; to HO bit to move.
length ! \.le;\: Number of bits to move
! ; (lower-order bits).
) = ! ;.end list
fpm_any (fpm$k_op_mant, offset, length) % ,
fpm_mant1 ! \.hl 4\
!++
! builds the instruction for creating the leading mantissa bit, which is
! not represented in some implementations.
!
! Formal arguments: None
!--
=
fpm_any (fpm$k_op_mant1, 0, 0) % ,
fpm_done ! \.hl 4\
!++
! builds the done instruction. This terminates processing of the
! pseudo-program and executes the final cleanup routine.
!
! The final cleanup routine transforms the broken-down bit fields made
! by the simple moves of the other instructions into the true canonical
! form.
!
! Formal arguments: None.
!--
=
fpm_any (fpm$k_op_done, 0, 0) % ;
!
! And now, the real class floating point definitions in terms of this glop.
!
declare_class ('fp') ! call declare_class
!
! The code following the call to declare_class is actually the body of the
! MACRO dt_class_fp_def.
!
%EXPAND data_type ('D_FLOAT', 'DFLOAT', fpd$k_vax, 128, 56,
(fpm_sign (15), fpm_exp (7, 8), fpm_mant1, fpm_mant (6, 7),
fpm_mant (31, 16), fpm_mant (47, 16), fpm_mant (63, 16), fpm_done ))
%EXPAND data_type ('F_FLOAT', 'FFLOAT', fpd$k_vax, 128, 24,
(fpm_sign (15), fpm_exp (7, 8), fpm_mant1, fpm_mant (6, 7),
fpm_mant (31, 16), fpm_done ))
%EXPAND data_type ('FLOAT_36', 'FLOT36', fpd$k_lcg, 128, 27,
(fpm_sign (35), fpm_exp (27, 8), fpm_mant (26, 27), fpm_done ))
%EXPAND data_type ('FLOAT_72', 'FLOT72', fpd$k_lcg, 128, 62,
(fpm_sign (-1), fpm_exp (-9, 8), fpm_mant (-10, 27), fpm_mant (34, 35),
fpm_done ))
%EXPAND data_type ('G_FLOAT', 'GFLOAT', fpd$k_vax, 1024, 53,
(fpm_sign (15), fpm_exp (4, 11), fpm_mant1, fpm_mant (3, 4),
fpm_mant (31, 16), fpm_mant (47, 16), fpm_mant (63, 16), fpm_done ))
%EXPAND data_type ('G_FLOAT72', 'GFLO72', fpd$k_lcg, 1024, 59,
(fpm_sign (-1), fpm_exp (-12, 11), fpm_mant (-13, 24), fpm_mant (34, 35),
fpm_done ))
%EXPAND data_type ('H_FLOAT', 'HFLOAT', fpd$k_vax, 16384, 113,
(fpm_sign (15), fpm_exp (0, 15), fpm_mant1, fpm_mant (31, 16),
fpm_mant (47, 16), fpm_mant (63, 16), fpm_mant (79, 16),
fpm_mant (95, 16), fpm_mant (111, 16), fpm_mant (127, 16), fpm_done ))
%EXPAND end_class
%SBTTL 'Floating point data table'
!++
! .hl 3 Floating point data table (>fpd>)
! Format for the floating point data table. This table is indexed
! by the data subtype (within its class).
! .literal
!--
$field
fpd_fields =
SET
!++ COPY
fpd$v_fpm_program = [$address], ! Address of FPM program for type
fpd$v_representation = [$byte], ! Encodes details of representation
! within the 3 standard fields
fpd$v_exp_offset = [$bytes (2)], ! Unsigned offset to apply to exponent
fpd$v_mant_bits = [$byte] ! Unsigned number of significant bits in mantissa
!-- .END LITERAL
TES;
LITERAL
fpd$k_size = $field_set_size;
MACRO
dtt_fp ! \.p;Macro >\
!++
! declares an item to have the right structure and field attributes for
! the floating point data table.
!--
= BLOCKVECTOR [dt_class_fp_max + 1, fpd$k_size] FIELD (fpd_fields) % ;
%SBTTL 'Class Display Numeric data type definitions'
!++
! .hl 2 Class Display Numeric
! .index class display numeric
!
! Information to be provided for each data type:
! .list 1, "o"
! .le;Name as quoted string
! .le;Short name as quoted string
! .le;Byte size
! .le;System of origin
! .le;code indicating sign type (use literals provided below)
! .le;Maximum length allowed
! .le;Character set used
! .le;Size of character set
! .end list
!--
! ; Literal names used to indicate different sign representations:
! ;.s1.list 0, "o"
LITERAL
dnd$k_unsigned = 0, ! \.le;>\ unsigned
dnd$k_lead_sep = 1, ! \.le;>\ signed/leading/separate
dnd$k_lead_over = 2, ! \.le;>\ signed/leading/overpunched
dnd$k_trail_sep = 3, ! \.le;>\ signed/trailing/separate
dnd$k_trail_over = 4; ! \.le;>\ signed/trailing/overpunched
! ;.end list
! ; Literals for display numeric character set reference codes:
LITERAL ! ;.s 1 .list 0, "o"
cs_ascii = 0, ! \.le;\ ascii char set
cs_asciix = 1, ! \.le;\ ascii extended char set
cs_ebcdic = 2, ! \.le;\ ebcdic char set
cs_sixbit = 3, ! \.le;\ sixbit char set
cs_max = 4; ! ;.end list
! ; Literals for display numeric character set sizes:
LITERAL ! ;.s 1 .list 0, "o"
ovp$k_ascii_max = 10, ! \.le;\size of ascii dn character set
ovp$k_asciix_max = 35, ! \.le;\size of ascii dn extended char set
ovp$k_ebcdic_max = 10, ! \.le;\size of ebcdic dn character set
ovp$k_sixbit_max = 10; ! \.le;\size of sixbit dn character set
! ;.end list
declare_class ('dnum') ! call declare_class
!
! The code following the call to declare_class is actually the body of the
! MACRO dt_class_dnum_def.
!
%EXPAND
data_type ('DN6LO', 'DN6LO', 6, sys_lcg, dnd$k_lead_over, 'sixbit', 18)
%EXPAND
data_type ('DN6LS', 'DN6LS', 6, sys_lcg, dnd$k_lead_sep, 'sixbit', 19)
%EXPAND
data_type ('DN6TO', 'DN6TO', 6, sys_lcg, dnd$k_trail_over, 'sixbit', 18)
%EXPAND
data_type ('DN6TS', 'DN6TS', 6, sys_lcg, dnd$k_trail_sep, 'sixbit', 19)
%EXPAND
data_type ('DN6U', 'DN6U', 6, sys_lcg, dnd$k_unsigned, 'sixbit', 18)
%EXPAND
data_type ('DN7LO', 'DN7LO', 7, sys_lcg, dnd$k_lead_over, 'ascii', 18)
%EXPAND
data_type ('DN7LS', 'DN7LS', 7, sys_lcg, dnd$k_lead_sep, 'ascii', 19)
%EXPAND
data_type ('DN7TO', 'DN7TO', 7, sys_lcg, dnd$k_trail_over, 'ascii', 18)
%EXPAND
data_type ('DN7TS', 'DN7TS', 7, sys_lcg, dnd$k_trail_sep, 'ascii', 19)
%EXPAND
data_type ('DN7U', 'DN7U', 7, sys_lcg, dnd$k_unsigned, 'ascii', 18)
%EXPAND
data_type ('DN8LO', 'DN8LO', 8, sys_8bit, dnd$k_lead_over, 'ascii', 31)
%EXPAND
data_type ('DN8LS', 'DN8LS', 8, sys_8bit, dnd$k_lead_sep, 'ascii', 32)
%EXPAND
data_type ('DN8TO', 'DN8TO', 8, sys_8bit, dnd$k_trail_over, 'asciix',31)
%EXPAND
data_type ('DN8TS', 'DN8TS', 8, sys_8bit, dnd$k_trail_sep, 'ascii', 32)
%EXPAND
data_type ('DN8U', 'DN8U', 8, sys_8bit, dnd$k_unsigned, 'ascii', 31)
%EXPAND
data_type ('DN9LO', 'DN9LO', 9, sys_lcg, dnd$k_lead_over, 'ebcdic', 18)
%EXPAND
data_type ('DN9LS', 'DN9LS', 9, sys_lcg, dnd$k_lead_sep, 'ebcdic', 19)
%EXPAND
data_type ('DN9TO', 'DN9TO', 9, sys_lcg, dnd$k_trail_over, 'ebcdic', 18)
%EXPAND
data_type ('DN9TS', 'DN9TS', 9, sys_lcg, dnd$k_trail_sep, 'ebcdic', 19)
%EXPAND
data_type ('DN9U', 'DN9U', 9, sys_lcg, dnd$k_unsigned, 'ebcdic', 18)
%EXPAND
end_class ! call MACRO end_class
%SBTTL 'Display Numeric date table (DND)'
!++
! .hl 3 Display Numeric data table (>dnd>)
! The format for the display numeric data table is below. This
! table is indexed by the data subtype (within its class).
!
! .literal
!--
$field
dnd_fields =
SET
!++ copy
dnd$v_byt_siz = [$bits(6)], ! byte size
dnd$v_sys_orig = [$bits(3)], ! system of origin
dnd$v_sign_type = [$bits(3)], ! sign type indicator
dnd$v_ovp_max_index = [$byte], ! maximum index of OVP
dnd$v_max_length = [$bits(6)], ! maximum field length
dnd$v_char_set = [$bits(3)] ! character set code
!-- .end literal
TES;
LITERAL dnd$k_size = $field_set_size;
MACRO
dtt_dn ! \.p;Macro >\
!++
! declares an item to have the right structure and field attributes for the
! display numeric data table.
!--
= BLOCKVECTOR [dt_class_dnum_max + 1, dnd$k_size]
FIELD (dnd_fields) % ;
%SBTTL 'Class Packed Decimal data type definitions'
!++
! .hl 2 Class Packed Decimal
! .index class packed decimal
!
! Information to be provided for each data type:
! .list 1, "o"
! .le;Name as quoted string
! .le;Short name as quoted string
! .le;Byte size
! .le;System of origin
! .le;Maximum length allowed
! .le;Name of sign set to be used. Note that valid sign set names are:
! .list
! .le;DECSTD
! .index packed decimal sign set names
! .end list
! .le;size of sign set
! .end list
!--
! ; Literal for packed decimal sign table sizes:
LITERAL ! ;.s1.list 0, "o"
pds$k_decstd_max = 6; ! \.le;\
! ;.end list
! ; Literals for packed decimal sign set reference codes:
LITERAL ! ;.s 1 .list 0, "o"
ss_decstd = 0, ! ;.le;ss_decstd -- DEC-10/DEC-20 COBOL and VAX COBOL packed decimal standard sign set
ss_max = 1; ! ;.end list
declare_class ('pdec')
!
! The code following the call to declare_class is actually the body of the
! MACRO dt_class_pdec_def.
!
%EXPAND
data_type ('PD8', 'PD8', 8, 4, sys_8bit, 31, 'decstd')
%EXPAND
data_type ('PD9', 'PD9', 9, 4, sys_lcg, 18, 'decstd')
%EXPAND
end_class ! call MACRO end_class
%SBTTL 'Packed Decimal data table (PDD)'
!++
! .hl 3 Packed decimal data table (>pdd>)
! Format for the packed decimal data table. This table is indexed
! by the data subtype (within its class).
!
! .literal
!--
$field
pdd_fields =
SET
!++ copy
pdd$v_byt_siz = [$bits(6)], ! byte size
pdd$v_nbl_siz = [$bits(6)], ! nibble size (within a byte)
pdd$v_sys_orig = [$bits(3)], ! system of origin
pdd$v_max_length = [$byte], ! maximum field length
pdd$v_sign_set = [$bits(4)] ! addr of sign table to use
!-- .end literal
TES;
LITERAL pdd$k_size = $field_set_size;
MACRO
dtt_pd ! \.p;Macro >\
!++
! Declares an item to have the right structure and field attributes for
! the packed decimal data table.
!--
= BLOCKVECTOR [dt_class_pdec_max + 1, pdd$k_size]
FIELD (pdd_fields) % ;
%SBTTL 'Clean up'
LITERAL ! ; .hl 2 Maximum class code value
dix$k_max_class = dt_class; ! \ .p;Maximum class code used: >
! ; This is set to max class code used.
%PRINT (dix$k_max_class, '=', %NUMBER (dix$k_max_class))
!
! Clean up
!
UNDECLARE
dt_class,
dt_code,
%QUOTE declare_class,
%QUOTE data_type,
%QUOTE end_class;
%SBTTL 'Short routine names for BLISS36'
!++
! .hl 1 Short routine names for BLISS36
! Short routine names are needed for all global routines, for use by BLISS36.
! To make things look as neat as possible, this will be done by defining
! macros with the long names, which expand to the short names.
!
! Here are the long and short name equivalences:
! .list 0, "o"
!--
%IF %BLISS (BLISS36)
%THEN
MACRO
!
! Routines
!
!++ copy /strip .le;
dix$$bit_offset = dixbof %,
dix$$check_alignment = dixcal %,
dix$$check_ffd = dixcfd %,
dix$$check_type = dixctp %,
dix$$con_cb_fb = dixcxb %,
dix$$con_cb_xi = dixcxx %,
dix$$con_cf_fp = dixcxf %,
dix$$con_fbin = dixfbn %,
dix$$con_fb_cb = dixbxc %,
dix$$con_fb_xi = dixbxx %,
dix$$con_fp = dixfp %,
dix$$con_fp_cf = dixfxc %,
dix$$con_gen = dixgen %,
dix$$con_str = dixstr %,
dix$$con_dn = dixdn %,
dix$$con_dn_xi = dixdxx %,
dix$$con_xi_dn = dixxxd %,
dix$$con_pd = dixpd %,
dix$$con_pd_xi = dixpxx %,
dix$$con_xi_pd = dixxxp %,
dix$$con_xi_cb = dixxxc %,
dix$$con_xi_fb = dixxxb %,
dix$$con_dn_pd = dixdxp %,
dix$$con_dn_fb = dixdxf %,
dix$$con_pd_dn = dixpxd %,
dix$$con_pd_fb = dixpxf %,
dix$$con_fb_pd = dixfxp %,
dix$$con_fb_dn = dixfxd %,
dix$$copy_structure = dixcpy %,
dix$$des_by_det = dixdbd %,
dix$$fetch_bits = dixfbt %,
dix$$get_argadr = dixadr %,
dix$$incr_des = dixifd %,
dix$$adj_xi_scal = dixajx %,
dix$$port_hand = dixpeh %,
dil$$return_kludge = dilret %,
dix$$round_cf = dixrcf %,
dix$$stuff_bits = dixsbt %,
dil$$usr_intrfc_hand = diluih %,
dix$by_det = cvgen %,
dix$by_dix_des = xcgen %, ! [8] Insert missing pseudonym
dil$init = dilini %,
dix$mak_des_det = xdescr %,
dix$xcvpd = xcvpd %,
dix$xcvdn = xcvdn %,
dix$xcvfb = xcvfb %,
dix$xcvfp = xcvfp %,
dix$xcvst = xcvst %,
dix$xcfbdn = xcfbdn %,
dix$xcfbpd = xcfbpd %,
dix$xcdnfb = xcdnfb %,
dix$xcdnpd = xcdnpd %,
dix$xcpddn = xcpddn %,
dix$xcpdfb = xcpdfb %,
!-- .end list
!
! ; Data structures need short names, too:
!
! ;.list 0, "o"
!++ copy /strip .le;
dil$a_copyright = cpyrgh %, ! [7]
dil$g_module_version = modver %, ! [7]
dil$g_version = dilver %, ! [7]
dil$k_version = %NAME ('DIL%VE') %, ! [7]
dit$k_version = %NAME ('dit%ve') %, ! [7]
dix$a_copyright = cpyrgh %, ! [7]
dix$acst_ascii = dixasc %,
dix$acst_ebcdic = dixebc %,
dix$acst_sixbit = dixsix %,
dix$adtt_fbin = dixfbd %,
dix$adtt_fp = dixfpd %,
dix$adttx_st = dixsdx %,
dix$adtt_st = dixstd %,
dix$adtt_dn = dixdnd %,
dix$adtt_pd = dixpdd %,
dix$at_max_dt_cod = dixmdt %,
dix$ag_sys_bpunit = dixbpu %,
dix$g_module_version = modver %, ! [7]
dix$g_version = dixver %, ! [7]
dix$gg_debug = dixdbf %,
dil$gg_return_severity = dilsev %,
dil$gg_return_msg_id = dilmid %,
dil$gg_return_stat_val = dilstv %,
dix$g_library_version = libver %, ! [7]
dix$g_dixcst_version = cstver %, ! [7]
dix$k_dixcst_version = %NAME ('CST%VE') %, ! [7]
dix$k_version = %NAME ('DIX%VE') %, ! [7]
dix$adnovp_ascii = dixoa %,
dix$adnovp_asciix = dixoax %,
dix$adnovp_ebcdic = dixoe %,
dix$adnovp_sixbit = dixos %,
dix$apds_decstd = dixpds %;
!-- .end list
;
%FI ! End %IF %BLISS (BLISS36)
!++
! .HL 1 Clean up after XPORT
! XPORT seems to be in the habit of leaving the following definition
! lying around, but won't tolerate its existence at the start of a
! file. Therefore it must be UNDECLAREd here:
!--
UNDECLARE ! \\
%QUOTE $descriptor; ! \\