https://gcc.gnu.org/g:e7356e34b2486a1c3e91214d295d5d24c034d839
commit r16-7580-ge7356e34b2486a1c3e91214d295d5d24c034d839 Author: Robert Dubner <[email protected]> Date: Wed Feb 18 23:01:38 2026 -0500 cobol: Improve generated code for fast_add and fast_subtract. These changes improve the efficiency of generated code by recognizing more instances where operations are on little-endian binary COBOL variables and then avoiding calls to libgcobol. The generated code also reduces the number of intermediate variables created for that little-endian arithmetic. gcc/cobol/ChangeLog: * genapi.cc (tree_type_from_field_type): Move static code. (compare_binary_binary): Identify little-endian compares. (psa_FldLiteralN): Eliminate obsolete development code; make the initialized variables TREE_CONSTANT. (parser_symbol_add): Adjust for modified FldLiteralN. * genmath.cc (all_results_binary): Renamed. Modified for fastness. (all_results_integer): Likewise. (all_refers_integer): Likewise. (largest_binary_term): Likewise. (fast_add): Expand conditions. Use get_binary_value_tree. (fast_subtract): Likewise. (fast_multiply): Expand conditions. (fast_divide): Expand conditions. (parser_add): Avoid fast_add when error or not-error are specified. (parser_multiply): Likewise. (parser_divide): Likewise. (parser_subtract): Likewise. * genutil.cc (tree_type_from_field): Disable; flagged for removal. (get_binary_value): Use get_binary_value_tree. (get_binary_value_tree): Avoid intermediate variables when possible. (refer_is_clean): Formatting. (is_pure_integer): Refine test for little-endian binary. * genutil.h (get_binary_value_tree): New declaration. (is_pure_integer): New declaration. * symbols.cc (symbol_table_init): Explanatory ZEROS comment. libgcobol/ChangeLog: * gfileio.cc (__gg__file_reopen): Raise exception on failed OPEN * gmath.cc (__gg__fixed_phase2_assign_to_c): Let pointer arithmetic go negative. (__gg__subtractf2_fixed_phase1): Edit a comment. Diff: --- gcc/cobol/genapi.cc | 253 +++++++++++++++++++------------- gcc/cobol/genmath.cc | 408 +++++++++++++++++++++++++++++++++++++++------------ gcc/cobol/genutil.cc | 197 +++++++++++++++++++------ gcc/cobol/genutil.h | 10 ++ gcc/cobol/symbols.cc | 3 +- libgcobol/gfileio.cc | 4 + libgcobol/gmath.cc | 17 ++- 7 files changed, 648 insertions(+), 244 deletions(-) diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 78122c12b16e..dcf49c7a90e1 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -2028,6 +2028,102 @@ normal_normal_compare(bool debugging, } } +static +tree +tree_type_from_field_type(cbl_field_t *field, size_t &nbytes) + { + /* This routine is used to determine what action is taken with type of a + CALL ... USING <var> and the matching PROCEDURE DIVISION USING <var> of + a PROGRAM-ID or FUNCTION-ID + */ + tree retval = COBOL_FUNCTION_RETURN_TYPE; + nbytes = 8; + if( field ) + { + // This maps a Fldxxx to a C-style variable type: + switch(field->type) + { + case FldGroup: + case FldAlphanumeric: + case FldAlphaEdited: + case FldNumericEdited: + retval = CHAR_P; + nbytes = field->data.capacity(); + break; + + case FldNumericDisplay: + case FldNumericBinary: + case FldPacked: + if( field->data.digits > 18 ) + { + retval = UINT128; + nbytes = 16; + } + else + { + retval = SIZE_T; + nbytes = 8; + } + break; + + case FldNumericBin5: + case FldIndex: + case FldPointer: + if( field->data.capacity() > 8 ) + { + retval = UINT128; + nbytes = 16; + } + else + { + retval = SIZE_T; + nbytes = 8; + } + break; + + case FldFloat: + if( field->data.capacity() == 8 ) + { + retval = DOUBLE; + nbytes = 8; + } + else if( field->data.capacity() == 4 ) + { + retval = FLOAT; + nbytes = 4; + } + else + { + retval = FLOAT128; + nbytes = 16; + } + break; + + case FldLiteralN: + // Assume a 64-bit signed integer. This happens for GOBACK STATUS 101, + // the like + retval = LONG; + nbytes = 8; + break; + + default: + cbl_internal_error( "%s: Invalid field type %s:", + __func__, + cbl_field_type_str(field->type)); + break; + } + if( retval == SIZE_T && field->attr & signable_e ) + { + retval = SSIZE_T; + } + if( retval == UINT128 && field->attr & signable_e ) + { + retval = INT128; + } + } + return retval; + } + static void compare_binary_binary(tree return_int, cbl_refer_t *left_side_ref, @@ -2040,6 +2136,54 @@ compare_binary_binary(tree return_int, tree left_side; tree right_side; + // Let's check for the simplified case where both left and right sides are + // little-endian binary values: + + if( is_pure_integer(left_side_ref->field) + && is_pure_integer(right_side_ref->field) ) + { + size_t left_bytes; + tree left_type = tree_type_from_field_type(left_side_ref->field, + left_bytes); + size_t right_bytes; + tree right_type = tree_type_from_field_type(right_side_ref->field, + right_bytes); + tree larger; + if( TREE_INT_CST_LOW(TYPE_SIZE(left_type)) + > TREE_INT_CST_LOW(TYPE_SIZE(right_type)) ) + { + larger = left_type; + } + else + { + larger = right_type; + } + left_side = get_binary_value_tree(larger, + NULL, + *left_side_ref); + right_side = get_binary_value_tree(larger, + NULL, + *right_side_ref); + IF( left_side, eq_op, right_side ) + { + gg_assign(return_int, integer_zero_node); + } + ELSE + { + IF( left_side, lt_op, right_side ) + { + gg_assign(return_int, integer_minusone_node); + } + ELSE + { + gg_assign(return_int, integer_one_node); + } + ENDIF + } + ENDIF + return; + } + // Use SIZE128 when we need two 64-bit registers to hold the value. All // others fit into 64-bit LONG with pretty much the same efficiency. @@ -4133,11 +4277,7 @@ psa_FldLiteralN(struct cbl_field_t *field ) uint32_t digits; int32_t rdigits; uint64_t attr; - //// DUBNERHACK. Necessary to prevent UAT lockup: - const char *source_text = field->data.original() - ? field->data.original() - : field->data.initial; - FIXED_WIDE_INT(128) value = dirty_to_binary(source_text, + FIXED_WIDE_INT(128) value = dirty_to_binary(field->data.original(), capacity, digits, rdigits, @@ -4167,7 +4307,9 @@ psa_FldLiteralN(struct cbl_field_t *field ) tree new_var_decl = gg_define_variable( var_type, base_name, vs_static); - DECL_INITIAL(new_var_decl) = wide_int_to_tree(var_type, value); + DECL_INITIAL(new_var_decl) = wide_int_to_tree(var_type, value); + TREE_CONSTANT(new_var_decl) = 1; + field->data_decl_node = new_var_decl; // Note that during compilation, the integer value, assuming it can be @@ -6148,102 +6290,6 @@ vs_file_static); gg_free(ttbls); } -static -tree -tree_type_from_field_type(cbl_field_t *field, size_t &nbytes) - { - /* This routine is used to determine what action is taken with type of a - CALL ... USING <var> and the matching PROCEDURE DIVISION USING <var> of - a PROGRAM-ID or FUNCTION-ID - */ - tree retval = COBOL_FUNCTION_RETURN_TYPE; - nbytes = 8; - if( field ) - { - // This maps a Fldxxx to a C-style variable type: - switch(field->type) - { - case FldGroup: - case FldAlphanumeric: - case FldAlphaEdited: - case FldNumericEdited: - retval = CHAR_P; - nbytes = field->data.capacity(); - break; - - case FldNumericDisplay: - case FldNumericBinary: - case FldPacked: - if( field->data.digits > 18 ) - { - retval = UINT128; - nbytes = 16; - } - else - { - retval = SIZE_T; - nbytes = 8; - } - break; - - case FldNumericBin5: - case FldIndex: - case FldPointer: - if( field->data.capacity() > 8 ) - { - retval = UINT128; - nbytes = 16; - } - else - { - retval = SIZE_T; - nbytes = 8; - } - break; - - case FldFloat: - if( field->data.capacity() == 8 ) - { - retval = DOUBLE; - nbytes = 8; - } - else if( field->data.capacity() == 4 ) - { - retval = FLOAT; - nbytes = 4; - } - else - { - retval = FLOAT128; - nbytes = 16; - } - break; - - case FldLiteralN: - // Assume a 64-bit signed integer. This happens for GOBACK STATUS 101, - // the like - retval = LONG; - nbytes = 8; - break; - - default: - cbl_internal_error( "%s: Invalid field type %s:", - __func__, - cbl_field_type_str(field->type)); - break; - } - if( retval == SIZE_T && field->attr & signable_e ) - { - retval = SSIZE_T; - } - if( retval == UINT128 && field->attr & signable_e ) - { - retval = INT128; - } - } - return retval; - } - static void restore_local_variables() { @@ -17428,7 +17474,8 @@ parser_symbol_add(struct cbl_field_t *new_var ) free(level_88_string); free(class_string); - if( !(new_var->attr & ( linkage_e | based_e)) ) + if( !(new_var->attr & ( linkage_e | based_e)) + && !(new_var->type == FldLiteralN) ) { static const bool explicitly = false; static const bool just_once = true; diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index 18ba682f30b5..6eb87544ac08 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -329,13 +329,29 @@ is_somebody_float(size_t nC, const cbl_num_result_t *C) } static bool -all_results_binary(size_t nC, const cbl_num_result_t *C) +all_results_integer(size_t nC, const cbl_num_result_t *C) { bool retval = true; for(size_t i=0; i<nC; i++) { - if(C[i].refer.field->data.digits != 0 || C[i].refer.field->type == FldFloat ) + if( !is_pure_integer(C[i].refer.field) ) + { + retval = false; + break; + } + } + return retval; + } + +static bool +all_refers_integer(size_t nC, const cbl_refer_t *C) + { + bool retval = true; + + for(size_t i=0; i<nC; i++) + { + if( !is_pure_integer(C[i].field) ) { retval = false; break; @@ -353,18 +369,20 @@ largest_binary_term(size_t nA, cbl_refer_t *A) for(size_t i=0; i<nA; i++) { - if( A[i].field->data.rdigits || A[i].field->type == FldFloat ) + if( !is_pure_integer(A[i].field) || A[i].field->type == FldFloat ) { - // We are prepared to work only with integers + // We are prepared to work only with binary integers retval = NULL_TREE; break; } if( A[i].field->type == FldLiteralN -// || A[i].field->type == FldNumericDisplay || A[i].field->type == FldNumericBinary || A[i].field->type == FldNumericBin5 || A[i].field->type == FldIndex - || A[i].field->type == FldPointer ) + || A[i].field->type == FldPointer + || ( A[i].field->type == FldAlphanumeric + && strcmp(A[i].field->name, "ZEROS") == 0 ) + ) { // This is an integer type that can be worked with quickly is_negative |= ( A[i].field->attr & signable_e ); @@ -386,62 +404,173 @@ fast_add( size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, cbl_arith_format_t format ) { + /* ADD A TO D: nC==1, nA==1, D += A. + ADD A B C TO D: nC==1, nA==3, D = (A + B + C) + ADD A B C TO D E nC==2, nA==3 + ADD A TO B GIVING D nC==1, nA==2, format==giving_e + ADD A B C TO D GIVING X Y nC==2, nA==3, format==giving_e */ bool retval = false; - if( all_results_binary(nC, C) ) + if( all_results_integer(nC, C) + && all_refers_integer(nA, A) ) { Analyze(); // All targets are non-PICTURE binaries: tree term_type = largest_binary_term(nA, A); if( term_type ) { - // All the terms are things we can work with. - - // We need to calculate the sum of all the A[] terms using term_type as - // the intermediate type: - - tree sum = gg_define_variable(term_type); - tree addend = gg_define_variable(term_type); - get_binary_value( sum, - NULL, - A[0].field, - refer_offset(A[0])); - - // Add in the rest of them: - for(size_t i=1; i<nA; i++) + tree dest_type = tree_type_from_size( + C[0].refer.field->data.capacity(), + 0); + // All the numbers are integers without rdigits + if( nC == 1 + && nA == 1 + && format != giving_e + ) { - get_binary_value( addend, - NULL, - A[i].field, - refer_offset(A[i])); - gg_assign(sum, gg_add(sum, addend)); - } - //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE); + // This is the simplest case of all. Just add A to C. We can't + // naively add A to multiple C, because of the possibility of + // ADD A TO A B C. That would change A before A gets added to B and + // C, which is not how COBOL works. - // We now either accumulate into C[n] or assign to C[n]: - for(size_t i=0; i<nC; i++ ) - { - tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity(), 0); - tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"), - refer_offset(C[i].refer)); - tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); - if( format == giving_e ) + tree A_value; + if( refer_is_clean(A[0]) ) + { + A_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + A[0].field, + integer_zero_node); + } + else { - // We are assigning + A_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + A[0].field, + refer_offset(A[0])); + } + if( refer_is_clean(C[0].refer) ) + { + tree dest_addr = member(C[0].refer.field->var_decl_node, + "data"); + tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); + // We are accumulating into memory gg_assign( gg_indirect(ptr), - gg_cast(dest_type, sum)); + gg_add( gg_indirect(ptr), + A_value)); } else { - // We are accumulating + tree dest_addr = gg_add(member(C[0].refer.field->var_decl_node, + "data"), + refer_offset(C[0].refer)); + tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); + // We are accumulating into memory gg_assign( gg_indirect(ptr), gg_add( gg_indirect(ptr), - gg_cast(dest_type, sum))); + A_value)); + } + } + else if( nC == 1 + && nA == 2 + && format == giving_e ) + { + // This is the very common ADD A TO B GIVING C + { + // Make C = A[0] + A[1] + tree dest_addr; + if( refer_is_clean(C[0].refer) ) + { + dest_addr = member(C[0].refer.field->var_decl_node, "data"); + } + else + { + dest_addr = gg_add(member(C[0].refer.field->var_decl_node, "data"), + refer_offset(C[0].refer)); + } + dest_addr = gg_cast(build_pointer_type(dest_type), dest_addr); + + tree A_value; + if( refer_is_clean(A[0]) ) + { + A_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + A[0].field, + integer_zero_node); + } + else + { + A_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + A[0].field, + refer_offset(A[0])); + } + + tree B_value; + if( refer_is_clean(A[1]) ) + { + B_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + A[1].field, + integer_zero_node); + } + else + { + B_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + A[1].field, + refer_offset(A[1])); + } + + gg_assign( gg_indirect(dest_addr), + gg_add( A_value, + B_value)); + } + } + else + { + // We need to calculate the sum of all the A[] terms using term_type as + // the intermediate type: + + tree sum = gg_define_variable(term_type); + tree addend = gg_define_variable(term_type); + get_binary_value( sum, + NULL, + A[0].field, + refer_offset(A[0])); + + // Add in the rest of them: + for(size_t i=1; i<nA; i++) + { + get_binary_value( addend, + NULL, + A[i].field, + refer_offset(A[i])); + gg_assign(sum, gg_add(sum, addend)); + } + + // We now either accumulate into C[n] or assign to C[n]: + for(size_t i=0; i<nC; i++ ) + { + tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, + "data"), + refer_offset(C[i].refer)); + tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); + if( format == giving_e ) + { + // We are assigning + gg_assign( gg_indirect(ptr), + gg_cast(dest_type, sum)); + } + else + { + // We are accumulating + gg_assign( gg_indirect(ptr), + gg_add( gg_indirect(ptr), + gg_cast(dest_type, sum))); + } } } retval = true; } - - //gg_insert_into_assembler("# DUBNER addition END "); } return retval; } @@ -452,8 +581,15 @@ fast_subtract(size_t nC, cbl_num_result_t *C, size_t nB, cbl_refer_t *B, cbl_arith_format_t format) { + /* SUBTRACT A FROM D: nC==1, nA==1, nB==0: D -= A. + SUBTRACT A B C FROM D: nC==1, nA==3, nB==0: D -= (A + B + C) + SUBTRACT A B C FROM D E nC==2, nA==3 + SUBTRACT A B C FROM D GIVING X Y + nC==2, nA==3, nB==1 */ bool retval = false; - if( all_results_binary(nC, C) ) + if( all_refers_integer(nA, A) + && all_refers_integer(nB, B) + && all_results_integer(nC, C) ) { Analyze(); // All targets are non-PICTURE binaries: @@ -480,48 +616,136 @@ fast_subtract(size_t nC, cbl_num_result_t *C, if( term_type ) { // All the terms are things we can work with. + // All the numbers are integers without rdigits + if( nC == 1 + && nA == 1 + && nB <= 1 + ) + { + // This is the simplest case of all. Just subtract A from C. + tree dest_type = tree_type_from_size( + C[0].refer.field->data.capacity(), + 0); + tree A_value; + if( refer_is_clean(A[0]) ) + { + A_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + A[0].field, + integer_zero_node); + } + else + { + A_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + A[0].field, + refer_offset(A[0])); + } + if( format == giving_e ) + { + // Make C = B - A + tree dest_addr; + if( refer_is_clean(C[0].refer) ) + { + dest_addr = member(C[0].refer.field->var_decl_node, "data"); + } + else + { + dest_addr = gg_add(member(C[0].refer.field->var_decl_node, "data"), + refer_offset(C[0].refer)); + } + dest_addr = gg_cast(build_pointer_type(dest_type), dest_addr); - // We need to calculate the sum of all the A[] terms using term_type as - // the intermediate type: - - tree sum = gg_define_variable(term_type); - tree addend = gg_define_variable(term_type); - get_binary_value(sum, NULL, A[0].field, refer_offset(A[0])); + tree B_value; + if( refer_is_clean(B[0]) ) + { + B_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + B[0].field, + integer_zero_node); + } + else + { + B_value = get_binary_value_tree(dest_type, + NULL, // No rdigits + B[0].field, + refer_offset(B[0])); + } - // Add in the rest of them: - for(size_t i=1; i<nA; i++) - { - get_binary_value(sum, NULL, A[i].field, refer_offset(A[i])); - gg_assign(sum, gg_add(sum, addend)); + gg_assign( gg_indirect(dest_addr), + gg_cast(dest_type, gg_subtract( B_value, + A_value))); + } + else + { + // Make C = C - A + if( refer_is_clean(C[0].refer) ) + { + tree dest_addr = member(C[0].refer.field->var_decl_node, + "data"); + tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); + // We are subtracting from memory + gg_assign( gg_indirect(ptr), + gg_subtract( gg_indirect(ptr), + A_value)); + } + else + { + tree dest_addr = gg_add(member(C[0].refer.field->var_decl_node, + "data"), + refer_offset(C[0].refer)); + tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); + // We are subtracting from memory + gg_assign( gg_indirect(ptr), + gg_subtract( gg_indirect(ptr), + A_value)); + } + } } - //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE); - - if( format == giving_e ) + else { - // We now subtract the sum from B[0] - get_binary_value(addend, NULL, B[0].field, refer_offset(B[0])); - gg_assign(sum, gg_subtract(addend, sum)); - } + // We need to calculate the sum of all the A[] terms using term_type as + // the intermediate type: + + tree sum = gg_define_variable(term_type); + tree addend = gg_define_variable(term_type); + get_binary_value(sum, NULL, A[0].field, refer_offset(A[0])); + + // Add in the rest of them: + for(size_t i=1; i<nA; i++) + { + get_binary_value(addend, NULL, A[i].field, refer_offset(A[i])); + gg_assign(sum, gg_add(sum, addend)); + } + //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE); - // We now either accumulate into C[n] or assign to C[n]: - for(size_t i=0; i<nC; i++ ) - { - tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity(), 0); - tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"), - refer_offset(C[i].refer)); - tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); if( format == giving_e ) { - // We are assigning - gg_assign( gg_indirect(ptr), - gg_cast(dest_type, sum)); + // We now subtract the sum from B[0] + get_binary_value(addend, NULL, B[0].field, refer_offset(B[0])); + gg_assign(sum, gg_subtract(addend, sum)); } - else + + // We now either accumulate into C[n] or assign to C[n]: + for(size_t i=0; i<nC; i++ ) { - // We are subtracting the sum from C[i] - gg_assign( gg_indirect(ptr), - gg_subtract(gg_indirect(ptr), - gg_cast(dest_type, sum))); + tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity(), 0); + tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"), + refer_offset(C[i].refer)); + tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); + if( format == giving_e ) + { + // We are assigning + gg_assign( gg_indirect(ptr), + gg_cast(dest_type, sum)); + } + else + { + // We are subtracting the sum from C[i] + gg_assign( gg_indirect(ptr), + gg_subtract(gg_indirect(ptr), + gg_cast(dest_type, sum))); + } } } retval = true; @@ -536,7 +760,7 @@ fast_multiply(size_t nC, cbl_num_result_t *C, size_t nB, cbl_refer_t *B) { bool retval = false; - if( all_results_binary(nC, C) ) + if( all_results_integer(nC, C) ) { Analyze(); // All targets are non-PICTURE binaries: @@ -609,7 +833,7 @@ fast_divide(size_t nC, cbl_num_result_t *C, const cbl_refer_t &remainder) { bool retval = false; - if( all_results_binary(nC, C) ) + if( all_results_integer(nC, C) ) { Analyze(); // All targets are non-PICTURE binaries: @@ -746,9 +970,9 @@ parser_add( size_t nC, cbl_num_result_t *C, bool handled = false; - if( fast_add( nC, C, - nA, A, - format) ) + if( !error && !not_error && fast_add(nC, C, + nA, A, + format) ) { handled = true; } @@ -1017,9 +1241,9 @@ parser_multiply(size_t nC, cbl_num_result_t *C, SHOW_PARSE_END } - if( fast_multiply(nC, C, - nA, A, - nB, B) ) + if( !error && !not_error && fast_multiply(nC, C, + nA, A, + nB, B) ) { } @@ -1108,10 +1332,10 @@ parser_divide( size_t nC, cbl_num_result_t *C, // C = A / B SHOW_PARSE_END } - if( fast_divide(nC, C, - nA, A, - nB, B, - remainder) ) + if( !error && !not_error && fast_divide(nC, C, + nA, A, + nB, B, + remainder) ) { } @@ -1441,10 +1665,10 @@ parser_subtract(size_t nC, cbl_num_result_t *C, // C = B - A bool handled = false; - if( fast_subtract(nC, C, - nA, A, - nB, B, - format) ) + if( !error && !not_error && fast_subtract(nC, C, + nA, A, + nB, B, + format) ) { handled = true; } diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index a143080542da..25f7b8070fa0 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -744,17 +744,18 @@ get_data_offset(const cbl_refer_t &refer, return retval; } -static tree tree_type_from_field(const cbl_field_t *field); +//static tree tree_type_from_field(const cbl_field_t *field); -void -get_binary_value( tree value, - tree rdigits, - cbl_field_t *field, - tree field_offset, - tree hilo - ) +tree +get_binary_value_tree(tree return_type, + tree rdigits, + cbl_field_t *field, + tree field_offset, + tree hilo + ) { - Analyze(); + tree retval; + if( hilo ) { gg_assign(hilo, integer_zero_node); @@ -766,12 +767,12 @@ get_binary_value( tree value, // Very special case: if( strcmp(field->name, "ZEROS") == 0 ) { - gg_assign(value, gg_cast(TREE_TYPE(value), integer_zero_node)); + retval = gg_cast(return_type, integer_zero_node); if( rdigits ) { gg_assign(rdigits, gg_cast(TREE_TYPE(rdigits), integer_zero_node)); } - return; + return retval; } static tree pointer = gg_define_variable( UCHAR_P, @@ -781,7 +782,7 @@ get_binary_value( tree value, { case FldLiteralN: { - if( SCALAR_FLOAT_TYPE_P(value) ) + if( return_type == FLOAT ) { cbl_internal_error("cannot get %<float%> value from %s", field->name); } @@ -792,21 +793,17 @@ get_binary_value( tree value, gg_assign(rdigits, build_int_cst_type(TREE_TYPE(rdigits), field->data.rdigits)); } - tree dest_type = TREE_TYPE(value); - tree source_type = tree_type_from_field(field); - - gg_assign(value, - gg_cast(dest_type, - gg_indirect( gg_cast(build_pointer_type(source_type), - gg_get_address_of(field->data_decl_node))))); + // tree source_type = tree_type_from_field(field); + // retval = gg_cast(return_type, + // gg_indirect( gg_cast(build_pointer_type(source_type), + // gg_get_address_of(field->data_decl_node)))); + retval = gg_cast(return_type, field->data_decl_node); } - break; } case FldNumericDisplay: { - Analyzer.Message("FldNumericDisplay"); const charmap_t *charmap = __gg__get_charmap(field->codeset.encoding); int stride = charmap->stride(); @@ -829,14 +826,13 @@ 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), - 0x7FFFFFFFFFFFFFFFUL)); + retval = build_int_cst_type(return_type, 0x7FFFFFFFFFFFFFFFUL); } ELSE { IF( digit, eq_op, build_int_cst(UCHAR, DEGENERATE_LOW_VALUE) ) { - // We are dealing with LOW-VALUE + // We are dealing with LOW-VALUE if( hilo ) { gg_assign(hilo, integer_minus_one_node); @@ -918,7 +914,10 @@ get_binary_value( tree value, build_int_cst_type(INT, field->codeset.encoding), NULL_TREE)); // Assign the value we got from the string to our "return" value: - gg_assign(value, gg_cast(TREE_TYPE(value), val128)); + + // Note that cppcheck can't understand the run-time IF() + // cppcheck-suppress redundantAssignment + retval = gg_cast(return_type, val128); } ENDIF } @@ -931,10 +930,11 @@ get_binary_value( tree value, { // As of this writing, the source value is big-endian // We have to convert it to a little-endian destination. + tree value = gg_define_variable(return_type); tree dest = gg_cast(build_pointer_type(UCHAR), gg_get_address_of(value)); tree source = get_data_address(field, field_offset); - size_t dest_nbytes = gg_sizeof(value); + size_t dest_nbytes = TREE_INT_CST_LOW(TYPE_SIZE_UNIT(return_type)); size_t source_nbytes = field->data.capacity(); if( debugging ) @@ -968,7 +968,7 @@ get_binary_value( tree value, if( field->attr & signable_e ) { IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)), - lt_op, + lt_op, gg_cast(SCHAR, integer_zero_node) ) { gg_assign(extension, build_int_cst_type(UCHAR, 0xFF)); @@ -1007,6 +1007,7 @@ get_binary_value( tree value, hex_dump(dest, dest_nbytes); gg_printf("\n", NULL_TREE); } + retval = value; break; } @@ -1035,7 +1036,6 @@ get_binary_value( tree value, } } tree source_address = get_data_address(field, field_offset); - tree dest_type = TREE_TYPE(value); tree source_type = tree_type_from_size( field->data.capacity(), field->attr & signable_e); if( debugging && rdigits) @@ -1043,10 +1043,9 @@ get_binary_value( tree value, gg_printf("get_binary_value bin5 rdigits: %d\n", rdigits, NULL_TREE); } - gg_assign(value, - gg_cast(dest_type, - gg_indirect(gg_cast( build_pointer_type(source_type), - source_address )))); + retval = gg_cast(return_type, + gg_indirect(gg_cast( build_pointer_type(source_type), + source_address ))); break; } @@ -1058,17 +1057,16 @@ get_binary_value( tree value, build_int_cst_type( TREE_TYPE(rdigits), get_scaled_rdigits(field))); } - tree dest_type = TREE_TYPE(value); - - gg_assign(value, - gg_cast(dest_type, - gg_call_expr(INT128, + tree value = gg_define_variable(return_type); + gg_assign(value, gg_cast(return_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))); + retval = value; break; } @@ -1080,13 +1078,14 @@ get_binary_value( tree value, gg_assign(rdigits, gg_cast( TREE_TYPE(rdigits), integer_zero_node)); } - gg_assign(value, - gg_cast(TREE_TYPE(value), - gg_call_expr( INT128, - "__gg__integer_from_float128", - gg_get_address_of(field->var_decl_node), - NULL_TREE))); + tree value = gg_define_variable(return_type); + gg_assign(value, gg_cast(return_type, + gg_call_expr( INT128, + "__gg__integer_from_float128", + gg_get_address_of(field->var_decl_node), + NULL_TREE))); needs_scaling = false; + retval = value; break; } @@ -1108,18 +1107,70 @@ get_binary_value( tree value, { if( field->data.rdigits < 0 ) { + // Hey, Dubner! + // Should that test be != 0 rather than < 0? Maybe not; this routine + // is supposed to be for integers. + tree value = gg_define_variable(return_type); + gg_assign(value, retval); scale_by_power_of_ten_N(value, -field->data.rdigits); + retval = value; } } } + return retval; + } + +tree +get_binary_value_tree(tree return_type, + tree rdigits, + const cbl_refer_t &refer, + tree hilo + ) + { + tree retval; + if( refer_is_clean(refer) ) + { + retval = get_binary_value_tree(return_type, + rdigits, + refer.field, + integer_zero_node, + hilo); + } + else + { + retval = get_binary_value_tree(return_type, + rdigits, + refer.field, + refer_offset(refer), + hilo); + } + return retval; + } + +void +get_binary_value( tree value, + tree rdigits, + cbl_field_t *field, + tree field_offset, + tree hilo + ) + { + tree return_type = TREE_TYPE(value); + gg_assign(value, get_binary_value_tree( return_type, + rdigits, + field, + field_offset, + hilo )); } +#if 0 static tree tree_type_from_field(const cbl_field_t *field) { gcc_assert(field); return tree_type_from_size(field->data.capacity(), field->attr & signable_e); } +#endif tree get_data_address( cbl_field_t *field, @@ -1788,7 +1839,7 @@ refer_is_clean(const cbl_refer_t &refer) // like. return true; } - + return !refer.all && !refer.addr_of && !refer.nsubscript() @@ -1989,3 +2040,61 @@ get_time_nanoseconds() #endif return retval; } + +bool +is_pure_integer(const cbl_field_t *field) + { + // Check to see if field is suitable for fast arithmetic. That is, it is + // a native binary integer with no fixed-point decimal places: + bool retval = false; + switch( field->type ) + { + case FldIndex: + case FldPointer: + case FldLiteralN: + retval = true; + break; + + case FldNumericBin5: + if( !(field->attr & intermediate_e) && field->data.rdigits == 0 ) + { + // This is a pure integer, with no rdigits + switch(field->data.capacity()) + { + case 1: + case 2: + case 4: + case 8: + case 16: + // These are the sizes we know how to handle + retval = true; + break; + } + } + break; + + case FldAlphanumeric: + if( strcmp(field->name, "ZEROS") == 0 ) + { + retval = true; + } + break; + + case FldInvalid: + case FldGroup: + case FldNumericBinary: + case FldFloat: + case FldPacked: + case FldNumericDisplay: + case FldNumericEdited: + case FldAlphaEdited: + case FldLiteralA: + case FldClass: + case FldConditional: + case FldForward: + case FldSwitch: + case FldDisplay: + break; + } + return retval; + } diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index f456f203ba57..3a2951e8175c 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -91,6 +91,15 @@ void get_binary_value( tree value, cbl_field_t *field, tree field_offset, tree hilo = NULL); +tree get_binary_value_tree(tree return_type, + tree rdigits, + cbl_field_t *field, + tree field_offset, + tree hilo = NULL); +tree get_binary_value_tree(tree return_type, + tree rdigits, + const cbl_refer_t &refer, + tree hilo = NULL); tree get_data_address( cbl_field_t *field, tree offset); @@ -150,5 +159,6 @@ void build_array_of_fourplets( int ngroup, void get_depending_on_value_from_odo(tree retval, cbl_field_t *odo); uint64_t get_time_nanoseconds(); +bool is_pure_integer(const cbl_field_t *field); #endif diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index ea686ab9c4ef..6229365284d7 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -2295,7 +2295,8 @@ symbol_table_init(void) { { FldAlphanumeric, LOW_VALUE_E | constq | register_e, {1,1,0,0, "L\0\xFF"}, 0, "LOW_VALUES", cp1252 }, { FldAlphanumeric, ZERO_VALUE_E | constq | register_e, - {1,1,0,0, "0"}, 0, "ZEROS", cp1252 }, + {1,1,0,0, "0"}, 0, "ZEROS", cp1252 }, // Don't change "ZEROS"; there are + // things that depend on it. { FldAlphanumeric, HIGH_VALUE_E | constq | register_e, {1,1,0,0, "H\0\xFF"}, 0, "HIGH_VALUES", cp1252 }, // IBM standard: QUOTE is a double-quote unless APOST compiler option diff --git a/libgcobol/gfileio.cc b/libgcobol/gfileio.cc index 144111ac0a65..884a145dbd54 100644 --- a/libgcobol/gfileio.cc +++ b/libgcobol/gfileio.cc @@ -4459,6 +4459,10 @@ __gg__file_reopen(cblc_file_t *file, int mode_char) done: file->prior_op = file_op_open; + // Call establish_status to raise exception if OPEN failed + // This ensures that if file->file_pointer is NULL, an exception is raised + // Patch by George Neill of data-axle.com + establish_status(file, -1); } static void diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index 2078dbedca5a..9419986d9be0 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -731,7 +731,7 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , int *compute_error ) { - // This is the assignment phase of an ADD Format 2 + // This is the assignment phase of an ADD or SUBTRACT Format 2 cblc_field_t **C = __gg__treeplet_3f; const size_t *C_o = __gg__treeplet_3o; @@ -769,6 +769,15 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , *compute_error |= compute_error_overflow; } + if( C[0]->type == FldPointer ) + { + // In case somebody does pointer arithmetic that goes negative, we need + // to make the top 64 bits positive. Otherwise, the conditional stash + // will see that FldPointer is not signable, and force the value + // positive with a two's complement. + value_a.i128[0] &= 0xFFFFFFFFFFFFFFFFUL; + } + // At this point, we assign that value to *C. *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], on_size_error, @@ -1056,7 +1065,7 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , on_error_flag, compute_error); - // Subtract that from the B value: + // Subtract the phase1_result from the B value: int256 value_a = phase1_result; int rdigits_a = phase1_rdigits; @@ -1078,8 +1087,8 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , scale_int256_by_digits(value_a, rdigits_b - rdigits_a); } - // The two numbers have the same number of rdigits. It's now safe to add - // them. + // The two numbers have the same number of rdigits. It's now safe to take + // the difference. subtract_int256_from_int256(value_b, value_a); int overflow = squeeze_int256(value_b, rdigits_b);
