diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index c9d2da481ab9..40b79ba5ce6c 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -2102,6 +2102,7 @@ compare_binary_binary(tree return_int, right_side_ref->field, refer_offset(*right_side_ref), hilo_right); + IF( hilo_left, eq_op, integer_one_node ) { // left side is hi-value @@ -2358,8 +2359,6 @@ cobol_compare( tree return_int, NULL_TREE)); // compared = true; // Commented out to quiet cppcheck } - -// gg_printf(" result is %d\n", return_int, NULL_TREE); } static void @@ -14852,7 +14851,7 @@ static bool mh_numeric_display( const cbl_refer_t &destref, const cbl_refer_t &sourceref, const TREEPLET &tsource, - tree size_error) + tree size_error) { bool moved = false; @@ -14862,98 +14861,106 @@ mh_numeric_display( const cbl_refer_t &destref, && !(sourceref.field->attr & scaled_e) ) { Analyze(); - // I believe that there are 225 pathways through the following code. That's - // because there are five different valid combination of signable_e, + // I believe that there are 450 pathways through the following code. + // That's because there are five different valid combination of signable_e, // separate_e, and leading_e. There are three possibilities for - // sender/receiver rdigits (too many, too few, and just right), and the same - // for ldigits. 5 * 5 * 3 * 3 = 225. + // sender/receiver rdigits (too many, too few, and just right), and the + // same for ldigits. 5 * 5 * 3 * 3 * 2 = 450. // Fasten your seat belts. - // In order to simplify processing of a signable internal sender, we are - // going to pick up the sign byte and temporarily turn off the sign bit in - // the source data. At the end, we will restore that value. This - // reflexively makes me a bit nervous (it isn't, for example, thread-safe), - // but it makes life easier. + // This routine is complicated by the fact that although I had several + // false starts of putting this into libgcobol, I keep coming back to the + // fact that assignment of zoned values is common. And, so, there are all + // kinds of things that are known at compile time that would turn into + // execution-time decisions if I moved them to the library. So, complex + // or not, I am doing all this code here at compile time because it will + // minimize the code at execution time. - static tree source_sign_loc = gg_define_variable(UCHAR_P, "..mhnd_sign_loc", vs_file_static); - static tree source_sign_byte = gg_define_variable(UCHAR, "..mhnd_sign_byte", vs_file_static); - static tree dest_p = gg_define_variable(UCHAR_P, "..mhnd_dest", vs_file_static); // The destination data pointer - static tree source_p = gg_define_variable(UCHAR_P, "..mhnd_source", vs_file_static); // The source data pointer - static tree source_ep = gg_define_variable(UCHAR_P, "..mhnd_source_e", vs_file_static); // When we need an end pointer + // One thing to keep in mind is the problem caused by a source value being + // internally signed. That turns an ASCII "123" into "12t", and we + // very probably don't want that "t" to find its way into the destination + // value. The internal sign characteristic of ASCII is that the high + // nybble of the sign location is 0x30 or 0x70. For EBCDIC, the high + // nybble is 0xC0 for positive values, and 0xD0 for negative; all other + // digits are 0x70. + + static tree source_sign_loc = gg_define_variable(UCHAR_P, + "..mhnd_sign_loc", + vs_file_static); + static tree source_sign_byte = gg_define_variable(UCHAR, + "..mhnd_sign_byte", + vs_file_static); + // The destination data pointer + static tree dest_p = gg_define_variable( UCHAR_P, + "..mhnd_dest", + vs_file_static); + // The source data pointer + static tree source_p = gg_define_variable( UCHAR_P, + "..mhnd_source", + vs_file_static); + // When we need an end pointer + static tree source_ep = gg_define_variable( UCHAR_P, + "..mhnd_source_e", + vs_file_static); gg_assign(dest_p, qualified_data_location(destref)); gg_assign(source_p, gg_add(member(sourceref.field, "data"), tsource.offset)); - if( sourceref.field->attr & signable_e ) - { - // The source is signable + bool source_is_signable = sourceref.field->attr & signable_e; + bool source_is_leading = sourceref.field->attr & leading_e; + bool source_is_separate = sourceref.field->attr & separate_e; - if( !(sourceref.field->attr & leading_e) ) + bool dest_is_signable = destref.field->attr & signable_e; + bool dest_is_leading = destref.field->attr & leading_e; + bool dest_is_separate = destref.field->attr & separate_e; + + if( source_is_signable ) + { + // The source is signable, so we are going to calculate the location of + // the source sign information. + + gg_assign(source_sign_loc, + gg_add(member(sourceref.field->var_decl_node, "data"), + tsource.offset)); + + if( (source_is_leading) ) { - // The sign location is trailing. Whether separate or not, the location - // is the final byte of the data: - gg_assign(source_sign_loc, gg_add(member( sourceref.field->var_decl_node, "data"), - tsource.offset)), - gg_assign(source_sign_loc, - gg_add(source_sign_loc, - build_int_cst_type(SIZE_T, - sourceref.field->data.capacity-1))); - if( (sourceref.field->attr & separate_e) ) + // The source sign location is in the leading position. + if( source_is_separate ) { - // We have trailing separate - } - else - { - // We have trailing internal + // We have LEADING SEPARATE, so the first actual digit is at + // source_p+1. + gg_increment(source_p); } } else { - // The source sign location is in the leading position. + // The sign location is trailing. Whether separate or not, the + // location is the final byte of the data: gg_assign(source_sign_loc, - gg_add(member(sourceref.field->var_decl_node, "data"), - tsource.offset)); - if( (sourceref.field->attr & separate_e) ) - { - // We have leading separate, so the first actual digit is at - // source_p+1. - gg_increment(source_p); - } - else - { - // We have leading internal - } + gg_add(source_sign_loc, + build_int_cst_type(SIZE_T, + sourceref.field->data.capacity-1))); } // Pick up the byte that contains the sign data, whether internal or // external: gg_assign(source_sign_byte, gg_indirect(source_sign_loc)); - if( !(sourceref.field->attr & separate_e) ) + if( !source_is_separate ) { - // This is signable and internal, so we want to turn off the sign bit - // in the original source data - if( internal_codeset_is_ebcdic() ) - { - gg_assign(gg_indirect(source_sign_loc), - gg_bitwise_or(source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - } - else - { - gg_assign(gg_indirect(source_sign_loc), - gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); - } + // The source is signable and internal. We will modify the zone of + // the source sign byte to force it to be plain vanilla positive. + + // When the move is done, we will replace that byte with the original + // value. + gg_assign(gg_indirect(source_sign_loc), + gg_bitwise_or(build_int_cst_type(UCHAR, ZONED_ZERO), + gg_bitwise_and( source_sign_byte, + build_int_cst_type( UCHAR, 0x0F)))); } } - else - { - // The number is unsigned, so do nothing. - } // Let the shenanigans begin. @@ -14961,83 +14968,49 @@ mh_numeric_display( const cbl_refer_t &destref, // The first thing to do is see if we need to output a leading sign // character - if( (destref.field->attr & signable_e) - && (destref.field->attr & leading_e) - && (destref.field->attr & separate_e) ) + if( dest_is_signable + && dest_is_leading + && dest_is_separate ) { // The output is signed, separate, and leading, so the first character // needs to be either '+' or '-' - if( (sourceref.field->attr & separate_e) ) + if( source_is_separate ) { - // The source is signable/separate - // Oooh. Shiny. We already have that character. + // The source and dest are both signable/separate. + // Oooh. Shiny. We already have the sign character from the source, + // so we assign that to the destination. gg_assign(gg_indirect(dest_p), source_sign_byte); } else { - // The source is internal. Not that up above we set source_sign_byte - // even for source values that aren't signable - if( internal_codeset_is_ebcdic() ) + // The source is internal. + if( source_is_signable ) { - // We are working in EBCDIC - if( sourceref.field->attr & signable_e ) + IF( gg_bitwise_and( source_sign_byte, + build_int_cst_type( UCHAR, + NUMERIC_DISPLAY_SIGN_BIT)), + ne_op, + build_int_cst_type( UCHAR, 0) ) { - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - eq_op, - build_int_cst_type( UCHAR, 0) ) - { - // The source was negative - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_MINUS)); - - } - ELSE - { - // The source was positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_PLUS)); - } - ENDIF - } - else - { - // The source is not signable, so the result is positive + // The source was negative gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_PLUS)); + build_int_cst_type( UCHAR, SEPARATE_MINUS)); + } + ELSE + { + // The source was positive + gg_assign(gg_indirect(dest_p), + build_int_cst_type( UCHAR, SEPARATE_PLUS)); + } + ENDIF } else { - // We are working in ASCII - if( sourceref.field->attr & signable_e ) - { - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - ne_op, - build_int_cst_type( UCHAR, 0) ) - { - // The source was negative - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '-')); - - } - ELSE - { - // The source was positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '+')); - } - ENDIF - } - else - { - // The source is not signable, so the result is positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '+')); - } + // The source is not signable, so the signed becomes positive no + // matter what the sign of the source. + gg_assign(gg_indirect(dest_p), + build_int_cst_type( UCHAR, SEPARATE_PLUS)); } } gg_increment(dest_p); @@ -15058,8 +15031,7 @@ mh_numeric_display( const cbl_refer_t &destref, // The destination has more ldigits than the source, and needs some // leading zeroes: picky_memset( dest_p, - internal_codeset_is_ebcdic() ? - EBCDIC_ZERO : '0' , + ZONED_ZERO , dest_ldigits - source_ldigits); // With the leading zeros set, copy over the ldigits: digit_count = source_ldigits; @@ -15085,8 +15057,7 @@ mh_numeric_display( const cbl_refer_t &destref, IF( gg_indirect(source_p), ne_op, build_int_cst_type( UCHAR, - internal_codeset_is_ebcdic() ? - EBCDIC_ZERO : '0') ) + ZONED_ZERO) ) { set_exception_code(ec_size_truncation_e); gg_assign(size_error, integer_one_node); @@ -15132,25 +15103,23 @@ mh_numeric_display( const cbl_refer_t &destref, // over only the necessary rdigits, discarding the ones to the right. digit_count += dest_rdigits; } - picky_memcpy(dest_p, source_p, digit_count); picky_memset( dest_p, - internal_codeset_is_ebcdic() ? - EBCDIC_ZERO : '0' , + ZONED_ZERO , trailing_zeros); // With the digits in place, we need to sort out what to do if the target // is signable: - if( destref.field->attr & signable_e ) + if( dest_is_signable ) { - if( (destref.field->attr & separate_e) - && !(destref.field->attr & leading_e) ) + if( dest_is_separate + && !dest_is_leading ) { // The target is separate/trailing, so we need to tack a '+' // or '-' character - if( sourceref.field->attr & separate_e ) + if( source_is_separate ) { - // The source was separate, so we already have what we need in t + // The source was separate, so we already have what we need in the // source_sign_byte: gg_assign(gg_indirect(dest_p), source_sign_byte); gg_increment(dest_p); @@ -15158,68 +15127,43 @@ mh_numeric_display( const cbl_refer_t &destref, else { // The source is either internal, or unsigned - if( sourceref.field->attr & signable_e ) + if( source_is_signable ) { // The source is signable/internal, so we need to extract the // sign bit from source_sign_byte - if( internal_codeset_is_ebcdic() ) + IF( gg_bitwise_and( source_sign_byte, + build_int_cst_type( UCHAR, + NUMERIC_DISPLAY_SIGN_BIT)), + ne_op, + build_int_cst_type( UCHAR, 0) ) { - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - eq_op, - build_int_cst_type( UCHAR, 0) ) - { - // The source was negative - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_MINUS)); + // The source was negative + gg_assign(gg_indirect(dest_p), + build_int_cst_type( UCHAR, SEPARATE_MINUS)); - } - ELSE - { - // The source was positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_PLUS)); - } - ENDIF } - else + ELSE { - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - ne_op, - build_int_cst_type( UCHAR, 0) ) - { - // The source was negative - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '-')); - - } - ELSE - { - // The source was positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '+')); - } - ENDIF + // The source was positive + gg_assign(gg_indirect(dest_p), + build_int_cst_type( UCHAR, SEPARATE_PLUS)); } + ENDIF } else { // The source is unsigned, so dest is positive gg_assign(gg_indirect(dest_p), build_int_cst_type( UCHAR, - internal_codeset_is_ebcdic() ? - EBCDIC_PLUS : '+' )); + SEPARATE_PLUS)); } } gg_increment(dest_p); } - else if( !(destref.field->attr & separate_e) ) + else if( !dest_is_separate ) { // The destination is signed/internal - if( destref.field->attr & leading_e ) + if( dest_is_leading ) { // The sign bit goes into the first byte: gg_assign(dest_p, qualified_data_location(destref)); @@ -15229,104 +15173,62 @@ mh_numeric_display( const cbl_refer_t &destref, // The sign bit goes into the last byte: gg_decrement(dest_p); } - if( sourceref.field->attr & signable_e ) + // dest_p now points to the internal sign location + if( internal_codeset_is_ebcdic() ) { - if( sourceref.field->attr & separate_e ) + // For EBCDIC, the zone is going to end up being 0xC0 or 0xD0 + gg_assign(gg_indirect(dest_p), + gg_bitwise_and(gg_indirect(dest_p), + build_int_cst_type(UCHAR, + ZONE_SIGNED_EBCDIC+0x0F))); + } + + if( source_is_signable ) + { + if( source_is_separate ) { // The source is separate, so source_sign_byte is '+' or '-' IF( source_sign_byte, eq_op, - build_int_cst_type(UCHAR, - internal_codeset_is_ebcdic() ? - EBCDIC_MINUS : '-') ) + build_int_cst_type(UCHAR, SEPARATE_MINUS) ) { - // The source is negative, so turn the ASCII bit on - if( !internal_codeset_is_ebcdic() ) - { - gg_assign(gg_indirect(dest_p), - gg_bitwise_or(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - - } - else - { - // It's ebcdic, so turn the sign bit OFF - gg_assign(gg_indirect(dest_p), - gg_bitwise_and(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); - } + // The source is negative, so turn on the internal "is minus" bit + gg_assign(gg_indirect(dest_p), + gg_bitwise_or(gg_indirect(dest_p), + build_int_cst_type( + UCHAR, + NUMERIC_DISPLAY_SIGN_BIT))); } ELSE - { - // The source is positive, so turn the EBCDIC bit ON: - if( internal_codeset_is_ebcdic() ) - { - gg_assign(gg_indirect(dest_p), - gg_bitwise_or(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - } - } ENDIF } else { // The source is signable/internal, so the sign bit is in // source_sign_byte. Whatever it is, it has to go into dest_p: - if( internal_codeset_is_ebcdic() ) + IF( gg_bitwise_and( source_sign_byte, + build_int_cst_type( + UCHAR, + NUMERIC_DISPLAY_SIGN_BIT)), + ne_op, + build_int_cst_type(UCHAR, 0) ) { - // This is EBCDIC, so if the source_sign_byte bit is LOW, we - // clear that bit in dest_p high. - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - eq_op, - build_int_cst_type(UCHAR, 0) ) - { - // The source was negative, so make the dest negative - gg_assign(gg_indirect(dest_p), - gg_bitwise_and(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); - } - ELSE - ENDIF - } - else - { - // This is ASCII, so if the source_sign_byte bit is high, we - // set that bit in dest_p high. - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - ne_op, - build_int_cst_type(UCHAR, 0) ) - { - // The source was negative, so make the dest negative - gg_assign(gg_indirect(dest_p), - gg_bitwise_or(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - } - ELSE - ENDIF + // The source was negative, so make the dest negative + gg_assign(gg_indirect(dest_p), + gg_bitwise_or(gg_indirect(dest_p), + build_int_cst_type( + UCHAR, + NUMERIC_DISPLAY_SIGN_BIT))); } + ELSE + ENDIF } } } } - if( (sourceref.field->attr & signable_e) - && !(sourceref.field->attr & separate_e)) + if( source_is_signable + && !source_is_separate) { // The source is signable internal, so we need to restore the original // sign byte in the original source data: @@ -15335,7 +15237,7 @@ mh_numeric_display( const cbl_refer_t &destref, moved = true; } return moved; - } + } //NUMERIC_DISPLAY_SIGN static bool mh_little_endian( const cbl_refer_t &destref, @@ -16068,12 +15970,12 @@ initial_from_initial(cbl_field_t *field) bool negative; if( real_isneg (&value) ) { - negative = true; - value = real_value_negate (&value); + negative = true; + value = real_value_negate (&value); } else { - negative = false; + negative = false; } digits_from_float128(ach, field, field->data.digits, rdigits, value); @@ -16083,6 +15985,7 @@ initial_from_initial(cbl_field_t *field) && (field->attr & separate_e) && (field->attr & leading_e ) ) { + // This zoned decimal value is signable, separate, and leading. if( negative ) { *pretval++ = internal_minus; @@ -16094,12 +15997,14 @@ initial_from_initial(cbl_field_t *field) } for(size_t i=0; idata.digits; i++) { + // Start by assuming its an value that can't be signed *pretval++ = internal_zero + ((*digits++) & 0x0F); } if( (field->attr & signable_e) && (field->attr & separate_e) && !(field->attr & leading_e ) ) { + // The value is signable, separate, and trailing if( negative ) { *pretval++ = internal_minus; @@ -16110,30 +16015,21 @@ initial_from_initial(cbl_field_t *field) } } if( (field->attr & signable_e) - && !(field->attr & separate_e) - && negative) + && !(field->attr & separate_e) ) { - if( field->attr & leading_e ) + // This value is signable, and not separate. So, the sign information + // goes into the first or last byte: + char *sign_location = field->attr & leading_e ? + retval : retval + field->data.digits - 1 ; + if( internal_codeset_is_ebcdic() ) { - if( internal_is_ebcdic ) - { - retval[0] &= ~NUMERIC_DISPLAY_SIGN_BIT; - } - else - { - retval[0] |= NUMERIC_DISPLAY_SIGN_BIT; - } + // Change the zone from 0xFO to 0xC0 + *sign_location &= (ZONE_SIGNED_EBCDIC + 0x0F); } - else + if( negative ) { - if( internal_is_ebcdic ) - { - pretval[-1] &= ~NUMERIC_DISPLAY_SIGN_BIT; - } - else - { - pretval[-1] |= NUMERIC_DISPLAY_SIGN_BIT; - } + // Turn on the sign bit: + *sign_location |= NUMERIC_DISPLAY_SIGN_BIT; } } break; diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index e7eb971d1acb..27d5c1ee65fc 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -394,7 +394,6 @@ fast_add( size_t nC, cbl_num_result_t *C, { Analyze(); // All targets are non-PICTURE binaries: - //gg_insert_into_assembler("# DUBNER addition START"); tree term_type = largest_binary_term(nA, A); if( term_type ) { diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index a5f69a09eec9..1c39ff19f338 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -858,57 +858,47 @@ get_binary_value( tree value, // The sign byte is internal if( field->attr & leading_e) { - // The first byte has the sign bit: + // The first byte has the sign bit. We need to turn it off, + // to make the value positive: gg_assign(signbyte, gg_get_indirect_reference(source_address, NULL_TREE)); - if( internal_codeset_is_ebcdic() ) - { - // We need to make sure the EBCDIC sign bit is ON, for positive - gg_assign(gg_get_indirect_reference(source_address, NULL_TREE), - gg_bitwise_or(signbyte, + // We need to make sure the ascii sign bit is off, for positive + gg_assign(gg_get_indirect_reference(source_address, NULL_TREE), + gg_bitwise_and( signbyte, build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - } - else - { - // We need to make sure the ascii sign bit is Off, for positive - gg_assign(gg_get_indirect_reference(source_address, NULL_TREE), - gg_bitwise_and( signbyte, - build_int_cst_type( UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); - } + ~NUMERIC_DISPLAY_SIGN_BIT))); } else { - // The final byte has the sign bit: + // The final byte has the sign bit. We need to turn it off, + // to make the value positive: gg_assign(signbyte, gg_get_indirect_reference(source_address, build_int_cst_type(SIZE_T, field->data.capacity-1))); - if( internal_codeset_is_ebcdic() ) - { - // We need to make sure the EBCDIC sign bit is ON, for positive - gg_assign(gg_get_indirect_reference(source_address, - build_int_cst_type( SIZE_T, - field->data.capacity-1)), - gg_bitwise_or(signbyte, + gg_assign(gg_get_indirect_reference(source_address, + build_int_cst_type( SIZE_T, + field->data.capacity-1)), + gg_bitwise_and( signbyte, build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - } - else - { - // We need to make sure the ASCII sign bit is Off, for positive - gg_assign(gg_get_indirect_reference(source_address, - build_int_cst_type( SIZE_T, - field->data.capacity-1)), - gg_bitwise_and( signbyte, - build_int_cst_type( UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); - } + ~NUMERIC_DISPLAY_SIGN_BIT))); } } } // We can now set up the byte-by-byte processing loop: + WHILE( pointer, lt_op, pend ) + { + // Pick up the byte + digit = gg_get_indirect_reference(pointer, NULL_TREE); + // Whether ASCII or EBCDIC, the bottom four bits tell the tale: + // Multiply our accumulator by ten: + gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10))); + // And add in the current digit + gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_bitwise_and(digit, build_int_cst_type(UCHAR, 0x0F))))); + gg_increment(pointer); + } + WEND +#if 0 if( internal_codeset_is_ebcdic() ) { // We are working in EBCDIC @@ -961,6 +951,7 @@ get_binary_value( tree value, } WEND } +#endif // Value contains the binary value. The last thing is to apply -- and // undo -- the signable logic: @@ -1004,10 +995,12 @@ get_binary_value( tree value, // The final byte is '+' or '-' if( internal_codeset_is_ebcdic() ) { - // We are operating in EBCDIC, so we look for a 96 (is minus sign) - IF( gg_get_indirect_reference(source_address, build_int_cst_type(SIZE_T, field->data.capacity-1)), - eq_op, - build_int_cst_type(UCHAR, 96) ) + // We are operating in EBCDIC + IF( gg_get_indirect_reference(source_address, + build_int_cst_type(SIZE_T, + field->data.capacity-1)), + eq_op, + build_int_cst_type(UCHAR, EBCDIC_MINUS) ) { gg_assign(value, gg_negate(value)); } @@ -1031,30 +1024,17 @@ get_binary_value( tree value, else { // The sign byte is internal. Check the sign bit - if(internal_codeset_is_ebcdic()) + IF( gg_bitwise_and(signbyte, + build_int_cst_type(UCHAR, + NUMERIC_DISPLAY_SIGN_BIT)), + ne_op, + build_int_cst_type(UCHAR, 0) ) { - IF( gg_bitwise_and( signbyte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), eq_op, build_int_cst_type(UCHAR, 0) ) - { - // The EBCDIC sign bit was OFF, so negate the result - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - else - { - IF( gg_bitwise_and( signbyte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), ne_op, build_int_cst_type(UCHAR, 0) ) - { - // The ASCII sign bit was on, so negate the result - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF + // The ASCII sign bit was on, so negate the result + gg_assign(value, gg_negate(value)); } + ELSE + ENDIF // It's time to put back the original data: if( field->attr & leading_e) { diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out index ea05e96cfb31..15e06d1d0345 100644 --- a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out @@ -1,15 +1,15 @@ initialize zeroes allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) (1) as allocated - "" "" 0x0000000000000000 + "" "000" 0x0000000000000000 initialize low-value allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) (1) as allocated - "" "" 0x0000000000000000 + "" "000" 0x0000000000000000 initialize spaces allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) (1) as allocated - " " " " 0x2020202020202020 + " " "000" 0x2020202020202020 initialize high-value allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) 0xffffffffffffffff diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h index 15d06831be74..80e524c1e666 100644 --- a/libgcobol/common-defs.h +++ b/libgcobol/common-defs.h @@ -52,12 +52,53 @@ // COBOL tables can have up to seven subscripts #define MAXIMUM_TABLE_DIMENSIONS 7 -// This bit gets turned on in the first or last byte (depending on the leading_e attribute -// phrase) of a NumericDisplay to indicate that the value is negative. +/* COBOL has the concept of Numeric Display values, which use an entire byte + per digit. IBM also calls this "Zoned Decimal". + + In ASCII, the digits are '0' through '9' (0x30 through 0x39'. Signed + values are indicated by turning on the 0x40 bit in either the first + byte (for LEADING variables) or the last byte (for TRAILING). -// When running the EBCDIC character set, the meaning of this bit is flipped, -// because an EBCDIC zero is 0xF0, while ASCII is 0x30 -#define NUMERIC_DISPLAY_SIGN_BIT 0x40 + In IBM EBCDIC, the representation is slightly more complex, because the + concept of Zone carries a little more information. Unsigned numbers are + made up of just the EBCDIC digits '0' through '9' (0xF0 through 0xF9). + + The TRAILING signed value +1234 has the byte sequence 0xF1 0xF2 0xF3 0xC3. + The TRAILING signed value -1234 has the byte sequence 0xF1 0xF2 0xF3 0xD3. + The LEADING signed value +1234 has the byte sequence 0xC1 0xF2 0xF3 0xF3. + The LEADING signed value -1234 has the byte sequence 0xD1 0xF2 0xF3 0xF3. + + Note that for IBM EBCDIC, the nybble indicating sign has the same meaning + as for COMP-3/packed-decimal numbers. + + The effective result of this is that for ASCII, the byte carrying the sign + is made negative by turning on the 0x40 bit. + + For EBCDIC, the value must be constructed properly as a positive value by + setting the high nybble of the sign-carrying byte to 0xC0, after which the + value is flagged negative by turning on the 0x10 bit, turning the 0xC0 to + 0xD0. */ + +#define EBCDIC_MINUS (0x60) +#define EBCDIC_PLUS (0x4E) +#define EBCDIC_ZERO (0xF0) +#define EBCDIC_NINE (0xF9) + +#define PACKED_NYBBLE_PLUS 0x0C +#define PACKED_NYBBLE_MINUS 0x0D +#define PACKED_NYBBLE_UNSIGNED 0x0F + +#define NUMERIC_DISPLAY_SIGN_BIT_ASCII 0x40 +#define NUMERIC_DISPLAY_SIGN_BIT_EBCDIC 0x10 + +#define NUMERIC_DISPLAY_SIGN_BIT (__gg__ebcdic_codeset_in_use ? \ + NUMERIC_DISPLAY_SIGN_BIT_EBCDIC : \ + NUMERIC_DISPLAY_SIGN_BIT_ASCII) + +#define SEPARATE_PLUS (__gg__ebcdic_codeset_in_use ? EBCDIC_PLUS : '+') +#define SEPARATE_MINUS (__gg__ebcdic_codeset_in_use ? EBCDIC_MINUS : '-') +#define ZONED_ZERO (__gg__ebcdic_codeset_in_use ? EBCDIC_ZERO : '0') +#define ZONE_SIGNED_EBCDIC (0xC0) #define LEVEL01 (1) #define LEVEL49 (49) diff --git a/libgcobol/configure b/libgcobol/configure index d130002b2b95..72715177c230 100755 --- a/libgcobol/configure +++ b/libgcobol/configure @@ -16019,7 +16019,6 @@ fi - use_additional=yes acl_save_prefix="$prefix" diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index eac6e3164198..b46fd13f2080 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -971,11 +971,11 @@ turn_sign_bit_on(unsigned char *location) { if( internal_is_ebcdic ) { - *location &= ~NUMERIC_DISPLAY_SIGN_BIT; + *location = (*location & 0xF) + 0xD0; } else { - *location |= NUMERIC_DISPLAY_SIGN_BIT; + *location = (*location & 0xF) + 0x70; } } @@ -984,11 +984,11 @@ turn_sign_bit_off(unsigned char *location) { if( internal_is_ebcdic ) { - *location |= NUMERIC_DISPLAY_SIGN_BIT; + *location = (*location & 0xF) + 0xF0; } else { - *location &= ~NUMERIC_DISPLAY_SIGN_BIT; + *location = (*location & 0xF) + 0x30; } } @@ -1003,14 +1003,7 @@ is_sign_bit_on(char ch) } else { - if( internal_is_ebcdic ) - { - retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) == 0; - } - else - { - retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) != 0; - } + retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) != 0; } return retval; } @@ -1581,6 +1574,9 @@ int128_to_field(cblc_field_t *var, case FldNumericDisplay: if( var->attr & signable_e ) { + /* There is a regrettable plethora of possibilities, here. */ + + // Things get exciting when a numeric-display value is signable if( var->attr & separate_e ) @@ -1592,7 +1588,8 @@ int128_to_field(cblc_field_t *var, // The sign character goes into the first location size_error = __gg__binary_to_string_internal(PTRCAST(char, location+1), - length-1, value); + length-1, + value); location[0] = sign_ch; } else @@ -1606,12 +1603,21 @@ int128_to_field(cblc_field_t *var, } else { - // The sign information is not separate, so we put it into - // the number + /* The sign information is not separate. The sign information + goes into the first byte for LEADING, or the last byte for + TRAILING. For ASCII, the zone will be 0x30. For EBCDIC, + the the zone is 0xC0. Those get modified, respectively, to + 0x70 and 0xD0 when the value is negative. */ + + // First, convert the binary value to the correct-length string size_error = __gg__binary_to_string_internal(PTRCAST(char, location), - length, value); + length, + value); + // Check for a size error on a negative value. It conceivably + // was truncated down to zero, in which case we need to + // suppress this is_negative flag. if( size_error && is_negative ) { // If all of the digits are zero, then the result is zero, and @@ -1627,27 +1633,28 @@ int128_to_field(cblc_field_t *var, } } + unsigned char *sign_location = + var->attr & leading_e ? location : location + length - 1; + + if( internal_is_ebcdic ) + { + // Change the sign location from 0xF0 to 0xC0. + *sign_location &= (ZONE_SIGNED_EBCDIC + 0xF); + } + if( is_negative ) { - if( var->attr & leading_e ) - { - // The sign bit goes into the first digit: - turn_sign_bit_on(&location[0]); - } - else - { - // The sign bit goes into the last digit: - turn_sign_bit_on(&location[length-1]); - } + *sign_location |= NUMERIC_DISPLAY_SIGN_BIT; } } } else { // It's a simple positive number - size_error = __gg__binary_to_string_internal( PTRCAST(char, - location), - length, value); + size_error = __gg__binary_to_string_internal( + PTRCAST(char, location), + length, + value); } break; @@ -1985,10 +1992,8 @@ get_binary_value_local( int *rdigits, { __int128 retval = 0; - unsigned char ch; switch( resolved_var->type ) { -#if 1 case FldLiteralA : fprintf(stderr, "%s(): is trying to handle a FldLiteralA\n", __func__); abort(); @@ -1997,7 +2002,6 @@ get_binary_value_local( int *rdigits, // resolved_length, // rdigits ); break; -#endif case FldGroup : case FldAlphanumeric : @@ -2008,7 +2012,8 @@ get_binary_value_local( int *rdigits, rdigits ); break; - case FldNumericDisplay : + case FldNumericDisplay: + { if( resolved_location[resolved_length-1] == DEGENERATE_HIGH_VALUE ) { // This is a degenerate case, which violates the language @@ -2036,53 +2041,142 @@ get_binary_value_local( int *rdigits, } else { - // Pick up the sign byte, and force our value to be positive unsigned char *sign_byte_location; - if( (resolved_var->attr & separate_e ) - && (resolved_var->attr & leading_e ) ) + unsigned char ch; + if( resolved_var->attr & signable_e ) { - sign_byte_location = resolved_location; - ch = *sign_byte_location; - *sign_byte_location = internal_plus; - } - else if( (resolved_var->attr & separate_e) - && !(resolved_var->attr & leading_e ) ) - { - sign_byte_location = resolved_location + resolved_length - 1; - ch = *sign_byte_location; - *sign_byte_location = internal_plus; - } - else if( (resolved_var->attr & leading_e) ) - { - sign_byte_location = resolved_location; - ch = *sign_byte_location; - turn_sign_bit_off(sign_byte_location); - } - else // if( !(resolved_var->attr & leading_e) ) - { - sign_byte_location = resolved_location + resolved_length - 1; - ch = *sign_byte_location; - turn_sign_bit_off(sign_byte_location); + // Pick up the sign byte, and force our value to be positive + if( (resolved_var->attr & separate_e ) + && (resolved_var->attr & leading_e ) ) + { + // LEADING SEPARATE + sign_byte_location = resolved_location; + resolved_location += 1; + resolved_length -= 1; + ch = *sign_byte_location; + *sign_byte_location = internal_plus; + } + else if( (resolved_var->attr & separate_e) + && !(resolved_var->attr & leading_e ) ) + { + // TRAILING SEPARATE + sign_byte_location = resolved_location + resolved_length - 1; + resolved_length -= 1; + ch = *sign_byte_location; + *sign_byte_location = internal_plus; + } + else if( (resolved_var->attr & leading_e) ) + { + // LEADING + sign_byte_location = resolved_location; + ch = *sign_byte_location; + turn_sign_bit_off(sign_byte_location); + } + else // if( !(resolved_var->attr & leading_e) ) + { + // TRAILING + sign_byte_location = resolved_location + resolved_length - 1; + ch = *sign_byte_location; + turn_sign_bit_off(sign_byte_location); + } } // We know where the decimal point is because of rdigits. Because - // we know that it a clean string of ASCII digits, we can use the - // dirty converter: - retval = __gg__dirty_to_binary_internal(PTRCAST(const char, - resolved_location), - resolved_length, - rdigits ); + // we know that we have a clean string of digits (either ASCII or + // EBCDIC), we can just build up the result: + + static const uint8_t from_ebcdic[256] = + { + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x00 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x10 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x20 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x30 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x40 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x50 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x60 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x70 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x80 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x90 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xa0 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xb0 + 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0xc0 + 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0xd0 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xe0 + 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0xf0 + }; + + static const uint8_t from_ascii[256] = + { + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x00 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x10 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x20 + 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0x30 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x40 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x50 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x60 + 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0x70 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x80 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x90 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xa0 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xb0 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xc0 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xd0 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xe0 + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xf0 + }; + + if( internal_is_ebcdic ) + { + for(size_t i=0; irdigits; - // Restore the sign byte - *sign_byte_location = ch; - - if( ch == internal_minus || is_sign_bit_on(ch) ) + if( resolved_var->attr & signable_e ) { - retval = -retval; + // Restore the sign byte + *sign_byte_location = ch; + + // And if the source is flagged negative, make our result negative + if( ch == internal_minus ) + { + retval = -retval; + } + else + { + if( internal_is_ebcdic ) + { + // EBCDIC characters: + if( (ch & 0xF0) == 0xD0 ) + { + retval = -retval; + } + } + else + { + // ASCII characters: + if( (ch & 0xF0) == 0x70 ) + { + retval = -retval; + } + } + } } } break; + } case FldNumericEdited : retval = edited_to_binary( PTRCAST(char, resolved_location), @@ -3024,6 +3118,47 @@ format_for_display_internal(char **dest, case FldNumericDisplay: { + // Because a NumericDisplay can have any damned thing as a character, + // we are going force things that aren't digits to display as '0' + static const uint8_t ascii_chars[256] = + { + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0x00 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0x10 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0x20 + '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '0', '0', '0', '0', '0', '0', // 0x30 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0x40 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0x50 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0x60 + '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '0', '0', '0', '0', '0', '0', // 0x70 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0x80 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0x90 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0xa0 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0xb0 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0xc0 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0xd0 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0xe0 + '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', // 0xf0 + }; + static const uint8_t ebcdic_chars[256] = + { + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x00 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x10 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x20 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x30 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x40 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x50 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x60 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x70 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x80 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0x90 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0xa0 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0xb0 + 0xf0,0xf1,0xf2,0xf3,0xf4,0xf5,0xf6,0xf7,0xf8,0xf9,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0xc0 + 0xf0,0xf1,0xf2,0xf3,0xf4,0xf5,0xf6,0xf7,0xf8,0xf9,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0xd0 + 0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0xe0 + 0xf0,0xf1,0xf2,0xf3,0xf4,0xf5,0xf6,0xf7,0xf8,0xf9,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0, // 0xf0 + } ; + // We are going to make use of fact that a NumericDisplay's data is // almost already in the format we need. We have to add a decimal point, // if necessary, in the right place, and we need to tack on leading or @@ -3097,50 +3232,67 @@ format_for_display_internal(char **dest, } } - {//xxx - // copy over the characters to the left of the decimal point: - for(int i=0; i