Trailing-Edge
-
PDP-10 Archives
-
bb-lw55a-bm
-
language-sources/dixfbn.bli
There are 21 other files named dixfbn.bli in the archive. Click here to see a list.
%TITLE 'Fixed-point Binary'
MODULE dixfbn
! 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 >dixfbn
!
! This module implements conversions of fixed-point binary data types,
! both signed and unsigned. This module implements the within-class
! conversions and the conversions to and from fixed intermediate (XI)
! form.
!--
(
IDENT = '2.1(53)' ! \.P;
! **EDIT**
%REQUIRE ('DIXSWI') ! [%O'34']
%BLISS36 (
, ENTRY ( ! ; .P;Entry names:
dixbxx, dixxxb, dixfbn ! \
)
)
) =
BEGIN
!++
! .hl 1 Require files
!--
REQUIRE 'DIXREQ'; ! \.p;\
%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', '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'53', '3-Jul-86', 'Sandy Clemens')
%( Add remaining sources to V2.1 area. Update copyright notices. )%
! **EDIT**
!-- .autoparagraph
mark_versions ('DIX')
!++
! .hl 1 Debugging declarations
!--
dix$module_debug (off);
!++
! .hl 1 OWN storage
!--
! [7] Remove version number word.
!++
! .hl 2 EXTERNAL STRUCTURES
!--
EXTERNAL ! ;.list 0, "o"
dix$adtt_fbin: dtt_fbin; ! \.le;
! ;.end list
!++
! .hl 2 EXTERNAL ROUTINES
!--
EXTERNAL ROUTINE ! ;.list 0, "o"
!++ copy /strip .le;
dix$$port_hand,
dix$$bit_offset: NOVALUE,
dix$$check_ffd: NOVALUE;
!-- .end list
%sbttl 'Routine XNEG'
ROUTINE XNEG ! \.!=;.hl 1 \
! ; .index XNEG
!++
! Negate an extended precision integer by taking the cb$k_base complement
! of it (i.e. two's complement for base two, tens-complement for base 10,
! etc.). This is done in one pass by propagating the carry as we go.
!
! SCH: Level = 2
!
! Routine value: NONE.
!
! Formal arguments:
!--
( ! ; .s 1.list 1
xval ! \.le;\: Adr of extended value
) : NOVALUE = ! ; .end list
BEGIN
MAP
xval: REF cb;
dix$routine_debug (off)
xval [0, cb$v_all] = ((cb$k_base - 1) - .xval [0, cb$v_dig]) + 1;
! Complement l.o. digit and add 1
debug_code (tty_put_quo ('Higher-order xneg results: '));
INCR ndx FROM 1 TO cb$k_segments - 1 DO ! For digits 1 to n
BEGIN
xval [.ndx, cb$v_all] = ((cb$k_base - 1) - .xval [.ndx, cb$v_dig]) +
.xval [.ndx - 1, cb$v_oflo];
debug_code (tty_put_integer (.xval [.ndx, cb$v_all], 10, 10));
END;
debug_code (tty_put_crlf ();
cbdmp (.xval));
END;
%SBTTL 'Routine XMUL'
ROUTINE XMUL ! \.!=;.hl 1 \
! ; .index XMUL
!++
! Multiply extended precision by single precision.
!
! SCH: Level = 2
!
! Routine value: 1 if dst overflow, else 0.
!
! Formal Arguments:
!--
( ! ; .s 1.list 1
m1, ! \.le;\: Adr of multiplicand vector
m2, ! \.le;\: Multiplier
dst ! \.le;\: Adr of destination vector
! ; (may be same as M1)
) = ! ; .end list
BEGIN
MAP
m1: REF cb,
dst: REF cb;
LOCAL
m1x, dstx, carry, temp;
carry = 0;
INCR m1x FROM 0 TO cb$k_segments-1 DO
BEGIN
temp = .m1 [.m1x,cb$v_dig] * .m2 + .carry;
dst [.m1x,cb$v_dig] = .temp <0, CB$K_BASE_BITS>;
carry = .temp <CB$K_BASE_BITS, %BPVAL - CB$K_BASE_BITS>;
END;
(IF .carry NEQ 0 THEN 1 ELSE 0) ! Return 1 if overflow, else 0
END;
%SBTTL 'Routine XDIV'
ROUTINE xdiv ! \.!=;.hl 1 \
! ; .index xdiv
!++
! Divide extended precision by single precision, yielding extended
! precision quotient and single precision remainder. Dividend must be
! positive, or results may be random.
!
! Quotient and dividend may be the same field.
!
! Think of each "chunk" of extended precision number as a digit in
! the base "b" representation of the number. See Knuth 4.3.1 for more
! detailed discussion of extended precision algorithms.
!
! SCH: Level = 2
!
! Routine Value: 0 if quotient non-zero, 1 if quotient zero. This can
! conveniently be used to terminate a divide-by-10 binary to decimal
! conversion loop at the earliest possible moment, and costs only about two
! instructions extra per segment in each divide call (assuming reasonable
! optimization).
!
! Formal Arguments:
!--
( ! ; .s 1.list 1
divdnd, ! \.le;\: Adr of dividend vector
divsor, ! \.le;\: Divisor
quotnt, ! \.le;\: Adr of quotient vector
rem ! \.le;\: Adr of remainder scalar
) = ! ; .end list
BEGIN
MAP
divdnd: REF cb,
quotnt: REF cb;
BIND
remndr = .rem;
LOCAL
quotient_zero;
remndr = 0;
quotient_zero = 1;
DECR ndx FROM cb$k_segments-1 TO 0 DO
BEGIN
LOCAL
temp;
temp = .remndr * cb$k_base + .divdnd [.ndx, cb$v_dig];
quotnt [.ndx, cb$v_dig] = .temp / .divsor;
! Integer division
if .temp / .divsor NEQ 0 THEN quotient_zero = 0;
remndr = .temp MOD .divsor;
END;
.quotient_zero
END;
%sbttl 'Routine dix$$con_fb_cb'
DIX$DEBUG (GLOBAL)
ROUTINE dix$$con_fb_cb ! \.!=;.hl 1 \
! ; .index dix$$con_fb_cb
!++
! Convert a specific fixed-point binary format (described by an FFD)
! to our canonical binary format (a sort of generic fixed-point binary).
!
! Algorithm: The binary field is described by a set of tuples in the
! dix$adtt_fbin (fixed binary data type table). These specify how to
! pick up the bits of the field in order and what to do with the sign.
! This routine implements the "pseudo-machine" which understands those
! tuples.
!
! The canonical binary format is described in library file DIXLIB.
!
! Routine value: None.
!
! Formal Arguments:
!--
( ! ; .s 1.list 1
fb_ffd, ! \.le;\: Adr of FFD for fbin field
cb_fld ! \.le;\: Adr of cb field (field is
! ; written to)
) : NOVALUE = ! ; .end list
BEGIN ! dix$$con_fb_cb
MAP
fb_ffd: REF forgn_descr,
cb_fld: REF cb;
dix$routine_debug (on)
LOCAL
cb_seg: BITVECTOR [cb$k_base_bits],
cb_seg_ndx,
cb_bit_ndx,
pseudo_pc,
pmp: REF BLOCKVECTOR [0, bpm$k_size] FIELD (bpm_fields);
!++
! .hl 2 Flow of Code
!
! Initialization:
! .list 0, " "
!--
cb_seg_ndx = 0; ! \.le;\
cb_bit_ndx = 0; ! \.le;\
cb_seg = 0; ! \.le;\
pseudo_pc = 0; ! \.le;\
pmp = .dix$adtt_fbin [.fb_ffd [ffd$v_dt_type], fbd$v_bpm_program]; ! \.le;\
! ;.end list
!++
! This UNTIL loop is the instruction execution of the pseudo-machine that
! reads the program pointed to by the FBD to control loading of the CB field.
!--
UNTIL .pmp [.pseudo_pc, bpm$v_opcode] EQL bpm$k_op_done DO
BEGIN ! ;.lm +4.!Pseudo-machine execution loop
dtype (on, 'bpm op = ', (.pmp [.pseudo_pc, bpm$v_opcode], 4),
' op 1 = ', (.pmp [.pseudo_pc, bpm$v_op_1], 5),
' op 2 = ', (.pmp [.pseudo_pc, bpm$v_op_2], 5));
CASE .pmp [.pseudo_pc, bpm$v_opcode] FROM 1 TO bpm$k_op_max OF ! ; Case on "opcodes"
SET ! ;.lm +4.!Case options
[bpm$k_op_move]: ! \.p;\ Move fixed bits to cb
BEGIN ! ;.lm +4.!Case: [bpm$k_op_move]
LOCAL
src_unit,
src_offset,
bit_cnt;
dix$$bit_offset (.fb_ffd [ffd$v_unit],
.fb_ffd [ffd$v_offset] + .pmp [.pseudo_pc, bpm$v_op_1],
src_unit, src_offset);
bit_cnt = .pmp [.pseudo_pc, bpm$v_op_2];
dtype (on, 'Unit = ', (.src_unit, 6),
' Offset = ', (.src_offset, 3),
' Bit count = ', (.bit_cnt, 3));
WHILE .bit_cnt GTR 0 DO ! ; While there are bits to be moved this "instruction"
BEGIN ! ;.lm +4.!While .bit_cnt gtr 0
LOCAL
bits_this_cycle;
! ; Compute number of bits to move this cycle
bits_this_cycle = MIN (.bit_cnt, cb$k_base_bits - .cb_bit_ndx,
%BPVAL - .src_offset);
dtype (on, 'Bits this cycle = ', (.bits_this_cycle, 3));
cb_seg <.cb_bit_ndx, .bits_this_cycle> =
.(.src_unit) <.src_offset, .bits_this_cycle, 0>;
! ; Update source field info
src_offset = .src_offset + .bits_this_cycle;
IF .src_offset GEQ %BPVAL
THEN
BEGIN ! src_unit empty
src_unit = .src_unit + %UPVAL;
src_offset = 0;
END; ! src_unit empty
! ; Update destination field info
cb_bit_ndx = .cb_bit_ndx + .bits_this_cycle;
IF .cb_bit_ndx GEQ cb$k_base_bits
THEN
BEGIN ! cb_seg full
dtype (on, 'Cb seg = ', (.cb_seg, 10));
cb_fld [.cb_seg_ndx, cb$v_all] = .cb_seg;
cb_seg = 0;
cb_seg_ndx = .cb_seg_ndx + 1;
cb_bit_ndx = 0;
END; ! cb_seg full
bit_cnt = .bit_cnt - .bits_this_cycle;
END; ! ;.lm -4.!While .bit_cnt gtr 0
END; ! ;.lm -4.!Case: [bpm$k_op_move]
[bpm$k_op_sign]: ! \.P;\Case
BEGIN ! ;.lm +4;.!Case bpm$k_op_sign
LOCAL
src_unit,
src_offset,
sign;
dix$$bit_offset (.fb_ffd [ffd$v_unit],
.fb_ffd [ffd$v_offset] + .pmp [.pseudo_pc, bpm$v_op_1],
src_unit, src_offset);
sign = .(.src_unit) <.src_offset, 1, 1>; ! ; Extend sign to full word
dtype (on, 'Unit = ', (.src_unit, 6),
' Offset = ', (.src_offset, 10, 3),
' Sign = ', (.sign, 10, 10));
cb_seg <.cb_bit_ndx, cb$k_base_bits - .cb_bit_ndx> = .sign;
! ; left-fill current cb_seg with sign
dtype (on, 'Cb seg = ', (.cb_seg, 10));
cb_fld [.cb_seg_ndx, cb$v_all] = .cb_seg;
INCR cb_ndx FROM .cb_seg_ndx + 1 to cb$k_segments - 1
DO ! ; Fill higher-order segments with sign
cb_fld [.cb_ndx, cb$v_all] = .sign;
cb_seg_ndx = cb$k_segments - 1;
cb_bit_ndx = 0;
END; ! ;.LM -4;.!Case bpm$k_op_sign
[bpm$k_op_move_var] : ! \.p;\Case
BEGIN ! ;.lm +4;.!Case bpm$k_op_move_var
SIGNAL (dix$_unimp) ! \\Unimplemented.
END; ! ;.lm -4;.!Case bpm$k_op_move_var
[bpm$k_op_sign_var] : ! \.p;\Case
BEGIN ! ;.lm +4;.!Case bpm$k_op_sign_var
SIGNAL (dix$_unimp) ! \\Unimplemented.
END; ! ;.lm -4;.!Case bpm$k_op_sign_var
TES; ! ;.lm -4.!Case options
pseudo_pc = .pseudo_pc + 1; ! ; Increment instruction pointer
END; ! ;.lm -4.!Pseudo-machine execution loop
!++
! Process the "done" (bpm$k_op_done) instruction. This is mostly end
! cleanup. This is done outside the while loop so that detection of the
! "done" instruction could conveniently be used to terminate the loop.
!--
IF .cb_bit_ndx NEQ 0 THEN
BEGIN ! ; Move partial segment to cb.
cb_fld [.cb_seg_ndx, cb$v_all] = .cb_seg;
END; ! Move partial segment to cb
INCR i FROM .cb_seg_ndx + 1 TO cb$k_segments - 1 DO
cb_fld [.i, cb$v_all] = 0; ! ; Clear unused high-order segments.
debug_code (
tty_put_quo ('CB extracted from FB = ');
cbdmp (.cb_fld);
tty_put_crlf ());
END; ! Routine dix$$con_fb_cb
%SBTTL 'ROUTINE dix$$con_cb_xi'
dix$debug (GLOBAL)
ROUTINE dix$$con_cb_xi ! \.!=;.hl 1 \
! ; .index dix$$con_cb_xi
!++
! Convert canonical binary (CB) to fixed intermediate (XI).
!
! SCH: Level = 3, DD = 3.
!
! Algorithm: Divide CB by 10 repeatedly, storing the remainders in
! successively higher-ordered positions in the XI field mantissa.
!
! Do not store low-order zeroes. Instead, count them and adjust scale
! factor.
!
! Routine value: NONE
!
! Formal Arguments:
!--
( ! ; .S 1 .LIST 1
cb_field, ! \.le;\: address of cb field.
! ; This field is trashed
xi_field ! \.le;\: address of xi field.
! ; This is filled in. The scale
! ; factor specified is used.
) ! ; .END LIST
: NOVALUE =
BEGIN ! ROUTINE dix$$con_cb_xi
MAP
cb_field: REF cb,
xi_field: REF xi;
dix$routine_debug (on)
LOCAL ! ; .hl 2 LOCAL declarations
sig, ! \.p;\this is set if a non-zero digit is generated
quotient_zero, ! \.p;\this is set if XDIV returns a zero quotient
! ; (this means no more information in field).
cb_sign, ! \.p;\hold CB sign.
xi_digit_ndx; ! \.p;\index into XI digits vector
! ; .hl 2 Flow of Code
sig = 0;
xi_digit_ndx = 0;
!++
! If CB field we have made is negative, negate it and set the sign.
! .s1
!--
IF .cb_field [cb$k_segments - 1, cb$v_sign]
THEN
BEGIN
dtype (on, 'Negating cb field and setting sign');
xneg (.cb_field);
cb_sign = 1
END
ELSE
cb_sign = 0;
DO
BEGIN ! ;.lm +4;Loop until all digits generated.
LOCAL
digit;
quotient_zero = xdiv (.cb_field, 10, .cb_field, digit);
IF .quotient_zero AND (.digit EQL 0) THEN
EXITLOOP; ! Field is entirely zero
dtype (off, 'Digit = ', (.digit, 2),
' Quotient zero flag = ', (.quotient_zero, 2));
sig = .sig OR (.digit NEQ 0); ! ; Set significance if appropriate.
dtype (on, ' Significance = ', (.sig, 2));
IF NOT .sig
THEN
xi_field [xi$v_scale] = .xi_field [xi$v_scale] - 1 ! ; Decrement scale
ELSE
BEGIN ! ; or store digit, as appropriate.
xi_field [xi$v_digit, .xi_digit_ndx] = .digit;
xi_digit_ndx = .xi_digit_ndx + 1; ! ;.p;If xi_digit_ndx gets too
! ; big, the error is not detected and results are random.
! ; However, this can only happen if xi$k_digits is not increased
! ; to accommodate some new data type.
dtype (on, 'xi_digit_ndx = ', (.xi_digit_ndx, 3));
END
END ! ;.lm -4.!Loop until all digits generated
UNTIL .quotient_zero;
INCR ndx from .xi_digit_ndx TO xi$k_digits - 1 DO ! ; .p;Clear unused high-order digits
xi_field [xi$v_digit, .ndx] = 0;
xi_field [xi$v_sign] = .cb_sign; ! ; .p;Set xi sign same as CB sign.
END; ! ROUTINE dix$$con_cb_xi
%SBTTL 'ROUTINE dix$$con_xi_cb'
dix$debug (GLOBAL)
ROUTINE dix$$con_xi_cb ! \.!=;.hl 1 \
! ; .index dix$$con_xi_cb
!++
! Convert fixed intermediate to canonical binary (with scale factor
! specified).
!
! SCH: Level = 3, DD = 2.
!
! Routine value: Status value
!
! Formal arguments:
!--
( ! ; .s 1.list 1
xi_field, ! \.le;\: Address of xi field
cb_scale, ! \.le;\: Scale factor of CB
cb_field ! \.le;\: Address of CB field.
! ; The field is written.
) = ! ; .end list
BEGIN ! ROUTINE dix$$con_xi_cb
MAP
xi_field: REF xi,
cb_field: REF cb;
dix$routine_debug (on)
LOCAL ! .hl 2 LOCAL declarations
lo_place, ! \.p;\ Index of highest order XI digit
! ; to be dropped in the conversion.
sig_lost, ! \.p;\ Used to track lost significance
sig_started, ! \.p;\ Used to avoid multiplying 0 by 10
! ; when making CB
carry, ! \.p;\ Used in local extended-precision work
temp; ! \.p;\ Also used in local extended-precision work
! ; .HL 2 Flow of Code
sig_lost = 0;
lo_place = MAX (.xi_field [xi$v_scale] - .cb_scale - 1, -1);
IF .lo_place GEQ 0 THEN
BEGIN ! ; .lm +4;IF xi scale GTR cb scale:
BEGIN ! ; .LM +4;Check for lost significance:
DECR ndx FROM .lo_place TO 0 DO ! ; Loop backwards through truncated digits.
IF .xi_field [xi$v_digit, .ndx] NEQ 0 THEN ! ; If any digit is nonzero,
BEGIN
sig_lost = 1; ! ; We have truncated a non-zero low-order digit.
EXITLOOP ! ; Don't waste time looking for more.
END;
END; ! ; .LM -4.!Check for lost significance
BEGIN ! ; .lm +4;Round XI at lo_place
carry = 5;
INCR ndx FROM .lo_place TO xi$k_digits - 1 DO
BEGIN ! ; .lm +4;Step from lo_place to high order:
temp = .xi_field [xi$v_digit, .ndx] + .carry; ! ; Add carry to this digit.
IF .temp GTR 9 THEN
BEGIN ! ; .lm +4;If the digit overflows:
xi_field [xi$v_digit, .ndx] = .temp - 10; ! ; Reduce it
carry = 1; ! ; and set the carry.
END ! ; .lm -4.!If the digit overflows
ELSE
BEGIN ! ; .lm +4;If digit doesn't overflow:
xi_field [xi$v_digit, .ndx] = .temp; ! ; Store digit and
EXITLOOP; ! ; terminate rounding loop
END; ! ; .lm -4.!If the digit doesn't overflow
END; ! ; .lm -4.!Step from lo_place to high order
END; ! ; .lm -4.!Round XI at lo_place
END; ! ; .lm -4.!xi scale GTR cb scale
dtype (on, 'XI after rounding: ');
debug_code (xidmp (.xi_field);
tty_put_crlf ());
!++
! Now we will create the CB field by the old multiply-by-10-and-add
! technique. Note that this requires that the CB field be zero to start with.
!--
INCR ndx FROM 0 TO cb$k_segments - 1 DO
cb_field [.ndx, cb$v_all] = 0; ! ; Init all CB fields to 0.
sig_started = 0; ! Significant digit not seen yet
DECR xi_ndx FROM xi$k_digits - 1 TO .lo_place + 1 DO
! ; .p;Do multiply-and-add for each xi digit not truncated.
BEGIN ! ; .LM +4;Step from HO xi digit to LO
dtype (on, 'XI digit = ', (.xi_field [xi$v_digit, .xi_ndx], 3));
carry = .xi_field [xi$v_digit, .xi_ndx]; ! ; Init carry to next XI digit
sig_started = .sig_started OR (.carry NEQ 0); ! ; Note if digit is significant
IF .sig_started THEN
BEGIN ! ; .LM +4;If there has been a significant digit,
INCR cb_ndx FROM 0 TO cb$k_segments - 1 DO
BEGIN ! ; .LM +4;Step from LO cb segment to HO
temp = .cb_field [.cb_ndx, cb$v_dig] * 10 + .carry;
! ; temp = seg * 10 + digit + carry
cb_field [.cb_ndx, cb$v_dig] = .temp <0, cb$k_base_bits>;
! ; LO part of temp is new seg value.
carry = .temp <cb$k_base_bits, %BPVAL - cb$k_base_bits>;
! ; HO part of temp is new carry value.
dtype (on, 'TEMP = ', .temp,
' new seg value = ', .temp <0, cb$k_base_bits>,
' carry = ', .carry);
END; ! ; .LM -4.!Step from LO cb seg to HO
IF .carry NEQ 0 THEN ! ; If overflow,
SIGNAL (dix$_toobig); ! \
END; ! ; .LM -4.!If there has been a significant digit
END; ! ; .LM -4.!Step from HO xi digit to lo
debug_code (tty_put_quo ('CB produced = ');
cbdmp (.cb_field);
tty_put_crlf ());
!++
! Do post-adjustment of scale factor for CB field.
!--
INCR count FROM 1 TO MAX (0, (.cb_scale - .xi_field [xi$v_scale])) DO
IF xmul (.cb_field, 10, .cb_field) THEN
SIGNAL (dix$_toobig);
debug_code (tty_put_quo ('CB after post-scaling = ');
cbdmp (.cb_field);
tty_put_crlf ());
!++
! [4] CB field produced should not contain more than cb$k_precision significant
! bits. If it does, call it an overflow condition. This check replaces
! a previous check on the sign bit. That check was sufficient to guard against
! loss of accuracy, but this version of the check will make behavior consistent
! across systems. This is desirable for the users, and also makes it much
! easier to maintain a consistent test system.
!--
! [4] IF .cb_field [cb$k_segments - 1, cb$v_sign] THEN
! [4] SIGNAL (dix$_toobig);
IF .(cb_field [cb$k_segments - 1, cb$v_all]) ! [4]
<cb$k_base_bits - (cb$k_segments * cb$k_base_bits) + cb$k_precision, ! [4]
(cb$k_segments * cb$k_base_bits) - cb$k_precision, 0> NEQ 0 THEN ! [4]
SIGNAL (dix$_toobig); ! [4]
!++
! Copy sign from XI field.
!--
IF .xi_field [xi$v_sign] THEN
xneg (.cb_field);
!++
! Return either dix$_rounded or dix$success_cond, as appropriate.
!--
(IF .sig_lost THEN
dix$_rounded
ELSE
dix$success_cond)
END; ! ROUTINE dix$$con_xi_cb
%SBTTL 'ROUTINE dix$$con_cb_fb'
dix$debug (GLOBAL)
ROUTINE dix$$con_cb_fb ! \.!=;.hl 1 \
! ; .index dix$$con_cb_fb
!++
! Convert canonical binary to a fixed binary format.
!
! SCH: Level = 2, DD = 3.
!
! The canonical binary should be in twos-complement form. The scaling
! should be the same as what is expected in the fixed binary field.
!
! Algorithm: Move bits around. This is done using the BIM (Binary Inverse
! Machine), which runs the same programs as the BPM (see dix$$con_fb_cb) but
! does the moves in the opposite direction.
!
! This structure could be extended to handle fixed binary formats that do
! not use twos-complement to represent negative by making CB be a
! sign-magnitude representation and having an entry in the dix$adtt_fbin
! telling what style negation to use on the CB field before reformatting as
! fixed binary.
!
! Routine value: NONE
!
! Formal arguments:
!--
( ! ; .s 1.list 1
cb_field, ! \.le;\: Adr of CB field
fb_ffd ! \.le;\: Adr of ffd for FB field
) : NOVALUE = ! ; .end list
BEGIN ! GLOBAL ROUTINE dix$$con_cb_fb
MAP
cb_field: REF cb,
fb_ffd: REF forgn_descr;
dix$routine_debug (on)
LOCAL
fld_signed,
pseudo_pc,
cb_bit_ndx,
cb_seg_ndx,
cb_seg,
pmp: REF BLOCKVECTOR [0, bpm$k_size] FIELD (bpm_fields);
! ; .HL 2 Flow of Code
fld_signed = 0;
cb_seg_ndx = 0;
cb_bit_ndx = 0;
pseudo_pc = 0;
pmp = .dix$adtt_fbin [.fb_ffd [ffd$v_dt_type], fbd$v_bpm_program];
cb_seg = .cb_field [.cb_seg_ndx, cb$v_dig];
!++
! This loop is the instruction execution of the inverse pseudo-machine that
! reads the program pointed to by the FBD to control creation of an FB field
! from the CB.
!--
UNTIL .pmp [.pseudo_pc, bpm$v_opcode] EQL bpm$k_op_done DO
BEGIN ! ;.LM +4;BIM instruction loop:
dtype (on, 'bpm op = ', (.pmp [.pseudo_pc, bpm$v_opcode], 4),
' op 1 = ', (.pmp [.pseudo_pc, bpm$v_op_1], 5),
' op 2 = ', (.pmp [.pseudo_pc, bpm$v_op_2], 5));
CASE .pmp [.pseudo_pc, bpm$v_opcode] FROM 1 TO bpm$k_op_max of ! ; Case on "opcodes"
SET ! ;.LM +4;Case options
[bpm$k_op_move]: ! \.p;\Move fixed bits to FB
BEGIN ! ;.LM +4.!Case move fixed
LOCAL
fb_unit, fb_offset, bit_cnt;
dix$$bit_offset (.fb_ffd [ffd$v_unit], ! ; Compute unit and offset
! ; for first FB field.
.fb_ffd [ffd$v_offset] + .pmp [.pseudo_pc, bpm$v_op_1],
fb_unit, fb_offset);
bit_cnt = .pmp [.pseudo_pc, bpm$v_op_2]; ! ; Get size (bits) of field.
dtype (on, 'bit_cnt = ', (.bit_cnt, 5));
WHILE .bit_cnt GTR 0 DO ! ; While there are still bits to move:
BEGIN ! ;.LM +4.!While bit_cnt gtr 0
LOCAL bits_this_cycle;
bits_this_cycle = MIN (.bit_cnt, cb$k_base_bits - .cb_bit_ndx,
%BPVAL - .fb_offset); ! ; Compute number of bits to move this cycle.
(.fb_unit) <.fb_offset, .bits_this_cycle> = ! ; Move the bits.
.cb_seg <.cb_bit_ndx, .bits_this_cycle>;
dtype (on, 'bits_this_cycle = ', (.bits_this_cycle, 5),
' fb_unit address = ', (.fb_unit, 6),
' fb_offset = ', (.fb_offset, 4));
dtype (on, 'fb_unit contents = ', ..fb_unit);
! ; Update CB field info
cb_bit_ndx = .cb_bit_ndx + .bits_this_cycle;
IF .cb_bit_ndx GEQ cb$k_base_bits THEN
BEGIN ! CB seg empty
cb_seg_ndx = .cb_seg_ndx + 1;
cb_seg = .cb_field [.cb_seg_ndx, cb$v_dig];
cb_bit_ndx = 0;
END; ! CB seg empty
dix$$bit_offset (.fb_unit, .fb_offset + .bits_this_cycle,
fb_unit, fb_offset); ! ; Update FB field info
bit_cnt = .bit_cnt - .bits_this_cycle; ! ; Update bit count
END; ! ;.LM -4.!While bit_cnt gtr 0
END; ! ;.LM -4.!Case move fixed
[bpm$k_op_sign]: ! \.p;\Move fixed sign to FB
BEGIN ! ;.LM +4.!Case sign fixed
LOCAL fb_unit, fb_offset;
fld_signed = 1; ! ; Remember field was signed.
dix$$bit_offset (.fb_ffd [ffd$v_unit], ! ; Find actual unit and
! ; offset from base (in FFD) and offset in program.
.fb_ffd [ffd$v_offset] + .pmp [.pseudo_pc, bpm$v_op_1],
fb_unit, fb_offset);
(.fb_unit) <.fb_offset, 1> = .cb_field [cb$k_segments - 1, cb$v_sign];
! ; Set sign from sign of CB_field.
END; ! ;.lm -4.!Case sign fixed
[bpm$k_op_move_var]: ! \.p;\Move variable bits to FB
BEGIN ! ;.LM +4.!Case move variable
SIGNAL (dix$_unimp); ! \\Not yet implemented
END; ! ;.LM -4.!Case move variable
[bpm$k_op_sign_var]: ! \.p;\Move variable sign to FB
BEGIN ! ;.LM +4.!Case sign variable
SIGNAL (dix$_unimp); ! \\Not yet implemented
END; ! ;.lm -4.!Case sign variable
TES; ! ;.LM -4.!Case options
pseudo_pc = .pseudo_pc + 1; ! ; Increment instruction pointer
END; ! ;.LM -4.!BIM instruction loop:
!++
! Process the "done" (bpm$k_op_done) instruction. This is mostly
! end cleanup. It is outside the loop because detection of the "done"
! instruction was a very convenient way to terminate the until loop.
!--
BEGIN ! ;.lm+4; Remaining HO of CB must equal sign
LOCAL sign;
sign = .cb_field [cb$k_segments - 1, cb$v_sign];
IF .sign AND NOT .fld_signed THEN SIGNAL (dix$_unsigned);
! ; Signal error if negative moved to unsigned.
sign = .sign <0, 1, 1>; ! ; Extend sign to fill word.
IF .cb_seg <.cb_bit_ndx, cb$k_base_bits - .cb_bit_ndx, 1> NEQ .sign
THEN ! ; Check remains of current segment
SIGNAL (dix$_toobig);
INCR ndx FROM .cb_seg_ndx + 1 TO cb$k_segments - 1 DO ! ; and all
IF .cb_field [.ndx, cb$v_dig] NEQ .sign <0, cb$k_base_bits> ! ; higher-order segments.
THEN
SIGNAL (dix$_toobig); ! \.p;\ if segments don't match sign
END; ! Remaining HO of CB must equal sign
END; ! GLOBAL ROUTINE dix$$con_cb_fb
%SBTTL 'GLOBAL ROUTINE dix$$con_fb_xi'
GLOBAL ROUTINE dix$$con_fb_xi ! \.!=;.hl 1 \
! ; .index dix$$con_fb_xi
!++
! Convert fixed-point binary to fixed intermediate form.
!
! SCH: Level = 2, DD = 2.
!
! Algorithm: Unfortunately, it's fairly messy to try to use any
! optimized hardware instructions or run-time support routines to do
! this, because the field being converted will not always fit into the
! size field that the instructions or whatever will work with.
!
! Option 1 is not an option, it's a necessity: write a
! system-independent routine to convert binary to packed decimal. This
! will do the following:
! .list 0, "o"
! .le;Convert fixed-point binary to binary intermediate form
! (DIX$$CON_FB_XB).
! .le;Convert binary intermediate to fixed intermediate mantissa
! (DIX$$CON_XB_XI).
! .le;Adjust XI scale factor.
! .end list
!
! Option 2 could be done and would help performance in most cases:
! write machine-specific routines to use optimized hardware instructions
! to perform the conversion as efficiently as possible. When the field
! size won't fit, fall back on option 1 (this is why that is a required
! option). This should be kept in mind as an optimization for version 2
! if performance is unsatisfactory.
!
! Routine value: None.
!
! Formal arguments:
!--
( ! ;.s 1.list 1
src_ffd, ! \.le;\: Adr of FFD for source
xi_field ! \.le;\: Adr of XI field (field is written)
) : NOVALUE = ! ;.end list
BEGIN ! GLOBAL ROUTINE dix$$con_fb_xi
MAP
src_ffd: REF forgn_descr,
xi_field: REF xi;
dix$routine_debug (on)
LOCAL
cb_field: cb;
dix$$con_fb_cb (.src_ffd, cb_field); ! Signals if error
xi_field [xi$v_scale] = .src_ffd [ffd$v_scale]; ! Init xi scale (it will be
! adjusted as trailing zeroes are killed)
dix$$con_cb_xi (cb_field, .xi_field); ! Signals if error
END; ! GLOBAL ROUTINE dix$$con_fb_xi
%SBTTL 'GLOBAL ROUTINE dix$$con_xi_fb'
GLOBAL ROUTINE dix$$con_xi_fb ! \.!=;.hl 1 \
! ; .index dix$$con_xi_fb
!++
! Convert fixed intermediate to fixed binary.
!
! SCH: Level = 2, DD = 1.
!
! This takes care of scale factor adjustment. The technique is to
! convert xi to cb, then cb to fb.
!
! Routine value: status value.
!
! Formal arguments:
!--
( ! ;.s 1.list 1
xi_field, ! \.le;\: Adr of XI field (source)
dst_ffd ! \.le;\: Adr of FFD for destination.
! ; The field described is written to.
) = ! ;.end list
BEGIN ! GLOBAL ROUTINE dix$$con_xi_fb
MAP
xi_field: REF xi,
dst_ffd: REF forgn_descr;
dix$routine_debug (on)
LOCAL
cb_field: cb,
status_xi_cb: condition_value;
! Error check: ffd should describe an FBIN field
status_xi_cb = dix$$con_xi_cb (.xi_field, .dst_ffd [ffd$v_scale], cb_field);
IF NOT .status_xi_cb [sts$v_success] THEN
RETURN .status_xi_cb; ! If it ain't good, pass it on.
dix$$con_cb_fb (cb_field, .dst_ffd);
.status_xi_cb ! Return status
END; ! GLOBAL ROUTINE dix$$con_xi_fb
%SBTTL 'GLOBAL ROUTINE dix$$con_fbin'
GLOBAL ROUTINE dix$$con_fbin ! \.!=;.hl 1 \
! ; .index dix$$con_fbin
!++
! Portal for fixed point binary conversions.
!
! SCH: Level = 1, DD = 1.
!
! This routine functions by converting the source field to XI form
! and then the XI form to the destination field. XI form is documented
! in DIXLIB.
!
! Routine value: status value, one of the following:
! .s 1.list 1, "o"
! .le;Any dix$$check_ffd error
! .le;dix$_toobig
! .le;dix$_unsigned
! .le;dix$_unimp
! .le;dix$_rounded
! .end list
!
! Formal arguments:
!--
( ! ;.s 1.list 1
src_ffd, ! \.le;\: Adr of source field ffd
dst_ffd ! \.le;\: Adr of destination field ffd
) = ! ;.end list
BEGIN ! GLOBAL ROUTINE dix$$con_fbin
MAP
src_ffd: REF forgn_descr;
dix$routine_debug (on)
LOCAL
error_temp: VOLATILE,
xi_field: xi; ! Need to put the xi form somewhere
ENABLE dix$$port_hand (error_temp); ! \.p;
dix$$check_ffd (.src_ffd); ! ;.p;Check source ffd, signal if not ok.
dix$$check_ffd (.dst_ffd); ! ; Do same for destination ffd.
! xi_field [xi$v_scale] = .src_ffd [ffd$v_scale];
dix$$con_fb_xi (.src_ffd, xi_field); ! Signals if error
dix$$con_xi_fb (xi_field, .dst_ffd) ! Signals if error; May return warning code
END; ! GLOBAL ROUTINE dix$$con_fbin
END
ELUDOM