Google
 

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