diff options
Diffstat (limited to 'gcc/cobol')
| -rw-r--r-- | gcc/cobol/ChangeLog | 43 | ||||
| -rw-r--r-- | gcc/cobol/cbldiag.h | 4 | ||||
| -rw-r--r-- | gcc/cobol/genapi.cc | 462 | ||||
| -rw-r--r-- | gcc/cobol/genapi.h | 2 | ||||
| -rw-r--r-- | gcc/cobol/genmath.cc | 1 | ||||
| -rw-r--r-- | gcc/cobol/genutil.cc | 330 | ||||
| -rw-r--r-- | gcc/cobol/parse.y | 9 | ||||
| -rw-r--r-- | gcc/cobol/scan.l | 2 | ||||
| -rw-r--r-- | gcc/cobol/scan_ante.h | 2 | ||||
| -rw-r--r-- | gcc/cobol/show_parse.h | 2 | ||||
| -rw-r--r-- | gcc/cobol/structs.cc | 25 | ||||
| -rw-r--r-- | gcc/cobol/structs.h | 1 | ||||
| -rw-r--r-- | gcc/cobol/symbols.cc | 10 | ||||
| -rw-r--r-- | gcc/cobol/util.cc | 4 |
14 files changed, 311 insertions, 586 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index 35d645c..256ee70 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,46 @@ +2025-08-20 Robert Dubner <rdubner@symas.com> + + * genutil.cc (get_binary_value): Fix a comment. + * parse.y: udf_args_valid(): Fix loc calculation. + * symbols.cc (assert): extend_66_capacity(): Avoid assert(e < e2) in + -O0 build until symbol_table expansion is fixed. + +2025-08-15 Robert Dubner <rdubner@symas.com> + + * genapi.h (parser_call_exception_end): Remove obsolete comment. + * structs.cc (create_cbl_enabled_exception_t): + Remove cbl_enabled_exception_type_node; + remove create_cbl_enabled_exception_t(). + (create_our_type_nodes): Likewise. + * structs.h (GTY): Likewise. + +2025-08-13 Robert Dubner <rdubner@symas.com> + + * genutil.cc (get_binary_value): Use the new routine. + +2025-08-13 Robert Dubner <rdubner@symas.com> + + * genutil.cc (get_binary_value): Use the new routine. + +2025-08-12 Robert Dubner <rdubner@symas.com> + + * genapi.cc (compare_binary_binary): Formatting. + (cobol_compare): Formatting. + (mh_numeric_display): Rewrite "move ND to ND" algorithm. + (initial_from_initial): Proper initialization of EBCDIC ND variables. + * genmath.cc (fast_add): Delete comment. + * genutil.cc (get_binary_value): Modify for updated EBCDIC. + +2025-08-07 Robert Dubner <rdubner@symas.com> + + * cbldiag.h (location_dump): Source code formatting. + * parse.y: error_msg formatting. + * scan.l: Remove UTF-8 character from regex pattern. + * scan_ante.h (numstr_of): error_msg formatting. + * show_parse.h (class ANALYZE): Suppress cppcheck error. + * util.cc (cbl_field_t::report_invalid_initial_value): + error_msg formatting. + 2025-08-02 Jakub Jelinek <jakub@redhat.com> * parse.y (intrinsic): Use %td format specifier with no cast on diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h index dd16190..2554deb 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -122,8 +122,8 @@ static void location_dump( const char func[], int line, const char tag[], const LOC& loc) { extern int yy_flex_debug; // cppcheck-suppress shadowVariable if( yy_flex_debug ) { - const char *detail = gcobol_getenv("update_location"); // cppcheck-suppress knownConditionTrueFalse - if( detail ) { + const char *detail = gcobol_getenv("update_location"); + if( detail ) { // cppcheck-suppress knownConditionTrueFalse fprintf(stderr, "%s:%d: %s location (%d,%d) to (%d,%d)\n", func, line, tag, loc.first_line, loc.first_column, loc.last_line, loc.last_column); diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index c9d2da4..40b79ba 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. - - 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 + // 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. + + // 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 ) + 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; + + 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 + // 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( !(sourceref.field->attr & leading_e) ) + 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) ) - { - // We have trailing separate - } - else + // The source sign location is in the leading position. + if( source_is_separate ) { - // 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)); + // 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 { - // The source is not signable, so the result is positive + // The source was positive gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_PLUS)); + 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() ) - { - // 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 + 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 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; i<field->data.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/genapi.h b/gcc/cobol/genapi.h index b41b906..b86be8e 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -536,8 +536,6 @@ void parser_exception_raise(ec_type_t ec); void parser_call_exception( cbl_label_t *name ); void parser_call_exception_end( cbl_label_t *name ); -//void parser_stash_exceptions(const cbl_enabled_exceptions_array_t *enabled); - void parser_match_exception(cbl_field_t *index); void parser_check_fatal_exception(); void parser_clear_exception(); diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index e7eb971..27d5c1e 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 a5f69a0..4b296e4 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -752,9 +752,9 @@ get_binary_value( tree value, return; } - static tree pointer = gg_define_variable(UCHAR_P, "..gbv_pointer", vs_file_static); - static tree pend = gg_define_variable(UCHAR_P, "..gbv_pend", vs_file_static); - + static tree pointer = gg_define_variable( UCHAR_P, + "..gbv_pointer", + vs_file_static); switch(field->type) { case FldLiteralN: @@ -791,8 +791,9 @@ get_binary_value( tree value, // We need to check early on for HIGH-VALUE and LOW-VALUE // Pick up the byte tree digit = gg_get_indirect_reference(source_address, NULL_TREE); - IF( digit, eq_op, build_int_cst(UCHAR, 0xFF) ) + IF( digit, eq_op, build_int_cst(UCHAR, DEGENERATE_HIGH_VALUE) ) { + // We are dealing with HIGH-VALUE if( hilo ) { gg_assign(hilo, integer_one_node); @@ -803,12 +804,14 @@ get_binary_value( tree value, build_int_cst_type( TREE_TYPE(rdigits), get_scaled_rdigits(field))); } - gg_assign(value, build_int_cst_type(TREE_TYPE(value), 0xFFFFFFFFFFFFFFFUL)); + gg_assign(value, build_int_cst_type(TREE_TYPE(value), + 0x7FFFFFFFFFFFFFFFUL)); } ELSE { - IF( digit, eq_op, build_int_cst(UCHAR, 0x00) ) + IF( digit, eq_op, build_int_cst(UCHAR, DEGENERATE_LOW_VALUE) ) { + // We are dealing with LOW-VALUE if( hilo ) { gg_assign(hilo, integer_minus_one_node); @@ -816,26 +819,25 @@ get_binary_value( tree value, } ELSE { - // Establish rdigits: + // We are dealing with an ordinary NumericDisplay value + gg_assign(pointer, source_address); + if( rdigits ) { gg_assign(rdigits, - build_int_cst_type( TREE_TYPE(rdigits), - get_scaled_rdigits(field))); + build_int_cst_type(TREE_TYPE(rdigits), + get_scaled_rdigits(field))); } - // Zero out the destination - gg_assign(value, gg_cast(TREE_TYPE(value), integer_zero_node)); - // Pick up a pointer to the source bytes: - - gg_assign(pointer, source_address); - - // This is the we-are-done pointer - gg_assign(pend, gg_add( pointer, - get_any_capacity(field))); - - static tree signbyte = gg_define_variable(UCHAR, "..gbv_signbyte", vs_file_static); - - // The big decision is whether or not the variable is signed: + // This will be the 128-bit value of the character sequence + static tree val128 = gg_define_variable(INT128, + "..gbv_val128", + vs_file_static); + // This is a pointer to the sign byte + static tree signp = gg_define_variable(UCHAR_P, + "..gbv_signp", + vs_file_static); + // We need to figure out where the sign information, if any is to be + // found: if( field->attr & signable_e ) { // The variable is signed @@ -845,12 +847,17 @@ get_binary_value( tree value, if( field->attr & leading_e) { // The first byte is '+' or '-' + gg_assign(signp, source_address); + // Increment pointer to point to the first actual digit gg_increment(pointer); } else { // The final byte is '+' or '-' - gg_decrement(pend); + gg_assign(signp, + gg_add(source_address, + build_int_cst_type( SIZE_T, + field->data.digits))); } } else @@ -858,219 +865,34 @@ get_binary_value( tree value, // The sign byte is internal if( field->attr & leading_e) { - // The first byte has the sign bit: - 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, - 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))); - } + // The first byte has the sign bit. + gg_assign(signp, source_address); } else { - // The final byte has the sign bit: - 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, - 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))); - } + // The final byte has the sign bit. + gg_assign(signp, + gg_add(source_address, + build_int_cst_type( SIZE_T, + field->data.digits-1))); } } } - // We can now set up the byte-by-byte processing loop: - if( internal_codeset_is_ebcdic() ) - { - // We are working in EBCDIC - WHILE( pointer, lt_op, pend ) - { - // Pick up the byte - digit = gg_get_indirect_reference(pointer, NULL_TREE); - IF( digit, lt_op, build_int_cst_type(UCHAR, EBCDIC_ZERO) ) - { - // break on a non-digit - gg_assign(pointer, pend); - } - ELSE - { - IF( digit, gt_op, build_int_cst_type(UCHAR, EBCDIC_NINE) ) - { - // break on a non-digit - gg_assign(pointer, pend); - } - ELSE - { - // 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); - } - ENDIF - } - ENDIF - } - WEND - } else { - // We are working in ASCII: - 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 + // This value is unsigned, so just use the first location: + gg_assign(signp, source_address); } - // Value contains the binary value. The last thing is to apply -- and - // undo -- the signable logic: - - if( field->attr & signable_e ) - { - // The variable is signed - if( field->attr & separate_e ) - { - // The sign byte is separate - if( field->attr & leading_e) - { - // The first 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, NULL_TREE), - eq_op, - build_int_cst_type(UCHAR, 96) ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - else - { - // We are operating in ASCII - IF( gg_get_indirect_reference(source_address, NULL_TREE), - eq_op, - build_int_cst_type(UCHAR, '-') ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - } - else - { - // 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) ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - else - { - // We are operating in ASCII - IF( gg_get_indirect_reference(source_address, build_int_cst_type(SIZE_T, field->data.capacity-1)), - eq_op, - build_int_cst_type(UCHAR, '-') ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - } - } - 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)), 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 - } - // It's time to put back the original data: - if( field->attr & leading_e) - { - // The first byte has the sign bit: - gg_assign(gg_get_indirect_reference(source_address, NULL_TREE), - signbyte); - } - else - { - // The final byte has the sign bit: - gg_assign(gg_get_indirect_reference(source_address, - build_int_cst_type(SIZE_T, field->data.capacity-1)), - signbyte); - } - } - } + gg_assign(val128, + gg_call_expr( INT128, + "__gg__numeric_display_to_binary", + signp, + pointer, + build_int_cst_type(INT, field->data.digits), + NULL_TREE)); + // Assign the value we got from the string to our "return" value: + gg_assign(value, gg_cast(TREE_TYPE(value), val128)); } ENDIF } @@ -1119,7 +941,9 @@ get_binary_value( tree value, vs_file_static); if( field->attr & signable_e ) { - IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)), lt_op, gg_cast(SCHAR, integer_zero_node) ) + IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)), + lt_op, + gg_cast(SCHAR, integer_zero_node) ) { gg_assign(extension, build_int_cst_type(UCHAR, 0xFF)); } @@ -1202,45 +1026,23 @@ get_binary_value( tree value, case FldPacked: { - // Zero out the destination: - gg_assign(value, gg_cast(TREE_TYPE(value), integer_zero_node)); - gg_assign(pointer, get_data_address(field, field_offset)); - gg_assign(pend, - gg_add(pointer, - build_int_cst_type(SIZE_T, field->data.capacity-1))); - - // Convert all but the last byte of the packed decimal sequence - WHILE( pointer, lt_op, pend ) - { - // Convert the first nybble - gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10))); - gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_rshift(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst(UINT, 4))))); - - // Convert the second nybble - gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10))); - gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_bitwise_and(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst_type(UCHAR, 0xF))))); - gg_increment(pointer); - } - WEND - - // This is the final byte: - gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10))); - gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_rshift(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst(UINT, 4))))); - - IF( gg_bitwise_and(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst_type(UCHAR, 0xF)), eq_op, build_int_cst_type(UCHAR, 0x0D) ) - { - gg_assign(value, gg_negate(value)); - } - ELSE + if( rdigits ) { - IF( gg_bitwise_and(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst_type(UCHAR, 0xF)), eq_op, build_int_cst_type(UCHAR, 0x0B) ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF + gg_assign(rdigits, + build_int_cst_type( TREE_TYPE(rdigits), + get_scaled_rdigits(field))); } - ENDIF + tree dest_type = TREE_TYPE(value); + + gg_assign(value, + gg_cast(dest_type, + gg_call_expr(INT128, + "__gg__packed_to_binary", + get_data_address( field, + field_offset), + build_int_cst_type(INT, + field->data.capacity), + NULL_TREE))); break; } diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index fae96ed..039cb95 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -10336,8 +10336,8 @@ intrinsic: function_udf if( p != NULL ) { auto loc = symbol_field_location(field_index(p->field)); error_msg(loc, "FUNCTION %qs has " - "inconsistent parameter type %td (%qs)", - keyword_str($1), p - args.data(), name_of(p->field) ); + "inconsistent parameter type %ld (%qs)", + keyword_str($1), (long)(p - args.data()), name_of(p->field) ); YYERROR; } $$ = is_numeric(args[0].field)? @@ -11959,7 +11959,10 @@ current_t::udf_args_valid( const cbl_label_t *L, if( arg.field ) { // else omitted auto tgt = cbl_field_of(symbol_at(udf.linkage_fields.at(i).isym)); if( ! valid_move(tgt, arg.field) ) { - auto loc = symbol_field_location(field_index(arg.field)); + auto loc = current_location; + if( ! is_temporary(arg.field) ) { + loc = symbol_field_location(field_index(arg.field)); + } error_msg(loc, "FUNCTION %s argument %zu, '%s' cannot be passed to %s, type %s", L->name, i, arg.field->pretty_name(), tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) ); diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l index ba4c044..5773f09 100644 --- a/gcc/cobol/scan.l +++ b/gcc/cobol/scan.l @@ -123,7 +123,7 @@ NUMEDCHAR [BPVZ90/,]+{COUNT}? NUMEDCHARS {NUMEDCHAR}([.]?{NUMEDCHAR})* NUMED ([+-]{NUMEDCHARS}+)|({NUMEDCHARS}+[+-]) CURRENCY [A-Zfhijklmoqtuwy\x80-\xFF]{-}[ABCDEGNPRSVXZ] -NUMEDCUR (([.]?[-$0B/Z*+,P9()V+–]|{CURRENCY}+|{COUNT})+([.][$0B/Z*+P9()V+\–])*)+ +NUMEDCUR (([.]?[$0B/Z*+,P9()V+-]|{CURRENCY}+|{COUNT})+([.][$0B/Z*+P9()V+-])*)+ NUMEDITED {NUMED}|{NUMEDCUR} EDITED {ALPHED}|{NUMED}|{NUMEDCUR} diff --git a/gcc/cobol/scan_ante.h b/gcc/cobol/scan_ante.h index 31093a6..c00826d 100644 --- a/gcc/cobol/scan_ante.h +++ b/gcc/cobol/scan_ante.h @@ -149,7 +149,7 @@ numstr_of( const char string[], radix_t radix = decimal_e ) { } auto nx = std::count_if(input, p, fisdigit); if( 36 < nx ) { - error_msg(yylloc, "significand of %s has more than 36 digits (%td)", input, nx); + error_msg(yylloc, "significand of %s has more than 36 digits (%ld)", input, (long)nx); return NO_CONDITION; } diff --git a/gcc/cobol/show_parse.h b/gcc/cobol/show_parse.h index bd0e16f..e1a8cb2 100644 --- a/gcc/cobol/show_parse.h +++ b/gcc/cobol/show_parse.h @@ -500,7 +500,7 @@ class ANALYZE int level; inline static int analyze_level=1; public: - ANALYZE(const char *func_) : func(func_) + ANALYZE(const char *func_) : func(func_) // cppcheck-suppress noExplicitConstructor { level = 0; if( getenv("Analyze") ) diff --git a/gcc/cobol/structs.cc b/gcc/cobol/structs.cc index 7a4db97..2393dfb 100644 --- a/gcc/cobol/structs.cc +++ b/gcc/cobol/structs.cc @@ -156,7 +156,6 @@ tree cblc_field_p_type_node; tree cblc_field_pp_type_node; tree cblc_file_type_node; tree cblc_file_p_type_node; -tree cbl_enabled_exception_type_node; tree cblc_goto_type_node; // The following functions return type_decl nodes for the various structures @@ -288,29 +287,6 @@ typedef struct cblc_file_t return retval; } -static tree -create_cbl_enabled_exception_t() - { - /* - struct cbl_enabled_exception_t - { - bool enabled, location; - ec_type_t ec; - size_t file; - }; - */ - tree retval = NULL_TREE; - retval = gg_get_filelevel_struct_type_decl( "cbl_enabled_exception_t", - 4, - BOOL, "enabled", - BOOL, "location", - UINT, "ec", - SIZE_T, "file"); - retval = TREE_TYPE(retval); - - return retval; - } - void create_our_type_nodes() { @@ -323,7 +299,6 @@ create_our_type_nodes() cblc_field_pp_type_node = build_pointer_type(cblc_field_p_type_node); cblc_file_type_node = create_cblc_file_t(); cblc_file_p_type_node = build_pointer_type(cblc_file_type_node); - cbl_enabled_exception_type_node = create_cbl_enabled_exception_t(); } } diff --git a/gcc/cobol/structs.h b/gcc/cobol/structs.h index 1a16523..47a78b4 100644 --- a/gcc/cobol/structs.h +++ b/gcc/cobol/structs.h @@ -54,7 +54,6 @@ extern GTY(()) tree cblc_field_p_type_node; extern GTY(()) tree cblc_field_pp_type_node; extern GTY(()) tree cblc_file_type_node; extern GTY(()) tree cblc_file_p_type_node; -extern GTY(()) tree cbl_enabled_exception_type_node; extern GTY(()) tree cblc_goto_type_node; extern void create_our_type_nodes(); diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index f2cd1b5..bbe99b6 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -1598,7 +1598,17 @@ extend_66_capacity( cbl_field_t *alias ) { symbol_elem_t *e = symbol_at(alias->parent); symbol_elem_t *e2 = reinterpret_cast<symbol_elem_t*>(const_cast<char*>(alias->data.picture)); +#ifndef __OPTIMIZE__ +#pragma message "The assert(e < e2) needs fixing" + // The following assert fails when valgrind is involved. This is the known + // problem of expecting mmap() to put new memory maps after older memory + // maps; that assumption fails when valgrind is involved. + + // For now I am defeating the assert when using -O0 so that I can run the + // NIST "make valgrind" tests. But this should be fixed so that the + // symbol table index is used, not the entry locations. assert(e < e2); +#endif alias->data.picture = NULL; capacity_of cap; diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index aed9483..2a7bf2b 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -1049,8 +1049,8 @@ cbl_field_t::report_invalid_initial_value(const YYLTYPE& loc) const { return TOUPPER(ch) == 'E'; } ); if( !has_exponent && data.precision() < pend - p ) { - error_msg(loc, "%s cannot represent VALUE %qs exactly (max %c%td)", - name, data.initial, '.', pend - p); + error_msg(loc, "%s cannot represent VALUE %qs exactly (max %c%ld)", + name, data.initial, '.', (long)(pend - p)); } } } |