%SBTTL 'ROUTINE dix$$con_pd_xi'
GLOBAL ROUTINE dix$$con_pd_xi ! \.!=;.hl 1\
! ; .index dix$$con_pd_xi
!++
! SCH: Level = 2, DD = 2. Pseudonym >dixpxx>.
!
! Algorithm: Initialize the XI mantissa to zero. Copy the PD scale
! into the XI form.
!
! Taking into account that each source PD byte contains two PD digits,
! scan the PD source, left to right, one byte at a time. Use a
! temporary copy of the source FFD as a byte pointer. While considering
! each byte, first fetch the high order nibble and then the low order
! nibble. Store each PD digit in the XI mantissa.
!
! The PD sign is always in the low order nibble of the last byte of the
! PD field. Note that the PD field may have a high order unused byte.
! If the field contains an odd number of digits then the sign is in the
! last nibble of the last byte, packed in with the last (least significant)
! digit. If the field contains an even number of bytes then the high order
! byte is unused and the sign is, again, in the last nibble of the last byte
! packed in with the least significant digit.
!
! Store the sign in the XI form.
!
! Routine value: None.
!
! Formal Arguements:
!--
( ! ; .s 1.list 1
src_ffd, ! \.le;\: Address of FFD for PD field
xi_field ! \.le;\: Address of XI intermediate field (field is written to)
) : NOVALUE = ! ;.end list
BEGIN ! dix$$con_pd_xi
MAP xi_field : REF xi,
src_ffd : REF forgn_descr;
dix$routine_debug (off)
LOCAL
src_pnt : forgn_descr, ! temp copy of FFD to use as a byt pntr
xi_digt_ndx,
src_digt,
nibble_offset;
ROUTINE dix$$proc_digt ! \.!=;.hl 2\
! ; .index dix$$proc_digt
!++
! SCH: Level = 3, DD = 3.
!
! Algorithm: If the digit is a valid PD digit (in the range 0
! through 9 decimal) then return the XI digit. Otherwise signal
! dix$_invpddgt (invalid source packed decimal digit).
!
! Routine value: .pd_digt (the value of the digit to be stored in
! the XI form).
!
! Formal arguements:
!--
( ! ; .s 1 .list 1
pd_digt ! \.le;\: the packed decimal digit
) = ! ;.end list
BEGIN
IF .pd_digt LSS 0
OR .pd_digt GTR 9 ! see if digit is invalid
THEN
SIGNAL (dix$_invpddgt);
.pd_digt ! if the digit is valid return it
! to be stored in the XI form
END; ! end local routine dix$$proc_digt
ROUTINE dix$$proc_sgn ! \.!=;.hl 2\
! ; .index dix$$proc_sgn
!++
! SCH: Level = 3, DD = 3.
!
! Algorithm: Select the packed decimal sign table to use. Look
! up the sign digit in the packed decimal sign table. If the
! sign digit does not exist in the PD sign table, signal an
! error, otherwise return the XI sign value.
!
! At the present time, there is one sign table (dix$apdt) since
! the valid sign representations are exactly the same for all
! supported PD data types. The sign table contains an entry for
! each valid PD sign and it's associated XI representation.
!
! Routine value: xi_sign (the value of the sign to be stored in
! the XI form).
!
! Formal Arguements:
!--
( ! ; .s 1 .list 1
pd_sgn, ! \.le;\: the packed decimal sign
src_pnt ! \.le;\: copy of the source ffd
) = ! ;.end list
BEGIN
LOCAL
src_pds, ! address of src PDS
pds_max_index, ! max index of src PDS
indx, ! an index
sign_found : INITIAL (0), ! if ON, indicates that the sign
! char has been found in the PDS
xi_sign : INITIAL (0); ! XI sign value to retun
MAP src_pnt : REF forgn_descr,
src_pds : REF pds (0); ! size is irrelevant
! get proper PD sign table to use for the given data type
SELECTONE .dix$adtt_pd [.src_pnt [ffd$v_dt_type], pdd$v_sign_set] OF
SET
[ss_decstd] : BEGIN
src_pds = dix$apds_decstd;
pds_max_index = pds$k_decstd_max - 1
END;
[OTHERWISE] : SIGNAL (dix$_impossible);
TES;
! search the PD sign table for the packed decimal sign
INCR indx FROM 0 TO .pds_max_index DO
IF .src_pds [.indx, pds$v_digit] EQL .pd_sgn
THEN BEGIN
xi_sign = .src_pds [.indx, pds$v_sign];
sign_found = 1;
EXITLOOP ! digit found so stop searching for it
END;
IF .sign_found NEQ 1 THEN SIGNAL (dix$_invpdsgn);
.xi_sign ! return XI sign value
END; ! end of local routine dix$$proc_sgn
! begin body of dix$$con_pd_xi
dix$$copy_structure (.src_ffd, ffd$k_size, src_pnt); ! make a modifiable copy of the src_ffd
xi_field [xi$v_sign] = 0; ! init the sign to positive
xi_field [xi$v_scale] = .src_ffd [ffd$v_scale]; ! copy the PD scale to XI form
! Initialize hign-order XI mantissa digits to zero.
DECR xi_digt_ndx FROM xi$k_digits TO .src_ffd [ffd$v_length] DO
xi_field [xi$v_digit, .xi_digt_ndx] = 0;
! Set the initial value of the XI digit index to the number of digits
! which should be stored in the XI field. This value is equal to the
! length of the source field minus 1. The XI digits are indexed from
! 0 to xi$k_digits, (rather than from 1 to xi$k_digits) so it is
! necessary to subtract 1 to reflect this.
xi_digt_ndx = .src_ffd [ffd$v_length] - 1;
!++
! Note some assumptions about packed decimal data storage:
! .list 0
! .le;There are always two nibbles in a byte.
! .le;All nibbles are of the same size (pdd$v_nbl_siz stored in dix$adtt_pd).
! .le;All nibbles are right justified within the byte with any unused bits
! collected at the left (high order) end of the byte.
! .end list
! All of this means that to look at the high order nibble of a byte, simply
! use the nibble size (pdd$v_nbl_siz stored in dix$adtt_pd) as the bit offset
! within the desired byte. To look at the low order nibble, the bit offset
! within a byte would be zero.
!--
! It may be necessary to skip the first (high order) nibble, since it may
! be unused. If field length is an even number then the high order nibble
! must be skipped, if the field length is odd, don't need to skip any nibbles.
IF .src_pnt [ffd$v_length] ! If length is "true" then the length is an odd number
THEN ! so set nibble offset to high order
nibble_offset = .dix$adtt_pd [.src_pnt [ffd$v_dt_type], ! nibble (offset equals the nibble size).
pdd$v_nbl_siz] ! If length is even, skip 1st nibble &
ELSE nibble_offset = 0; ! set nibble offset to zero for low order nibble.
DO BEGIN ! scan the source PD field and insert digits into the XI form
src_digt = dix$$fetch_bits(.src_pnt [ffd$v_unit], ! fetch desired nibble from specified byte
.src_pnt [ffd$v_offset] + .nibble_offset,
.dix$adtt_pd [.src_pnt [ffd$v_dt_type],
pdd$v_nbl_siz]
);
xi_field [xi$v_digit, .xi_digt_ndx] =
dix$$proc_digt(.src_digt); ! insert processed digit into the XI
xi_digt_ndx = .xi_digt_ndx - 1; ! decr XI digit index each time a digit is stored
SELECTONE .nibble_offset OF
SET
[0] : BEGIN
nibble_offset = .dix$adtt_pd [.src_pnt [ffd$v_dt_type],
pdd$v_nbl_siz]; ! set nibble offset to high order nibble
dix$$incr_des(src_pnt); ! increment pointer to next whole byte
END;
[.dix$adtt_pd [.src_pnt [ffd$v_dt_type], pdd$v_nbl_siz]] :
nibble_offset = 0; ! set nibble offset to low order nibble
! & don't increment byte pointer since
! we aren't done with this byte yet
TES;
END
UNTIL .xi_digt_ndx LSS 0;
!++
! While scanning the packed decimal field, the src_pnt (the byte
! pointer) has been incremented so that it is now pointing to the last
! byte of the field. Packed decimal signs are always stored in the
! low order nibble of the last (low order) byte. To get the sign,
! simply fetch the low order nibble of the present byte.
!--
! nibble_offset will always be zero here, since we want the low
! order nibble, therefore, don't need to add .nibble_offset to
! .src_pnt [ffd$v_offset] when fetching the sign...
src_digt = dix$$fetch_bits (.src_pnt [ffd$v_unit], ! fetch sign
.src_pnt [ffd$v_offset],
.dix$adtt_pd [.src_pnt [ffd$v_dt_type],
pdd$v_nbl_siz]
);
xi_field [xi$v_sign] = dix$$proc_sgn(.src_digt, src_pnt); ! store sign in XI form
END; ! end of global routine dix$$con_pd_xi