Google
 

Trailing-Edge - PDP-10 Archives - SRI_NIC_PERM_SRC_1_19910112 - 7/language-sources/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