https://gcc.gnu.org/g:7cfe4a5f97ec98622c85c071f9b093631c0fd167
commit r17-1488-g7cfe4a5f97ec98622c85c071f9b093631c0fd167 Author: Robert Dubner <[email protected]> Date: Wed Jun 10 23:42:20 2026 -0400 cobol: Improve execution speed of MOVE NumericDisplay TO COMP-3 gcc/cobol/ChangeLog: * move.cc (mh_packed_to_packed): Moved. (mh_numdisp_to_packed): New function. (move_helper): Use mh_numdisp_to_packed(). (hex_msg): New debugging function. * parse.y: Enable __gg__char_national(). libgcobol/ChangeLog: * intrinsic.cc (__gg__char_national): New function. gcc/testsuite/ChangeLog: * cobol.dg/group2/MOVE_NumericDisplay_to_COMP-3.cob: New test. * cobol.dg/group2/MOVE_NumericDisplay_to_COMP-3.out: New test. Diff: --- gcc/cobol/move.cc | 801 ++++++++++++++------- gcc/cobol/parse.y | 4 +- .../group2/MOVE_NumericDisplay_to_COMP-3.cob | 32 + .../group2/MOVE_NumericDisplay_to_COMP-3.out | 13 + libgcobol/intrinsic.cc | 34 + 5 files changed, 627 insertions(+), 257 deletions(-) diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc index 8c445cb789db..677b5b0ffb35 100644 --- a/gcc/cobol/move.cc +++ b/gcc/cobol/move.cc @@ -1994,9 +1994,307 @@ mh_alpha_to_alpha(const cbl_refer_t &destref, } static bool -mh_packed_to_packed(const cbl_refer_t &destref, +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) + { + 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); + + 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'. + source_digits += 1; + source_rdigits += 1; + source_capacity = source_digits/2 + 1; + gg_assign(source_location, shifted_p_left); + } + gg_assign(source_sign, + gg_add(source_location, + build_int_cst_type(SIZE_T, + source_capacity-1))); + gg_assign(dest_sign, + gg_add(dest_location, + build_int_cst_type(SIZE_T, + destref.field->data.capacity()-1))); + + // This is the straightforward case, where the dest and source decimal + // places are in phase, which means that the middles of the values can + // simply be moved. + int dest_rbytes = destref.field->data.rdigits/2 + 1; + int dest_lbytes = destref.field->data.capacity() - dest_rbytes; + + int source_rbytes = source_rdigits/2 + 1; + int source_lbytes = source_capacity - source_rbytes; + + uint32_t dest_bytes = destref.field->data.capacity(); + + if( source_lbytes > dest_lbytes ) + { + // There are too many source lbytes. We just skip those extra bytes, + // truncating off those high-order digits. + gg_assign(source_location, + gg_add(source_location, + build_int_cst_type(SIZE_T, + source_lbytes-dest_lbytes))); + } + else if( source_lbytes < dest_lbytes ) + { + // There are too few source lbytes. We zero out the extra bytes on the + // left side of the destination. + gg_memset(dest_location, + integer_zero_node, + build_int_cst_type(SIZE_T, dest_lbytes-source_lbytes)); + gg_assign(dest_location, + gg_add(dest_location, + build_int_cst_type(SIZE_T, dest_lbytes-source_lbytes))); + // And reduce the total number to move by the number we zeroed: + dest_bytes -= dest_lbytes-source_lbytes; + } + source_lbytes = dest_lbytes; + // We have lined up source_location and dest_location so that the source + // lbytes will go into the correct location in the destination + + // We copy over as many bytes as we have in the source that can fit into + // the destination: + size_t bytes_to_copy = + std::min(static_cast<uint32_t>(source_lbytes) + source_rbytes, + dest_bytes); + gg_memcpy(dest_location, + source_location, + build_int_cst_type(SIZE_T, bytes_to_copy)); + + // We make sure the final sign nybble is correct. + + if( source_rbytes == dest_rbytes ) + { + // The sign nybble from the source is now in the destination. It might + // need to be changed + if( !(sourceref.field->attr & signable_e) + && (destref.field->attr & signable_e) ) + { + // The unsignable source has an 0xF sign nybble, so we need to turn + // that into an positive 0xC in the signable destination: + gg_assign(gg_indirect(dest_sign), + gg_bitwise_and(gg_indirect(dest_sign), + build_int_cst_type(UCHAR, 0xFC))); + } + 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))); + } + } + 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)))); + } + } + } + return true; + } + void move_helper(tree size_error, // This is an INT cbl_refer_t destref, @@ -2053,6 +2351,18 @@ move_helper(tree size_error, // This is an INT moved = mh_identical(destref, sourceref); } + if( !moved ) + { + moved = mh_packed_to_packed(destref, + sourceref); + } + + if( !moved ) + { + moved = mh_numdisp_to_packed(destref, + sourceref); + } + if( !moved ) { moved = mh_source_is_literalN(destref, @@ -2104,12 +2414,6 @@ move_helper(tree size_error, // This is an INT size_error); } - if( !moved ) - { - moved = mh_packed_to_packed(destref, - sourceref); - } - if( !moved ) { SHOW_PARSE1 @@ -2430,302 +2734,291 @@ hex_of(tree location, size_t bytes) 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_packed_to_packed(const cbl_refer_t &destref, +mh_numdisp_to_packed(const cbl_refer_t &destref, const cbl_refer_t &sourceref) { - 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); + 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; - get_location(temp, sourceref); - gg_assign(source_location, temp); + // 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". - 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) ) + if( !(dest_digits & 0x01) ) { - /* 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 ) + // 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. - shifted_size = source_capacity + 1; + // 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. - shifted_size = source_capacity; + // 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; } - // 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_increment(dest_p); + } - 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)); - } + // At this point, we know that leading + source + trailing is an odd + // number. - // We now have the left-shifted source in 'shifted'. - source_digits += 1; - source_rdigits += 1; - source_capacity = source_digits/2 + 1; - gg_assign(source_location, shifted_p_left); + // 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; } - gg_assign(source_sign, - gg_add(source_location, - build_int_cst_type(SIZE_T, - source_capacity-1))); - gg_assign(dest_sign, - gg_add(dest_location, - build_int_cst_type(SIZE_T, - destref.field->data.capacity()-1))); - // This is the straightforward case, where the dest and source decimal - // places are in phase, which means that the middles of the values can - // simply be moved. - int dest_rbytes = destref.field->data.rdigits/2 + 1; - int dest_lbytes = destref.field->data.capacity() - dest_rbytes; + // 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); + } - int source_rbytes = source_rdigits/2 + 1; - int source_lbytes = source_capacity - source_rbytes; + // 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. - uint32_t dest_bytes = destref.field->data.capacity(); + // We are going to transfer as many pairs of source_remaining digits as we + // can. - if( source_lbytes > dest_lbytes ) + digit_pairs = source_remaining/2; + if( digit_pairs ) { - // There are too many source lbytes. We just skip those extra bytes, - // truncating off those high-order digits. - gg_assign(source_location, - gg_add(source_location, - build_int_cst_type(SIZE_T, - source_lbytes-dest_lbytes))); + 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; } - else if( source_lbytes < dest_lbytes ) + + // At this point, source_remaining is zero or one + + if( source_remaining ) { - // There are too few source lbytes. We zero out the extra bytes on the - // left side of the destination. - gg_memset(dest_location, - integer_zero_node, - build_int_cst_type(SIZE_T, dest_lbytes-source_lbytes)); - gg_assign(dest_location, - gg_add(dest_location, - build_int_cst_type(SIZE_T, dest_lbytes-source_lbytes))); - // And reduce the total number to move by the number we zeroed: - dest_bytes -= dest_lbytes-source_lbytes; + 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; + } } - source_lbytes = dest_lbytes; - // We have lined up source_location and dest_location so that the source - // lbytes will go into the correct location in the destination + // At this point, we know trailing_zeroes has to be an even number, and we + // need to zero out that many nybbles: - // We copy over as many bytes as we have in the source that can fit into - // the destination: - size_t bytes_to_copy = - std::min(static_cast<uint32_t>(source_lbytes) + source_rbytes, - dest_bytes); - gg_memcpy(dest_location, - source_location, - build_int_cst_type(SIZE_T, bytes_to_copy)); + 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; + } - // We make sure the final sign nybble is correct. + if( trailing_zeroes ) + { + // There is one trailing zero left + gg_assign(gg_indirect(dest_p), uzero); + gg_increment(dest_p); + //trailing_zeroes -= 1; + } - if( source_rbytes == dest_rbytes ) + 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 sign nybble from the source is now in the destination. It might - // need to be changed - if( !(sourceref.field->attr & signable_e) - && (destref.field->attr & signable_e) ) - { - // The unsignable source has an 0xF sign nybble, so we need to turn - // that into an positive 0xC in the signable destination: - gg_assign(gg_indirect(dest_sign), - gg_bitwise_and(gg_indirect(dest_sign), - build_int_cst_type(UCHAR, 0xFC))); - } - 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 destination is not signable + gg_assign(gg_indirect(dest_p), + gg_bitwise_or(gg_indirect(dest_p), umask)); } else { - // There is mismatch between source and dest rdigits: - if( source_rbytes < dest_rbytes ) + if( sourceref.field->attr & signable_e ) { - // 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, + // 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, - 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) ) + sourceref.field->data.capacity()-1))); + if( charmap->is_like_ebcdic() ) { - gg_assign(gg_indirect(dest_sign), build_int_cst_type(UCHAR, 0x0F)); + // 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 { - // 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)))); + // 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 // 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)))); - } + gg_assign(gg_indirect(dest_p), + gg_bitwise_or(gg_indirect(dest_p), + build_int_cst_type(UCHAR, 0x0C))); } } + return true; } diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index dfd5bbf0a903..419f08dddaf2 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -11918,9 +11918,7 @@ intrinsic0: CURRENT_DATE { intrinsic_I: BOOLEAN_OF_INTEGER { $$ = BOOLEAN_OF_INTEGER; cbl_unimplemented("BOOLEAN-OF-INTEGER"); } - | CHAR_NATIONAL { $$ = CHAR_NATIONAL; - cbl_unimplemented("CHAR-NATIONAL"); - } + | CHAR_NATIONAL { $$ = CHAR_NATIONAL; } | DATE_OF_INTEGER { $$ = DATE_OF_INTEGER; } | DAY_OF_INTEGER { $$ = DAY_OF_INTEGER; } | FACTORIAL { $$ = FACTORIAL; } diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_NumericDisplay_to_COMP-3.cob b/gcc/testsuite/cobol.dg/group2/MOVE_NumericDisplay_to_COMP-3.cob new file mode 100644 index 000000000000..0cdb0664aef9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_NumericDisplay_to_COMP-3.cob @@ -0,0 +1,32 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_NumericDisplay_to_COMP-3.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 var11 pic 9 value 1 . + 01 var12 pic 99 value 12 . + 01 var13 pic 999 value 123 . + 01 var14 pic 9999 value 1234 . + 01 var1t pic 999v999 COMP-3. + 01 var21 pic s9v9 value -1.2 . + 01 var22 pic s99v9 value -12.3 . + 01 var23 pic s999v9 value -123.4 . + 01 var24 pic s9999v9 value -1234.5 . + 01 var2t pic s999v999 COMP-3. + procedure division. + move var11 to var1t display var1t + move var12 to var1t display var1t + move var13 to var1t display var1t + move var14 to var1t display var1t + move var21 to var2t display var2t + move var22 to var2t display var2t + move var23 to var2t display var2t + move var24 to var2t display var2t + move var11 to var2t display var2t + move var12 to var2t display var2t + move var13 to var2t display var2t + move var14 to var2t display var2t + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_NumericDisplay_to_COMP-3.out b/gcc/testsuite/cobol.dg/group2/MOVE_NumericDisplay_to_COMP-3.out new file mode 100644 index 000000000000..499809f93a2e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_NumericDisplay_to_COMP-3.out @@ -0,0 +1,13 @@ +001.000 +012.000 +123.000 +234.000 +-001.200 +-012.300 +-123.400 +-234.500 ++001.000 ++012.000 ++123.000 ++234.000 + diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc index e9577f46bf53..9e6660d97ab2 100644 --- a/libgcobol/intrinsic.cc +++ b/libgcobol/intrinsic.cc @@ -1210,6 +1210,40 @@ __gg__char( cblc_field_t *dest, } } +extern "C" +void +__gg__char_national(cblc_field_t *dest, + const cblc_field_t *source, + size_t source_offset, + size_t source_size ) + { + // Since we haven't tried to implement collation sequences for National, + // this whole subroutine is a Hail Mary play. I frankly don't even know + // why we tried. + int rdigits; + + // The CHAR function takes an integer, the ordinal position. It + // returns a single-character string, which is the character at that + // ordinal position in the DISPLAY collation. + + // 'A', with the ascii value of 65, is at the ordinal position 66 + // in the default collation. + + int ordinal = (int)(__gg__binary_value_from_qualified_field(&rdigits, + source, + source_offset, + source_size)); + ordinal /= __gg__power_of_ten(rdigits); + ordinal -= 1; + + // We need to convert the ch character to the destination encoding. + // THIS IS A KLUDGE UNTIL WE MAKE THE CURRENT_COLLATION TO BE A MAP OF + // WIDE CHARACTERS! + const charmap_t *charmap_dest = __gg__get_charmap(dest->encoding); + + memcpy(dest->data, &ordinal, charmap_dest->stride()); + } + extern "C" void __gg__combined_datetime(cblc_field_t *dest,
