Google
 

Trailing-Edge - PDP-10 Archives - bb-r775d-bm_tops20_ks_upd_4 - 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;                 ! \\