Google
 

Trailing-Edge - PDP-10 Archives - SRI_NIC_PERM_SRC_1_19910112 - 7/language-sources/dixpd.bli
There are 21 other files named dixpd.bli in the archive. Click here to see a list.
%TITLE 'DIXPD -- Packed Decimal Conversion Module'

MODULE dixpd

!  COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1985, 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 >DIXPD
!
!   The module DIXPD contains the packed decimal conversion routines
! and data structures.
!
!   FACILITY: Data Conversion Routines (DIX)
! 
!   ABSTRACT: Packed decimal conversion routines and related data
! structures.
! 
!   ENVIRONMENT:
! 
!   AUTHOR: Sandy Clemens, Creation Date: 17-Jan-84
!--

    (					!
    IDENT = '2.1(53)'                   ! \.p;\
    %REQUIRE ('DIXSWI.REQ')             ! **EDIT**
%BLISS36 (
        , ENTRY (                       ! ; .P;Entry names:
        dixpxx, dixxxp, dixpd           ! \	
        )
)
    ) =

BEGIN

!++
! .hl 1 Require files
!--

REQUIRE 'DIXREQ.REQ';

%sbttl 'Edit History'

!++
! .hl 1 Edit History
!--

LIBRARY 'VERSION';

! ; .autotable

!++ COPY 

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
!--

UNDECLARE %QUOTE $descriptor;		!\.p;\Something leaves this around.

dix$module_debug (off)


!++
! .hl 1 External References
!--

EXTERNAL                                ! \.p;\DATA STRUCTURES: 
!++ copy /strip
    dix$adtt_pd : dtt_pd;               
!--

!;.p
!; EXTERNAL ROUTINES:
EXTERNAL ROUTINE                        ! ;.list 0, "o"
    dix$$fetch_bits,                    ! \.le;\
    dix$$stuff_bits : NOVALUE,          ! \.le;\
    dix$$incr_des : NOVALUE,            ! \.le;\
    dix$$copy_structure : NOVALUE,      ! \.le;\
    dix$$check_ffd : NOVALUE,           ! \.le;\
    dix$$port_hand,                     ! \.le;\
    dix$$adj_xi_scal;                   ! \.le;\
                                        ! ;.end list
!++
! .hl 1 Own storage
!--

!++
! .hl 2 Packed Decimal Sign Table
! .index Packed Decimal Sign Table
!  The packed decimal sign table contains the valid sign values for the
! packed decimal data types.  At the present time, the possible sign values
! are the same for each of the supported packed decimal data types.
! There is, therefore, one table for all data types.  The information
! included in this table is the following:
!
!--

$field pds_fields =
       SET                              ! ; .list 0, "o"
       pds$v_digit = [$byte],           ! ; .le;numeric value of packed decimal sign digit
       pds$v_sign = [$bit]              ! ; .le;associated sign value (0 or 1)
       TES;                             ! ; .end list

LITERAL pds$k_size = $field_set_size;

!++
! .hl 3 Macros Used
! .list
! .index pds
! .le;PDS -- This is a macro to define the PDS (packed decimal sign
! table) structure.
!--
MACRO
     pds (table_size) = BLOCKVECTOR [table_size, pds$k_size]
                        FIELD (pds_fields) %;

!++
! .index build_pds
! .le;BUILD_PDS -- This is a macro to help put together a given PDS table.
! There is one PDS structure for each set of sign representations (sign_set).
! The legal sign sets are:
! .list "o"
! .index DECSTD
! .le;DECSTD -- the standard sign representations used by DEC-10/20 COBOL
! and VAX COBOL.
! .end list
!--
MACRO build_pds (sign_set) =
      OWN %NAME ('dix$apds_', sign_set) :
                           pds (%NAME ('pds$k_', sign_set, '_max'))
                           PSECT (readonly_psect)
                           PRESET (%NAME ('def_pds_', sign_set));
      %;

!++
! .index def_pds_decstd
! .le;DEF_PDS_DECSTD -- This is a macro to define the entries for the
! DECSTD sign table.  Note that the first two entries should be the
! preferred positive sign value and the preferred negative sign value.
! This is necessary since, when converting something to a PD value,
! the first positive or negative sign value encountered in the table
! will be the one used in the destination PD field.  Note that the
! table is of size pds$k_<sign_set`>_max, which is must be previously
! defined in module DIXLIB.
! .index pds$k_<sign_set`>_max
! .end list
!--

!++
! .hl 3 Packed Decimal Sign Table Entries
! .hl 4 DECSTD Sign Set
!  The following are the entries in the packed decimal sign table for
! DECSTD sign set.
!--

MACRO def_pds_decstd =                  ! ; .s1 .list 0, "o"
          [0, pds$v_digit] = 12,        ! ; .le;Decimal 12 is the preferred positive sign value
          [0, pds$v_sign] = 0,
          [1, pds$v_digit] = 13,        ! ; .le;Decimal 13 is the preferred negative sign value
          [1, pds$v_sign] = 1,
          [2, pds$v_digit] = 10,        ! ; .le;Decimal 10 is a positive sign
          [2, pds$v_sign] = 0,
          [3, pds$v_digit] = 11,        ! ; .le;Decimal 11 is a negative sign
          [3, pds$v_sign] = 1,
          [4, pds$v_digit] = 14,        ! ; .le;Decimal 14 is a positive sign
          [4, pds$v_sign] = 0,
          [5, pds$v_digit] = 15,        ! ; .le;Decimal 15 is a positive sign
          [5, pds$v_sign] = 0           ! ; .end list
      % ;


! PDS's
! ; .hl 3 Expand sign tables
! ;  Expand the sign tables for each sign set:
! ; .s1 .list 0, " "
build_pds ('decstd')                    ! \.le;\ -- generate dix$apds_decstd
! ; .end list
%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
%SBTTL 'ROUTINE dix$$con_xi_pd'

GLOBAL ROUTINE dix$$con_xi_pd           ! \.!=;.hl 1\
! ; .index dix$$con_xi_pd

!++
!   Convert fixed intermediate (XI) field to packed decimal field.
!
!   SCH:  Level = 2, DD = 2.   Pseudonym >dixxxp>.
!
!  Algorithm:  Adjust the XI mantissa so the XI form has the  same  scale
! as the destination field.
!   Make sure the destination  field  is  large  enough  to  hold  the  XI
! significant digits.
!   Using a temporary (modifiable) copy of the destination FFD as a byte
! pointer to the PD field, scan the XI field from left to right.  Insert
! each XI digit into the corresponding PD nibble.
!   Store the sign value in the PD field.
!
!   Routine value:  Status value
!
!   Formal Arguements:
!--
    (                                   ! ; .s 1 .list 1
     xi_field,                          ! \.le;\: address of XI field.
     dst_ffd                            ! \.le;\: address of PD field (field written to).
    ) =                                 ! ; .end list

BEGIN                                   ! routine dix$$con_xi_pd

MAP xi_field : REF xi,
    dst_ffd : REF forgn_descr;

dix$routine_debug (off)

LOCAL
     status_pd,                         ! status value
     xi_digt_ndx,                       ! index into XI digits
     dst_pnt : forgn_descr,             ! destination field byte pointer
     nibble_offset,                     ! bit offset to high or low order nibble
     xi_sign,                           ! temporary place to put XI sign
     dst_sign;                          ! destination sign character


     ROUTINE dix$$proc_sgn              ! \.!=;.hl 2\
     ! ; .index dix$$proc_sgn

     !++
     !   SCH:  Level = 3, DD = 3.
     !
     !  Algorithm: Find the preferred packed decimal sign
     ! representation from the packed decimal sign table.  The first
     ! (smallest indexed) positive or negative sign value encountered
     ! in the PD sign table will automatically be the preferred
     ! representation.
     !
     !  Routine value: Packed decimal sign value returned
     !
     !  Formal Arguements:
     !--
         (                              ! ; .s 1 .list 1
          xi_sign,                      ! \.le;\: the XI sign
          dst_pnt                       ! \.le;\: copy of the destination ffd
         ) =                            ! ;.end list

         BEGIN
         LOCAL dst_pds,
               pds_max_index,
               indx,
               sign_found : INITIAL (0),
               pd_sign;

         MAP dst_pnt : REF forgn_descr,
             dst_pds : REF pds (0);     ! size irrelevant

         SELECTONE .dix$adtt_pd [.dst_pnt [ffd$v_dt_type], pdd$v_sign_set] OF
         SET
         [ss_decstd] : BEGIN
                       dst_pds = dix$apds_decstd;
                       pds_max_index = pds$k_decstd_max - 1;
                       END;
         [OTHERWISE] : SIGNAL (dix$_impossible);
         TES;

         ! Search dst PDS for sign character associated with given
         ! XI sign.  Stop as soon as the sign is found.

         INCR indx FROM 0 to .pds_max_index DO
              IF .dst_pds [.indx, pds$v_sign] EQL .xi_sign      ! sign is found
                 THEN BEGIN
                      pd_sign = .dst_pds [.indx, pds$v_digit];
                      sign_found = 1;                           ! indicate sign found
                      EXITLOOP                                  ! & don't waste any time
                      END;

         IF .sign_found NEQ 1 THEN SIGNAL (dix$_impossible);    ! Sign should occur in PDS!

         .pd_sign                                               ! return value of PD sign

         END;                                                   ! end of local routine dix$$proc_sgn


! begin body of dix$$con_xi_pd

dix$$copy_structure(.dst_ffd, ffd$k_size, dst_pnt);            ! make tmp (modifiable) copy of dest
                                                               ! ffd to be used as a byte pointer

status_pd = dix$$adj_xi_scal(.dst_pnt [ffd$v_scale],           ! adjust XI field to match the dest scale
                             .xi_field);                       ! may return DIX$_ROUNDED or signal DIX$_TOOBIG 


! Make sure the destination field is large enough to hold the significant
! XI digits:

INCR xi_digt_ndx FROM .dst_pnt [ffd$v_length] TO xi$k_digits DO
         IF .xi_field [xi$v_digit, .xi_digt_ndx] NEQ 0         ! if non-zero digits occur in high ord positions
             THEN                                              ! then the source is too big for the dest
                 SIGNAL (dix$_toobig);

! Since the XI field is indexed from 0, not from 1, set the xi_digt_ndx to be
! the field length minus one:

xi_digt_ndx = .dst_pnt [ffd$v_length] - 1;


IF .dst_pnt [ffd$v_length]                                              ! if length is "true"
    THEN nibble_offset = .dix$adtt_pd [.dst_pnt [ffd$v_dt_type],        ! start with
                                       pdd$v_nbl_siz]                   ! high order nibble
    ELSE BEGIN
         nibble_offset = .dix$adtt_pd [.dst_pnt [ffd$v_dt_type],        ! else put a zero
                                       pdd$v_nbl_siz];                  ! in high order unused
         dix$$stuff_bits (.dst_pnt [ffd$v_unit],                        ! nibble as filler
                          .dst_pnt [ffd$v_offset] + .nibble_offset,
                          .dix$adtt_pd [.dst_pnt [ffd$v_dt_type],
                                        pdd$v_nbl_siz],
                          0);

         nibble_offset = 0;                                             ! set nibble offset to get
                                                                        ! next low order nibble
         END;


DO BEGIN                                                                ! Scan XI fld & put PD digits into dst

! Since the XI digits are simply packed decimal digits, store them directly
! in the destination field without conversion.  No checking is made to see
! that the XI digits are valid, since the digits are checked when they are
! put INTO the XI digit form.  Should a check for validity of XI digits be
! made here???

   dix$$stuff_bits (.dst_pnt [ffd$v_unit],                              ! Stuff XI src digits into the dest
                    .dst_pnt [ffd$v_offset] + .nibble_offset,           ! PD field, one nibble at a time
                    .dix$adtt_pd [.dst_pnt [ffd$v_dt_type],
                                  pdd$v_nbl_siz],
                    .xi_field [xi$v_digit, .xi_digt_ndx]
                   ) ;

   xi_digt_ndx = .xi_digt_ndx - 1;


   SELECTONE .nibble_offset OF                                          ! set nibble offset & incr byte pntr if necessary
      SET

      [0] : BEGIN

            nibble_offset = .dix$adtt_pd [.dst_pnt [ffd$v_dt_type], pdd$v_nbl_siz];
            dix$$incr_des(dst_pnt);
            END;


      [.dix$adtt_pd [.dst_pnt [ffd$v_dt_type], pdd$v_nbl_siz]] :

            nibble_offset = 0;

      TES;

END

UNTIL .xi_digt_ndx LSS 0;                       ! end of scan XI digits loop


! Consider sign.

xi_sign = .xi_field [xi$v_sign];                ! get the XI sign value

dst_sign = dix$$proc_sgn(.xi_sign, dst_pnt);    ! get the dest PD sign

! Store the destination packed decimal sign.  Note: the nibble offset,
! when storing the sign, is always zero, so there is no need to add
! the nibble offset to the field offset as was done above.

dix$$stuff_bits (.dst_pnt [ffd$v_unit],
                 .dst_pnt [ffd$v_offset],
                 .dix$adtt_pd [.dst_pnt [ffd$v_dt_type], pdd$v_nbl_siz],
                 .dst_sign);

IF .xi_digt_ndx NEQ -1                          ! we should use up all the XI digits
    THEN SIGNAL (dix$_impossible);


.status_pd                                      ! return status value

END;                                            ! end of global routine dix$$con_xi_pd
%SBTTL 'GLOBAL ROUTINE dix$$con_pd'

GLOBAL ROUTINE dix$$con_pd            ! \.!=;.hl 1\
! ; .index dix$$con_pd

!++
!  Portal for Packed Decimal conversions.
!
!   SCH:  Level = 1, DD = 1.   Pseudonym >dixpd>.
!
!  Algorithm:  Convert packed decimal field to XI (fixed intermediate)
! form.  Convert the XI intermediate digits to the destination packed
! decimal type.  Scaling is correctly handled.
!
!  Routine value: Status Value, one of the following:
! .list 1, "o"
! .le;dix$_impossible
! .le;dix$_rounded
! .le;dix$_toobig
! .le;dix$_invpddgt
! .le;dix$_invpdsgn
! .end list
!  Formal arguements:
!--
   (                                    ! ; .s 1 .list 1
   src_ffd,                             ! \.le;\: Address of source FFD
   dst_ffd                              ! \.le;\: Address of destination FFD
   ) =                                  ! ; .end list

BEGIN                                   ! Begin dix$$con_pd

MAP
   src_ffd : REF forgn_descr,
   dst_ffd : REF forgn_descr;

dix$routine_debug (off)

LOCAL
     error_tmp : VOLATILE,
     xi_field : xi;

ENABLE dix$$port_hand (error_tmp);      ! \Establish condition handler: \

dix$$check_ffd (.src_ffd);
dix$$check_ffd (.dst_ffd);

dix$$con_pd_xi (.src_ffd, xi_field);    ! convert src PD field to xi form,
                                        ! signals if error

dtype (on, 'XI field before scale adjustment: ');
debug_code (xidmp (xi_field);           ! debugging code
            tty_put_crlf ());

dix$$con_xi_pd (xi_field, .dst_ffd)     ! convert xi form to dst PD field,
                                        ! signals if error and may return warning

END;                                    ! end global routine dix$$con_pd

END
ELUDOM