From: Robert Dubner Date: Sun, 14 Jun 2026 20:25:38 +0000 (-0400) Subject: cobol: Improve MOVE routines. X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=feb4dcd40582aeb331cd20b51951c6848023664e;p=thirdparty%2Fgcc.git 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. --- 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; iattr & 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; icodeset.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.cob b/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.cob new file mode 100644 index 00000000000..8fd3fc58e55 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.cob @@ -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.out b/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.out new file mode 100644 index 00000000000..9198611a5fa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Clear_negative_zero_after_truncated_MOVE.out @@ -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.