>From c346732bfc6fce4ebc6d2295c9cdb759c136eab9 Mon Sep 17 00:00:00 2001
From: Robert Dubner <[email protected]>
Date: Sun, 14 Jun 2026 16:25:38 -0400
Subject: [PATCH] cobol: Improve MOVE routines.
Implement MOVE COMP-3 to NumericDisplay. Expand test routines verifying
SIZE
ERROR behavior for the new MOVE algorithms. Fix long-standing errors in
processing truncated MOVEs to numeric-display and packed-decimal that
resulted
in "negative zero" constructions.
gcc/cobol/ChangeLog:
* move.cc (hex_of): Move the routine.
(hex_msg): Likewise.
(clear_negative_zero): New routine for clearing "negative zero"
after certain MOVEs.
(mh_numeric_display): Use clear_negative_zero().
(mh_packed_to_packed): Check for SIZE-ERROR; use
clear_negative_zero().
(mh_packed_to_numdisp): New routine.
(move_helper): Use mh_packed_to_numdisp().
(parser_move): Move the parser_move routine.
(parser_move_multi): Likewise.
(mh_numdisp_to_packed): Move routine; use clear_negative_zero;
* parse.y: Set separate_e for COMP-6 variables.
libgcobol/ChangeLog:
* libgcobol.cc (int128_to_field): Set packed-decimal sign nybble
to
"positive" when value is zero.
gcc/testsuite/ChangeLog:
* cobol.dg/group2/COMP-3_to_COMP-3_size_error.cob: New test.
* cobol.dg/group2/COMP-3_to_COMP-3_size_error.out: New test.
* cobol.dg/group2/COMP-3_to_numeric-display_size_error.cob: New
test.
* cobol.dg/group2/COMP-3_to_numeric-display_size_error.out: New
test.
* cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.cob:
New test.
* cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.out:
New test.
* cobol.dg/group2/numeric-display_to_COMP-3_size_error.cob: New
test.
* cobol.dg/group2/numeric-display_to_COMP-3_size_error.out: New
test.
---
gcc/cobol/move.cc | 1737 ++++++++++-------
gcc/cobol/parse.y | 2 +-
.../group2/COMP-3_to_COMP-3_size_error.cob | 34 +
.../group2/COMP-3_to_COMP-3_size_error.out | 5 +
.../COMP-3_to_numeric-display_size_error.cob | 34 +
.../COMP-3_to_numeric-display_size_error.out | 5 +
...ear_negative_zero_after_truncated_MOVE.cob | 23 +
...ear_negative_zero_after_truncated_MOVE.out | 5 +
.../numeric-display_to_COMP-3_size_error.cob | 34 +
.../numeric-display_to_COMP-3_size_error.out | 5 +
libgcobol/libgcobol.cc | 5 +
11 files changed, 1236 insertions(+), 653 deletions(-)
create mode 100644
gcc/testsuite/cobol.dg/group2/COMP-3_to_COMP-3_size_error.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/COMP-3_to_COMP-3_size_error.out
create mode 100644
gcc/testsuite/cobol.dg/group2/COMP-3_to_numeric-display_size_error.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/COMP-3_to_numeric-display_size_error.out
create mode 100644
gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.out
create mode 100644
gcc/testsuite/cobol.dg/group2/numeric-display_to_COMP-3_size_error.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/numeric-display_to_COMP-3_size_error.out
diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc
index 677b5b0ffb3..705d9a032d6 100644
--- a/gcc/cobol/move.cc
+++ b/gcc/cobol/move.cc
@@ -57,6 +57,28 @@
#include "realmpfr.h"
#include "compare.h"
+#if 0
+// This is a debugging function used from time-to-time
+static void
+hex_of(tree location, size_t bytes)
+ {
+ gg_printf("0x", NULL_TREE);
+ for(size_t i=0; i<bytes; i++)
+ {
+ gg_printf("%2.2X", gg_indirect_i(gg_cast(UCHAR_P, location), i),
NULL_TREE);
+ }
+ }
+
+static void
+hex_msg(const char *msg, tree location, size_t bytes)
+ {
+ gg_printf("%s ", gg_string_literal(msg), NULL_TREE);
+ hex_of(location, bytes);
+ gg_printf("\n", NULL_TREE);
+ }
+
+#endif
+
static cbl_figconst_t
is_figconst_t(const cbl_field_t *field)
{
@@ -1008,6 +1030,102 @@ picky_memcpy(tree &dest_p, const tree &source_p,
size_t length, tree zero)
}
}
+static void
+clear_negative_zero(const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ tree dest_location)
+ {
+ // It is an idiosyncracy of numeric-edited and packed-decimal that a
+ // truncated value can end up zero, but with a negative flag. This
routine
+ // makes such values positive.
+ if( !(sourceref.field->attr & signable_e)
+ || !(destref.field->attr & signable_e) )
+ {
+ return;
+ }
+ // They are both signable.
+ // Was truncation involved?
+ if( (sourceref.field->data.digits - sourceref.field->data.rdigits)
+ <= (destref.field->data.digits - destref.field->data.rdigits ) )
+ {
+ return;
+ }
+ // The source side was truncated.
+
+ charmap_t *charmap =
+ __gg__get_charmap(destref.field->codeset.encoding);
+ tree goto_bugout;
+ tree label_bugout;
+ gg_create_goto_pair(&goto_bugout,
+ &label_bugout);
+ tree p = gg_define_variable(UCHAR_P);
+ tree p_end = gg_define_variable(UCHAR_P);
+ gg_assign(p, dest_location);
+ gg_assign(p_end,
+ gg_add(p,
+ build_int_cst_type(SIZE_T,
+
destref.field->data.capacity()-1)));
+ // All the bytes before last one have to be zero:
+ tree tzero = build_int_cst_type(UCHAR,
+ destref.field->type == FldPacked
+ ? 0
+ : charmap->mapped_character(ascii_zero));
+ WHILE( p, lt_op, p_end )
+ {
+ IF( gg_indirect(p), ne_op, tzero )
+ {
+ // This byte is non-zero, so beat it.
+ gg_append_statement(goto_bugout);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ gg_increment(p);
+ }
+ WEND
+ if( destref.field->type == FldPacked )
+ {
+ // If the final byte is 0x0D, then we have to make it 0x0C
+ IF( gg_indirect(p), eq_op, build_int_cst_type(UCHAR, 0x0D) )
+ {
+ gg_assign(gg_indirect(p), build_int_cst_type(UCHAR, 0x0C) );
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ else
+ {
+ // This is numeric display.
+ IF( gg_bitwise_and(gg_indirect(p), build_int_cst_type(UCHAR, 0x0F)),
+ eq_op,
+ build_int_cst_type(UCHAR, 0x00) )
+ {
+ if( charmap->is_like_ebcdic() )
+ {
+ // We force it positive by making 0xDN into 0xFN
+ gg_assign(gg_indirect(p),
+ gg_bitwise_or(gg_indirect(p),
+ build_int_cst_type(UCHAR, 0xF0)));
+ }
+ else
+ {
+ // We force it positive by making 0x7N into 0x3N
+ gg_assign(gg_indirect(p),
+ gg_bitwise_and(gg_indirect(p),
+ build_int_cst_type(UCHAR, 0x3F)));
+ }
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ gg_append_statement(label_bugout);
+ }
+
static bool
mh_numeric_display( const cbl_refer_t &destref,
const cbl_refer_t &sourceref,
@@ -1398,8 +1516,13 @@ mh_numeric_display( const cbl_refer_t &destref,
}
moved = true;
}
+
+ clear_negative_zero(destref,
+ sourceref,
+ qualified_data_location(destref));
+
return moved;
- } //NUMERIC_DISPLAY_SIGN
+ }
static bool
mh_little_endian( const cbl_refer_t &destref,
@@ -1995,130 +2118,480 @@ mh_alpha_to_alpha(const cbl_refer_t &destref,
static bool
mh_numdisp_to_packed(const cbl_refer_t &destref,
- const cbl_refer_t &sourceref);
-
-static bool
-mh_packed_to_packed(const cbl_refer_t &destref,
- const cbl_refer_t &sourceref)
+ const cbl_refer_t &sourceref,
+ tree size_error,
+ bool check_for_error)
{
- if( (destref.field->type != FldPacked )
- || (sourceref.field->type != FldPacked )
- || (destref.field->attr & scaled_e )
- || (sourceref.field->attr & scaled_e )
- || (destref.field->attr & packed_no_sign_e )
- || (sourceref.field->attr & packed_no_sign_e ) )
+ const charmap_t *charmap =
+ __gg__get_charmap(sourceref.field->codeset.encoding);
+ if( (destref.field->type != FldPacked )
+ || (sourceref.field->type != FldNumericDisplay )
+ || (charmap->stride() != 1 )
+ || (destref.field->attr & scaled_e )
+ || (sourceref.field->attr & scaled_e )
+ || (destref.field->attr & packed_no_sign_e )
+ || (sourceref.field->attr & leading_e )
+ || (sourceref.field->attr & separate_e ) )
{
return false;
}
- // Arriving here means both are packed, neither is scaled, and neither
is
- // COMP-6 or PACKED NO SIGN.
-
- // We are going to move source to the dest doing the absolute minimum
number
- // of operations. We are thus going to use memcpy (with constant
lengths)
- // as much as we can, and use conditionals and nybble operations as
little
- // little as possible.
-
- // There are two broad cases. The more straightforward case is where
source
- // rdigits and dest rdigits are both even, or both odd. When that is
the
- // case, the source and destination decimal places are "in phase"
somewhere
- // inside both the dest and the source. Once we figure out the right
- // offsets, we can memcpy the "inside" of the source to the correct
location
- // in the dest. We fiddle with the leading digits, the trailing
digits, and
- // the sign nybble as necessary.
+ /* Source is NumericDisplay, dest is packed, neither are scaled, the
+ packed destination has a sign nybble, and the numeric source has an
+ ordinarysign bit encoded in the final digit. */
+ tree uzero = build_int_cst_type(UCHAR, 0);
+ tree umask = build_int_cst_type(UCHAR, 0x0F);
+ tree ufour = build_int_cst_type(SIZE_T, 4);
tree source_location = gg_define_variable(UCHAR_P);
tree dest_location = gg_define_variable(UCHAR_P);
- tree source_sign = gg_define_variable(UCHAR_P);
- tree dest_sign = gg_define_variable(UCHAR_P);
+ tree dest_p = gg_define_variable(UCHAR_P);
+ tree source_p = gg_define_variable(UCHAR_P);
+
tree temp;
get_location(temp, destref);
gg_assign(dest_location, temp);
-
+ gg_assign(dest_p, dest_location);
get_location(temp, sourceref);
gg_assign(source_location, temp);
- int source_digits = sourceref.field->data.digits;
- int source_rdigits = sourceref.field->data.rdigits;
- size_t source_capacity = source_digits/2 + 1;
- if( ((destref.field->data.rdigits ^ source_rdigits) & 1) )
+ int source_digits = sourceref.field->data.digits;
+ int source_rdigits = sourceref.field->data.rdigits;
+ int source_ldigits = source_digits - source_rdigits;
+ int dest_digits = destref.field->data.digits;
+ int dest_rdigits = destref.field->data.rdigits;
+ int dest_ldigits = dest_digits - dest_rdigits;
+
+ int truncate_ldigits = std::max(0, source_ldigits-dest_ldigits);
+ int truncate_rdigits = std::max(0, source_rdigits-dest_rdigits);
+ int leading_zeroes = std::max(0, dest_ldigits-source_ldigits);
+ int trailing_zeroes = std::max(0, dest_rdigits-source_rdigits);
+
+ int zero_pairs;
+ int digit_pairs;
+ int source_remaining;
+
+ if( truncate_ldigits )
{
- /* This is an "out-of-phase" move, e.g., MOVE 999v99 to 999v9. The
code
- below handles in-phase moves, so we handle this by making a
left-shifted
- copy of the source side. By left-shifting it one nybble,
incrementing
- the source_rdigits, and changing the location to the shifted
version, we
- turn the out-of-phase problem into an in-phase problem. */
- size_t shifted_size;
- if( source_digits & 1 )
+ // We handle truncation of digits on the left by moving the starting
line.
+ if( check_for_error )
{
- // The source, plus the sign nybble, fills an even number of
nybbles, and
- // so the shift requires an addition byte on the left.
- shifted_size = source_capacity + 1;
+ // We need to flag as a truncation error any truncated places that
are
+ // not zero.
+ gg_assign(source_p, source_location);
+ tree trunc_end = gg_define_variable(UCHAR_P);
+ gg_assign(trunc_end,
+ gg_add(source_p,
+ build_int_cst_type(SIZE_T, truncate_ldigits)));
+ WHILE(source_p, lt_op, trunc_end)
+ {
+ gg_assign(size_error,
+ gg_bitwise_or(size_error,
+ gg_indirect(source_p)));
+ gg_increment(source_p);
+ }
+ WEND
+ // We care about only the bottom four bits.
+ gg_assign(size_error,
+ gg_bitwise_and(size_error, gg_cast(INT, umask)));
}
else
{
- // The highest-order source nybble is a zero, so the shift will
fill it
- // without any additional storage needed.
- shifted_size = source_capacity;
+ gg_assign(source_p,
+ gg_add(source_location,
+ build_int_cst_type(SIZE_T, truncate_ldigits)));
}
- // Allocate storage for the shifted version:
- tree shifted_type = build_array_type_nelts(UCHAR, shifted_size);
- tree shifted = gg_define_variable(shifted_type);
- TREE_ADDRESSABLE(shifted) = 1;
- tree source_p = gg_define_variable(UCHAR_P);
- tree shifted_p_left = gg_define_variable(UCHAR_P);
- tree shifted_p_right = gg_define_variable(UCHAR_P);
- tree carry = gg_define_variable(UCHAR);
- tree carry_next = gg_define_variable(UCHAR);
- gg_assign(source_p,
- gg_add(source_location,
- build_int_cst_type(SIZE_T,
- source_capacity-1)));
- gg_assign(shifted_p_left, gg_pointer_to_array(shifted));
- gg_assign(shifted_p_right,
- gg_add(shifted_p_left,
- build_int_cst_type(SIZE_T, shifted_size-1)));
- // Start with the right side.
- // Pick up the carry, which is the left side of the rightmost byte
- gg_assign(carry,
- gg_rshift(gg_indirect(source_p),
- build_int_cst_type(SIZE_T, 4)));
- // Keep the sign nybble in place, but with a zero to its left
- gg_assign(gg_indirect(shifted_p_right),
- gg_bitwise_and(gg_indirect(source_p),
- build_int_cst_type(UCHAR, 0x0F)));
+ source_digits -= truncate_ldigits;
+ source_ldigits -= truncate_ldigits;
+ }
+ else
+ {
+ gg_assign(source_p, source_location);
+ }
- gg_decrement(source_p);
- gg_decrement(shifted_p_right);
- WHILE(shifted_p_right, gt_op, shifted_p_left)
- {
- gg_assign(carry_next,
- gg_rshift(gg_indirect(source_p),
- build_int_cst_type(SIZE_T, 4)));
- gg_assign(gg_indirect(shifted_p_right),
- gg_bitwise_or(gg_lshift(gg_indirect(source_p),
- build_int_cst_type(SIZE_T, 4)),
- carry));
- gg_assign(carry, carry_next);
- gg_decrement(source_p);
- gg_decrement(shifted_p_right);
- }
- WEND
- // At this point, shifted_p_right equals shifted_p_left
- if( source_digits & 1 )
+ if( truncate_rdigits )
+ {
+ // We handle truncation of digits on the right by moving the finish
line.
+ source_digits -= truncate_rdigits;
+ source_ldigits -= truncate_rdigits;
+ }
+
+ if( !source_digits )
+ {
+ // When source_digits is zero, it means that some pervert of a COBOL
+ // programmer told us to MOVE 999V TO V999. The result has to be
zero,
+ // and our life down below will be easier when we know that there is
at
+ // least one digit that needs to be moved from the source to the
+ // destination.
+ gg_memset(dest_p,
+ integer_zero_node,
+ build_int_cst_type(SIZE_T,
destref.field->data.capacity()));
+ goto adjust_sign;
+ }
+
+ source_remaining = source_digits;
+
+ // The first thing we need to do is adjust the first byte of the
destination
+ // so that we know where we are in left-nybble/right-nybble space.
Let's
+ // call the digit at source_p "N". (That digit might be a leading
zero.)
+ // When dest_digits is an even number, it means the final result is
something
+ // like 0N.23.4s. So, when dest_digits is even, we have to start
things off
+ // with "0N".
+
+ if( !(dest_digits & 0x01) )
+ {
+ // dest_digits is an even number.
+ if( leading_zeroes )
{
- // The source, plus the sign nybble, fills an even number of
nybbles, and
- // so the shift requires an addition byte on the left.
- gg_assign(gg_indirect(shifted_p_left), carry);
+ // The first byte is "0N", but N is zero:
+ gg_assign(gg_indirect(dest_p), uzero);
+ leading_zeroes -= 1;
}
else
{
- // The highest-order source nybble is a zero, so the shift will
fill it
- // without any additional storage needed.
- gg_assign(gg_indirect(shifted_p_left),
- gg_bitwise_or(gg_lshift(gg_indirect(source_p),
- build_int_cst_type(SIZE_T, 4)),
- carry));
+ // The first byte is "0N", where N is the value from the first
character
+ // of the source. We know that source_remaining is at least one at
this
+ // point.
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_and(gg_indirect(source_p), umask));
+ gg_increment(source_p);
+ source_remaining -= 1;
+ }
+ gg_increment(dest_p);
+ }
+
+ // At this point, we know that leading + source + trailing is an odd
+ // number.
+
+ // We know that dest_p is set up to accept a left/right pair next.
Let's
+ // see if we have enough leading_zeroes to warrant using memset:
+ zero_pairs = leading_zeroes/2;
+ if( zero_pairs )
+ {
+ // We can use memset to handle left-side zero-fill:
+ tree tpairs = build_int_cst_type(SIZE_T, zero_pairs);
+ gg_memset(dest_p, integer_zero_node, tpairs);
+ gg_assign(dest_p, gg_add(dest_p, tpairs));
+ leading_zeroes -= 2 * zero_pairs;
+ }
+
+ // dest-p is still set up for a left/right pair.
+ if( leading_zeroes )
+ {
+ // But we still have one leading zero left. We know at this point
that
+ // there is at least one source digit left, so build the byte using
+ // zero/*source_p
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_and(gg_indirect(source_p), umask));
+ //leading_zeroes -= 1;
+ source_remaining -= 1;
+ gg_increment(source_p);
+ gg_increment(dest_p);
+ }
+
+ // At this point, we know that leading_zeroes is zero. We know that
+ // source_remaining + trailing_zeroes is an odd number. We
+ // currently have dest_p lined up on a left-right boundary.
+
+ // We are going to transfer as many pairs of source_remaining digits as
we
+ // can.
+
+ digit_pairs = source_remaining/2;
+ if( digit_pairs )
+ {
+ tree dest_end = gg_define_variable(UCHAR_P);
+ gg_assign(dest_end,
+ gg_add(dest_p,
+ build_int_cst_type(SIZE_T, digit_pairs)));
+ WHILE( dest_p, lt_op, dest_end )
+ {
+ tree left_nybble = gg_lshift(gg_indirect(source_p), ufour);
+ tree right_nybble = gg_bitwise_and(gg_indirect(source_p,
+ integer_one_node),
+ umask);
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(left_nybble, right_nybble));
+ gg_increment(dest_p);
+ gg_assign(source_p,
+ gg_add(source_p, build_int_cst_type(SIZE_T, 2)));
+ }
+ WEND
+ source_remaining -= 2 * digit_pairs;
+ }
+
+ // At this point, source_remaining is zero or one
+
+ if( source_remaining )
+ {
+ gg_assign(gg_indirect(dest_p),
+ gg_lshift(gg_indirect(source_p), ufour));
+ gg_increment(dest_p);
+ //source_remaining -= 1;
+ if( trailing_zeroes )
+ {
+ trailing_zeroes -= 1;
+ }
+ }
+ // At this point, we know trailing_zeroes has to be an even number, and
we
+ // need to zero out that many nybbles:
+
+ if( trailing_zeroes >= 2 )
+ {
+ zero_pairs = trailing_zeroes/2;
+ // We can use memset to handle left-side zero-fill:
+ tree tpairs = build_int_cst_type(SIZE_T, zero_pairs);
+ gg_memset(dest_p, integer_zero_node, tpairs);
+ gg_assign(dest_p, gg_add(dest_p, tpairs));
+ trailing_zeroes -= 2 * zero_pairs;
+ }
+
+ if( trailing_zeroes )
+ {
+ // There is one trailing zero left
+ gg_assign(gg_indirect(dest_p), uzero);
+ gg_increment(dest_p);
+ //trailing_zeroes -= 1;
+ }
+
+ adjust_sign:
+ gg_assign(dest_p, gg_add(dest_location,
+ build_int_cst_type(SIZE_T,
+
destref.field->data.capacity()-1)));
+
+ if( !(destref.field->attr & signable_e) )
+ {
+ // The destination is not signable
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p), umask));
+ }
+ else
+ {
+ if( sourceref.field->attr & signable_e )
+ {
+ // This is the location of the character with the sign flag.
+ gg_assign(source_p, gg_add(source_location,
+ build_int_cst_type(SIZE_T,
+
sourceref.field->data.capacity()-1)));
+ if( charmap->is_like_ebcdic() )
+ {
+ // EBCDIC digits are 0xF0 through 0xF9; negative is flagged by
+ // 0xD0 through 0xD9
+ IF( gg_indirect(source_p), lt_op, build_int_cst_type(UCHAR, 0xF0)
)
+ {
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(UCHAR, 0x0D)));
+ }
+ ELSE
+ {
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(UCHAR, 0x0C)));
+ }
+ ENDIF
+ }
+ else
+ {
+ // EBCDIC digits are 0x30 through 0x39; negative is flagged by
+ // 0x70 through 0x79
+ IF( gg_indirect(source_p), ge_op, build_int_cst_type(UCHAR, 0x70)
)
+ {
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(UCHAR, 0x0D)));
+ }
+ ELSE
+ {
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(UCHAR, 0x0C)));
+ }
+ ENDIF
+ }
+ }
+ else
+ {
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(UCHAR, 0x0C)));
+ }
+ }
+ clear_negative_zero(destref,
+ sourceref,
+ dest_location);
+ return true;
+ }
+
+static bool
+mh_packed_to_packed(const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ tree size_error,
+ bool check_for_error)
+ {
+ if( (destref.field->type != FldPacked )
+ || (sourceref.field->type != FldPacked )
+ || (destref.field->attr & scaled_e )
+ || (sourceref.field->attr & scaled_e )
+ || (destref.field->attr & packed_no_sign_e )
+ || (sourceref.field->attr & packed_no_sign_e ) )
+ {
+ return false;
+ }
+ // Arriving here means both are packed, neither is scaled, and neither
is
+ // COMP-6 or PACKED NO SIGN.
+
+ // We are going to move source to the dest doing the absolute minimum
number
+ // of operations. We are thus going to use memcpy (with constant
lengths)
+ // as much as we can, and use conditionals and nybble operations as
little
+ // little as possible.
+
+ // There are two broad cases. The more straightforward case is where
source
+ // rdigits and dest rdigits are both even, or both odd. When that is
the
+ // case, the source and destination decimal places are "in phase"
somewhere
+ // inside both the dest and the source. Once we figure out the right
+ // offsets, we can memcpy the "inside" of the source to the correct
location
+ // in the dest. We fiddle with the leading digits, the trailing
digits, and
+ // the sign nybble as necessary.
+
+ tree source_location = gg_define_variable(UCHAR_P);
+ tree dest_location = gg_define_variable(UCHAR_P);
+ tree source_sign = gg_define_variable(UCHAR_P);
+ tree dest_sign = gg_define_variable(UCHAR_P);
+ tree temp;
+
+ get_location(temp, destref);
+ gg_assign(dest_location, temp);
+
+ get_location(temp, sourceref);
+ gg_assign(source_location, temp);
+
+ if( check_for_error )
+ {
+ int source_digits = sourceref.field->data.digits;
+ if( !(source_digits & 1) )
+ {
+ // When source_digits is an even number, then the leftmost byte is
+ // 0x0n.
+ source_digits += 1;
+ }
+ int source_ldigits = source_digits
+ - sourceref.field->data.rdigits;
+ int dest_ldigits = destref.field->data.digits
+ - destref.field->data.rdigits;
+ int truncate_ldigits = std::max(0, source_ldigits - dest_ldigits);
+ if( truncate_ldigits )
+ {
+ tree truncate_p = gg_define_variable(UCHAR_P);
+ gg_assign(truncate_p, source_location);
+ int truncate_pairs = truncate_ldigits / 2;
+ if( truncate_pairs )
+ {
+ tree truncate_e = gg_define_variable(UCHAR_P);
+ gg_assign(truncate_e,
+ gg_add(truncate_p,
+ build_int_cst_type(SIZE_T, truncate_pairs)));
+ WHILE( truncate_p, lt_op, truncate_e )
+ {
+ gg_assign(size_error,
+ gg_bitwise_or(size_error,
+ gg_cast(INT,
gg_indirect(truncate_p))));
+ gg_increment(truncate_p);
+ }
+ WEND
+ truncate_ldigits &= 1;
+ }
+ if( truncate_ldigits )
+ {
+ gg_assign(size_error,
+ gg_bitwise_or(size_error,
+ gg_cast(INT,
+ gg_bitwise_and(gg_indirect(truncate_p),
+ build_int_cst_type(UCHAR,
+
0xF0)))));
+ }
+ }
+ }
+ int source_digits = sourceref.field->data.digits;
+ int source_rdigits = sourceref.field->data.rdigits;
+ size_t source_capacity = source_digits/2 + 1;
+ if( ((destref.field->data.rdigits ^ source_rdigits) & 1) )
+ {
+ /* This is an "out-of-phase" move, e.g., MOVE 999v99 to 999v9. The
code
+ below handles in-phase moves, so we handle this by making a
left-shifted
+ copy of the source side. By left-shifting it one nybble,
incrementing
+ the source_rdigits, and changing the location to the shifted
version, we
+ turn the out-of-phase problem into an in-phase problem. */
+ size_t shifted_size;
+ if( source_digits & 1 )
+ {
+ // The source, plus the sign nybble, fills an even number of
nybbles, and
+ // so the shift requires an addition byte on the left.
+ shifted_size = source_capacity + 1;
+ }
+ else
+ {
+ // The highest-order source nybble is a zero, so the shift will
fill it
+ // without any additional storage needed.
+ shifted_size = source_capacity;
+ }
+ // Allocate storage for the shifted version:
+ tree shifted_type = build_array_type_nelts(UCHAR, shifted_size);
+ tree shifted = gg_define_variable(shifted_type);
+ TREE_ADDRESSABLE(shifted) = 1;
+ tree source_p = gg_define_variable(UCHAR_P);
+ tree shifted_p_left = gg_define_variable(UCHAR_P);
+ tree shifted_p_right = gg_define_variable(UCHAR_P);
+ tree carry = gg_define_variable(UCHAR);
+ tree carry_next = gg_define_variable(UCHAR);
+ gg_assign(source_p,
+ gg_add(source_location,
+ build_int_cst_type(SIZE_T,
+ source_capacity-1)));
+ gg_assign(shifted_p_left, gg_pointer_to_array(shifted));
+ gg_assign(shifted_p_right,
+ gg_add(shifted_p_left,
+ build_int_cst_type(SIZE_T, shifted_size-1)));
+ // Start with the right side.
+ // Pick up the carry, which is the left side of the rightmost byte
+ gg_assign(carry,
+ gg_rshift(gg_indirect(source_p),
+ build_int_cst_type(SIZE_T, 4)));
+ // Keep the sign nybble in place, but with a zero to its left
+ gg_assign(gg_indirect(shifted_p_right),
+ gg_bitwise_and(gg_indirect(source_p),
+ build_int_cst_type(UCHAR, 0x0F)));
+
+ gg_decrement(source_p);
+ gg_decrement(shifted_p_right);
+ WHILE(shifted_p_right, gt_op, shifted_p_left)
+ {
+ gg_assign(carry_next,
+ gg_rshift(gg_indirect(source_p),
+ build_int_cst_type(SIZE_T, 4)));
+ gg_assign(gg_indirect(shifted_p_right),
+ gg_bitwise_or(gg_lshift(gg_indirect(source_p),
+ build_int_cst_type(SIZE_T, 4)),
+ carry));
+ gg_assign(carry, carry_next);
+ gg_decrement(source_p);
+ gg_decrement(shifted_p_right);
+ }
+ WEND
+ // At this point, shifted_p_right equals shifted_p_left
+ if( source_digits & 1 )
+ {
+ // The source, plus the sign nybble, fills an even number of
nybbles, and
+ // so the shift requires an addition byte on the left.
+ gg_assign(gg_indirect(shifted_p_left), carry);
+ }
+ else
+ {
+ // The highest-order source nybble is a zero, so the shift will
fill it
+ // without any additional storage needed.
+ gg_assign(gg_indirect(shifted_p_left),
+ gg_bitwise_or(gg_lshift(gg_indirect(source_p),
+ build_int_cst_type(SIZE_T, 4)),
+ carry));
}
// We now have the left-shifted source in 'shifted'.
@@ -2200,98 +2673,345 @@ mh_packed_to_packed(const cbl_refer_t &destref,
else if( (sourceref.field->attr & signable_e)
&& !(destref.field->attr & signable_e) )
{
- // The signable source has an 0xC or 0xD sign nybble, so we need to
- // turn that into an 0xF in the unsignable destination:
- gg_assign(gg_indirect(dest_sign),
- gg_bitwise_or(gg_indirect(dest_sign),
- build_int_cst_type(UCHAR, 0x0F)));
+ // The signable source has an 0xC or 0xD sign nybble, so we need to
+ // turn that into an 0xF in the unsignable destination:
+ gg_assign(gg_indirect(dest_sign),
+ gg_bitwise_or(gg_indirect(dest_sign),
+ build_int_cst_type(UCHAR, 0x0F)));
+ }
+ }
+ else
+ {
+ // There is mismatch between source and dest rdigits:
+ if( source_rbytes < dest_rbytes )
+ {
+ // The source was too short to fill the destination, which means we
+ // currently have a source's sign nybble sitting in the middle of
the
+ // destination. We need to zero out that nybble
+ gg_assign(gg_indirect(dest_location,
+ build_int_cst_type(SIZE_T,
+ bytes_to_copy-1)),
+ gg_bitwise_and(gg_indirect(dest_location,
+ build_int_cst_type(SIZE_T,
+ bytes_to_copy-1)),
+ build_int_cst_type(UCHAR,
0xF0)));
+ // And then we need to zero out the remaining dest_rbytes:
+ int remaining_rbytes = dest_rbytes - source_rbytes;
+ if( remaining_rbytes > 1 )
+ {
+ gg_memset(gg_add(dest_location,
+ build_int_cst_type(SIZE_T, bytes_to_copy)),
+ integer_zero_node,
+ build_int_cst_type(SIZE_T,
+ destref.field->data.capacity() -
bytes_to_copy));
+ }
+ // And now we have to adjust the final nybble:
+
+ if( !(sourceref.field->attr & signable_e)
+ && (destref.field->attr & signable_e) )
+ {
+ // The source is unsignable, so we turn that into an positive 0xC
in
+ // the signable destination:
+ gg_assign(gg_indirect(dest_sign), build_int_cst_type(UCHAR,
0x0C));
+ }
+ else if( (sourceref.field->attr & signable_e)
+ && !(destref.field->attr & signable_e) )
+ {
+ gg_assign(gg_indirect(dest_sign), build_int_cst_type(UCHAR,
0x0F));
+ }
+ else
+ {
+ // The source and the destination are either both signable, or
+ // both unsignable. We copy the source's sign nybble to the
dest.
+ gg_assign(gg_indirect(dest_sign),
+ gg_bitwise_or(gg_indirect(dest_sign),
+ gg_bitwise_and(gg_indirect(source_sign),
+ build_int_cst_type(UCHAR,
+
0x0F))));
+ }
+ }
+ else // source_rbytes > dest_rbytes
+ {
+ // There were more source_rbytes than we needed, which means the
final
+ // nybble of the destination is a digit that needs to be truncated
+ // away and replaced with the correct sign nybble.
+ if( !(sourceref.field->attr & signable_e)
+ && (destref.field->attr & signable_e) )
+ {
+ // The source was unsignable, so we set the sign nybble to a
+ // a positive 0x0C
+ gg_assign(gg_indirect(dest_sign),
+ gg_bitwise_or(gg_bitwise_and(gg_indirect(dest_sign),
+ build_int_cst_type(UCHAR, 0xF0)),
+ build_int_cst_type(UCHAR, 0x0C)));
+ }
+ else if( (sourceref.field->attr & signable_e)
+ && !(destref.field->attr & signable_e) )
+ {
+ // The dest is unsignable; turn the final nybble into an 0xFo
+ gg_assign(gg_indirect(dest_sign),
+ gg_bitwise_or(gg_indirect(dest_sign),
+ build_int_cst_type(UCHAR, 0x0F)));
+ }
+ else
+ {
+ // The source and the destination are either both signable, or
+ // both unsignable. We copy the source's sign nybble to the
dest.
+ gg_assign(gg_indirect(dest_sign),
+ gg_bitwise_or(gg_bitwise_and(gg_indirect(dest_sign),
+ build_int_cst_type(UCHAR, 0xF0)),
+ gg_bitwise_and(gg_indirect(source_sign),
+ build_int_cst_type(UCHAR, 0x0F))));
+ }
+ }
+ }
+ clear_negative_zero(destref,
+ sourceref,
+ dest_location);
+ return true;
+ }
+
+static bool
+mh_packed_to_numdisp(const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ tree size_error,
+ bool check_for_error)
+ {
+ charmap_t *charmap =
+ __gg__get_charmap(destref.field->codeset.encoding);
+
+ if( (sourceref.field->type != FldPacked )
+ || (destref.field->type != FldNumericDisplay )
+ || (charmap->stride() != 1 )
+ || (sourceref.field->attr & scaled_e )
+ || (destref.field->attr & scaled_e )
+ || (sourceref.field->attr & packed_no_sign_e )
+ || (destref.field->attr & leading_e )
+ || (destref.field->attr & separate_e ) )
+ {
+ return false;
+ }
+
+ /* Source is packed, dest is numeric-display, neither are scaled, the
+ packed source has a sign nybble, and the numeric-display dest has an
+ ordinary sign bit encoded in the final digit. */
+ tree umask = build_int_cst_type(UCHAR, 0x0F);
+ tree ufour = build_int_cst_type(SIZE_T, 4);
+ tree uzero = build_int_cst_type(UCHAR,
+ charmap->mapped_character(ascii_zero));
+ tree source_location = gg_define_variable(UCHAR_P);
+ tree dest_location = gg_define_variable(UCHAR_P);
+ tree dest_p = gg_define_variable(UCHAR_P);
+ tree source_p = gg_define_variable(UCHAR_P);
+
+ tree temp;
+ get_location(temp, destref);
+ gg_assign(dest_location, temp);
+ gg_assign(dest_p, dest_location);
+ get_location(temp, sourceref);
+ gg_assign(source_location, temp);
+
+ // source_digits will be the number of digits extracted from the source
that
+ // find their way into the destination.
+ int source_digits = sourceref.field->data.digits;
+
+ if( !(source_digits & 0x01) )
+ {
+ // Because this is an even number, the first byte of the packed value
is
+ // 0x0N. The following logic is a tad simpler when we just increment
it,
+ // as if the zero in the left nybble is part of the packed-decimal
value.
+ source_digits += 1;
+ }
+
+ int source_rdigits = sourceref.field->data.rdigits;
+ int source_ldigits = source_digits - source_rdigits;
+ int dest_digits = destref.field->data.digits;
+ int dest_rdigits = destref.field->data.rdigits;
+ int dest_ldigits = dest_digits - dest_rdigits;
+
+ int truncate_ldigits = std::max(0, source_ldigits-dest_ldigits);
+ int truncate_rdigits = std::max(0, source_rdigits-dest_rdigits);
+ int leading_zeroes = std::max(0, dest_ldigits-source_ldigits);
+ int trailing_zeroes = std::max(0, dest_rdigits-source_rdigits);
+
+ int digit_pairs;
+ int source_remaining;
+
+ int truncate_pairs = truncate_ldigits/2 ;
+ if( truncate_pairs )
+ {
+ // We handle truncation of digits on the left by moving the starting
line
+ // one byte to the right for each full pair of digits
+
+ if( check_for_error )
+ {
+ gg_assign(source_p, source_location);
+ tree truncate_end = gg_define_variable(UCHAR_P);
+ gg_assign(truncate_end,
+ gg_add(source_location,
+ build_int_cst_type(SIZE_T, truncate_pairs)));
+ WHILE( source_p, lt_op, truncate_end )
+ {
+ gg_assign(size_error,
+ gg_bitwise_or(size_error,
+ gg_cast(INT, gg_indirect(source_p))));
+ gg_increment(source_p);
+ }
+ WEND
+ }
+ else
+ {
+ gg_assign(source_p,
+ gg_add(source_location,
+ build_int_cst_type(SIZE_T, truncate_pairs)));
+ }
+ source_digits -= 2*truncate_pairs;
+ //source_ldigits -= 2*truncate_pairs;
+ truncate_ldigits &= 0x01;
+ }
+ else
+ {
+ gg_assign(source_p, source_location);
+ }
+
+ // At this point, truncate_ldigits might be one, meaning that when we
+ // get around to moving digits, we will have to skip the first one.
+
+ if( truncate_rdigits )
+ {
+ // We handle truncation of digits on the right by moving the finish
line
+ // to the left.
+ source_digits -= truncate_rdigits;
+ //source_ldigits -= truncate_rdigits;
+ }
+
+ source_remaining = source_digits;
+
+ // We are ready to start building our numeric-displace destination.
+
+ if( leading_zeroes )
+ {
+ tree tleading_zeroes = build_int_cst_type(SIZE_T, leading_zeroes);
+ gg_memset(dest_p,
+ uzero,
+ tleading_zeroes);
+ gg_assign(dest_p, gg_add(dest_p, tleading_zeroes));
+ }
+
+ // At this point, we are ready to start moving over source_remaining
digits.
+
+ if( truncate_ldigits )
+ {
+ // When truncate_ldigits is one, the first byte comes from the right
nybble
+ // of *source_p. We therefore skip the digit in the left nybble.
+ if( check_for_error )
+ {
+ gg_assign(size_error,
+ gg_cast(INT,
+ gg_bitwise_and(gg_indirect(source_p),
+ build_int_cst_type(UCHAR,
0xF0))));
}
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_bitwise_and(gg_indirect(source_p),
+ umask),
+ uzero));
+ gg_increment(source_p);
+ gg_increment(dest_p);
+ source_remaining -= 2;
}
- else
+
+ // We now pull pairs of digits from the packed source, and put them
into the
+ // destination numeric-display.
+
+ digit_pairs = source_remaining/2;
+
+ if( digit_pairs )
{
- // There is mismatch between source and dest rdigits:
- if( source_rbytes < dest_rbytes )
+ tree source_end = gg_define_variable(UCHAR_P);
+ gg_assign(source_end,
+ gg_add(source_p,
+ build_int_cst_type(SIZE_T, digit_pairs)));
+ WHILE( source_p, lt_op, source_end )
{
- // The source was too short to fill the destination, which means we
- // currently have a source's sign nybble sitting in the middle of
the
- // destination. We need to zero out that nybble
- gg_assign(gg_indirect(dest_location,
- build_int_cst_type(SIZE_T,
- bytes_to_copy-1)),
- gg_bitwise_and(gg_indirect(dest_location,
- build_int_cst_type(SIZE_T,
- bytes_to_copy-1)),
- build_int_cst_type(UCHAR,
0xF0)));
- // And then we need to zero out the remaining dest_rbytes:
- int remaining_rbytes = dest_rbytes - source_rbytes;
- if( remaining_rbytes > 1 )
- {
- gg_memset(gg_add(dest_location,
- build_int_cst_type(SIZE_T, bytes_to_copy)),
- integer_zero_node,
- build_int_cst_type(SIZE_T,
- destref.field->data.capacity() -
bytes_to_copy));
- }
- // And now we have to adjust the final nybble:
+ // Left digit
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_rshift(gg_indirect(source_p),
+ ufour),
+ uzero));
+ gg_increment(dest_p);
+ // Right digit
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_bitwise_and(gg_indirect(source_p),
+ umask),
+ uzero));
+ gg_increment(dest_p);
+ gg_increment(source_p);
+ }
+ WEND
+ source_remaining -= 2 * digit_pairs;
+ }
- if( !(sourceref.field->attr & signable_e)
- && (destref.field->attr & signable_e) )
- {
- // The source is unsignable, so we turn that into an positive 0xC
in
- // the signable destination:
- gg_assign(gg_indirect(dest_sign), build_int_cst_type(UCHAR,
0x0C));
- }
- else if( (sourceref.field->attr & signable_e)
- && !(destref.field->attr & signable_e) )
+ // At this point, source_remaining is zero or one
+
+ if( source_remaining )
+ {
+ // We have one remaining left digit;
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_rshift(gg_indirect(source_p),
+ ufour),
+ uzero));
+ gg_increment(dest_p);
+ }
+
+ if( trailing_zeroes )
+ {
+ tree ttrailing_zeroes = build_int_cst_type(SIZE_T, trailing_zeroes);
+ gg_memset(dest_p,
+ uzero,
+ ttrailing_zeroes);
+ }
+
+ if( (destref.field->attr & signable_e)
+ && (sourceref.field->attr & signable_e) )
+ {
+ // The source and the destination are both signable.
+ gg_assign(source_p,
+ gg_add(source_location,
+ build_int_cst_type(SIZE_T,
+
sourceref.field->data.capacity()-1)));
+ IF(gg_bitwise_and(gg_indirect(source_p),
+ umask),
+ eq_op,
+ build_int_cst_type(UCHAR, 0x0D) )
+ {
+ // The source is negative
+ gg_assign(dest_p,
+ gg_add(dest_location,
+ build_int_cst_type(SIZE_T,
+
destref.field->data.capacity()-1)));
+ if( charmap->is_like_ebcdic() )
{
- gg_assign(gg_indirect(dest_sign), build_int_cst_type(UCHAR,
0x0F));
+ // Turn the 0xFZ EBCDIC digit into 0xDZ to flag it as negative.
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_and(gg_indirect(dest_p),
+ build_int_cst_type(UCHAR, 0xDF)));
}
else
{
- // The source and the destination are either both signable, or
- // both unsignable. We copy the source's sign nybble to the
dest.
- gg_assign(gg_indirect(dest_sign),
- gg_bitwise_or(gg_indirect(dest_sign),
- gg_bitwise_and(gg_indirect(source_sign),
- build_int_cst_type(UCHAR,
-
0x0F))));
+ // Turn the 0x3Z ASCII digit into 07Z to flag it as negative.
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(UCHAR, 0x70)));
}
}
- else // source_rbytes > dest_rbytes
+ ELSE
{
- // There were more source_rbytes than we needed, which means the
final
- // nybble of the destination is a digit that needs to be truncated
- // away and replaced with the correct sign nybble.
- if( !(sourceref.field->attr & signable_e)
- && (destref.field->attr & signable_e) )
- {
- // The source was unsignable, so we set the sign nybble to a
- // a positive 0x0C
- gg_assign(gg_indirect(dest_sign),
- gg_bitwise_or(gg_bitwise_and(gg_indirect(dest_sign),
- build_int_cst_type(UCHAR, 0xF0)),
- build_int_cst_type(UCHAR, 0x0C)));
- }
- else if( (sourceref.field->attr & signable_e)
- && !(destref.field->attr & signable_e) )
- {
- // The dest is unsignable; turn the final nybble into an 0xFo
- gg_assign(gg_indirect(dest_sign),
- gg_bitwise_or(gg_indirect(dest_sign),
- build_int_cst_type(UCHAR, 0x0F)));
- }
- else
- {
- // The source and the destination are either both signable, or
- // both unsignable. We copy the source's sign nybble to the
dest.
- gg_assign(gg_indirect(dest_sign),
- gg_bitwise_or(gg_bitwise_and(gg_indirect(dest_sign),
- build_int_cst_type(UCHAR, 0xF0)),
- gg_bitwise_and(gg_indirect(source_sign),
- build_int_cst_type(UCHAR, 0x0F))));
- }
}
+ ENDIF
}
+ clear_negative_zero(destref,
+ sourceref,
+ dest_location);
return true;
}
@@ -2354,13 +3074,25 @@ move_helper(tree size_error, // This is an
INT
if( !moved )
{
moved = mh_packed_to_packed(destref,
- sourceref);
+ sourceref,
+ size_error,
+ check_for_error);
}
if( !moved )
{
moved = mh_numdisp_to_packed(destref,
- sourceref);
+ sourceref,
+ size_error,
+ check_for_error);
+ }
+
+ if( !moved )
+ {
+ moved = mh_packed_to_numdisp(destref,
+ sourceref,
+ size_error,
+ check_for_error);
}
if( !moved )
@@ -2444,175 +3176,76 @@ move_helper(tree size_error, // This is an
INT
refer_size_dest(destref),
tsource.pfield,
tsource.offset,
- tsource.length,
- build_int_cst_type(INT, nflags),
- build_int_cst_type(INT, rounded),
- NULL_TREE));
- }
- else
- {
- gg_call ( INT,
- "__gg__move",
-
gg_get_address_of(destref.field->var_decl_node),
- refer_offset(destref),
- refer_size_dest(destref),
- tsource.pfield,
- tsource.offset,
- tsource.length,
- build_int_cst_type(INT, nflags),
- build_int_cst_type(INT, rounded),
- NULL_TREE);
-
- }
- if( destref.refmod.from
- || destref.refmod.len
- || sourceref.refmod.from
- || sourceref.refmod.len )
- {
- // Return that value to its original form
- attribute_bit_clear(destref.field, refmod_e);
- }
-
- // moved = true; // commented out to quiet cppcheck
- }
-
- if( restore_on_error )
- {
- IF(size_error, ne_op, integer_zero_node)
- {
- gg_memcpy(st_data,
- stash,
- st_size);
- }
- ELSE
- ENDIF
- }
- else
- {
- if( check_for_error )
- {
- IF(size_error, ne_op, integer_zero_node)
- {
- // We had a size error, but there was no restore_on_error.
Pointer
- // Let our lord and master know there was a truncation:
- set_exception_code(ec_size_truncation_e);
- }
- ELSE
- ENDIF
- }
- }
-
- SHOW_PARSE1
- {
- SHOW_PARSE_END
- }
- }
-
-void
-parser_move(cbl_refer_t destref,
- cbl_refer_t sourceref,
- cbl_round_t rounded,
- bool skip_fill_from // Defaults to false
- )
- {
- Analyze();
- SHOW_PARSE
- {
- SHOW_PARSE_HEADER
- if( sourceref.field && is_figconst_low(sourceref.field) )
- {
- SHOW_PARSE_TEXT(" LOW-VALUE")
- }
- else if( sourceref.field && is_figconst_zero(sourceref.field) )
- {
- SHOW_PARSE_TEXT(" ZERO-VALUE")
- }
- else if( sourceref.field && is_figconst_space(sourceref.field) )
- {
- SHOW_PARSE_TEXT(" SPACE-VALUE")
- }
- else if( sourceref.field && is_figconst_quote(sourceref.field) )
- {
- SHOW_PARSE_TEXT(" QUOTE-VALUE")
- }
- else if( sourceref.field && is_figconst_high(sourceref.field) )
- {
- SHOW_PARSE_TEXT(" HIGH-VALUE")
- }
- else
- {
- SHOW_PARSE_REF(" ", sourceref)
- }
- SHOW_PARSE_REF(" TO ", destref)
- switch(rounded)
- {
- case away_from_zero_e:
- SHOW_PARSE_TEXT(" AWAY_FROM_ZERO")
- break;
- case nearest_toward_zero_e:
- SHOW_PARSE_TEXT(" NEAREST_TOWARD_ZERO")
- break;
- case toward_greater_e:
- SHOW_PARSE_TEXT(" TOWARD_GREATER")
- break;
- case toward_lesser_e:
- SHOW_PARSE_TEXT(" TOWARD_LESSER")
- break;
- case nearest_away_from_zero_e:
- SHOW_PARSE_TEXT(" NEAREST_AWAY_FROM_ZERO")
- break;
- case nearest_even_e:
- SHOW_PARSE_TEXT(" NEAREST_EVEN")
- break;
- case prohibited_e:
- SHOW_PARSE_TEXT(" PROHIBITED")
- break;
- case truncation_e:
- SHOW_PARSE_TEXT(" TRUNCATED")
- break;
- default:
- gcc_unreachable();
- break;
- }
- SHOW_PARSE_END
+ tsource.length,
+ build_int_cst_type(INT, nflags),
+ build_int_cst_type(INT, rounded),
+ NULL_TREE));
+ }
+ else
+ {
+ gg_call ( INT,
+ "__gg__move",
+
gg_get_address_of(destref.field->var_decl_node),
+ refer_offset(destref),
+ refer_size_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ tsource.length,
+ build_int_cst_type(INT, nflags),
+ build_int_cst_type(INT, rounded),
+ NULL_TREE);
+
+ }
+ if( destref.refmod.from
+ || destref.refmod.len
+ || sourceref.refmod.from
+ || sourceref.refmod.len )
+ {
+ // Return that value to its original form
+ attribute_bit_clear(destref.field, refmod_e);
+ }
+
+ // moved = true; // commented out to quiet cppcheck
}
- if( !skip_fill_from )
+ if( restore_on_error )
{
- cbl_figconst_t figconst = is_figconst(sourceref);
- if( figconst )
+ IF(size_error, ne_op, integer_zero_node)
{
- sourceref.all = true;
+ gg_memcpy(st_data,
+ stash,
+ st_size);
}
+ ELSE
+ ENDIF
}
-
- TRACE1
+ else
{
- TRACE1_HEADER
- TRACE1_TEXT("About to call move_helper")
+ if( check_for_error )
+ {
+ IF(size_error, ne_op, integer_zero_node)
+ {
+ // We had a size error, but there was no restore_on_error.
Pointer
+ // Let our lord and master know there was a truncation:
+ set_exception_code(ec_size_truncation_e);
+ }
+ ELSE
+ ENDIF
+ }
}
- TREEPLET tsource;
- treeplet_fill_source(tsource, sourceref);
- static bool dont_check_for_error = false;
- move_helper(NULL, destref, sourceref, tsource, rounded,
dont_check_for_error );
- TRACE1
+ SHOW_PARSE1
{
- TRACE1_INDENT
- TRACE1_REFER_INFO("source ", sourceref)
- TRACE1_INDENT
- TRACE1_REFER_INFO("dest ", destref)
- TRACE1_END
+ SHOW_PARSE_END
}
}
-static
void
-parser_move_multi(cbl_refer_t destref,
- cbl_refer_t sourceref,
- TREEPLET tsource,
- cbl_round_t rounded,
- bool skip_fill_from )
+parser_move(cbl_refer_t destref,
+ cbl_refer_t sourceref,
+ cbl_round_t rounded,
+ bool skip_fill_from // Defaults to false
+ )
{
Analyze();
SHOW_PARSE
@@ -2673,352 +3306,152 @@ parser_move_multi(cbl_refer_t destref,
gcc_unreachable();
break;
}
- SHOW_PARSE_END
- }
-
- if( !skip_fill_from )
- {
- cbl_figconst_t figconst = is_figconst(sourceref);
- if( figconst )
- {
- sourceref.all = true;
- }
- }
-
- TRACE1
- {
- TRACE1_HEADER
- TRACE1_TEXT("About to call move_helper")
- }
-
- static bool dont_check_for_error = false;
- move_helper(NULL, destref, sourceref, tsource, rounded,
dont_check_for_error );
-
- TRACE1
- {
- TRACE1_INDENT
- TRACE1_REFER_INFO("source ", sourceref)
- TRACE1_INDENT
- TRACE1_REFER_INFO("dest ", destref)
- TRACE1_END
- }
- }
-
-void
-parser_move(size_t ntgt, cbl_refer_t *tgts, cbl_refer_t src, cbl_round_t
rounded)
- {
- if( mode_syntax_only() ) return;
-
- cbl_figconst_t figconst = is_figconst(src);
- if( figconst )
- {
- src.all = true;
- }
- TREEPLET tsource;
- treeplet_fill_source(tsource, src);
- static const bool skip_fill_from = true;
- for( cbl_refer_t *p=tgts; p < tgts + ntgt; p++ )
- {
- parser_move_multi(*p, src, tsource, rounded, skip_fill_from);
- }
- }
-
-#if 0
-// This is a debugging function used from time-to-time
-static void
-hex_of(tree location, size_t bytes)
- {
- gg_printf("0x", NULL_TREE);
- for(size_t i=0; i<bytes; i++)
- {
- gg_printf("%2.2X", gg_indirect_i(gg_cast(UCHAR_P, location), i),
NULL_TREE);
- }
- }
-
-static void
-hex_msg(const char *msg, tree location, size_t bytes)
- {
- gg_printf("%s ", gg_string_literal(msg), NULL_TREE);
- hex_of(location, bytes);
- gg_printf("\n", NULL_TREE);
- }
-
-#endif
-
-static bool
-mh_numdisp_to_packed(const cbl_refer_t &destref,
- const cbl_refer_t &sourceref)
- {
- const charmap_t *charmap =
- __gg__get_charmap(sourceref.field->codeset.encoding);
- if( (destref.field->type != FldPacked )
- || (sourceref.field->type != FldNumericDisplay )
- || (charmap->stride() != 1 )
- || (destref.field->attr & scaled_e )
- || (sourceref.field->attr & scaled_e )
- || (destref.field->attr & packed_no_sign_e )
- || (sourceref.field->attr & leading_e )
- || (sourceref.field->attr & separate_e ) )
- {
- return false;
- }
- /* Source is NumericDisplay, dest is packed, neither are scaled, the
- packed destination has a sign nybble, and the numeric source has an
- ordinarysign bit encoded in the final digit. */
- tree uzero = build_int_cst_type(UCHAR, 0);
- tree umask = build_int_cst_type(UCHAR, 0x0F);
- tree ufour = build_int_cst_type(SIZE_T, 4);
-
- tree source_location = gg_define_variable(UCHAR_P);
- tree dest_location = gg_define_variable(UCHAR_P);
- tree dest_p = gg_define_variable(UCHAR_P);
- tree source_p = gg_define_variable(UCHAR_P);
-
- tree temp;
-
- get_location(temp, destref);
- gg_assign(dest_location, temp);
- gg_assign(dest_p, dest_location);
- get_location(temp, sourceref);
- gg_assign(source_location, temp);
-
- int source_digits = sourceref.field->data.digits;
- int source_rdigits = sourceref.field->data.rdigits;
- int source_ldigits = source_digits - source_rdigits;
- int dest_digits = destref.field->data.digits;
- int dest_rdigits = destref.field->data.rdigits;
- int dest_ldigits = dest_digits - dest_rdigits;
-
- int truncate_ldigits = std::max(0, source_ldigits-dest_ldigits);
- int truncate_rdigits = std::max(0, source_rdigits-dest_rdigits);
- int leading_zeroes = std::max(0, dest_ldigits-source_ldigits);
- int trailing_zeroes = std::max(0, dest_rdigits-source_rdigits);
-
- int zero_pairs;
- int digit_pairs;
- int source_remaining;
-
- if( truncate_ldigits )
- {
- // We handle truncation of digits on the left by moving the starting
line.
- gg_assign(source_p,
- gg_add(source_location,
- build_int_cst_type(SIZE_T, truncate_ldigits)));
- source_digits -= truncate_ldigits;
- source_ldigits -= truncate_ldigits;
- }
- else
- {
- gg_assign(source_p, source_location);
- }
-
- if( truncate_rdigits )
- {
- // We handle truncation of digits on the right by moving the finish
line.
- source_digits -= truncate_rdigits;
- source_ldigits -= truncate_rdigits;
- }
-
- if( !source_digits )
- {
- // When source_digits is zero, it means that some pervert of a COBOL
- // programmer told us to MOVE 999V TO V999. The result has to be
zero,
- // and our life down below will be easier when we know that there is
at
- // least one digit that needs to be moved from the source to the
- // destination.
- gg_memset(dest_p,
- integer_zero_node,
- build_int_cst_type(SIZE_T,
destref.field->data.capacity()));
- goto adjust_sign;
- }
-
- source_remaining = source_digits;
-
- // The first thing we need to do is adjust the first byte of the
destination
- // so that we know where we are in left-nybble/right-nybble space.
Let's
- // call the digit at source_p "N". (That digit might be a leading
zero.)
- // When dest_digits is an even number, it means the final result is
something
- // like 0N.23.4s. So, when dest_digits is even, we have to start
things off
- // with "0N".
-
- if( !(dest_digits & 0x01) )
- {
- // dest_digits is an even number.
- if( leading_zeroes )
- {
- // The first byte is "0N", but N is zero:
- gg_assign(gg_indirect(dest_p), uzero);
- leading_zeroes -= 1;
- }
- else
+ SHOW_PARSE_END
+ }
+
+ if( !skip_fill_from )
+ {
+ cbl_figconst_t figconst = is_figconst(sourceref);
+ if( figconst )
{
- // The first byte is "0N", where N is the value from the first
character
- // of the source. We know that source_remaining is at least one at
this
- // point.
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_and(gg_indirect(source_p), umask));
- gg_increment(source_p);
- source_remaining -= 1;
+ sourceref.all = true;
}
- gg_increment(dest_p);
}
- // At this point, we know that leading + source + trailing is an odd
- // number.
-
- // We know that dest_p is set up to accept a left/right pair next.
Let's
- // see if we have enough leading_zeroes to warrant using memset:
- zero_pairs = leading_zeroes/2;
- if( zero_pairs )
+ TRACE1
{
- // We can use memset to handle left-side zero-fill:
- tree tpairs = build_int_cst_type(SIZE_T, zero_pairs);
- gg_memset(dest_p, integer_zero_node, tpairs);
- gg_assign(dest_p, gg_add(dest_p, tpairs));
- leading_zeroes -= 2 * zero_pairs;
+ TRACE1_HEADER
+ TRACE1_TEXT("About to call move_helper")
}
+ TREEPLET tsource;
+ treeplet_fill_source(tsource, sourceref);
+ static bool dont_check_for_error = false;
+ move_helper(NULL, destref, sourceref, tsource, rounded,
dont_check_for_error );
- // dest-p is still set up for a left/right pair.
- if( leading_zeroes )
+ TRACE1
{
- // But we still have one leading zero left. We know at this point
that
- // there is at least one source digit left, so build the byte using
- // zero/*source_p
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_and(gg_indirect(source_p), umask));
- //leading_zeroes -= 1;
- source_remaining -= 1;
- gg_increment(source_p);
- gg_increment(dest_p);
+ TRACE1_INDENT
+ TRACE1_REFER_INFO("source ", sourceref)
+ TRACE1_INDENT
+ TRACE1_REFER_INFO("dest ", destref)
+ TRACE1_END
}
+ }
- // At this point, we know that leading_zeroes is zero. We know that
- // source_remaining + trailing_zeroes is an odd number. We
- // currently have dest_p lined up on a left-right boundary.
-
- // We are going to transfer as many pairs of source_remaining digits as
we
- // can.
-
- digit_pairs = source_remaining/2;
- if( digit_pairs )
+static
+void
+parser_move_multi(cbl_refer_t destref,
+ cbl_refer_t sourceref,
+ TREEPLET tsource,
+ cbl_round_t rounded,
+ bool skip_fill_from )
+ {
+ Analyze();
+ SHOW_PARSE
{
- tree dest_end = gg_define_variable(UCHAR_P);
- gg_assign(dest_end,
- gg_add(dest_p,
- build_int_cst_type(SIZE_T, digit_pairs)));
- WHILE( dest_p, lt_op, dest_end )
+ SHOW_PARSE_HEADER
+ if( sourceref.field && is_figconst_low(sourceref.field) )
{
- tree left_nybble = gg_lshift(gg_indirect(source_p), ufour);
- tree right_nybble = gg_bitwise_and(gg_indirect(source_p,
- integer_one_node),
- umask);
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(left_nybble, right_nybble));
- gg_increment(dest_p);
- gg_assign(source_p,
- gg_add(source_p, build_int_cst_type(SIZE_T, 2)));
+ SHOW_PARSE_TEXT(" LOW-VALUE")
}
- WEND
- source_remaining -= 2 * digit_pairs;
+ else if( sourceref.field && is_figconst_zero(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" ZERO-VALUE")
+ }
+ else if( sourceref.field && is_figconst_space(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" SPACE-VALUE")
+ }
+ else if( sourceref.field && is_figconst_quote(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" QUOTE-VALUE")
+ }
+ else if( sourceref.field && is_figconst_high(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" HIGH-VALUE")
+ }
+ else
+ {
+ SHOW_PARSE_REF(" ", sourceref)
+ }
+ SHOW_PARSE_REF(" TO ", destref)
+ switch(rounded)
+ {
+ case away_from_zero_e:
+ SHOW_PARSE_TEXT(" AWAY_FROM_ZERO")
+ break;
+ case nearest_toward_zero_e:
+ SHOW_PARSE_TEXT(" NEAREST_TOWARD_ZERO")
+ break;
+ case toward_greater_e:
+ SHOW_PARSE_TEXT(" TOWARD_GREATER")
+ break;
+ case toward_lesser_e:
+ SHOW_PARSE_TEXT(" TOWARD_LESSER")
+ break;
+ case nearest_away_from_zero_e:
+ SHOW_PARSE_TEXT(" NEAREST_AWAY_FROM_ZERO")
+ break;
+ case nearest_even_e:
+ SHOW_PARSE_TEXT(" NEAREST_EVEN")
+ break;
+ case prohibited_e:
+ SHOW_PARSE_TEXT(" PROHIBITED")
+ break;
+ case truncation_e:
+ SHOW_PARSE_TEXT(" TRUNCATED")
+ break;
+ default:
+ gcc_unreachable();
+ break;
+ }
+ SHOW_PARSE_END
}
- // At this point, source_remaining is zero or one
-
- if( source_remaining )
+ if( !skip_fill_from )
{
- gg_assign(gg_indirect(dest_p),
- gg_lshift(gg_indirect(source_p), ufour));
- gg_increment(dest_p);
- //source_remaining -= 1;
- if( trailing_zeroes )
+ cbl_figconst_t figconst = is_figconst(sourceref);
+ if( figconst )
{
- trailing_zeroes -= 1;
+ sourceref.all = true;
}
}
- // At this point, we know trailing_zeroes has to be an even number, and
we
- // need to zero out that many nybbles:
- if( trailing_zeroes >= 2 )
+ TRACE1
{
- zero_pairs = trailing_zeroes/2;
- // We can use memset to handle left-side zero-fill:
- tree tpairs = build_int_cst_type(SIZE_T, zero_pairs);
- gg_memset(dest_p, integer_zero_node, tpairs);
- gg_assign(dest_p, gg_add(dest_p, tpairs));
- trailing_zeroes -= 2 * zero_pairs;
+ TRACE1_HEADER
+ TRACE1_TEXT("About to call move_helper")
}
- if( trailing_zeroes )
+ static bool dont_check_for_error = false;
+ move_helper(NULL, destref, sourceref, tsource, rounded,
dont_check_for_error );
+
+ TRACE1
{
- // There is one trailing zero left
- gg_assign(gg_indirect(dest_p), uzero);
- gg_increment(dest_p);
- //trailing_zeroes -= 1;
+ TRACE1_INDENT
+ TRACE1_REFER_INFO("source ", sourceref)
+ TRACE1_INDENT
+ TRACE1_REFER_INFO("dest ", destref)
+ TRACE1_END
}
+ }
- adjust_sign:
- gg_assign(dest_p, gg_add(dest_location,
- build_int_cst_type(SIZE_T,
-
destref.field->data.capacity()-1)));
+void
+parser_move(size_t ntgt, cbl_refer_t *tgts, cbl_refer_t src, cbl_round_t
rounded)
+ {
+ if( mode_syntax_only() ) return;
- if( !(destref.field->attr & signable_e) )
+ cbl_figconst_t figconst = is_figconst(src);
+ if( figconst )
{
- // The destination is not signable
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(gg_indirect(dest_p), umask));
+ src.all = true;
}
- else
+ TREEPLET tsource;
+ treeplet_fill_source(tsource, src);
+ static const bool skip_fill_from = true;
+ for( cbl_refer_t *p=tgts; p < tgts + ntgt; p++ )
{
- if( sourceref.field->attr & signable_e )
- {
- // This is the location of the character with the sign flag.
- gg_assign(source_p, gg_add(source_location,
- build_int_cst_type(SIZE_T,
-
sourceref.field->data.capacity()-1)));
- if( charmap->is_like_ebcdic() )
- {
- // EBCDIC digits are 0xF0 through 0xF9; negative is flagged by
- // 0xD0 through 0xD9
- IF( gg_indirect(source_p), lt_op, build_int_cst_type(UCHAR, 0xF0)
)
- {
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(gg_indirect(dest_p),
- build_int_cst_type(UCHAR, 0x0D)));
- }
- ELSE
- {
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(gg_indirect(dest_p),
- build_int_cst_type(UCHAR, 0x0C)));
- }
- ENDIF
- }
- else
- {
- // EBCDIC digits are 0x30 through 0x39; negative is flagged by
- // 0x70 through 0x79
- IF( gg_indirect(source_p), ge_op, build_int_cst_type(UCHAR, 0x70)
)
- {
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(gg_indirect(dest_p),
- build_int_cst_type(UCHAR, 0x0D)));
- }
- ELSE
- {
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(gg_indirect(dest_p),
- build_int_cst_type(UCHAR, 0x0C)));
- }
- ENDIF
- }
- }
- else
- {
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(gg_indirect(dest_p),
- build_int_cst_type(UCHAR, 0x0C)));
- }
+ parser_move_multi(*p, src, tsource, rounded, skip_fill_from);
}
-
- return true;
}
+
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 419f08dddaf..e0d1620a772 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -5001,7 +5001,7 @@ usage_clause1: usage BIT
if( field->has_attr(separate_e) ) {
error_msg(@$, "SIGN clause conflicts with NO SIGN");
}
- field->clear_attr(separate_e);
+ field->set_attr(separate_e);
field->clear_attr(signable_e);
$$ = field->type = FldPacked;
}
diff --git a/gcc/testsuite/cobol.dg/group2/COMP-3_to_COMP-3_size_error.cob
b/gcc/testsuite/cobol.dg/group2/COMP-3_to_COMP-3_size_error.cob
new file mode 100644
index 00000000000..5db5ee15e8c
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/COMP-3_to_COMP-3_size_error.cob
@@ -0,0 +1,34 @@
+ *> { dg-do run }
+ *> { dg-output-file "group2/COMP-3_to_COMP-3_size_error.out" }
+ identification division.
+ program-id. onsize.
+ data division.
+ working-storage section.
+ 01 var11 pic 99999 comp-3 value 12345.
+ 01 var12 pic 999999 comp-3 value 123456.
+ 01 var13 pic 999 comp-3 .
+ 01 var14 pic 9999 comp-3 .
+ procedure division.
+ display "test1: " with no advancing
+ compute var13 = var11
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ display "test2: " with no advancing
+ compute var14 = var11
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ display "test3: " with no advancing
+ compute var13 = var12
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ display "test4: " with no advancing
+ compute var14 = var12
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ goback.
+ end program onsize.
+
diff --git a/gcc/testsuite/cobol.dg/group2/COMP-3_to_COMP-3_size_error.out
b/gcc/testsuite/cobol.dg/group2/COMP-3_to_COMP-3_size_error.out
new file mode 100644
index 00000000000..7a27b51c984
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/COMP-3_to_COMP-3_size_error.out
@@ -0,0 +1,5 @@
+test1: Proper size error
+test2: Proper size error
+test3: Proper size error
+test4: Proper size error
+
diff --git
a/gcc/testsuite/cobol.dg/group2/COMP-3_to_numeric-display_size_error.cob
b/gcc/testsuite/cobol.dg/group2/COMP-3_to_numeric-display_size_error.cob
new file mode 100644
index 00000000000..1679bd12be0
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/COMP-3_to_numeric-display_size_error.cob
@@ -0,0 +1,34 @@
+ *> { dg-do run }
+ *> { dg-output-file
"group2/COMP-3_to_numeric-display_size_error.out" }
+ identification division.
+ program-id. onsize.
+ data division.
+ working-storage section.
+ 01 var11 pic 99999 comp-3 value 12345.
+ 01 var12 pic 999999 comp-3 value 123456.
+ 01 var13 pic 999 display .
+ 01 var14 pic 9999 display .
+ procedure division.
+ display "test1: " with no advancing
+ compute var13 = var11
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ display "test2: " with no advancing
+ compute var14 = var11
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ display "test3: " with no advancing
+ compute var13 = var12
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ display "test4: " with no advancing
+ compute var14 = var12
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ goback.
+ end program onsize.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/COMP-3_to_numeric-display_size_error.out
b/gcc/testsuite/cobol.dg/group2/COMP-3_to_numeric-display_size_error.out
new file mode 100644
index 00000000000..7a27b51c984
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/COMP-3_to_numeric-display_size_error.out
@@ -0,0 +1,5 @@
+test1: Proper size error
+test2: Proper size error
+test3: Proper size error
+test4: Proper size error
+
diff --git
a/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.c
ob
b/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.c
ob
new file mode 100644
index 00000000000..8fd3fc58e55
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.c
ob
@@ -0,0 +1,23 @@
+ *> { dg-do run }
+ *> { dg-output-file
"group2/Clear_negative_zero_after_truncated_MOVE.out" }
+ identification division.
+ program-id. onsize.
+ data division.
+ working-storage section.
+ 01 var11 pic s9999 value -1000.
+ 01 var12 pic s999.
+ 01 var21 pic s9999 comp-3 value -1000.
+ 01 var22 pic s999 comp-3 .
+ procedure division.
+ *> Make sure we don't create "-0000"
+ move var21 to var22
+ display var22 space function hex-of(var22)
+ move var11 to var22
+ display var22 space function hex-of(var22)
+ move var11 to var12
+ display var12 space ''''var12(3:1)''''
+ move var21 to var12
+ display var12 space ''''var12(3:1)''''
+ goback.
+ end program onsize.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.o
ut
b/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.o
ut
new file mode 100644
index 00000000000..9198611a5fa
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.o
ut
@@ -0,0 +1,5 @@
++000 000C
++000 000C
++000 '0'
++000 '0'
+
diff --git
a/gcc/testsuite/cobol.dg/group2/numeric-display_to_COMP-3_size_error.cob
b/gcc/testsuite/cobol.dg/group2/numeric-display_to_COMP-3_size_error.cob
new file mode 100644
index 00000000000..cddbade4ffa
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/numeric-display_to_COMP-3_size_error.cob
@@ -0,0 +1,34 @@
+ *> { dg-do run }
+ *> { dg-output-file
"group2/numeric-display_to_COMP-3_size_error.out" }
+ identification division.
+ program-id. onsize.
+ data division.
+ working-storage section.
+ 01 var11 pic 99999 display value 12345.
+ 01 var12 pic 999999 display value 123456.
+ 01 var13 pic 999 comp-3 .
+ 01 var14 pic 9999 comp-3 .
+ procedure division.
+ display "test1: " with no advancing
+ compute var13 = var11
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ display "test2: " with no advancing
+ compute var14 = var11
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ display "test3: " with no advancing
+ compute var13 = var12
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ display "test4: " with no advancing
+ compute var14 = var12
+ ON SIZE ERROR Display "Proper size error"
+ NOT ON SIZE ERROR Display "IMPROPER no error"
+ end-compute
+ goback.
+ end program onsize.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/numeric-display_to_COMP-3_size_error.out
b/gcc/testsuite/cobol.dg/group2/numeric-display_to_COMP-3_size_error.out
new file mode 100644
index 00000000000..7a27b51c984
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/numeric-display_to_COMP-3_size_error.out
@@ -0,0 +1,5 @@
+test1: Proper size error
+test2: Proper size error
+test3: Proper size error
+test4: Proper size error
+
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index b9c34ea417c..8c9e94df528 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -2052,6 +2052,11 @@ int128_to_field(cblc_field_t *var,
// We are now set up to do the conversion:
__gg__binary_to_packed(location, digits, value);
+ if( value == 0 && sign_nybble == 0x0D )
+ {
+ sign_nybble = 0x0C;
+ }
+
// We can put the sign nybble into place at this point. Note
that
// for COMP-6 numbers the sign_nybble value is zero, so the
next
// operation is harmless.
--
2.34.1
