github.com/PDP-10.stacken
1
0
Fork 0
mirror of https://github.com/PDP-10/stacken.git synced 2026-04-20 08:46:31 +00:00
Code Issues Projects Releases Wiki Activity
Files
master
PDP-10.stacken/files/stacken-tape-backup/dskb:10_7/dil/dilsrc/dixlib.bli
Lars Brinkhoff 6e18f5ebef Extract files from tape images. 
Some tapes could not be extracted.
2021-01-29 10:47:33 +01:00

2292 lines
83 KiB
Plaintext
Raw Permalink Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
%TITLE 'Library of definitions for the DIX'
!
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983, 1986.
! 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 )%
new_version (2, 1)
Edit (%O'51', '11-Jun-85', 'Sandy Clemens')
%( Update DIL for DIU support. Includes support complex floating-point
number conversion. FILES: DIXLIB.BLI, DIXUTL.BLI, DIXFP.BLI.
)%
Edit (%O'53', '3-Jul-86', 'Sandy Clemens')
%( Add remaining sources to V2.1 area. Update copyright notices. )%
! **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
MACRO ffd_flds (prefx) = ! THIS MACRO IS ADDED FOR DIU.
! IT WILL MAKE THE TRANSFORM STRUCTURE
! EASIER TO KEEP COMPATIBLE WITH DIL.
%NAME (prefx, '$v_unit') = [$address], ! Address of lowest unit
! containing some bit of the
! field
%NAME (prefx, '$v_length') = [$bits (16)], ! Length of field in "natural"
! units (listed explicitly
! with data type definitions)
%NAME (prefx, '$v_scale') = [$short_integer], ! Scale factor for fixed-point
! decimal-based data types
%NAME (prefx, '$v_offset') = [$bits (unit_offset_size)], ! Bit offset within
! addressable unit to
! low-order bit of
! field
%NAME (prefx, '$v_type') = [$bits (class_code_bits + type_code_bits)],
! Data type code
$overlay (%NAME (prefx, '$v_type')) blf$comma
%NAME (prefx, '$v_dt_type') = [$bits (type_code_bits)], ! Type subfield
%NAME (prefx, '$v_dt_class') = [$bits (class_code_bits)], ! Class subfield
$continue
%NAME (prefx, '$v_align') = [$bits (6)], ! Bit offset within original
! system addressable unit to
! low-order bit of field
%NAME (prefx, '$v_sys_orig') = [$bits (2)] ! system of origin code
%;
$field
ffd_fields =
SET
ffd_flds ('ffd')
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),
dix_max_cond = %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), 128, 127)
%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), 16, 15)
%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), 32, 31)
%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), 36, 35)
%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), 48, 47)
%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), 64, 63)
%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), 72, 70)
%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), 8, 7)
%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), 0, 0)
%EXPAND data_type ('UBF16', 'UBF16', fbd$k_lng_fixed, fbd$k_unsigned,0,0,0,0,
(bpm_move (0, 16), bpm_done), 16, 16)
%EXPAND data_type ('UBF32', 'UBF32', fbd$k_lng_fixed, fbd$k_unsigned,0,0,0,0,
(bpm_move (0, 32), bpm_done), 32, 32)
%EXPAND data_type ('UBF8', 'UBF8', fbd$k_lng_fixed, fbd$k_unsigned,0,0,0,0,
(bpm_move (0, 8), bpm_done), 8, 8)
%EXPAND data_type ('UBFVAR', 'UBFVAR', fbd$k_lng_variable, fbd$k_unsigned,0,36,0,0,
(bpm_move_var (0, 0), bpm_done), 0, 0)
! UBF128 is new for DIL V2.1
%EXPAND data_type ('UBF128', 'UBF128', fbd$k_lng_fixed, fbd$k_unsigned,0,0,-18,18,
(bpm_move (0, 128), bpm_done), 128, 128)
! UBF36 is new for DIL V2.1
%EXPAND data_type ('UBF36', 'UBF36', fbd$k_lng_fixed, fbd$k_unsigned,0,0,-18,18,
(bpm_move (0, 36), bpm_done), 36, 36)
! UBF64 is new for DIL V2.1
%EXPAND data_type ('UBF64', 'UBF64', fbd$k_lng_fixed, fbd$k_unsigned,0,0,-18,18,
(bpm_move (0, 64), bpm_done), 64, 64)
! UBF72 is new for DIL V2.1
%EXPAND data_type ('UBF72', 'UBF72', fbd$k_lng_fixed, fbd$k_unsigned,0,0,-18,18,
(bpm_move (0, 36), bpm_move (-36, 36), bpm_done), 72, 72)
%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
fbd$v_siz = [$byte], ! fld size in bits (necessary for DIU)
fbd$v_signif_bits = [$byte] ! for unsigned integers = # of bits used,
! for signed integers = # of significant bits (necessary for DIU)
!-- .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;
! Literals for complex/simple floating point types
$LITERAL fpd$k_complex = $DISTINCT,
fpd$k_simple = $DISTINCT,
fpd$k_typ_ult = $DISTINCT;
LITERAL fpd$k_typ_max = fpd$k_typ_ult - 1;
UNDECLARE fpd$k_typ_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 ), 64,
fpd$k_simple)
%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 ), 32, fpd$k_simple)
%EXPAND data_type ('FLOAT_36', 'FLOT36', fpd$k_lcg, 128, 27,
(fpm_sign (35), fpm_exp (27, 8), fpm_mant (26, 27), fpm_done ), 36,
fpd$k_simple)
%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 ), 72, fpd$k_simple)
%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 ), 64,
fpd$k_simple)
%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 ), 72, fpd$k_simple)
%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 ), 128,
fpd$k_simple)
%EXPAND data_type ('D_CMPLX', 'DCMPLX', 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 ),
64, fpd$k_complex)
%EXPAND data_type ('F_CMPLX', 'FCMPLX', fpd$k_vax, 128, 24,
(fpm_sign (15), fpm_exp (7, 8), fpm_mant1, fpm_mant (6, 7),
fpm_mant (31, 16), fpm_done ), 32, fpd$k_complex)
%EXPAND data_type ('F_CMPLX36', 'FCMP36', fpd$k_lcg, 128, 27,
(fpm_sign (35), fpm_exp (27, 8), fpm_mant (26, 27), fpm_done ),
36, fpd$k_complex)
%EXPAND data_type ('G_CMPLX', 'GCMPLX', 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 ),
64, fpd$k_complex)
%EXPAND data_type ('H_CMPLX', 'HCMPLX', 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 ),
128, fpd$k_complex)
%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
fpd$v_siz = [$short_integer], ! fld size in bits (necessary for DIU)
fpd$v_typ = [$byte] ! code indicates simple or complex fp type (for DIU)
!-- .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; ! \\
Reference in New Issue View Git Blame Copy Permalink