
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE fdm$move_cobol_data;
?? NEWTITLE := 'NOS/VE Screen Formatter : Move COBOL data' ??

*copyc fdc$cobol_operations_max
*copyc fdc$decimal_currency_symbol
*copyc fdc$dollar_currency_symbol
*copyc fdc$pound_currency_symbol
*copyc fdc$thousands_currency_symbol
*copyc fde$condition_identifiers
*copyc fdt$cobol_currency_symbols
*copyc fdt$cobol_category
*copyc fdt$cobol_picture_symbols
*copyc fdt$cobol_usage
*copyc fdt$cobol_operation
*copyc fdt$cobol_cr_db_means
*copyc fdt$cobol_description
*copyc fdt$usage
*copyc fdc$maximum_picture_length
*copyc ost$status
*copyc osv$lower_to_upper

*copyc i#move
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

VAR
    fdv$cobol_currency_symbols: [XDCL] fdt$cobol_currency_symbols :=
          [fdc$dollar_currency_symbol, fdc$pound_currency_symbol, fdc$thousands_currency_symbol,
           fdc$decimal_currency_symbol];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] fdp$change_currency_symbols', EJECT ??
*copyc fdh$change_currency_symbols


  PROCEDURE [XDCL] fdp$change_currency_symbols
    (    primary_money_symbol: string (1);
         secondary_money_symbol: string (1);
         thousands_separator_symbol: string (1);
         decimal_symbol: string (1));

    fdv$cobol_currency_symbols.primary_money_symbol := primary_money_symbol (1);
    fdv$cobol_currency_symbols.secondary_money_symbol := secondary_money_symbol (1);
    fdv$cobol_currency_symbols.thousands_separator_symbol := thousands_separator_symbol (1);
    fdv$cobol_currency_symbols.decimal_symbol :=  decimal_symbol (1);

  PROCEND fdp$change_currency_symbols;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] fdp$move_cobol_data', EJECT ??
*copyc fdh$move_cobol_data

  PROCEDURE [XDCL] fdp$move_cobol_data
    (    source: fdt$cobol_description,
         source_address: ^STRING ( * );
         destination: fdt$cobol_description;
         destination_address: ^STRING ( * );
     VAR status: ost$status);

    TYPE
      ch = SET OF CHAR; { to be able to use literals for sets

    CONST
      bytes_for_integer = 8,
      bytes_for_single = 8,
      bytes_for_double = 16,
      item_index_min   = 0,
      item_index_max   = fdc$cobol_item_size_maximum,
      value_conversion_length = fdc$cobol_digits_maximum + 1;

    VAR

{ each loop, set to destination.operation_characters[oi], then scratch

      c: char,

{ destination index into "destination_address^"

      destination_index: item_index_min..item_index_max,
      leading_zero_c: char, { char indicating replacement of leading zeros
      leading_zeros: BOOLEAN, { iff we are suppressing leading zeros
      positive: BOOLEAN, { iff signed number is positive
      skip_leading_separate: BOOLEAN, { whether to skip leading separate sign
      temporary_source: STRING (value_conversion_length),
      ts: fdt$cobol_description, { temporary source description
      ts_address: ^STRING ( * ); { address of temporary source value

?? NEWTITLE :=  'initialize_ts', EJECT ??

    PROCEDURE initialize_ts;

{ Initialize a "temporary source" item as
{ PIC S9(18)V9(18) USAGE DISPLAY SIGN IS LEADING SEPARATE.


      temporary_source := '+000000000000000000000000000000000000';
      ts_address := ^temporary_source;
      ts.sign_index := 1; { Point to the "+"
      ts.sign_separate := TRUE; { SIGN IS SEPARATE
      ts.size := value_conversion_length;
      ts.significant_digits := 18; { 18 digits to left of the decimal point
      ts.number_digits := value_conversion_length - 1;
      ts.cobol_category := fdc$cobol_numeric_signed;
      ts.cobol_usage := fdc$cobol_usage_display; { USAGE IS DISPLAY
      ts.display_cr := FALSE; { Do not cause destination "CR" to be shown
      ts.display_db := FALSE; { Do not cause destination "DB" to be shown
      ts.move_operations := 2; { 2 operations when moving to this item
      ts.cobol_operations [1] := fdc$cobol_separate_sign; { Insert "+" or "-"
      ts.cobol_operations [2] := fdc$cobol_move; { Move 36 digits
      ts.operation_numbers [2] := value_conversion_length - 1;
    PROCEND initialize_ts;

?? OLDTITLE ??
?? NEWTITLE :=  'move_free_form_to_standard', EJECT ??

    PROCEDURE move_free_form_to_standard;

{ Extract value described by "source" into "ts", which is S9(18)V9(18),
{ setting "status"

      CONST
        dest_len = 36, { size of 9(18)V9(18)
        source_len = 255;

      VAR
        dest: STRING (dest_len),
        dest_idx: item_index_min..item_index_max,
        digits: SET OF CHAR,
        done: BOOLEAN,
        found_point: BOOLEAN,
        found_sign: BOOLEAN,
        i: item_index_min..item_index_max,
        ignore_chars: ch,
        legal_chars: ch,
        need_right_paren: BOOLEAN,
        num_fraction_digits: item_index_min..item_index_max,
        num_signif_digits: item_index_min..item_index_max,
        sign_means: fdt$cobol_cr_db_means,
        source_data: STRING (source_len),
        source_idx: item_index_min..item_index_max; {to last-used character

?? NEWTITLE :=  'get_c', EJECT ??

      PROCEDURE get_c
        (VAR c: char;
         VAR done: BOOLEAN);

        c := ' ';
        WHILE (source_idx < source_len) AND (c IN ignore_chars) DO
          source_idx := source_idx + 1;
          c := source_data (source_idx);
        WHILEND;
        IF c = ' ' THEN

{ Must have reached end of source

          done := TRUE; { Tell caller we reached end of source
        ELSEIF (c = '(') OR (c = ')') THEN

{ Any legal use of "(...)" has already been processed,
{ the the "(" and ")" removed from source.
{ Parentheses, when used, must surround all non-spaces.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_nonblk_outside_paren, '',
           status);
          EXIT fdp$move_cobol_data;
        ELSE

{ Have a character within the source

          IF NOT (c IN legal_chars) THEN

{ ?  Is this needed else where?

            IF c = 'E' THEN

{ Scientific notation is not allowed.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_no_scientific, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSE

{ Only characters produced by numeric-edited may be entered,
{ plus "(" and ")", with lower case accepted.
{ These are digits, space, ".", "+", "-", "CR", "DB", "$",
{ "#", "*", "/", or ",".

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_illegal_char_entered, '',
               status);
              EXIT fdp$move_cobol_data;

            IFEND;
            done := TRUE;
          IFEND
        IFEND { Have a character within the source
      PROCEND get_c;

?? OLDTITLE ??
?? NEWTITLE :=  'handle_sign', EJECT ??

      PROCEDURE handle_sign;

        IF found_sign THEN

{ Have at least two sign symbols.
{ Can have only one sign ("+", "-", "CR", "DB", or "(...)")

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_two_signs_entered, '',
           status);
          EXIT fdp$move_cobol_data;

        ELSE

{ Found first sign symbol

          found_sign := TRUE;
          IF (c = '+') OR (c = '-') THEN

{ "+" or "-"

            IF  (source.cr_means = fdc$cobol_cr_set)
             OR (source.db_means = fdc$cobol_db_set) THEN

{ "+" and "-" are not allowed in this field now.
{ Use "CR" or "DB".

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_no_plus_or_minus_now, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSEIF c = '+' THEN
              sign_means := fdc$cobol_positive
            ELSE { c = '-'
              sign_means := fdc$cobol_negative
            IFEND
          ELSEIF c = 'C' THEN
            source_idx := source_idx + 1;
            c := source_data (source_idx);
            IF c <> 'R' THEN

{ "C" must be followed by "R" to form "CR".

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_c_without_r, '', status);
              EXIT fdp$move_cobol_data;

            ELSEIF source.cr_means = fdc$cobol_cr_db_illegal THEN

{ CR and DB are not allowed for this field now.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_no_cr_or_db_now, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSE
              sign_means := source.cr_means;
            IFEND

{ c was 'C'

          ELSE

{ c = 'D'

            source_idx := source_idx + 1;
            c := source_data (source_idx);
            IF c <> 'B' THEN

{ "D" must be followed by "B" to form "DB".

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_d_without_b, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSEIF source.db_means = fdc$cobol_cr_db_illegal THEN

{ CR and DB are not allowed for this field now.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_no_cr_or_db_now, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSE
              sign_means := source.db_means;
            IFEND

{ c was 'D'

          IFEND { Found first sign symbol
        IFEND
      PROCEND handle_sign;

?? OLDTITLE, EJECT ??

      IF source.size > source_len THEN

{ A USAGE IS FREE-FORM value cannot be longer than 255 characters.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_usage_size_too_big, '', status);
        EXIT fdp$move_cobol_data;
      IFEND;

      source_data := source_address^;
      initialize_ts;
      dest := ' ';
      dest_idx := 0; { Index to last-filled character in dest

      FOR i := 1 TO source_len DO
        IF (source_data (i) >= 'a') AND (source_data (i) <= 'z') THEN
          source_data (i) :=
           $CHAR ($INTEGER (source_data  (i)) - $INTEGER ('a') + $INTEGER ('A'));
        IFEND
      FOREND { i} ;

      digits := $ch ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'];
      ignore_chars := $ch [' ', fdv$cobol_currency_symbols.thousands_separator_symbol, '/',
             fdv$cobol_currency_symbols.primary_money_symbol,
             fdv$cobol_currency_symbols.secondary_money_symbol, '*'];
      legal_chars := digits + $ch [fdv$cobol_currency_symbols.decimal_symbol, '+', '-',
             'C', 'D', '('];
      found_sign := FALSE;
      found_point := FALSE;
      need_right_paren := FALSE;
      num_signif_digits := 0;
      num_fraction_digits := 0;

{ Check for "(...)"

      done := FALSE;
      need_right_paren := FALSE;
      source_idx := 1;

      WHILE (source_idx < source_len) AND (source_data (source_idx) = ' ') DO
        source_idx := source_idx + 1;
      WHILEND;

      c := source_data (source_idx);
      IF c = '(' THEN
        source_data (source_idx) := ' '; { Remove "(" for later processing
        source_idx := source_len;

        WHILE (source_idx > 1) AND (source_data (source_idx) = ' ') DO
          source_idx := source_idx - 1;
        WHILEND;

        c := source_data (source_idx);

        IF c = ')' THEN

{ Have "(...)"

          found_sign := TRUE;
          sign_means := fdc$cobol_negative;
          IF  (source.cr_means = fdc$cobol_cr_set)
           OR (source.db_means = fdc$cobol_db_set) THEN

{ "+", "-", and "(...)" are not allowed in this field now.
{ Use "CR" OR "DB".

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_no_plus_or_minus_now, '',
             status);
            EXIT fdp$move_cobol_data;
            ;
          IFEND { "(...)" conflicts with CR/DB desires} ;
          source_data(source_idx) := ' '; { Now ignore trailing ")"

{ end: Have "(...)"

        ELSE

{ Right-most non-blank was not ")"
{ Parentheses, when used, must surround all non-spaces.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_nonblk_outside_paren, '',
           status);
          EXIT fdp$move_cobol_data;

        IFEND { Right-most non-blank was not ")"} ;
        source_idx := 0; { Index to last-used character from source
        get_c (c, done);

{ end: Found "(..."

      ELSEIF c IN $ch ['+', '-', 'C', 'D', '('] THEN
        handle_sign;
        get_c (c, done);

{ end: c was sign character

      ELSE
        source_idx := 0; { Index to last-used character from source
        get_c (c, done);
      IFEND;

      WHILE NOT done DO
        IF c IN digits THEN
          IF ((num_fraction_digits + num_signif_digits) > 18) THEN

{ Cannot enter more than 18 digit positions.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_too_many_digits, '', status);
              EXIT fdp$move_cobol_data;
          IFEND;

          dest_idx := dest_idx + 1;
          dest (dest_idx) := c;
          IF found_point THEN
           num_fraction_digits := num_fraction_digits + 1;
          ELSE
           num_signif_digits := num_signif_digits + 1;
          IFEND;

          get_c (c, done);

{ end: c IN digits

        ELSEIF c = fdv$cobol_currency_symbols.decimal_symbol THEN

{ Decimal point

          IF found_point THEN

{ Only a single decimal point may be entered.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_two_points_entered, '',
             status);
            EXIT fdp$move_cobol_data;

          ELSE
            found_point := TRUE;
          IFEND;
          get_c (c, done);

{ end: c = fdv$cobol_currency_symbols.decimal_symbol

        ELSE

{ c must be '+', '-', 'C', or 'D'

          handle_sign;

{ Ensure remainder is spaces

          IF NOT done THEN
            WHILE source_idx < source_len DO

{ Still have more characters to look at

              source_idx := source_idx + 1;
              IF source_data (source_idx) <> ' ' THEN

{ non-blank to right of sign.
{ Only spaces can follow trailing "+", "-", "CR" or "DB".

                osp$set_status_abnormal (
                 fdc$format_display_identifier,fde$cobol_trailing_sign_nonblk, '',
                 status);
                EXIT fdp$move_cobol_data;

              IFEND { non-blank to right of sign
            WHILEND { Had more characters to look at} ;
            done := TRUE; { With terminal sign
          IFEND { was NOT done
        IFEND { c was sign
      WHILEND { NOT done} ;

      FOR i := 1 TO num_signif_digits + num_fraction_digits DO
        ts_address^ (19 - num_signif_digits + i) := dest (i);
      FOREND { i} ;

      IF found_sign THEN
        CASE sign_means OF
        = fdc$cobol_positive =
          ts_address^ (1) := '+';
        = fdc$cobol_negative =
          ts_address^ (1) := '-';
        = fdc$cobol_1_quadrillion =
          ts_address^ (2) := '1';
        = fdc$cobol_2_quadrillion =
          ts_address^ (2) := '2';
        = fdc$cobol_cr_set =
          ts.display_cr := TRUE;
        = fdc$cobol_db_set =
          ts.display_db := TRUE;
        ELSE
        CASEND { sign_means
      IFEND { found_sign

    PROCEND move_free_form_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_binary_to_standard', EJECT ??

    PROCEDURE move_binary_to_standard { from "source" to "ts"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          = 3 =
            i: INTEGER,
          casend,
        recend { kludge_type} ;

      VAR
        digit: 0..9,
        integer_value: integer,
        kludge: kludge_type,
        tens: INTEGER,
        tens_index: 2 .. fdc$cobol_digits_maximum,
        test_value: integer,
        tsi: 2 .. value_conversion_length,
        tsi_max: 2 .. value_conversion_length;

{ The method is to first move the "binary" format value to a CYBIL
{ INTEGER.  Fortunately, CYBIL INTEGERs hold 18 decimal digits,
{ which is just what we need. See "move_standard_to_binary" for a
{ discussion of "binary" format.  Then digits are extracted from
{ the CYBIL INTEGER by division and truncation.  These digits are
{ inserted into the standard display value.

{ Set up ts: fdt$cobol_description for S9(18)V9(18) USAGE DISPLAY

      initialize_ts;

{ Handle the sign.

      test_value := 0;
      i#move (source_address, ^test_value, source.size);
      IF test_value < 0 THEN
        ts_address^ (1) := '-';
        test_value := -test_value;
      IFEND;

{ Move the "binary" format value to a CYBIL INTEGER.

      kludge.i := 0;
      i#move (^test_value, ^kludge.source [bytes_for_integer + 1 - source.size],
           source.size);

      integer_value := kludge.i;

{ Prepare the power of ten for the division
{ For example, if source.number_digits=5 we could have a
{ number as large as 99999 and we should start by dividing by 10000.

      tens := 1;
      FOR tens_index := 2 TO source.number_digits DO
        tens := tens * 10;
      FOREND;

{ Deposit all the digits into the destination
{ For example, if source.significant_digits=18 we would start at 2
{ and if source.significant_digits=1  we would start at 19.

      tsi := 20 - source.significant_digits;
      tsi_max := tsi - 1 + source.number_digits;

      /move_to_standard/
       FOR tsi := tsi TO tsi_max DO
          digit := integer_value DIV tens;
          integer_value := integer_value - (digit * tens);
          ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
          tens := tens DIV 10;
        FOREND /move_to_standard/;

    PROCEND move_binary_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_single_to_standard', EJECT ??

    PROCEDURE move_single_to_standard { from "source" to "ts"} ;


      VAR
        digit: 0..9,
        f: real,
        integer_value: integer,
        negative: BOOLEAN,
        tsi: 2..value_conversion_length;

{ Set up ts: fdt$cobol_description for S9(18)V9(18) USAGE DISPLAY

      initialize_ts;

{ Set up the floating point number

      i#move (source_address, ^f, bytes_for_single);

{ Remember and strip sign

      negative := f < 0.0;
      IF negative THEN
        f := -f;
      IFEND;

{ Divide by 10.0^18, to put all meaningful digits to right of point

{ A simple method would be to divide the floating point value by 10.0^18
{ which puts all meaningful digits to the right of the decimal point,
{ followed by repeatedly multiplying by 10 and getting the most
{ significant digit by truncating.
{ The problem with this approach is that significance can be lost.
{ For example, converting 12.0 to floating point retains the exact
{ mathematical value of 12.0, but dividing by 10^n loses accuracy,
{ since 12 has factors other than 2 or 5.
{ The solution is to convert the INTEGER portion of the number
{ separately from the fraction portion.

{ First ensure that the INTEGER part will fit in a CYBIL INTEGER, which
{ fortunately agrees with COBOL'source 18 digit accuracy requirement.

      IF f >= 1000000000000000000.0 THEN

{ The INTEGER portion of a COMPUTATIONAL-1 or COMPUTATIONAL-2 value
{ must be less than 1,000,000,000,000,000,000.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_float_too_big, '', status);
        EXIT fdp$move_cobol_data;

      IFEND;

      integer_value := $INTEGER (f); { Extract the INTEGER part of the source
      f := f - $REAL (integer_value); { Extract the fraction part of the source

{ Put the INTEGER part into the destination

      FOR tsi := 19 DOWNTO 2 DO
        digit := integer_value MOD 10;
        integer_value := integer_value DIV 10;
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND;

{ Insert fraction digits into destination

      FOR tsi := 20 TO 37 DO
        f := f * 10.0;
        digit := $INTEGER (f);
        f := f - $REAL (digit);
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND;

{ Apply sign, if necessary

      IF negative THEN
        ts_address^ (1) := '-';
      IFEND;

    PROCEND move_single_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_double_to_standard', EJECT ??

    PROCEDURE move_double_to_standard { from "source" to "ts"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          casend,
        recend { kludge_type} ;

      VAR
        destination_index: 1 ..bytes_for_single,
        digit: 0..9,
        f: real,
        kludge: kludge_type,
        n: item_index_min..item_index_max,
        negative: BOOLEAN,
        source_index: 1 .. value_conversion_length,
        tsi: 2 .. value_conversion_length;

{ Set up ts: fdt$cobol_description for S9(18)V9(18) USAGE DISPLAY

      initialize_ts;

{ Set up the floating point number


      FOR destination_index := 1 TO bytes_for_single DO
        kludge.source [destination_index] := source_address^ (destination_index);
      FOREND ;
      f := kludge.r;

{ Remember and strip sign

      negative := f < 0.0;
      IF negative THEN
        f := -f;
      IFEND { negative} ;

{ Divide by 10.0^18, to put all meaningful digits to right of point

{ A simple method would be to divide the floating point value by 10.0^18
{ which puts all meaningful digits to the right of the decimal point,
{ followed by repeatedly multiplying by 10 and getting the most
{ significant digit by truncating.
{ The problem with this approach is that significance can be lost.
{ For example, converting 12.0 to floating point retains the exact
{ mathematical value of 12.0, but dividing by 10^n loses accuracy,
{ since 12 has factors other than 2 or 5.
{ The solution is to convert the INTEGER portion of the number
{ separately from the fraction portion.

{ First ensure that the INTEGER part will fit in a CYBIL INTEGER,
{ which fortunately agrees with COBOL'source 18 digit accuracy requirement.

      IF f >= 1000000000000000000.0 THEN

{ The INTEGER portion of a COMPUTATIONAL-1 or COMPUTATIONAL-2 value
{ must be less than 1,000,000,000,000,000,000.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_float_too_big, '', status);
        EXIT fdp$move_cobol_data;
      IFEND;

      n := $INTEGER (f); { Extract the INTEGER part of the source
      f := f - $REAL (n); { Extract the fraction part of the source

{ Put the INTEGER part into the destination

      FOR tsi := 19 DOWNTO 2 DO
        digit := n MOD 10;
        n := n DIV 10;
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND { tsi} ;

{ Insert fraction digits into destination

      FOR tsi := 20 TO value_conversion_length DO
        f := f * 10.0;
        digit := $INTEGER (f);
        f := f - $REAL (digit);
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND { tsi} ;

{ Apply sign, if necessary

      IF negative THEN
        ts_address^ (1) := '-';
      IFEND;

    PROCEND move_double_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_packed_to_standard', EJECT ??

    PROCEDURE move_packed_to_standard { from "source" to "ts"} ;

      VAR
        digit: 0 .. 15, { decimal digit extracted from source
        left: BOOLEAN, { iff left parcel is next to be filled
        left_parcel: INTEGER, { 4-bit parcel to go in left side of byte
        source_index: 1 .. value_conversion_length,
        tsi: 1 .. value_conversion_length,
        tsi_max: 1 .. value_conversion_length;

{ A PACKED-DECIMAL number has an associated PICTURE that determines
{ the total number of digits (source.number_digits), the number of significant
{ digits (source.significant_digits), and whether a sign is present
{ (source.sign_index<>0).
{ A PACKED-DECIMAL number is represented by putting each decimal digit
{ in its own 4-bit parcel.  A sign is indicated by certain values in
{ the right-most parcel.  An extra zero-value parcel may be added on
{ the left to make a whole number of bytes.

{ Set up ts: fdt$cobol_description for S9(18)V9(18) USAGE DISPLAY

      initialize_ts;

{ Deposit all the digits into the destination
{ For example, if source.significant_digits=18, we would start at 2
{          and if source.significant_digits=1,  we would start at 19.

      left := ((source.number_digits + source.sign_index) MOD 2) = 0;
      source_index := 1;
      tsi := 20 - source.significant_digits;
      tsi_max := tsi - 1 + source.number_digits;
      FOR tsi := tsi TO tsi_max DO
        IF left THEN
          digit := $INTEGER (source_address^ (source_index)) DIV 16
        ELSE
          digit := $INTEGER (source_address^ (source_index)) MOD 16;
          source_index := source_index + 1;
        IFEND;
        left := NOT left;
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND { tsi} ;

      IF source.sign_index <> 0 THEN

{ Source has a sign parcel

        IF left THEN
          digit := $INTEGER (source_address^ (source_index)) DIV 16
        ELSE
          digit := $INTEGER (source_address^ (source_index)) MOD 16;
        IFEND;

        IF digit = 13 THEN
          ts_address^ (1) := '-';
        IFEND { sign parcel is negative
      IFEND { Source has a sign parcel
    PROCEND move_packed_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_standard_to_standard', EJECT ??

    PROCEDURE move_standard_to_binary { from "ts" to "destination"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          = 3 =
            i: INTEGER,
          casend,
        recend;

      VAR
        kludge: kludge_type,
        integer_value: integer,
        tsi: 1 .. value_conversion_length,
        tsi_max: 1 .. value_conversion_length;

{ A "binary" number has an associated PICTURE that determines the
{ total number of digits (destination.number_digits) and the
{ number of significant digits (destination.significant_digits).
{ For example, S9(8)V99 would have destination.size=10 and
{ destination.significant_digits=8.  Take the INTEGER whose digits correspond
{ to the "binary" PICTURE.  For example, a source value of -123456789.1
{ would yield an INTEGER of -2345678910.  Represent this INTEGER
{ in binary.  Keep only the bytes on the right necessary to represent
{ the largest number fitting the "binary" PICTURE.  The COBOL/VE
{ Usage Manual on page 5-34 shows the indicated number of bytes
{ for each PICTURE size.

{ Add all the digits into the destination
{ For example, if destination.significant_digits=18, we would start at 2
{          and if destination.significant_digits=1,  we would start at 19.

      integer_value := 0;
      tsi := 20 - destination.significant_digits;
      tsi_max := tsi - 1 + destination.number_digits;
      FOR tsi := tsi TO tsi_max DO
        integer_value := integer_value * 10 + $INTEGER (ts_address^ (tsi)) - $INTEGER ('0');
      FOREND;

{ Apply sign, if called for

      IF (destination.sign_index = 1) AND (ts_address^ (1) = '-') THEN
        integer_value := -integer_value;
      IFEND { negative} ;

{ Map the final value to the destination.

      kludge.i := integer_value;
      i#move (^kludge.source [bytes_for_integer + 1 - destination.size],
            destination_address, destination.size);

    PROCEND move_standard_to_binary;

?? OLDTITLE ??
?? NEWTITLE :=  'move_standard_to_single', EJECT ??

    PROCEDURE move_standard_to_single { from "ts" to "destination"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          casend,
        recend { kludge_type} ;

      VAR
        digit: INTEGER,
        i: 2 .. value_conversion_length,
        f: real,
        kludge: kludge_type,
        r: real;


      f := 0.0;
      FOR i := 2 TO 19 DO
        digit := $INTEGER (ts_address^ (i)) - $INTEGER ('0');
        f := f * 10.0 + $REAL (digit);
      FOREND;

      r := 0.0;
      FOR i := 20 TO value_conversion_length DO
        digit := $INTEGER (ts_address^ (i)) - $INTEGER ('0');
        r := r * 10.0 + $REAL (digit);
      FOREND { i} ;
      f := f + (r / 1000000000000000000.0 { 10^18} );

{ Put the single-precision result into the destination

      IF ts_address^ (1) = '+' THEN
        kludge.r := f;
      ELSE
        kludge.r := -f;
      IFEND;

      i#move (^kludge.source [bytes_for_single + 1 - destination.size],
            destination_address, destination.size);
    PROCEND move_standard_to_single;

?? OLDTITLE ??
?? NEWTITLE :=  'move_standard_to_double', EJECT ??

    PROCEDURE move_standard_to_double { from "ts" to "destination"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          casend,
        recend { kludge_type} ;

      VAR
        digit: INTEGER,
        i: 1 .. value_conversion_length,
        f: real,
        kludge: kludge_type,
        r: real,
        source_index: 1 .. bytes_for_double;

      f := 0.0;
      FOR i := 2 TO 19 DO
        digit := $INTEGER (ts_address^ (i)) - $INTEGER ('0');
        f := f * 10.0 + $REAL (digit);
      FOREND { i} ;
      r := 0.0;
      FOR i := 20 TO 37 DO
        digit := $INTEGER (ts_address^ (i)) - $INTEGER ('0');
        r := r * 10.0 + $REAL (digit);
      FOREND { i} ;
      f := f + (r / 1000000000000000000.0 { 10^18} );

{ Put the double-precision result into the destination

    IF ts_address^ (1) = '+' THEN
      kludge.r := f;
    ELSE
      kludge.r := -f;
    IFEND;

    destination_index := 1;
    FOR source_index := 1 TO bytes_for_double DO
       destination_address^ (destination_index)
        := kludge.source [source_index];
       destination_index := destination_index + 1;
    FOREND {source_index};

    PROCEND move_standard_to_double;

?? OLDTITLE ??
?? NEWTITLE :=  'move_standard_to_packed', EJECT ??

    PROCEDURE move_standard_to_packed { from "ts" to "destination"} ;

      VAR
        destination_index: 1 .. fdc$cobol_digits_maximum,
        digit: 0 .. 15, { decimal digit extracted from source
        left: BOOLEAN, { iff left parcel is next to be filled
        left_parcel: INTEGER, { 4-bit parcel to go in left side of byte
        tsi: 1 .. value_conversion_length,
        tsi_max: 1 .. value_conversion_length;

{ A PACKED-DECIMAL number has an associated PICTURE that determines
{ the total number of digits (destination.number_digits), the
{ number of significant digits (destination.significant_digits), and
{ whether a sign is present (destination.sign_index<>0).
{ A PACKED-DECIMAL number is represented by putting each decimal digit
{ in its own 4-bit parcel.  A sign is indicated by certain values in
{ the right-most parcel.  An extra zero-value parcel may be added on
{ the left to make a whole number of bytes.
{
{ Space has already been reserved for the final result.

{ Deposit all the digits into the destination
{ For example, if destination.significant_digits=18, we would start at 2
{          and if destination.significant_digits=1,  we would start at 19.

      left :=
       ((destination.number_digits + destination.sign_index) MOD 2) = 0;
      left_parcel := 0;
      destination_index := 1;
      tsi := 20 - destination.significant_digits;
      tsi_max := tsi - 1 + destination.number_digits;
      FOR tsi := tsi TO tsi_max DO
        digit := $INTEGER (ts_address^ (tsi)) - $INTEGER ('0');
        IF left THEN
          left_parcel := digit
        ELSE
          destination_address^ (destination_index) :=
           $CHAR (left_parcel * 16 + digit);
          destination_index := destination_index + 1;
        IFEND;
        left := NOT left;
      FOREND { tsi} ;

      IF destination.sign_index <> 0 THEN

{ Destination needs a sign parcel

        IF ts_address^ (1) = '+' THEN
          digit := 12
        ELSE
          digit := 13;
        IFEND;
        destination_address^ (destination_index) :=
         $CHAR (left_parcel * 16 + digit);
      IFEND { Destination needed a sign parcel
    PROCEND move_standard_to_packed;

?? OLDTITLE ??
?? NEWTITLE :=  'move_display_to_display', EJECT ??

    PROCEDURE move_display_to_display
      (    ts: fdt$cobol_description,
           ts_address: ^STRING ( * );
           destination: fdt$cobol_description;
           destination_address: ^STRING ( * ));

{ Move the USAGE IS DISPLAY source item described by ts & ts_address
{  to the USAGE IS DISPLAY destination item described by destination
{ and destination_address

      VAR

{ each loop, set to destination.operation_characters[oi], then scratch

        c: char,
        destination_index: 1 .. item_index_max + 1,
        i: item_index_min..item_index_max, { scratch
        imax: item_index_min..item_index_max,
        leading_zero_c: char, { char indicating replacement of leading zeros
        leading_zeros: BOOLEAN, { iff we are suppressing leading zeros
        oi: 1 .. fdc$cobol_operations_max, { operation index
        op_code: fdt$cobol_operation, { operation to be done

{ index to "." in destination, else 0

        point_destination_index: item_index_min..item_index_max,
        positive: BOOLEAN, { iff signed number is positive
        source_index: -item_index_max .. item_index_max + 1,
        skip_leading_separate: BOOLEAN, { iff to skip leading separate sign
        zero: BOOLEAN; { iff inserted digits are all zero

?? NEWTITLE := 'get_digit', EJECT ??

      PROCEDURE get_digit

{ This procedure gets the next physical digit from the source,
{ properly skipping any separate sign, and properly extracting
{ the digit from an overpunch sign.
{ It is not a function because CYBIL does not let functions change
{ non-local variables such as "skip_leading_separate".

        (VAR source_index: -item_index_max .. item_index_max + 1;
         VAR digit: char); { The next physical digit

        VAR
          c: char; { Scratch variable


        c := ts_address^ (source_index); { Examine character from source

{ Check if we have a character containing a sign
{ Note that "skip_leading_separate" is true only when the source
{ has a leading separate sign and no digits have been moved yet.
{ We cannot simply check whether source_index = ts.sign_index because
{ we might have to skip leading source physical digits (Test 39).

        IF (source_index = ts.sign_index) OR skip_leading_separate THEN
          skip_leading_separate := FALSE;
          IF ts.sign_separate THEN
            source_index := source_index + 1;
            IF ts.sign_index = 1 THEN
              c := ts_address^ (source_index)
            ELSE
              c := '0'; { Must now be beyond actual digits
            IFEND;

{ end: sign is separate

          ELSE

{ overpunch sign

            IF (c >= '0') AND (c <= '9') THEN

{ Most likely case - leave c a digit

            ELSEIF c = '}' THEN
              c := '0'
            ELSEIF (c >= 'J') AND (c <= 'R') THEN
              c := $CHAR ($INTEGER (c) - $INTEGER ('J') + $INTEGER ('1'))
            ELSEIF (c >= 'j') AND (c <= 'r') THEN
              c := $CHAR ($INTEGER (c) - $INTEGER ('j') + $INTEGER ('1'))
            ELSEIF c = '{' THEN
              c := '0'
            ELSEIF (c >= 'A') AND (c <= 'I') THEN
              c := $CHAR ($INTEGER (c) - $INTEGER ('A') + $INTEGER ('1'))
            ELSEIF (c >= 'a') AND (c <= 'i') THEN
              c := $CHAR ($INTEGER (c) - $INTEGER ('a') + $INTEGER ('1'))
            ELSE

{ Sign of COBOL number does not have correct
{ overpunch representation.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_bad_overpunch_sign, '',
               status);
              EXIT fdp$move_cobol_data;
            IFEND;
          IFEND { overpunch sign
        IFEND { sign} ;
        digit := c;
      PROCEND { get_digit} get_digit;

?? OLDTITLE ??
?? NEWTITLE :=  'set_prev_char', EJECT ??

      PROCEDURE set_prev_char;

        VAR
          pc: char;

{ Change the previous character, if necessary

        pc := '0';
        IF leading_zero_c = fdv$cobol_currency_symbols.primary_money_symbol THEN
          pc := fdv$cobol_currency_symbols.primary_money_symbol;
        ELSEIF leading_zero_c = fdv$cobol_currency_symbols.secondary_money_symbol THEN
          pc := fdv$cobol_currency_symbols.secondary_money_symbol;
        ELSEIF (leading_zero_c = '+') AND positive THEN
          pc := '+'
        ELSEIF (leading_zero_c = '+') { and negative} THEN
          pc := '-'
        ELSEIF (leading_zero_c = '-') AND positive THEN
          pc := ' '
        ELSEIF (leading_zero_c = '-') { and negative} THEN
          pc := '-';
        IFEND;
        IF pc <> '0' THEN

{ We know there is always a previous character,
{ due to fdc$cobol_set_leading_zeros.

          destination_address^ (destination_index - 1) := pc;
        IFEND;
        leading_zeros := FALSE;
      PROCEND set_prev_char;

?? OLDTITLE,  EJECT ??

      skip_leading_separate := FALSE;
      source_index :=
       ts.significant_digits - destination.significant_digits + 1;
      IF ts.sign_index = 0 THEN
        positive := TRUE { Source has no sign
      ELSE

{ source has a sign

        c := ts_address^ (ts.sign_index);
        IF ts.sign_separate THEN
          IF ts.sign_index = 1 THEN
            skip_leading_separate := TRUE;
          IFEND;
          IF c = '+' THEN
            positive := TRUE
          ELSEIF c = '-' THEN
            positive := FALSE
          ELSE

{ Expected source separate sign to be "+" OR "-",
{ but it was not.

            osp$set_status_abnormal (
             fdc$format_display_identifier,
             fde$cobol_bad_separate_sign, '', status);
            EXIT fdp$move_cobol_data;
          IFEND;

        ELSE

{ overpunch sign

          IF  ((c >= 'A') AND (c <= 'I'))
           OR (  c = '{'               )
           OR ((c >= '0') AND (c <= '9'))
           THEN
            positive := TRUE
          ELSEIF ((c >= 'J') AND (c <= 'R')) OR (c = '}') THEN
            positive := FALSE
          ELSE

{ Below should actually be
{ Expected source overpunch sign to be A..R, "{ " OR ")",
{ but it was not.

            osp$set_status_abnormal (
             fdc$format_display_identifier,
             fde$cobol_bad_overpunch_sign, '', status);
            EXIT fdp$move_cobol_data;
          IFEND;
        IFEND; { overpunch sign
      IFEND { source has a sign} ;

      point_destination_index := 0;
      zero := TRUE;
      destination_index := 1;
      leading_zeros := FALSE;
      destination_address^ := '';

      FOR oi := 1 TO destination.move_operations DO
        op_code := destination.cobol_operations [oi];
        c := destination.operation_characters [oi];
        CASE op_code OF
        = fdc$cobol_move =

{ Since this operation corresponds to "9" in a numeric-edited
{ picture, we do not want to blank out the destination field
{ if the destination digits are all zero.

          zero := FALSE;

          imax := destination.operation_numbers [oi];
          FOR i := 1 TO imax DO
            IF source_index <= 0 THEN
              c := '0'
            ELSEIF source_index <= ts.size THEN
              get_digit (source_index, c)
            ELSEIF (destination.cobol_category = fdc$cobol_numeric_signed)
             OR    (destination.cobol_category = fdc$cobol_numeric_unsigned)
             OR    (destination.cobol_category = fdc$cobol_numeric_edited)
             THEN
              c := '0'
            ELSE
              c := ' ';
            IFEND;
            destination_address^ (destination_index) := c;
            destination_index := destination_index + 1;
            source_index := source_index + 1;
          FOREND { i} ;
{ end: fdc$cobol_move} ;

        = fdc$cobol_move_float =

{ move <op_num> chars, floating <op_char>

          imax := destination.operation_numbers [oi];
          FOR i := 1 TO imax DO
            IF source_index <= 0 THEN
              c := '0'
            ELSEIF source_index <= ts.size THEN
              get_digit (source_index, c)
            ELSE
              c := '0';
            IFEND;

            IF c <> '0' THEN
              zero := FALSE; { Remember to not blank field
            IFEND;

            IF leading_zeros THEN
              IF c = '0' THEN
                IF leading_zero_c = '*' THEN
                  c := '*'
                ELSE
                  c := ' '
                IFEND
              ELSE
                set_prev_char; { Switch from suppressing zeros to not
              IFEND;
            IFEND;

            destination_address^ (destination_index) := c;
            destination_index := destination_index + 1;
            source_index := source_index + 1;
          FOREND { i} ;
{ end: fdc$cobol_move_float} ;

        = fdc$cobol_set_leading_zeros =
          leading_zeros := TRUE;
          leading_zero_c := c;
          IF leading_zero_c <> '*' THEN
            c := ' ';
          IFEND;
          IF  (leading_zero_c = '+')
           OR (leading_zero_c = '-')
           OR (leading_zero_c = fdv$cobol_currency_symbols.primary_money_symbol)
           OR (leading_zero_c = fdv$cobol_currency_symbols.secondary_money_symbol) THEN
            destination_address^ (destination_index) := c;
            destination_index := destination_index + 1;
          IFEND;

{ end: fdc$cobol_set_leading_zeros

        = fdc$cobol_overpunch_sign =

{ Since this operation corresponds to "9" in a numeric-edited
{ picture, we do not want to blank out the destination field
{ if the destination digits are all zero.

          zero := FALSE;

          IF source_index <= 0 THEN
            c := '0'
          ELSEIF source_index <= ts.size THEN
            get_digit (source_index, c)
          ELSE
            c := '0';
          IFEND;

          IF NOT positive THEN
            IF c = '0' THEN
              c := '}'
            ELSE
              c := $CHAR ($INTEGER (c) - $INTEGER ('0') + $INTEGER ('I'));
            IFEND
          IFEND { NOT positive} ;

          destination_address^ (destination_index) := c;
          destination_index := destination_index + 1;
          source_index := source_index + 1;
{ end: fdc$cobol_overpunch_sign} ;

        = fdc$cobol_separate_sign =

{ This code is generated for a signed numeric picture
{ with SIGN IS SEPARATE clause, or
{ for a numeric-edited picture with a single "+".

          IF positive THEN
            c := '+'
          ELSE
            c := '-';
          IFEND;
          destination_address^ (destination_index) := c;
          destination_index := destination_index + 1;
{ end: fdc$cobol_separate_sign} ;

        = fdc$cobol_insert =

{ If inserting decimal point, remember in case of "***.**"
{ and zero

          IF c = fdv$cobol_currency_symbols.decimal_symbol THEN
            point_destination_index := destination_index;
          IFEND { .} ;
          imax := destination.operation_numbers [oi];
          IF leading_zeros THEN
            IF leading_zero_c = '*' THEN
              c := '*'
            ELSE
              c := ' '
            IFEND
          IFEND;

          FOR i := 1 TO imax DO
            destination_address^ (destination_index) := c;
            destination_index := destination_index + 1;
          FOREND;

        = fdc$cobol_set_char_if_negative =

{ insert <op_char> if neg, else " "
{ For "CR",
{ if the source is negative or has "cr" set then
{    show "CR"
{ else
{    show "  "
{ Similarly for "DB".
{ For "+" or "-", consider only whether source is negative

          IF (c = 'C') OR (c = 'R') THEN
            IF positive AND NOT ts.display_cr THEN
              c := ' ';
            IFEND
          ELSEIF (c = 'D') OR (c = 'B') THEN
            IF positive AND NOT ts.display_db THEN
              c := ' ';
            IFEND
          ELSE
            IF positive THEN
              c := ' ';
            IFEND
          IFEND;
          destination_address^ (destination_index) := c;
          destination_index := destination_index + 1;

{ end: fdc$cobol_set_char_if_negative

        = fdc$cobol_stop_float =
          IF leading_zeros THEN
            set_prev_char; { and set leading_zeros := false
          IFEND
{ end: fdc$cobol_stop_float} ;
        ELSE
        CASEND { op_code
      FOREND { oi} ;

      IF zero THEN

{ All destination digits were zero, and the destination picture
{ did not have a "9", so clear destination field.

        IF leading_zero_c = '*' THEN
          c := '*'
        ELSE
          c := ' ';
        IFEND;
        FOR destination_index := destination_index - 1 DOWNTO 1 DO
          destination_address^ (destination_index) := c;
        FOREND { destination_index} ;
        IF (leading_zero_c = '*') AND (point_destination_index >= 1) THEN
          destination_address^ (point_destination_index) := fdv$cobol_currency_symbols.decimal_symbol;
        IFEND { e.g. ***.**
      IFEND; { zero

    PROCEND move_display_to_display;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    IF destination.cobol_category = fdc$cobol_free_form THEN

{ Any source to free-form destination.
{ Free form field cannot be destination of fdp$move_cobol_data.

      osp$set_status_abnormal (
       fdc$format_display_identifier, fde$cobol_free_form_not_dest, '', status);
      RETURN;
    IFEND;

    IF source.cobol_category <> fdc$cobol_free_form THEN
      IF source.size <> STRLENGTH (source_address^) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$cobol_source_invalid, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (source.size), 10, FALSE,
                status);
        osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (STRLENGTH (source_address^)), 10, FALSE, status);
        RETURN;
      IFEND;
    IFEND;

   IF destination.size  > STRLENGTH (destination_address^) THEN
      osp$set_status_abnormal (
       fdc$format_display_identifier, fde$cobol_destination_invalid, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (destination.size), 10, FALSE,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (STRLENGTH (destination_address^)), 10, FALSE, status);
      RETURN;
    IFEND;


{ The problem is to move a wide variety of source formats
{ to a wide variety.  We could have special-case code for
{ many conversions, such as COMP-1 to COMP-1, or COMP-1 to COMP-2.
{ We could have as many as 30 such conversion routines - a lot of work!
{ However the use of these routines - in Screen Formatting for use by
{ IM/SMART, and in DM/SQL for use by the COBOL interface -
{ is such that most of the conversions will be from and/or to
{ display.  So we simplify coding by converting non-display
{ source_data (source) to display temporary source_data (ts), if needed.
{ Then we convert the temporary source to the final destination (destination).

{ First ensure the source is in display form, described by "ts"

       IF source.cobol_category = fdc$cobol_free_form THEN
         move_free_form_to_standard
       ELSE

        CASE source.cobol_usage OF

        = fdc$cobol_usage_binary =
          move_binary_to_standard;

        = fdc$cobol_usage_single =
          move_single_to_standard;

        = fdc$cobol_usage_double =
          move_double_to_standard;

        = fdc$cobol_usage_packed =
          move_packed_to_standard;

        ELSE
          IF destination.cobol_usage <> fdc$cobol_usage_display THEN

{ moving display to non-display

           initialize_ts;
           move_display_to_display (source, source_address, ts, ts_address);
          ELSE

{ moving display to display
{ Copy the description from "source" to "ts"

           ts := source;

{ Copy the value from "source_address^" to "ts_address^"

          ts_address := source_address;
        IFEND;
      CASEND;
    IFEND;

{ Now move the display source to the final output, described by "destination"

    CASE destination.cobol_usage OF

    = fdc$cobol_usage_binary =
      move_standard_to_binary;

    = fdc$cobol_usage_single =
      move_standard_to_single;

    = fdc$cobol_usage_double =
      move_standard_to_double;

    = fdc$cobol_usage_packed =
      move_standard_to_packed;

    = fdc$cobol_usage_display =
      move_display_to_display
       (ts, ts_address, destination, destination_address);

    ELSE
    CASEND;

  PROCEND fdp$move_cobol_data;

MODEND fdm$move_cobol_data;

