Trailing-Edge
-
PDP-10 Archives
-
bb-r775e-bm_tops20_ks_upd_5
-
sources/dil/dixfp.bli
There are 21 other files named dixfp.bli in the archive. Click here to see a list.
%TITLE 'Binary Floating-Point Data Conversion'
MODULE dixfp
! 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 >dixfp
!
! FACILITY: Data Conversion Routines (DIX)
!
! ABSTRACT: These routines implement conversion from binary floating point
! (FP) to canonical floating point (CF) and vs.
!
! ENVIRONMENT:
!
! AUTHOR: David Dyer-Bennet, Creation Date: 4-May-82
!--
(IDENT = '2.1(53)' ! \.P;\
! **EDIT**
%REQUIRE ('DIXSWI.REQ') ! [%O'34']
%BLISS36 (
, ENTRY ( ! ;.P;Entry names:
dixfp ! \
) ! ENTRY
) ! %BLISS36
) =
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'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
mark_versions ('DIX')
!++
! .HL 1 Debugging Declarations
!--
dix$module_debug (off)
!++
! .hl 1 OWN storage
!--
! [7] Remove version number word.
!++
! .HL 1 External references
!--
EXTERNAL ! ; Data items:
dix$adtt_fp: dtt_fp; ! \
EXTERNAL ROUTINE ! ; Routines:
! ; .list 0, " "
!++ Copy /strip .le;
dix$$bit_offset: NOVALUE,
dix$$check_ffd: NOVALUE,
dix$$port_hand,
dix$$stuff_bits: NOVALUE,
dix$$fetch_bits,
dix$$incr_des : NOVALUE;
!-- .end list
%SBTTL 'ROUTINE dix$$round_cf'
ROUTINE dix$$round_cf ! \.!=;.hl 1 \
! ; .index dix$$round_cf
!++
! Round canonical floating to specified number of bits of mantissa.
!
! Algorithm: "Unbiased rounding."
! Consider a floating point (magnitude) mantissa of m+n bits. We will round
! this to m bits in an unbiased fashion. The mantissa will be passed to
! us in the usual CF field. The discussion here ignores the division of the
! field into segments and treats it as a simple bit string.
!
! The mantissa looks like this: ...xxx`|xxx... where there are m x's before
! the vertical bar and n after. We will round at the bar. (The first mantissa
! bit is x(1). The one just before the bar is x(m). The one just after the
! bar is x(m+1). The last one is x(m+n).)
!
! First, represent the mantissa as follows: ...xxy`|zw where y is x(m),
! z is x(m+1), and w is the famous "sticky bit." W is 1 if any of x(m+2)
! through x(m+n) is 1, and is zero otherwise.
!
! In terms of this representation, round up if (y=1, z=1, w=0) or z=1 w=1.
! Round down in all other cases.
!
! When you round up, there is a possibility of a carry out of the most
! significant mantissa bit. If this happens, a single right normalization
! shift must be made (including exponent adjustment). When this happens,
! the LO bit is zero, so nothing is lost when it is shifted out.
!
! SCH: Level = 2
!
! Routine Values:
! .list 0, " "
! .le; 1 if bits which are lower order than y bit (as defined above) are
! set (in other words, if conversion is not exact)
! .le; 0 otherwise.
! .end list
!
! Formal Arguments:
!--
( ! ;.s 1.list 1
cf_fld, ! \.le;\: Adr of CF field to round
! ; (the field may be modified)
bits_kept ! \.le;\: Number of bits to keep
) = ! ;.END LIST
BEGIN ! Routine dix$$round_cf
MAP
cf_fld: REF cf;
dix$routine_debug (off)
LOCAL
cf_y_seg, ! Segment index of "y" bit
cf_y_bit, ! Bit index of "y" bit
Y,
cf_z_seg, ! segment index of "z" bit
cf_z_bit, ! Bit index of "z" bit
Z,
mant_seg, ! Segment being massaged
w; ! The "w" bit
!++
! .hl 2 Flow of Code
!
! First, find and remember the y and z bit locations.
!--
dtype (1, 'Bits_kept = ', (.bits_kept, 5));
cf_y_seg = (.bits_kept - 1) / cf$k_mantissa_seg_bits;
cf_y_bit = cf$k_mantissa_seg_bits - 1 - (.bits_kept - 1) MOD cf$k_mantissa_seg_bits;
mant_seg = .cf_fld [cf$v_mantissa, .cf_y_seg];
y = .mant_seg <.cf_y_bit, 1>;
cf_z_seg = .cf_y_seg;
cf_z_bit = .cf_y_bit - 1;
IF .cf_z_bit LSS 0 THEN
BEGIN
cf_z_seg = .cf_z_seg + 1;
cf_z_bit = cf$k_mantissa_seg_bits - 1;
END;
mant_seg = .cf_fld [cf$v_mantissa, .cf_z_seg];
z = .mant_seg <.cf_z_bit, 1>;
!++
! Then compute the "sticky bit" (w).
!--
w = 0;
IF .cf_z_bit GTR 0 THEN ! ; Check remainder of current seg, if any
! ; (to right of z bit only).
BEGIN
mant_seg = .cf_fld [cf$v_mantissa, .cf_z_seg];
w = .mant_seg <0, .cf_z_bit - 1> NEQ 0 ;
END;
INCR ndx FROM .cf_z_seg + 1 TO cf$k_mantissa_segs - 1 DO ! ; Look at lower order segments.
BEGIN
IF .cf_fld [cf$v_mantissa, .ndx] NEQ 0 THEN
BEGIN
w = 1;
EXITLOOP;
END;
END;
dtype (1, 'y = ', (.y, 2), ' z = ', (.z, 2), ' w = ', (.w, 2));
!++
! Now that y, z, and w are available, round.
!--
IF (.z AND .w) OR (.y AND .z AND NOT .w) THEN ! \\round up.
BEGIN ! ;.LM +4.!Round up
LOCAL carry;
carry = 1^.cf_y_bit; ! ; Add 1 to the y bit
dtype (1, 'Rounding up. Y_bit = ', .cf_y_bit, ' Initial carry = ', .carry);
DECR ndx FROM .cf_y_seg TO 0 DO ! ; and propagate carry upwards
BEGIN ! ;.LM +4.!Loop from LO to HO
LOCAL temp;
temp = .cf_fld [cf$v_mantissa, .ndx] + .carry;
carry = .temp <cf$k_mantissa_seg_bits, %BPVAL - cf$k_mantissa_seg_bits>;
cf_fld [cf$v_mantissa, .ndx] = .temp <0, cf$k_mantissa_seg_bits>;
dtype (1, 'Rounding. Ndx = ', (.ndx, 4), ' Temp = ', .temp, ' Carry = ', (.carry, 3));
IF .carry EQL 0 THEN EXITLOOP; ! ; If carry zero, stop propagating.
END; ! ;.LM -4.!Loop from LO to HO
IF .carry NEQ 0 THEN ! ; Need a right normalization shift:
BEGIN ! ;.LM +4.!Perform right normalization shift
LOCAL loan;
dtype (1, 'Scaling right 1.');
loan = 1;
INCR ndx FROM 0 TO .cf_y_seg DO ! ; Shift each seg right, HO to LO:
BEGIN ! ;.LM +4.!Shift each seg right
mant_seg = .cf_fld [cf$v_mantissa, .ndx];
cf_fld [cf$v_mantissa, .ndx] = .loan ^ (cf$k_mantissa_seg_bits - 1) +
.mant_seg ^ - 1; ! ; Put load at left and shift seg right.
loan = .mant_seg AND 1; ! ; Loan to next cycle the LO bit.
dtype (1, 'Ndx = ', (.ndx, 4), ' Mant_seg = ', .mant_seg,
' Resulting cf mantissa = ', .cf_fld [cf$v_mantissa, .ndx],
' Loan = ', (.loan, 3));
END; ! ;.LM -4.!Shift each seg right
cf_fld [cf$v_exponent] = .cf_fld [cf$v_exponent] + 1; ! ; Increment exponent to compensate
! ; for right normalization shift.
END; ! ;.LM -4.!Perform right normalization shift
debug_code (termo (0, 'CF after rounding = ');
cfdmp (.cf_fld);
tty_put_crlf ());
1 ! ; Value of 1 to return
END; ! ;.lm -4.!Round up
!++
! Return proper value. If all bits after y are zero, then "rounding"
! to that position produces an exact result; in this case return 0.
! If any bit past y is set (that is, if z is set or w is set), then
! rounding actually did something (either increased or decreased the
! value); in this case, return 1.
!--
RETURN ((.z NEQ 0) OR (.w NEQ 0));
END; ! Routine dix$$round_cf
%SBTTL 'ROUTINE dix$$con_fp_cf'
GLOBAL ROUTINE dix$$con_fp_cf ! \.!=;.hl 1 \
! ; .index dix$$con_fp_cf
!++
! Convert binary floating point to canonical floating form.
! CF form is defined in DIXLIB.
!
! SCH: Level = 2, DD = 3.
!
! Algorithm: The FP data table contains a pseudo-machine program for
! moving the various fields of a floating point number to the CF field.
! The "done" routine for the FPM understands the different floating
! representations well enough to convert the raw bit fields to the
! canonical representation.
!
! Routine value: None
!
! Formal Arguments:
!--
( ! ;.s 1.list 1
src_ffd, ! \.le;\: Adr of FFD for source FP field
cf_fld ! \.le;\: Adr of CF field to fill in
) : NOVALUE = ! ;.end list
BEGIN ! ROUTINE dix$$con_fp_cf
MAP
src_ffd: REF forgn_descr,
cf_fld: REF cf;
dix$routine_debug (off)
LOCAL
cf_mant_seg_ndx, ! Index of current mantissa segment
cf_mant_bit_ndx, ! Index of bit in current mant segment
cf_mant_seg, ! The segment currently being assembled
cf_exponent_bits, ! Used to save size of exponent found
pmp: REF BLOCKVECTOR [0, fpm$k_size] FIELD (fpm_fields),
pseudo_pc;
cf_mant_seg_ndx = 0;
cf_mant_bit_ndx = cf$k_mantissa_seg_bits - 1; ! Points to next bit to use
cf_mant_seg = 0;
pseudo_pc = 0;
pmp = .dix$adtt_fp [.src_ffd [ffd$v_dt_type], fpd$v_fpm_program];
cf_fld [cf$v_sign] = 0; ! This is an invalid sign value
cf_fld [cf$v_exponent] = 0;
UNTIL .pmp [.pseudo_pc, fpm$v_opcode] EQL fpm$k_op_done DO ! ; Until end of pseudo-program
BEGIN ! ;.lm +4.!fpm execution loop
dtype (1, 'FPM op = ', (.pmp [.pseudo_pc, fpm$v_opcode], 3), ' Op_1 = ',
.pmp [.pseudo_pc, fpm$v_op_1], ' Op_2 = ', .pmp [.pseudo_pc, fpm$v_op_2]);
CASE .pmp [.pseudo_pc, fpm$v_opcode] FROM 1 TO fpm$k_op_done - 1 OF ! ; Case on opcode
SET ! ;.lm +4.!Case on opcode
[fpm$k_op_sign]: ! \.p;
BEGIN ! ;.LM +4.!Case fpm$k_op_sign
LOCAL
src_unit, src_offset;
dix$$bit_offset (.src_ffd [ffd$v_unit], ! ; Find single sign bit
.src_ffd [ffd$v_offset] + .pmp [.pseudo_pc, fpm$v_op_1],
src_unit, src_offset); ! ; from FFD info and offset.
cf_fld [cf$v_sign] = (IF .(.src_unit) <.src_offset, 1, 0> THEN
cf$k_sign_neg ! ; On means negative.
ELSE
cf$k_sign_pos); ! ; Off means positive.
END; ! ;.LM -4.!Case fpm$k_op_sign
[fpm$k_op_exp]: ! \.p;
BEGIN ! ;.LM +4.!Case fpm$k_op_exp
LOCAL
src_unit, src_offset;
dix$$bit_offset (.src_ffd [ffd$v_unit],
.src_ffd [ffd$v_offset] + .pmp [.pseudo_pc, fpm$v_op_1],
src_unit, src_offset);
! ; This routine will die when we meet an exponent larger than
! ; a fullword, or not contiguous. Until then, it wins.
cf_fld [cf$v_exponent] = dix$$fetch_bits (.src_unit, .src_offset,
.pmp [.pseudo_pc, fpm$v_op_2]);
dtype (1, 'Unit = ', (.src_unit, 6), ' Offset = ', (.src_offset, 6),
' Exponent = ', .cf_fld [cf$v_exponent]);
cf_exponent_bits = .pmp [.pseudo_pc, fpm$v_op_2]; ! Remember size of exponent
END; ! ;.LM -4.!Case fpm$k_op_exp
[fpm$k_op_mant]: ! \.p;
BEGIN ! ;.LM +4.!Case fpm$k_op_mant
LOCAL bit_cnt, src_unit, src_offset;
bit_cnt = .pmp [.pseudo_pc, fpm$v_op_2];
src_unit = .src_ffd [ffd$v_unit];
src_offset = .src_ffd [ffd$v_offset] + .pmp [.pseudo_pc, fpm$v_op_1] + 1;
WHILE .bit_cnt GTR 0 DO ! ; As long as there are bits to move,
BEGIN ! ;.LM +4.!WHILE .bit_cnt GTR 0
LOCAL
bits_this_cycle;
bits_this_cycle = MIN (.bit_cnt, .cf_mant_bit_ndx + 1);
dix$$bit_offset (.src_unit, .src_offset - .bits_this_cycle,
src_unit, src_offset);
cf_mant_seg <.cf_mant_bit_ndx - .bits_this_cycle + 1, .bits_this_cycle> =
dix$$fetch_bits (.src_unit, .src_offset, .bits_this_cycle);
dtype (1, 'Unit = ', (.src_unit, 6), ' Offset = ', (.src_offset, 6),
' Mantiss seg = ', .cf_mant_seg);
cf_mant_bit_ndx = .cf_mant_bit_ndx - .bits_this_cycle;
IF .cf_mant_bit_ndx LSS 0 THEN ! ; If mantissa segment full,
BEGIN ! ;.lm +4.!Mantissa segment full
! ; Store it away and update indices.
cf_fld [cf$v_mantissa, .cf_mant_seg_ndx] = .cf_mant_seg;
cf_mant_seg_ndx = .cf_mant_seg_ndx + 1;
cf_mant_seg = 0;
cf_mant_bit_ndx = cf$k_mantissa_seg_bits - 1;
END; ! ;.LM -4.!Mantissa segment full
bit_cnt = .bit_cnt - .bits_this_cycle;
END; ! ;.LM -4.!WHILE .bit_cnt GTR 0
END; ! ;.LM -4.!Case fpm$k_op_mant
[fpm$k_op_mant1]: ! \.p;
BEGIN ! ;.LM +4.!Case fpm$k_op_mant1
cf_mant_seg <cf$k_mantissa_seg_bits - 1, 1> = 1;
cf_mant_bit_ndx = cf$k_mantissa_seg_bits - 2;
END; ! ;.LM -4.!Case fpm$k_op_mant1
TES; ! ;.lm -4.!Case on opcode
pseudo_pc = .pseudo_pc + 1;
END; ! ;.lm -4.!fpm execution loop
!++
! Complete any segment in progress at the end of the loop.
!--
debug_code (termo (off, 'CF raw bits before completion: ');
cfdmp (.cf_fld);
tty_put_crlf ());
IF .cf_mant_bit_ndx NEQ cf$k_mantissa_seg_bits - 1 THEN ! ; If some stuff in current segment,
BEGIN ! ;.LM +4.!cf_mant_seg non-empty
cf_fld [cf$v_mantissa, .cf_mant_seg_ndx] = .cf_mant_seg;
cf_mant_seg_ndx = .cf_mant_seg_ndx + 1;
END; ! ;.LM -4.!cf_mant_seg non-empty
INCR ndx FROM .cf_mant_seg_ndx TO cf$k_mantissa_segs - 1 DO
cf_fld [cf$v_mantissa, .ndx] = 0; ! ; Clear unused low-order mantissa segments
!++
! Now, convert the raw fields (still in their original representations)
! to true canonical form.
!--
debug_code (termo (off, 'CF raw bits (after completion) = ');
cfdmp (.cf_fld);
tty_put_crlf ());
CASE .dix$adtt_fp [.src_ffd [ffd$v_dt_type], fpd$v_representation] FROM 1 TO fpd$k_rep_max OF
! ; Case on fp representation:
SET ! ;.lm +4.!Case on fp representation
[fpd$k_lcg]: ! \.p;\DEC-10/20 representation.
BEGIN ! ;.LM +4.!Case fpd$k_lcg
dtype (1, 'Wrap-up lcg representation');
IF .cf_fld [cf$v_exponent] EQL 0 AND ! Exponent is zero,
.cf_fld [cf$v_sign] EQL cf$k_sign_pos AND ! Sign was zero (mapped to positive)
(INCR ndx FROM 0 TO cf$k_mantissa_segs - 1 DO ! All of mantissa is zero
IF .cf_fld [cf$v_mantissa, .ndx] NEQ 0 THEN EXITLOOP 0)
THEN ! ; If field value was zero:
BEGIN ! ;.LM +4.!Field value is zero
dtype (1, 'Field is zero');
cf_fld [cf$v_sign] = cf$k_sign_zero; ! ; Set CF sign to zero.
END ! ;.LM -4.!Field value is zero
ELSE ! ; Else field value not zero:
BEGIN ! ;.LM +4.!Field value not zero
IF .cf_fld [cf$v_sign] EQL cf$k_sign_neg THEN ! ; If sign is negative:
BEGIN ! ;.lm +4.!Sign is negative
LOCAL carry;
dtype (1, 'Field is negative');
cf_fld [cf$v_exponent] = .dix$adtt_fp [.src_ffd [ffd$v_dt_type], fpd$v_exp_offset] - 1 -
.cf_fld [cf$v_exponent];
! ; Set exponent field (remember that representation
! ; is a one complement in this case).
carry = 1; ! ; Negate mantissa by performing
DECR ndx FROM cf$k_mantissa_segs - 1 TO 0 DO
! ; twos-complement from LO to HO
BEGIN ! ;.LM +4.!Negate mantissa
LOCAL temp;
temp = (NOT .cf_fld [cf$v_mantissa, .ndx] AND (1^cf$k_mantissa_seg_bits - 1)) +
.carry;
carry = .temp <cf$k_mantissa_seg_bits, 1, 0>;
cf_fld [cf$v_mantissa, .ndx] = .temp <0, cf$k_mantissa_seg_bits, 0>;
END ! ;.LM -4.!Negate mantissa
END ! ;.lm -4.!Sign is negative
ELSE ! ; If sign is positive:
BEGIN ! ;.LM +4.!Sign is positive
dtype (1, 'Field is positive');
cf_fld [cf$v_exponent] = .cf_fld [cf$v_exponent] -
.dix$adtt_fp [.src_ffd [ffd$v_dt_type], fpd$v_exp_offset];
! ; Apply offset in "done" instruction
! ; to exponent.
END ! ;.LM -4.!Sign is positive
END ! ;.LM -4.!Field value not zero
END; ! ;.LM -4.!Case fpd$k_lcg
[fpd$k_vax]: ! \.p;\VAX/PDP-11 representation
BEGIN ! ;.LM +4.!Case fpd$k_vax
DTYPE (ON, 'Wrap up VAX representation');
IF .cf_fld [cf$v_exponent] EQL 0 AND
.cf_fld [cf$v_sign] EQL cf$k_sign_pos THEN
! ; If field value is zero:
BEGIN ! ;.LM +4.!Field value is zero
cf_fld [cf$v_sign] = cf$k_sign_zero; !; Set CF sign to zero.
INCR ndx FROM 0 TO cf$k_mantissa_segs - 1 DO
cf_fld [cf$v_mantissa, .ndx] = 0; ! ; Clear mantissa.
END ! ;.LM -4.!Field value is zero
ELSE ! ; Else field value is not zero:
BEGIN ! ;.LM +4.!Field value is not zero
cf_fld [cf$v_exponent] = .cf_fld [cf$v_exponent] -
.dix$adtt_fp [.src_ffd [ffd$v_dt_type], fpd$v_exp_offset];
! ; Apply offset specified in "done"
! ; instruction to exponent value.
END ! ;.LM -4.!Field value is not zero
END; ! ;.LM -4.!Case fpd$k_vax
TES; ! ;.lm -4.!Case on fp representation
debug_code (
termo (off, 'Final form: ');
cfdmp (.cf_fld);
tty_put_crlf ()
);
!++
! Check for normalization (required of all representations)
!--
IF NOT (.cf_fld [cf$v_sign] EQL cf$k_sign_zero) AND
.cf_fld [cf$v_mantissa, 0] LSS 1^(cf$k_mantissa_seg_bits - 1)
THEN
SIGNAL (dix$_unnorm); ! \If not right, \
END; ! ROUTINE dix$$con_fp_cf
%SBTTL 'ROUTINE dix$$con_cf_fp'
global ROUTINE dix$$con_cf_fp ! \.!=;.hl 1 \
! ; .index dix$$con_cf_fp
!++
! Convert canonical floating to a specific binary floating point format.
!
! SCH: Level = 2
!
! Routine Value: Status value
!
! Formal Arguements:
!--
( ! ;.s 1.list 1
cf_fld, ! \.le;\: Adr of CF field
dst_ffd ! \.le;\: Adr of FFD for destination field
! ; (field written to)
) = ! ;.end list
BEGIN ! ROUTINE dix$$con_cf_fp
MAP
cf_fld: REF cf,
dst_ffd: REF forgn_descr;
dix$routine_debug (off)
LOCAL
stat_rounded,
pmp: REF BLOCKVECTOR [0, fpm$k_size] FIELD (fpm_fields),
pseudo_pc,
cf_mant_seg_ndx,
cf_mant_bit_ndx,
cf_mant_seg;
!++
! .hl 2 Flow of Code
!--
stat_rounded = dix$$round_cf (.cf_fld, .dix$adtt_fp [.dst_ffd [ffd$v_dt_type], fpd$v_mant_bits]);
! ; Round CF mantissa to precision needed for
! ; destination type.
!++
! Convert CF to appropriate representation:
! .lm +4
!--
CASE .dix$adtt_fp [.dst_ffd [ffd$v_dt_type], fpd$v_representation] FROM 1 TO fpd$k_rep_max OF
! ; Case on FP representation:
SET ! ;.lm +4.!Case on FP representation
[fpd$k_lcg]: ! \.p;\DEC-10/20 representation
BEGIN ! ;.LM +4.!Case fpd$k_lcg
CASE .cf_fld [cf$v_sign] FROM cf$k_sign_pos TO cf$k_sign_neg OF
! ; Case on sign of CF field:
SET ! ;.LM +4.!Case on sign of CF field
[cf$k_sign_zero]: ! \.p;\CF field is zero.
BEGIN ! ;.lm +4.!Case cf$k_sign_zero
cf_fld [cf$v_sign] = cf$k_sign_pos; ! ; Make CF sign positive
! ; (this will map to zero in FP representation).
END; ! ;.lm -4.!Case cf$k_sign_zero
[cf$k_sign_pos]: ! \.p;\CF field is positive.
BEGIN ! ;.lm +4.!Case cf$k_sign_pos
cf_fld [cf$v_exponent] = .cf_fld [cf$v_exponent] +
.dix$adtt_fp [.dst_ffd [ffd$v_dt_type], fpd$v_exp_offset];
! ; Apply exponent offset from DTT_FP
! ; to CF field exponent.
END; ! ;.lm -4.!Case cf$k_sign_pos
[cf$k_sign_neg]: ! \.p;\CF field is negative.
BEGIN ! ;.LM +4.!Case cf$k_sign_neg
LOCAL carry;
! ; The DEC-10/20 representation for negative is somewhat
! ; strange. A fuller explanation can be found in the
! ; appropriate hardware reference manual, or up in
! ; dix$$con_fp_cf.
cf_fld [cf$v_exponent] = .dix$adtt_fp [.dst_ffd [ffd$v_dt_type], fpd$v_exp_offset] - 1 -
.cf_fld [cf$v_exponent]; ! ; Apply exponent offset from dtt_fp
! ; to CF exponent and ones-complement.
! ; Perform twos-complement on the mantissa.
carry = 1; ! ; Initialize carry to 1 to get twos-comp.
DECR ndx FROM cf$k_mantissa_segs - 1 TO 0 DO
! ;.p; Loop from LO to HO through mantissa segs:
BEGIN ! ;.lm +4.!Loop through mantissa
LOCAL temp;
temp = (NOT .cf_fld [cf$v_mantissa, .ndx] AND (1^cf$k_mantissa_seg_bits - 1)) +
.carry; ! ; Ones-complement a segment (used bits only)
! ; and add carry.
carry = .temp <cf$k_mantissa_seg_bits, 1, 0>; ! ; Compute new carry.
cf_fld [cf$v_mantissa, .ndx] = .temp <0, cf$k_mantissa_seg_bits, 0>;
! ; Store back revised segment.
END ! ;.lm -4.!Loop through mantissa
END; ! ;.LM -4.!Case cf$k_sign_neg
TES; ! ;.LM -4.!Case on sign of CF field
END; ! ;.LM -4.!Case fpd$k_lcg
[fpd$k_vax]: ! \.p;\VAX/PDP-11 representation
BEGIN ! ;.lm +4.!Case fpd$k_vax
IF .cf_fld [cf$v_sign] EQL cf$k_sign_zero THEN ! ; Case CF sign is zero
BEGIN ! ;.lm +4.!If CF sign is zero
cf_fld [cf$v_sign] = cf$k_sign_pos;
cf_fld [cf$v_exponent] = 0
END ! ;.lm -4.!If CF sign is zero
ELSE ! ; Case CF sign not zero
BEGIN ! ;.LM +4.!Else CF sign not zero
cf_fld [cf$v_exponent] = .cf_fld [cf$v_exponent] +
.dix$adtt_fp [.dst_ffd [ffd$v_dt_type], fpd$v_exp_offset];
! ; Apply exponent offset from FPD.
END ! ;.LM -4.!Else CF sign not zero
END; ! ;.lm -4.!Case fpd$k_vax
TES; ! ;.lm -4.!Case on FP representation
!++
! Run the Floating Inverse Machine (FIM), which interprets the FPM program
! stored in the dtt_fp in such a way as to move the information from the CF
! field (converted to the proper representation by the code above) into the
! proper bits of the FP field.
!--
pseudo_pc = 0;
pmp = .dix$adtt_fp [.dst_ffd [ffd$v_dt_type], fpd$v_fpm_program];
cf_mant_seg_ndx = 0;
cf_mant_bit_ndx = cf$k_mantissa_seg_bits - 1;
cf_mant_seg = .cf_fld [cf$v_mantissa, .cf_mant_seg_ndx];
UNTIL .pmp [.pseudo_pc, fpm$v_opcode] EQL fpm$k_op_done DO ! ; Until end of pseudo-program
BEGIN ! ;.lm +4.!fpm execution loop
CASE .pmp [.pseudo_pc, fpm$v_opcode] FROM 1 TO fpm$k_op_done - 1 OF ! ; Case on opcode
SET ! ;.LM +4.!Case on opcode
[fpm$k_op_sign]: ! \.p;\Place sign bit in FP representation
BEGIN ! ;.LM +4.!Case fpm$k_op_sign
LOCAL dst_unit, dst_offset;
dix$$bit_offset (.dst_ffd [ffd$v_unit], ! ; Find sign bit in FP
.dst_ffd [ffd$v_offset] + .pmp [.pseudo_pc, fpm$v_op_1],
dst_unit, dst_offset); ! ; from FFD info and offset
(.dst_unit) <.dst_offset, 1> = (CASE .cf_fld [cf$v_sign] FROM cf$k_sign_pos TO cf$k_sign_neg OF
SET
[cf$k_sign_neg]: 1;
[cf$k_sign_pos]: 0;
[cf$k_sign_zero]: SIGNAL (dix$_impossible);
TES);
END; ! ;.LM -4.!Case fpm$k_op_sign
[fpm$k_op_exp]: ! \.P;\Move exponent from CF to FP representation
BEGIN ! ;.lm +4.!Case fpm$k_op_exp
LOCAL dst_unit, dst_offset, exp;
exp = .cf_fld [cf$v_exponent];
IF .exp <.pmp [.pseudo_pc, fpm$v_op_2], %BPVAL - .pmp [.pseudo_pc, fpm$v_op_2]> NEQ 0
THEN SIGNAL (dix$_toobig); ! ; Exponent overflow if HO (unused) bits not 0.
dix$$bit_offset (.dst_ffd [ffd$v_unit],
.dst_ffd [ffd$v_offset] + .pmp [.pseudo_pc, fpm$v_op_1],
dst_unit, dst_offset);
dix$$stuff_bits (.dst_unit, .dst_offset,
.pmp [.pseudo_pc, fpm$v_op_2], .exp);
END; ! ;.lm -4.!Case fpm$k_op_exp
[fpm$k_op_mant1]: ! \.p;\Skip over hidden HO bit in CF
BEGIN ! ;.LM +4.!Case fpm$k_op_mant1
! ; This works because the HO mantissa bit must be at the
! ; start of the HO mantissa segment. Thus no segment bounds
! ; checks are needed.
cf_mant_bit_ndx = .cf_mant_bit_ndx - 1;
END; ! ;.LM -4.!Case fpm$k_op_mant1
[fpm$k_op_mant]: ! \.p;\Move contiguous mantissa bits from HO to LO
BEGIN ! ;.lm +4.!Case fpm$k_op_mant
LOCAL bit_cnt, dst_unit, dst_offset;
bit_cnt = .pmp [.pseudo_pc, fpm$v_op_2];
dst_unit = .dst_ffd [ffd$v_unit];
dst_offset = .dst_ffd [ffd$v_offset] + .pmp [.pseudo_pc, fpm$v_op_1] + 1;
WHILE .bit_cnt GTR 0 DO ! ; As long as there are bits to move,
BEGIN ! ;.LM +4.!While bit_cnt GTR 0
LOCAL bits_this_cycle;
bits_this_cycle = MIN (.bit_cnt, .cf_mant_bit_ndx + 1);
dix$$bit_offset (.dst_unit, .dst_offset - .bits_this_cycle,
dst_unit, dst_offset);
dix$$stuff_bits (.dst_unit, .dst_offset, .bits_this_cycle,
.cf_mant_seg <.cf_mant_bit_ndx - .bits_this_cycle + 1, .bits_this_cycle>);
cf_mant_bit_ndx = .cf_mant_bit_ndx - .bits_this_cycle;
IF .cf_mant_bit_ndx LSS 0 THEN ! ; If mantissa seg empty,
BEGIN ! ;.lm +4.!If mantissa seg empty
cf_mant_seg_ndx = .cf_mant_seg_ndx + 1; ! ; Bump index to next segment,
cf_mant_seg = .cf_fld [cf$v_mantissa, .cf_mant_seg_ndx]; ! ; bring it into temp area,
cf_mant_bit_ndx = cf$k_mantissa_seg_bits - 1; ! ; init bit index to new seg.
END; ! ;.lm -4.!If mantissa seg empty
bit_cnt = .bit_cnt - .bits_this_cycle; ! ; Compute remaining bits
END; ! ;.LM -4.!While bit_cnt GTR 0
END; ! ;.lm -4.!Case fpm$k_op_mant
TES; ! ;.LM -4.!Case on opcode
pseudo_pc = .pseudo_pc + 1; ! ; Increment the pseudo program counter
END; ! ;.LM -4.!fpm execution loop
!++
! If the field overflowed, the exponent instruction of the FIM signalled
! a toobig error and we never got here. If rounding took place, stat_rounded
! contains 1. If neither is true, then the conversion was exact.
!--
(IF .stat_rounded THEN dix$_rounded ELSE dix$success_cond)
! ; Return rounded or success condition.
END; ! ROUTINE dix$$con_cf_fp
%SBTTL 'GLOBAL ROUTINE dix$$con_fp'
GLOBAL ROUTINE dix$$con_fp ! \.!=;.hl 1 \
! ; .index dix$$con_fp
!++
! Portal for binary floating point conversion.
!
! Routine value: Status value, one of the following:
! .s 1 .list 1,"o"
! .le;Any dix$$check_ffd status value
! .le;dix$_unnorm
! .le;dix$_toobig
! .le;dix$_rounded
! .end list
!
! Formal Arguements:
!--
( ! ;.s 1.list
src_ffd, ! \.le;\: Address of FFD for source field
dst_ffd ! \.le;\: Address of FFD for destination field
) = ! ;.end list
BEGIN ! GLOBAL ROUTINE dix$$con_fp
MAP
src_ffd : REF forgn_descr,
dst_ffd : REF forgn_descr;
LOCAL
error_temp : VOLATILE,
cf_fld1 : cf, ! The intermediate is local
cf_fld2 : cf,
stat1 : INITIAL (dix$success_cond),
stat2 : INITIAL (dix$success_cond);
ENABLE dix$$port_hand (error_temp); ! \.p;\
IF (.dix$adtt_fp [.src_ffd [ffd$v_dt_type], fpd$v_typ] NEQ
.dix$adtt_fp [.dst_ffd [ffd$v_dt_type], fpd$v_typ])
THEN ! ;.p;Prevent attempted convertion of
SIGNAL (dix$_unimp); ! ;complex to "simple" types.
dix$$check_ffd (.src_ffd); ! ;.p;Check source ffd, signal if bad.
dix$$check_ffd (.dst_ffd); ! ;Same for destination.
dix$$con_fp_cf (.src_ffd, cf_fld1); ! ; Convert source to CF intermediate
! ; (may signal an error).
stat1 = dix$$con_cf_fp (cf_fld1, .dst_ffd); ! ; Convert CF to destination.
! ; If these are complex fields, then convert the second FP field. First
! ; increment the FFDs to point to the second fields.
! only need to check src since we know the types are the same...
IF .dix$adtt_fp [.src_ffd [ffd$v_dt_type], fpd$v_typ] EQL fpd$k_complex
THEN
BEGIN
dix$$incr_des (.src_ffd);
dix$$incr_des (.dst_ffd);
! ; If the fields are complex, convert
dix$$con_fp_cf (.src_ffd, cf_fld2); ! ; second source field to CF intermediate (may signal error).
stat2 = dix$$con_cf_fp (cf_fld2, .dst_ffd); ! ; Convert second CF to destination.
END;
! ; Return the approparite status.
IF (.stat1 NEQ dix$success_cond) ! ; If the status from the first field
THEN .stat1 ! ; is not success then return it, else
ELSE IF (.stat2 NEQ dix$success_cond) ! ; if the status from the second word
THEN .stat2 ! ; is not success then return it; else
ELSE dix$success_cond ! ; return dix$_success_cond.
END; ! GLOBAL ROUTINE dix$$con_fp
END ! End of module
ELUDOM