Trailing-Edge
-
PDP-10 Archives
-
cuspmar86binsrc_2of2_bb-fp63a-sb
-
10,7/dil/dilsrc/dixutl.bli
There are 21 other files named dixutl.bli in the archive. Click here to see a list.
%TITLE 'DIX Utility Routines'
MODULE dixutl
! 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 >DIXUTL
!
! The module DIXUTL contains base routines common to all data types and
! which must be included in all images -- utility routines, as it were.
!
! FACILITY: Data Conversion Routines (DIX)
!
! ABSTRACT:
!
! ENVIRONMENT:
!
! AUTHOR: David Dyer-Bennet, Creation Date: 11-Jan-82
!--
(IDENT = '2.0(50)' ! \.p;\
! **EDIT**
%REQUIRE ('DIXSWI.REQ') ! [%O'34']
%BLISS36 (
, ENTRY ( ! ; Entry symbols:
dixpeh, dixadr, dixctp, dixcfd, ! \
dixdbd, dixifd, dixcpy, dixfbt, dixsbt, ! \
dixstd, dixbof, dixfbd, dixbpu, dixajx ! \
)
)
) =
BEGIN
%SBTTL 'Declarations'
!++
! .hl 1 Require files
!--
REQUIRE 'DIXREQ.REQ'; ! \
!++
! .hl 1 Library files
!--
%sbttl 'Edit History' ! [7] Add this entire subsection
!++
! .hl 1 Edit History
!--
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 (10, '22-Sep-82', 'David Dyer-Bennet')
%( Always use long_relative addressing on VAX. )%
Edit (%O'30', '19-Jan-83', 'David Dyer-Bennet')
%( Update copyright notices, add mark at end of edit histories.
)%
Edit (%O'34', '19-May-83', 'David Dyer-Bennet')
%( Add DIXSWI require file to headings of all modules. DIXSWI
contains the BLISS32 addressing-mode declarations and the TOPS-10
OTS declaration to avoid invoking the losing default of .REQUESTING
the OTS library from whatever directory the compiler was called from
when the build ran.
)%
Edit (%O'35', '8-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
mark_versions ('DIX')
!++
! .hl 1 Debugging declarations
!--
!!dix$module_debug (off);
dix$module_debug (on);
!++
! .hl 1 Macros
!--
!++
! .hl 1 Literals
!--
!++
! .hl 1 Own storage
!--
! [7] Remove version number word
!++
! .hl 1 Global data
!--
!++
! .hl 2 Miscellaneous structures
! Small structures are grouped together in this section.
!--
GLOBAL
!
! ; Table of maximum data type codes within each class, used for
! ; error checking:
!
dix$at_max_dt_cod : VECTOR [dix$k_max_class + 1] ! \>\Wanted 1-origin.
PSECT (readonly_psect) ! \\Place in read-only storage.
PRESET ( [dt_string] = dt_class_string_max,
[dt_fbin] = dt_class_fbin_max,
[dt_fp] = dt_class_fp_max,
[dt_dnum] = dt_class_dnum_max,
[dt_pdec] = dt_class_pdec_max),
!
! ; Table of bits per unit for each supported system type:
!
dix$ag_sys_bpunit : VECTOR [sys_max + 1] ! \>\Really wanted 1-origin.
PSECT (readonly_psect) ! \\Place in read-only storage.
PRESET ( [sys_lcg] = 36, [sys_8bit] = 8);
%SBTTL 'Data type tables'
!++
! .hl 2 Data type tables
!
! Data tables for the various data type classes.
!
! These tables are indexed by the within-class part of the data type code.
!
! There is one table here for each class of data type supported. It
! contains information needed in all versions of the library; but it
! does not contain extensive data needed only when conversions
! involving that class are being performed.
!
! The tables are used mostly in error checking within utility
! routines.
!--
!++
! .hl 3 Alphanumeric strings
! The format of this table is defined in DIXLIB (>dtt_st>).
!
! The values used to initialize it are also there: they reside in
! macro >dt_class_string_def>. The table is initialized by declaring
! a macro here which is called when dt_class_string_def gets expanded;
! thus we control exactly how the table is initialized, although the
! data is entered in the library.
!--
MACRO
decl_string_item ! \.P;Macro \:
!++
! This macro gets called for each string data type when dt_class_string_def
! gets expanded. This definition of the macro produces preset-items
! which will statically initialize the dix$adtt_st structure.
!--
( ! ; Arguments:
class_code, item_name, short_name, type_code, byt_siz, sys_orig, length_spec ! \\.
) =
[type_code, std$v_byt_siz] = byt_siz,
[type_code, std$v_sys_orig] = sys_orig,
[type_code, std$v_lng_indic] = length_spec,
%;
GLOBAL ! ;.P;Global table
dix$adtt_st : ! \>\ the string data type table.
dtt_st ! \Type is\.
PSECT (readonly_psect) ! \Assign to \.
PRESET ( ! ; Initialize by calling
dt_class_string_def ! \\.
[0, std$v_byt_siz] = 0 ! Previous macro call leaves trailing ","
); ! End PRESET
!++
! .hl 3 Fixed-point binary
!
! The format of this table is defined in DIXLIB (>dtt_fbin>).
!
! The values used to initialize it are also there: they reside in
! macro >dt_class_fbin_def>. The table is initialized by declaring
! a macro here which is called when dt_class_fbin_def gets expanded;
! thus we control exactly how the table is initialized, although the
! data is entered in the library.
!--
MACRO
decl_fbin_item ! \.P;Macro \:
!++
! This macro gets called for each fbin data type when dt_class_fbin_def
! gets expanded. This definition of the macro produces preset-items
! which will statically initialize the dix$adtt_fbin structure.
!--
( ! ; Arguments:
class_code, item_name, short_name, type_code, length_type, fld_signed, ! \\
min_lng, max_lng, min_scale, max_scale, bpm_code ! \\.
) =
[type_code, fbd$v_variable] = %QUOTE %IF length_type EQL fbd$k_lng_variable
%THEN 1 %ELSE 0 %FI,
[type_code, fbd$v_signed] = %QUOTE %IF fld_signed EQL fbd$k_signed
%THEN 1 %ELSE 0 %FI,
[type_code, fbd$v_min_lng] = min_lng,
[type_code, fbd$v_max_lng] = max_lng,
[type_code, fbd$v_min_scale] = min_scale,
[type_code, fbd$v_max_scale] = max_scale,
[type_code, fbd$v_bpm_program] = UPLIT bpm_code,
! bpm_code provides parens
%;
GLOBAL ! ;.P;Global table
dix$adtt_fbin : ! \>\ the fbin data type table.
dtt_fbin ! \Type is\.
PSECT (readonly_psect) ! \Assign to \.
PRESET ( ! ; Initialize by calling
dt_class_fbin_def ! \\.
[0, fbd$v_bpm_program] = 0 ! Previous macro call leaves trailing ","
); ! End PRESET
!++
! .HL 3 Floating point
!
! The format of this table is defined in DIXLIB (>dtt_fp>).
!
! The values used to initialize it are also there: they reside in
! macro >dt_class_fp_def>. The table is initialized by declaring
! a macro here which is called when dt_class_fp_def gets expanded;
! thus we control exactly how the table is initialized, although the
! data is entered in the library.
!--
MACRO
decl_fp_item ! \.p;Macro \:
!++
! This macro gets called for each FP data type when dt_class_fp_def gets
! expanded. This definition of the macro produces preset items which will
! statically initialize the dix$adtt_fp structure.
!--
( ! ; Arguments:
class_code, item_name, short_name, type_code, representation, ! \\
exp_offset, mant_bits, fpm_code ! \\
) =
[type_code, fpd$v_representation] = representation,
[type_code, fpd$v_exp_offset] = exp_offset,
[type_code, fpd$v_mant_bits] = mant_bits,
[type_code, fpd$v_fpm_program] = UPLIT fpm_code,
%;
GLOBAL ! ;.P;Global table
dix$adtt_fp : ! \>\ the fp data type table.
dtt_fp ! \Type is\.
PSECT (readonly_psect) ! \Assign to \.
PRESET ( ! ; Initialize by calling
dt_class_fp_def ! \\.
[0, fpd$v_fpm_program] = 0 ! Previous macro call leaves trailing ","
); ! end Preset
!++
! .HL 3 Display numeric
!
! The format of this table is defined in DIXLIB (>dtt_dn>).
!
! The values used to initialize it are also there: they reside in
! macro >dt_class_dnum_def>. The table is initialized by declaring a
! macro here which is called when dt_class_dnum_def gets expanded;
! thus we control exactly how the table is initialized, although the
! data is entered in the library.
!--
MACRO
decl_dnum_item ! \.p;Macro \:
!++
! This macro gets called for each DNUM data type when dt_class_dnum_def
! gets expanded. This definition of the macro produces PRESET items which
! will statically initialize the dix$adtt_dn structure.
!--
( ! ; Arguements:
class_code, item_name, short_name, type_code, byte_size, ! \\
sys_orig, sign_type, char_set_name, max_length ! \\.
) =
[type_code, dnd$v_byt_siz] = byte_size,
[type_code, dnd$v_sys_orig] = sys_orig,
[type_code, dnd$v_sign_type] = sign_type,
[type_code, dnd$v_ovp_max_index] = %NAME ('ovp$k_', char_set_name, '_max'),
[type_code, dnd$v_max_length] = max_length,
[type_code, dnd$v_char_set] = %NAME ('cs_', char_set_name),
%;
GLOBAL ! ;.P;Global table
dix$adtt_dn : ! \>\ the display numeric data type table
dtt_dn ! \Type is \.
PSECT (readonly_psect) ! \Assign to \.
PRESET ( ! ; Initialize by calling
dt_class_dnum_def ! \\.
[0, dnd$v_byt_siz] = 0 ! Previous macro call leaves trailing ","
); ! End PRESET
!++
! .hl 3 Packed decimal
!
! The format of this table is defined in DIXLIB (>dtt_pd>).
!
! The values used to initialize the table are also there: they reside in
! macro >dt_class_pdec_def>. The table is initialized by declaring a macro
! here which is called when dt_class_pdec_def gets expanded; thus we control
! exactly how the table is initialized, although the data is entered in the
! library.
!--
MACRO
decl_pdec_item ! \.p;Macro \:
!++
! This macro gets called for each PDEC data type when dt_class_pdec_def
! gets expanded. This definition of the macro produces PRESET items which
! will statically initialize the dix$adtt_pd structure.
!--
(
class_code, item_name, short_name, type_code, byte_size, ! \\
nibble_size, sys_orig, max_length, sign_set ! !\\.
) =
[type_code, pdd$v_byt_siz] = byte_size,
[type_code, pdd$v_nbl_siz] = nibble_size,
[type_code, pdd$v_sys_orig] = sys_orig,
[type_code, pdd$v_max_length] = max_length,
[type_code, pdd$v_sign_set] = %NAME ('ss_', sign_set),
%;
GLOBAL ! ;.P;Global table
dix$adtt_pd : ! \>\ the packed numeric data type table
dtt_pd ! \Type is \.
PSECT (readonly_psect) ! \Assign to \.
PRESET ( ! ; Initialize by calling
dt_class_pdec_def ! \\.
[0, pdd$v_byt_siz] = 0 ! Previous macro call leavs trailing ","
); ! End PRESET
%SBTTL 'GLOBAL ROUTINE dix$$port_hand'
GLOBAL ROUTINE dix$$port_hand ! \.!=;.hl 1 \
! ; .index dix$$port_hand
!++
! By convention, this handler should be enabled by all portal
! routines to the DIX. (User interface routines use a different
! handler, in module DILINT.)
!
! This handler traps any signals that get up this high and
! returns them to the routine calling the enabling routine as the
! function return value (if any). This prevents errors from being
! "lost" in the sense of not being reported to the caller.
!
! Routine Value:
! Information for CHF, as described in BLISS condition handling
! documentation.
!
! Formal arguments:
! .list 1
!--
(
sig_vec, ! \.le;\: Signal vector, as
! ; described in BLISS condition
! ; handling documentation.
mech_vec, ! \.le;\: Mechanism vector, as
! ; described in BLISS condition
! ; handling documentation.
enabl_vec ! \.le;\: Enable vector, as
! ; described in BLISS condition
! ; handling documentation. The first
! ; parameter specified by the enabler is a
! ; local data segment in the enabler that
! ; can be used for temporary storage of
! ; error information.
) = ! ; .end list
BEGIN
MAP
sig_vec : REF VECTOR,
mech_vec : REF VECTOR,
enabl_vec : REF VECTOR;
BIND
cond = sig_vec [1] : condition_value,
return_value = mech_vec [ %BLISS16 (1) %BLISS36 (1) %BLISS32 (3)],
error_temp = .enabl_vec [1] : condition_value;
dix$routine_debug (off);
! ; .hl 2 Flow of code
IF .cond NEQ dix$unwind_cond ! ; .P;If not unwinding,
THEN
BEGIN
error_temp = .cond; ! ; store away condition value,
SETUNWIND () ! ; initiate unwind.
END
ELSE ! ; .P;When called during unwind,
return_value = .error_temp ! ; return condition value saved earlier.
END; ! END OF DIX$$PORT_HAND
%SBTTL 'GLOBAL ROUTINE dix$$copy_structure'
GLOBAL ROUTINE dix$$copy_structure ! \.!=;.hl 1 \
! ; .index dix$$copy_structure
!++
! Copy a structure. This is necessary because BLISS assignment only works
! on field references, which work on at most a fullword.
!
! Routine value: none
! Formal arguments:
! .list 1
!--
(
src_adr, ! \.le;\: Address of structure to copy
str_siz, ! \.le;\: Length in fullwords of structure
dst_adr ! \.le;\: Address of destination field
) : NOVALUE = ! ; .end list
BEGIN ! dix$$copy_structure
dix$routine_debug (off);
LOCAL
src_pnt,
dst_pnt;
dst_pnt = .dst_adr;
INCRA src_pnt FROM .src_adr TO .src_adr + (.str_siz - 1 ) * %UPVAL BY %UPVAL DO
BEGIN ! INCRA
.dst_pnt = ..src_pnt;
dst_pnt = .dst_pnt + %UPVAL;
END; ! INCRA
END; ! Dix$$copy_structure
%SBTTL 'GLOBAL ROUTINE dix$$get_argadr (LCG version)'
! LCG version of DIX$$GET_ARGADR
%IF %BLISS (BLISS36)
%THEN
GLOBAL ROUTINE dix$$get_argadr ! \.!=;.hl 1 \
! ; .index dix$$get_argadr
!++
! This routine is present only in the LCG/36 bit version.
!
! When passed the contents of a formal parameter of a routine
! called with the DEC-10/20 standard calling sequence, return the
! actual address of the first word of the argument, regardless of
! whether the field passed is display or computational.
!
! If an error (such as invalid format in the descriptors) is
! detected, signal that error to the calling routine (no handler
! is enabled at this level).
!
! Routine Value:
! The address of the first word of the actual argument.
!
! Side Effects:
! May signal a condition:
! dix$_unkargtyp
!
! Formal arguments:
! .list 1
!--
(
formal_param ! \.le;\: The value of a formal
! ; parameter from another routine
! ; called with the standard calling sequence.
) = ! ; .end list
BEGIN
BUILTIN
MACHOP, INCP;
MAP
formal_param : scs_arg;
BIND
arg_descr = .formal_param [scs$v_adr] : scs_descr;
REGISTER
arg_adr: REF scs_descr;
! ; .hl 2 Flow of Code
MACHOP (%O'415', arg_adr, formal_param, 0, on);
! ; This XMOVEI will place the adr of
! ; the argument (or its descriptor)
! ; in arg_adr.
SELECTONEU .formal_param [scs$v_type] OF
! ; .P;Process one alternative based on type field in scs argument
! ; list entry passed to us:
SET
[scs$k_for36_bool, scs$k_sbf36, scs$k_float36, scs$k_float72, !
scs$k_unspecified, ! [2] Treat unspecified as by ref
scs$k_sbf72, scs$k_fcmplx36, scs$k_asciz] :
!
! ; Argument is passed by reference; the address in the
! ; arg list is the address of the entry.
!
.arg_adr; ! ; Return address from arg list.
[scs$k_display] :
!
! ; Argument is passed by descriptor. Must
! ; retrieve address from pointer in descriptor.
!
BEGIN
LOCAL
byt_pntr;
byt_pntr = .arg_adr [scs$v_bytpntr]; ! ; Make local copy of byte pointer from descriptor.
INCP (byt_pntr); ! ; Increment to point to first byte of string.
MACHOP (%O'201', arg_adr, byt_pntr, 0, on);
! ; This MOVEI will force an effective adr
! ; calculation on the byte-pointer word
! ; and store the result in arg_adr;
! ; Thus the actual argument address becomes known.
! ; Note: I don't certify this to work in
! ; an extended addressing environment.
.arg_adr ! ; Return the address
END;
[OTHERWISE] :
!
! ; None of the above. We don't recognize the type specified.
!
SIGNAL (dix$_unkargtyp); ! \So \ to tell user.
TES ! Value of SELECTONE is value of dix$$get_argadr
END; ! END OF DIX$$GET_ARGADR
%FI ! %IF %BLISS (BLISS36)
%SBTTL 'GLOBAL ROUTINE dix$$fetch_bits'
GLOBAL ROUTINE dix$$fetch_bits ! \.!=;.hl 1 \
! ; .index dix$$fetch_bits
!++
! This routine fetches strings of bits (in order of significance) from any
! foreign record (or, for that matter, anywhere else; that's where it's useful)
! in local memory. It cannot fetch more than %BPVAL bits at a crack. It can,
! however, fetch across unit boundaries.
!
! Routine value:
! The bits fetched, or undefined if something failed (signal generated)
!
! Side Effects:
! Signal generated on error:
! List of conditions TBS
!
! Formal arguments:
!--
( ! ; .list 1
p_unit, ! \.le;\: Address of unit containing
! ; low-order bit to fetch
p_offset, ! \.le;\: Offset within that unit to !
! ; low-order bit
p_num_bits ! \.le;\: Number of bits to fetch
! ; (0 < .p_num_bits <= %bpval)
) = ! ; .end list
BEGIN
LOCAL
result,
unit,
offset,
bits_this_cycle,
bits_left;
!
! Initialize local variables
!
result = 0;
unit = .p_unit;
offset = .p_offset;
bits_left = .p_num_bits;
DO
BEGIN
bits_this_cycle = MIN (.bits_left, %BPVAL - .offset);
result <.p_num_bits - .bits_left, .bits_this_cycle> =
.(.unit) <.offset, .bits_this_cycle, 0>;
bits_left = .bits_left - .bits_this_cycle;
unit = .unit + %UPVAL;
offset = 0;
END
WHILE .bits_left GTR 0;
.result ! Value returned
END;
%SBTTL 'GLOBAL ROUTINE dix$$stuff_bits'
GLOBAL ROUTINE dix$$stuff_bits ! \.!=;.hl 1 \
! ; .index dix$$stuff_bits
!++
! This routine stuffes strings of bits (in order of significance) into any
! foreign record (or, for that matter, anywhere else; that's where it's useful)
! in local memory. It cannot stuff more than %BPVAL bits at a crack. It can,
! however, stuff across unit boundaries.
!
! Routine value:
! None
!
! Side Effects:
! Signal generated on error:
! List of conditions TBS
!
! Formal arguments:
!--
( ! ; .list 1
p_unit, ! \.le;\: Address of unit
! ; containing low-order bit to stuff
p_offset, ! \.le;\: Offset within that unit
! ; to low-order bit
p_num_bits, ! \.le;\: Number of bits to stuff
! ; (0 < .p_num_bits <= %bpval)
p_source_value ! \.le;\: Value to stuff
) : NOVALUE = ! ; .end list
BEGIN
LOCAL
unit,
offset,
bits_this_cycle,
bits_left;
!
! Initialize local variables.
!
unit = .p_unit;
offset = .p_offset;
bits_left = .p_num_bits;
DO
BEGIN
bits_this_cycle = MIN (.bits_left, %BPVAL - .offset);
(.unit) <.offset, .bits_this_cycle> =
.p_source_value <.p_num_bits - .bits_left, .bits_this_cycle>;
bits_left = .bits_left - .bits_this_cycle;
unit = .unit + %UPVAL;
offset = 0;
END
WHILE .bits_left GTR 0;
END;
%SBTTL 'Global Routine dix$$bit_offset'
GLOBAL ROUTINE dix$$bit_offset ! \.!=;.hl 1 \
! ; .index dix$$bit_offset
!++
! Given a unit and a bit offset (possibly large, positive or negative),
! compute the unit addressed and the offset within it.
!
! Routine value: NONE
!
! Formal arguments:
!--
( ! ; .s 1.list 1
in_unit, ! \.le;\: Base memory address
in_offset, ! \.le;\: bit offset from that address
out_unit_addr, ! \.le;\: Adr to write unit to
out_offset_addr ! \.le;\: Adr to write offset to
) : NOVALUE = ! ; .end list
BEGIN ! GLOBAL ROUTINE dix$$bit_offset
.out_unit_addr = .in_unit;
.out_offset_addr = .in_offset;
WHILE ..out_offset_addr LSS 0 DO
BEGIN
.out_offset_addr = ..out_offset_addr + %BPUNIT;
.out_unit_addr = ..out_unit_addr - 1;
END;
.out_unit_addr = ..out_unit_addr + ..out_offset_addr / %BPUNIT;
.out_offset_addr = ..out_offset_addr MOD %BPUNIT;
END; ! GLOBAL ROUTINE dix$$bit_offset
%SBTTL 'ROUTINE dix$$check_alignment'
ROUTINE dix$$check_alignment ! \.!=;.hl 1 \
! ; .index dix$$check_alignment
!++
! Check to see if the original-system alignment as described by the user
! is valid for the data type specified. If not, signal an alignment error.
! If so, return with no value.
!
! Routine value: None.
!
! Formal arguments:
!--
( ! ;.s 1.list 1
data_type, ! \.le;\: Data type of field
sys_origin, ! \.le;\: Code for system of origin
alignment ! \.le;\: Alignment value
) : NOVALUE = ! ;.END LIST
BEGIN ! ROUTINE dix$$check_alignment
MAP
data_type: data_type_sep;
CASE .data_type [dt_class_sep] FROM 1 TO dix$k_max_class OF ! ; Case on dt_class
SET ! ;.lm +4.!Cases
[dt_string]: ! \
!++
! Strings on the VAX must be byte aligned. Other systems can be
! aligned any old which way. String:
!--
IF .sys_origin EQL sys_8bit AND .alignment NEQ 0 THEN
SIGNAL (dix$_align);
[dt_fbin]: ! \
!++
! Fixed binary fields are all unit-aligned except for the variable
! length ones, which may be anywhere.
!
! On the lcg systems, variable length fields must fit in a word. This
! should be checked for when variable length fbin fields get implemented.
!--
IF NOT .dix$adtt_fbin [.data_type [dt_code_sep], fbd$v_variable] AND
.alignment NEQ 0 THEN
SIGNAL (dix$_align);
[dt_fp]: ! \
!++
! Floating-point fields are always unit-aligned.
!--
IF .alignment NEQ 0 THEN
SIGNAL (dix$_align);
[dt_dnum]: ! \
!++
! Display Numeric fields on the VAX must be byte aligned.
! Other systems can be aligned in any way.
!--
IF .sys_origin EQL sys_8bit AND .alignment NEQ 0 THEN
SIGNAL (dix$_align);
[dt_pdec]: ! \
!++
! Packed Decimal fields on the VAX must be byte aligned.
! Other systems can be aligned in any way.
!--
IF .sys_origin EQL sys_8bit AND .alignment NEQ 0 THEN
SIGNAL (dix$_align);
TES; ! ;.lm -4.!Cases
END; ! ROUTINE dix$$check_alignment
%SBTTL 'GLOBAL ROUTINE DIX$$CHECK_TYPE'
GLOBAL ROUTINE dix$$check_type ! \.!=;.hl 1 \
! ; .index dix$$check_type
!++
! Check the type-dependent information required in a foreign field
! descriptor. If this routine returns, the arguments passed were ok.
! If they are not ok, an appropriate condition is signalled.
!
! Routine value: None
!
! Side effects:
!
! Signals conditions as appropriate:
! .s 1.list 0, "o"
! dix$_invdattyp ! Class or type within class invalid
! dix$_invlng ! Length invalid for type specified
! dix$_invscal ! Scale invalid for type specified
! dix$_unksys ! Unknown system of origin
! .end list
!
! Formal arguments:
!--
( ! ;.s 1.list 1
dat_typ, ! \.le;\: Data type code
sys_orig, ! \.le;\: System of origin
fld_lng, ! \.le;\: Field length
scale ! \.le;\: Scale factor
) ! ;.end list
: NOVALUE = !
BEGIN ! Routine dix$$check_type
MAP
dat_typ : data_type_sep;
!
! ; .hl 2 Flow of Code
! ; Check validity of data class code.
!
IF .dat_typ [dt_class_sep] LSS 1 OR .dat_typ [dt_class_sep] GTR dix$k_max_class
THEN
SIGNAL (dix$_invdattyp); ! \
!
! ; .p;Check validity of within-class data type code.
!
IF .dat_typ [dt_code_sep] LSS 1 OR .dat_typ [dt_code_sep] GTR dix$at_max_dt_cod [.dat_typ [dt_class_sep]]
THEN
SIGNAL (dix$_invdattyp); ! \
!
! ; .p;Check system of origin.
!
IF .sys_orig LSS 1 OR .sys_orig GTR sys_max
THEN
SIGNAL (dix$_unksys); ! \
!++
! Check for necessity, presence, and validity of field length and
! scale factor.
!
! This code will be implemented piecemeal as data types are
! implemented which require it.
!--
CASE .dat_typ [dt_class_sep] FROM 1 TO dix$k_max_class OF
SET
[dt_string] :
!++
! Strings require length specification sometimes (we
! tell by the value in dix$adtt_st). Lengths must be
! positive if required.
!
! Scale factors are never used.
!--
IF .dix$adtt_st [.dat_typ [dt_code_sep], std$v_lng_indic] EQL std$k_lng_spec
! Length must be specified
AND .fld_lng LSS 1
THEN ! Length negative or 0
SIGNAL (dix$_invlng); ! \.p;\ if length is invalid.
[dt_fbin] :
!++
! Fixed-point binary always requires a scale factor. It
! requires a length if fbd$v_variable is set. The legal range
! of scale factors and lengths is stored for each data type.
!--
BEGIN ! Case dt_fbin
IF .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_variable]
THEN
BEGIN ! Type is variable-length
IF .fld_lng LSS .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_min_lng] OR
.fld_lng GTR .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_max_lng]
THEN
SIGNAL (dix$_invlng); ! \.p;\ if length is invalid.
END; ! Type is variable-length
IF .scale LSS .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_min_scale] OR
.scale GTR .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_max_scale]
THEN
SIGNAL (dix$_invscal); ! \.p;\ if scale is invalid.
END; ! Case dt_fbin
[dt_fp]: ! \.p;\
BEGIN ! ;.LM +4.!Case dt_fp
IF .fld_lng NEQ 0 THEN SIGNAL (dix$_invlng); ! ; Field length must be 0.
IF .scale NEQ 0 THEN SIGNAL (dix$_invscal); ! ; Scale factor must be 0.
END; ! ;.LM -4.!Case dt_fp
[dt_dnum]: ! \.p;\
!++
! Display numeric fields require a length specification.
! A maximum length is specified for each data type in the
! dix$adtt_dn table in the dnd$v_max_length entry. The
! field length must be less than or equal to the maximum
! length for the data type. For any field with a separate
! sign, the field length must be greater than or equal to 2.
! For any other sign type the field length must be greater
! than 1.
!--
BEGIN
IF (SELECTONE .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_sign_type] OF
SET
[dnd$k_lead_sep, dnd$k_trail_sep] : .fld_lng LSS 2;
[OTHERWISE] : .fld_lng LSS 1;
TES)
OR
(.fld_lng GTR .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length])
THEN ! Length out of range
SIGNAL (dix$_invlng); ! \.p;\ if length is invalid.
!++
! The scale factor must be valid. The legal scale
! factor range is dependant upon the data type and the
! length of the specified field. The following formula
! defines the valid scale factor values:
! .literal
! (-m + l) <= s <= m
! .end literal
! where "m" is the maximum field length for the given data
! type (minus 1 for a data type with a separate sign), "l"
! is the field length specified (minus 1 for a data type
! with a separate sign), and "s" is the specified scale
! factor. Note that the maximum field length value for
! each data type is located in the table dix$adtt_dn.
!--
SELECTONE .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_sign_type] OF
SET
[dnd$k_lead_sep, dnd$k_trail_sep] :
IF (.scale GTR .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length] - 1)
OR (.scale LSS -.dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length] + .fld_lng)
THEN SIGNAL (dix$_invscal); ! \.p;\ if scale is invalid.
[OTHERWISE] :
IF (.scale GTR .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length])
OR (.scale LSS -.dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length] + .fld_lng)
THEN SIGNAL (dix$_invscal); ! \.p;\ if scale is invalid.
TES
END;
[dt_pdec]: ! \.p;\
!++
! Packed decimal fields require a length specification.
! A maximum length is specified for each data type in the
! dix$adtt_pd table in the pdd$v_max_length entry. The
! field length must be less than or equal to the maximum
! length for the data type and greater than or equal to one.
!--
BEGIN
IF .fld_lng LSS 1 OR
.fld_lng GTR .dix$adtt_pd[.dat_typ[dt_code_sep], pdd$v_max_length]
THEN ! Length out of range
SIGNAL (dix$_invlng); ! \.p;\ if length is invalid.
!++
! The scale factor must be valid. The legal scale factor range
! is dependant upon the data type and the length of the specified
! field. The following formula defines the valid scale factor
! values:
! .literal
! (-m + 1) <= s <= m
! .end literal
! where "m" is the maximum field length for the given data type,
! "l" is the field length specified, and "s" is the specified
! scale factor. Note the the maximum field length value for each
! data type is located in the table dix$adtt_pd.
!--
IF (.scale GTR .dix$adtt_pd[.dat_typ[dt_code_sep], pdd$v_max_length])
OR (.scale LSS -.dix$adtt_pd[.dat_typ[dt_code_sep], pdd$v_max_length] + .fld_lng)
THEN SIGNAL (dix$_invscal) ! \.p;\ if scale is invalid.
END;
TES;
END; ! Routine dix$$check_type
%SBTTL 'GLOBAL ROUTINE DIX$$CHECK_FFD'
GLOBAL ROUTINE dix$$check_ffd ! \.!=;.hl 1 \
! ; .index dix$$check_ffd
!++
! Perform the checks on an FFD that are to be performed on each entry from
! a user routine that passes an FFD. If the FFD passes, the routine returns
! with no value. If the FFD fails, an appropriate condition is signalled.
!
! The checks performed by dix$$check_type are used here. In addition,
! Alignment checks are performed based on the data type.
!
! Routine value: None.
!
! Side effects:
!
! May signal any condition signalled by dix$$check_type.
!
! Formal arguments:
!--
( ! ; .s 1.list 1
ffd ! \.le;\: The address of a foreign field descriptor
) ! ; .end list
: NOVALUE =
BEGIN ! Routine dix$$check_ffd
MAP
ffd : REF forgn_descr;
dix$$check_type (.ffd [ffd$v_type], .ffd [ffd$v_sys_orig], .ffd [ffd$v_length], .ffd [ffd$v_scale]);
dix$$check_alignment (.ffd [ffd$v_type], .ffd [ffd$v_sys_orig], .ffd [ffd$v_align]);
END; ! Routine dix$$check_ffd
%SBTTL 'GLOBAL ROUTINE dix$$des_by_det'
GLOBAL ROUTINE dix$$des_by_det ! \.!=;.hl 1 \
! ; .index dix$$des_by_det
!++
!
! Make DIX Descriptor From Detailed Description
!
! Level = 1, DD = 1. Portal routine.
! Algorithm: Brute force. All information necessary is available.
!
! Routine value: Status value.
!
! Side Effects:
!
! May signal any condition signalled by dix$$check_type or dix$$check_alignment.
! May signal dix$_invbytsiz.
!
! Formal arguments:
!--
( ! ;.s 1.list 1
res_ffd, ! \.le;\: (by reference, written) The DIX descriptor to be produced
con_rec, ! \.le;\: (by reference) The record in which the field exists
sys_orig, ! \.le;\: (integer) A code for
! ; the system on which the record
! ; originated
byt_siz, ! \.le;\: (integer) The byte size to interpret the offset in
byt_off, ! \.le;\: (integer) The offset to the
! ; field in the record, in bytes (as
! ; defined above)
bit_off, ! \.le;\: (integer) The bit offset to
! ; the field within the selected
! ; byte
dat_typ, ! \.le;\: (integer) The code for the data type of the field
fld_lng, ! \.le;\: (integer) The length of
! ; the field in the natural
! ; units for the data type (value
! ; ignored if field is not variable length)
scal_fac ! \.le;\: (integer) The scale factor
! ; of the field if it is a fixed-point
! ; binary or display-numeric field
! ; (including packed decimal)
) = ! ; .end list
BEGIN
MAP
res_ffd : REF forgn_descr;
LOCAL
bit_disp;
!++
! .hl 2 Flow of Code
! This routine is an exception to the rule that checking of user
! arguments should be done at the interface level. The arguments for
! FFD making are checked here to avoid a horrible amount of code
! duplication in the routines for the umpteen interfaces to this.
!--
dix$$check_type (.dat_typ, .sys_orig, .fld_lng, .scal_fac); ! \\ Signals if fails
IF (.byt_siz LSS 1) OR (.byt_siz GTR .dix$ag_sys_bpunit [.sys_orig]) THEN
SIGNAL (dix$_invbytsiz); ! \ If byte size too small or large,
!
! ; Compute bit offset to lsb of field
!
bit_disp = (CASE .sys_orig FROM 1 to sys_ult OF
SET
[sys_8bit]: .byt_siz * .byt_off + .bit_off; ! ; On VAX this is simple
[sys_lcg]: (((.dix$ag_sys_bpunit [.sys_orig] - 1) - .byt_siz + 1)
! ; On LCG, not so simple
! ; Offset to first byte in first unit
+ .dix$ag_sys_bpunit [.sys_orig]*(.byt_off/(.dix$ag_sys_bpunit [.sys_orig]/.byt_siz))
! ; Offset to that byte in unit containing LSB of field
- .byt_siz*(.byt_off MOD (.dix$ag_sys_bpunit [.sys_orig]/.byt_siz))
! ; Offset to byte containing LSB of field
+ .bit_off); ! ; Include specified bit offset
[INRANGE, OUTRANGE]: ! ; If no known system,
SIGNAL (dix$_unksys); ! \
TES);
! ; .p;Compute FFD fields from bit displacement
res_ffd [ffd$v_unit] = .con_rec + .bit_disp/%BPUNIT;
res_ffd [ffd$v_offset] = .bit_disp MOD %BPUNIT;
res_ffd [ffd$v_align] = .bit_disp MOD .dix$ag_sys_bpunit [.sys_orig];
res_ffd [ffd$v_length] = .fld_lng;
res_ffd [ffd$v_scale] = .scal_fac;
res_ffd [ffd$v_type] = .dat_typ;
res_ffd [ffd$v_sys_orig] = .sys_orig;
dix$$check_alignment (.dat_typ, .sys_orig, .res_ffd [ffd$v_align]);
dix$success_cond
END; ! END OF dix$$des_by_det
%SBTTL 'GLOBAL ROUTINE dix$$incr_des'
GLOBAL ROUTINE dix$$incr_des ! \.!=;.hl 1 \
! ; .index dix$$incr_des
!++
! Increment String Descriptor.
!
! Level = 3, DD = 3.
!
! Algorithm: based on data type specified, increment spot pointed to by
! descriptor past one character, taking into account synchronization and
! alignment (this is a problem with all DEC-10/20 strings, and with
! PASCAL packed arrays of characters in packed records).
!
! Routine Value: None
!
! Side Effects: Signals if error detected.
!
! Formal arguments:
!--
( ! ;.s 1.list 1
ffd ! \.le;\: Address of descriptor pointing to
! ; string-type field. Descriptor is modified.
) : NOVALUE = ! ;.end list
BEGIN
LOCAL
delta,
byt_siz;
MAP
ffd : REF forgn_descr;
BIND
orig_bpu = dix$ag_sys_bpunit [.ffd [ffd$v_sys_orig]];
! ; Currently, this routine deals with class string, class display
! ; numeric and class packed decimal data only.
byt_siz =
(SELECTONE .ffd[ffd$v_dt_class] OF
SET
[dt_string] : .dix$adtt_st [.ffd [ffd$v_dt_type], std$v_byt_siz];
[dt_dnum] : .dix$adtt_dn [.ffd [ffd$v_dt_type], dnd$v_byt_siz];
[dt_pdec] : .dix$adtt_pd [.ffd [ffd$v_dt_type], pdd$v_byt_siz];
TES);
!
! ; Since this routine is roughly third level in the conversion routines, no
! ; check is necessary for validity of data type.
!
CASE .ffd [ffd$v_sys_orig] FROM 1 TO sys_max OF
SET
[sys_lcg] :
!
! 36-bit system specific
!
BEGIN
IF .ffd [ffd$v_align] LSSU .byt_siz
THEN
BEGIN ! Byte is at start of next word
delta = 2*.orig_bpu - .ffd [ffd$v_align];
ffd [ffd$v_align] = .orig_bpu;
END
ELSE
delta = 0;
delta = .delta - .byt_siz;
ffd [ffd$v_align] = .ffd [ffd$v_align] - .byt_siz;
END; ! 36-bit system-specific
[sys_8bit] :
!
! 8-bit system specific
!
BEGIN ! 8-bit system-specific
ffd [ffd$v_align] = (.ffd [ffd$v_align] + .byt_siz) MOD .orig_bpu;
delta = .byt_siz
END; ! 8-bit system-specific
!
! We could insert a check for invalid sys_orig here with an OUTRANGE
! CASE label. I'm not sure if we want to or not.
!
TES; ! Value of CASE is not used
!
! Common to all systems
!
delta = .delta + .ffd [ffd$v_offset];
WHILE .delta LSS 0 DO ! Grind down if we moved backwards
BEGIN
ffd [ffd$v_unit] = .ffd [ffd$v_unit] - 1;
delta = .delta + %BPUNIT
END;
ffd [ffd$v_unit] = .ffd [ffd$v_unit] + .delta/%BPUNIT;
ffd [ffd$v_offset] = .delta MOD %BPUNIT;
END; ! END OF dix$$incr_des
%SBTTL 'GLOBAL ROUTINE dix$$adj_xi_scal'
GLOBAL ROUTINE dix$$adj_xi_scal ! \.!=;.hl 1 \
! ; .index dix$$adj_xi_scal
!++
! Adjust XI Field to correspond to given Scale.
!
! Algorithm: Keeping the decimal point aligned, shift the decimal
! places of the XI field. In order to facilitate this, copy the XI
! digits into a temporary XI field (xi_tmp) as they are shifted.
!
! Routine value: Status value, either dix$_rounded or dix$status_cond.
!
! Formal Arguements:
!--
( ! ; .s 1 .list 1
dst_scal, ! \.le;\: the destination scale desired
xi_field ! \.le;\: the address of the XI field (the XI field is modified)
) = ! ; .end list
BEGIN ! begin dix$$adj_xi_scal routine
MAP xi_field : REF xi;
LOCAL c1,
shift : INITIAL(0),
xi_tmp : xi,
lowsig_lost;
lowsig_lost = 0; ! initialize
shift = .dst_scal - .xi_field[xi$v_scale]; ! calculate required shift
IF .shift GTR 0 ! if it is a positive shift
THEN BEGIN
INCR c1 FROM 0 TO .shift - 1 DO ! then shift in low order zeros
xi_tmp[xi$v_digit, .c1] = 0;
INCR c1 FROM xi$k_digits - .shift + 1 TO xi$k_digits DO ! be sure high order
IF .xi_field[xi$v_digit, .c1] NEQ 0 ! digits shifted out are zero
THEN SIGNAL (dix$_toobig); ! if not, signal an error.
END
ELSE IF .shift LSS 0 ! If it's a negative shift
THEN BEGIN ! then shift in high order zeros
INCR c1 FROM xi$k_digits + .shift + 1 TO xi$k_digits DO
xi_tmp[xi$v_digit, .c1] = 0;
INCR c1 FROM 0 TO -.shift - 1 DO ! & make sure low order digits shifted out
IF .xi_field[xi$v_digit, .c1] NEQ 0 ! are also zero, if any aren't zero then we
THEN BEGIN ! will lose a non-zero low order digit
lowsig_lost = 1; ! so indicate rounded and
EXITLOOP ! don't waste any time looking for more
END;
END;
! Now that the shift has been aligned, fill the rest of xi_tmp
! with the digits from xi_field. What we are doing here is making
! a temporary copy of the XI form which has the scale adjusted for
! our use.
IF .shift GEQ 0
THEN INCR c1 FROM 0 TO xi$k_digits - .shift DO
xi_tmp[xi$v_digit, .c1 + .shift] = .xi_field[xi$v_digit, .c1]
ELSE ! (if shift < 0)
INCR c1 FROM 0 TO xi$k_digits + .shift DO
xi_tmp[xi$v_digit, .c1] = .xi_field[xi$v_digit, .c1 - .shift];
INCR c1 FROM 0 TO xi$k_digits DO ! copy scale-adjusted temp XI form into
xi_field[xi$v_digit, .c1] = .xi_tmp[xi$v_digit, .c1]; ! perm XI form
(IF .lowsig_lost ! return status dix$_rounded if we
THEN dix$_rounded ! lost low order significant digits,
ELSE dix$success_cond) ! else return success status
END; ! end of routine DIX$$ADJ_XI_SCAL
END ! End of module
ELUDOM