https://gcc.gnu.org/g:05194aeeaa5165246a9ebfd1d1e74899ec395cc4
commit r17-1596-g05194aeeaa5165246a9ebfd1d1e74899ec395cc4 Author: Robert Dubner <[email protected]> Date: Tue Jun 16 14:26:24 2026 -0400 cobol: Simplify tree type determination; eliminate file-static variables. Use tree_type_from_field() and tree_type_from_refer() to replace a number of similar routines. Replace a number of specific file-static variable definitions with non-specific variable definitions. Repair calculation of DIVIDE ... GIVING REMAINDER where parameters are negative. gcc/cobol/ChangeLog: * compare.cc (numeric_alpha_compare): Use tree_type_from_refer(). * genapi.cc (file_static_variable): Eliminate function. (psa_FldLiteralN): Use tree_type_from_field. (parser_accept_command_line): Eliminate file-static variables. (parser_accept_envar): Likewise. (parser_assign): Likewise. (parser_initialize_table): Likewise. (parser_see_stop_run): Likewise. (parser_file_write): Likewise. (parser_file_start): Likewise. (inspect_tally): Likewise. (inspect_replacing): Likewise. (field_increment): Likewise. (parser_match_exception): Likewise. * genapi.h (file_static_variable): Eliminate function. * genmath.cc (largest_binary_term): Use tree_type_from_refer(). (fast_add): Likewise. (fast_subtract): Likewise. (fast_multiply): Likewise. (fast_divide): Likewise. (parser_divide): Likewise. * genutil.cc (tree_type_from_digits): Eliminate function. (get_integer_value): Eliminate file-static variables. (get_data_offset): Eliminate file-static variables. (get_binary_value_tree): Eliminate file-static variables. (tree_type_from_field): Updated function. (tree_type_from_refer): New function. (scale_by_power_of_ten): Eliminate file-static variables. (tree_type_from_size): Eliminate function. (copy_little_endian_into_place): Improve logic. (build_array_of_size_t): Eliminate file-static variables. (refer_refmod_length): Likewise. (refer_fill_depends): Likewise. (refer_size): Likewise. (refer_size_source): Likewise. * genutil.h (tree_type_from_digits): Eliminate function. (tree_type_from_size): Eliminate function. (tree_type_from_refer): New function. * lang.opt: Updated documentation. * lang.opt.urls: Updated documentation. * move.cc (digits_to_bytes): Eliminate function. (get_bytes_needed): Likewise. (mh_source_is_literalN): Eliminate file-static variables; use tree_type_from_refer(). (mh_numeric_display): Likewise. (mh_little_endian): tree_type_from_refer(). (mh_numdisp_to_packed): Use get_location() function. (mh_packed_to_packed): Likewise. (mh_packed_to_numdisp): Likewise. (move_helper): Likewise. libgcobol/ChangeLog: * gmath.cc (multiply_int256_by_int64): Comment. (int256_as_decimal): Handle negative values. (__gg__dividef45): Repair remainder logic when numeric-display parameters are negative. gcc/testsuite/ChangeLog: * cobol.dg/group2/DIVIDE_binary-long_giving_remainder.cob: New test. * cobol.dg/group2/DIVIDE_binary-long_giving_remainder.out: New test. * cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.cob: New test. * cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.out: New test. * cobol.dg/group2/GCC_125616_RT3601_-_IBM_incorrect_DISPLAY_of_COMP-1_COMP-2_float.cob: New test. * cobol.dg/group2/PR39_RT3573_-_Parser_issue_w_concat._source_lines.cob: New test. Diff: --- gcc/cobol/compare.cc | 24 +-- gcc/cobol/genapi.cc | 56 ++--- gcc/cobol/genapi.h | 2 - gcc/cobol/genmath.cc | 27 +-- gcc/cobol/genutil.cc | 213 +++++-------------- gcc/cobol/genutil.h | 3 +- gcc/cobol/lang.opt | 4 + gcc/cobol/lang.opt.urls | 3 + gcc/cobol/move.cc | 236 +++++---------------- .../group2/DIVIDE_binary-long_giving_remainder.cob | 26 +++ .../group2/DIVIDE_binary-long_giving_remainder.out | 5 + .../DIVIDE_numeric-display_giving_remainder.cob | 26 +++ .../DIVIDE_numeric-display_giving_remainder.out | 5 + ...BM_incorrect_DISPLAY_of_COMP-1_COMP-2_float.cob | 20 ++ ...T3573_-_Parser_issue_w_concat._source_lines.cob | 10 + libgcobol/gmath.cc | 28 ++- 16 files changed, 267 insertions(+), 421 deletions(-) diff --git a/gcc/cobol/compare.cc b/gcc/cobol/compare.cc index 3fade5813d37..d04aad45d52c 100644 --- a/gcc/cobol/compare.cc +++ b/gcc/cobol/compare.cc @@ -1101,26 +1101,8 @@ numeric_alpha_compare(tree &left, // The type of the variable should be straightforward. It is not. There // are various considerations in determining the type. - tree type; - size_t digits = left_side.field->data.digits; tree value; - if( digits == 0 ) - { - // This is a pure binary type. - type = tree_type_from_size(left_side.field->data.capacity(), - left_side.field->attr & signable_e); - } - else - { - // There is some specified number of digits in the variable: - // But if the variable is scaled, we have to multiply by 10^N, where - // N is the number of zeroed P digits: - if( left_side.field->data.rdigits < 0 ) - { - digits += -left_side.field->data.rdigits; - } - type = tree_type_from_digits(digits, left_side.field->attr&signable_e); - } + tree type = tree_type_from_refer(left_side); // We have what we need to get the value: get_binary_value(value, left_side, type); @@ -1197,7 +1179,7 @@ numeric_alpha_compare(tree &left, "__gg__compare_numeric_all", gg_get_address_of(left), gg_cast(UINT128, value), - build_int_cst_type(SIZE_T, digits), + build_int_cst_type(SIZE_T, left_side.field->data.digits), build_string_literal(nbytes, converted), build_int_cst_type(SIZE_T, nbytes), build_int_cst_type(INT, left_side.field->codeset.encoding), @@ -1214,7 +1196,7 @@ numeric_alpha_compare(tree &left, "__gg__compare_binary_to_string", gg_get_address_of(left), gg_cast(UINT128, value), - build_int_cst_type(SIZE_T, digits), + build_int_cst_type(SIZE_T, left_side.field->data.digits), location_right, length_right, build_int_cst_type(INT, right_side.field->codeset.encoding), diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index f883ab41f6e1..aed3d6942a4f 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -115,14 +115,6 @@ line_tick() #define line_tick() #endif -tree -file_static_variable(tree type, const char *v) - { - // This routine returns a reference to an already-defined file_static - // variable. You need to know the type that was used for the definition. - return gg_declare_variable(type, v, NULL, vs_file_static); - } - // set using -f-trace-debug, defined in lang.opt int f_trace_debug; @@ -3720,8 +3712,7 @@ psa_FldLiteralN(struct cbl_field_t *field ) // The value is 1, 2, 4, 8 or 16 bytes, so an ordinary constructor can be // used. - var_type = tree_type_from_size( field->data.capacity(), - field->attr & signable_e); + var_type = tree_type_from_field(field); tree new_var_decl = gg_define_variable( var_type, base_name, vs_static); @@ -3997,7 +3988,7 @@ parser_accept_command_line( const cbl_refer_t &tgt, SHOW_PARSE_END } - static tree erf = gg_define_variable(INT, "..pac_erf", vs_file_static); + tree erf = gg_define_variable(INT); if( !source.field ) { @@ -4168,7 +4159,7 @@ parser_accept_envar(const struct cbl_refer_t &tgt, TRACE1_END } - static tree erf = gg_define_variable(INT, "..pae_erf", vs_file_static); + tree erf = gg_define_variable(INT); gg_assign(erf, gg_call_expr( INT, @@ -5227,10 +5218,7 @@ parser_assign( size_t nC, cbl_num_result_t *C, CHECK_FIELD(destref.field); CHECK_FIELD(sourceref.field); - // gg_printf("parser_assign: The compute_error_code is %d\n", - // gg_cast(INT, compute_error->structs.compute_error->compute_error_code), NULL_TREE); - - static tree erf = gg_define_variable(INT, "..pa_erf", vs_file_static); + tree erf = gg_define_variable(INT); if( on_error ) { // There is an ON ERROR clause. When there is an ON ERROR clause, and @@ -5477,12 +5465,9 @@ parser_initialize_table(size_t nelem, } typedef size_t span_t[2]; static_assert(sizeof(spans[0]) == sizeof(span_t), "pair size wrong"); - static tree tspans = gg_define_variable(SIZE_T_P, - "..pit_v1", - vs_file_static); - static tree ttbls = gg_define_variable(SIZE_T_P, - "..pit_v2", -vs_file_static); + tree tspans = gg_define_variable(SIZE_T_P); + tree ttbls = gg_define_variable(SIZE_T_P); + gg_assign(tspans, build_array_of_size_t(2*nspan, reinterpret_cast<const size_t *>(spans))); @@ -7341,7 +7326,7 @@ parser_see_stop_run(struct cbl_refer_t exit_status, } // It's a stop run. Return return-code to the operating system: - static tree returned_value = gg_define_variable(INT, "..pssr_retval", vs_file_static); + tree returned_value = gg_define_variable(INT); if( exit_status.field ) { @@ -9441,10 +9426,10 @@ parser_file_write( cbl_file_t *file, file->name); } - static tree t_advance = gg_define_variable(INT, "..pfw_advance", vs_file_static); + tree t_advance = gg_define_variable(INT); if(advance.field) { - static tree value = gg_define_variable(INT, "..pfw_value", vs_file_static); + tree value = gg_define_variable(INT); get_binary_value( value, NULL, advance.field, @@ -9811,7 +9796,7 @@ parser_file_start(struct cbl_file_t *file, flk = -1; } - static tree length = gg_define_variable(SIZE_T, "..pfs_length", vs_file_static); + tree length = gg_define_variable(SIZE_T); gg_assign(length, size_t_zero_node); if( flk > 0 && !length_ref.field ) @@ -9958,8 +9943,8 @@ inspect_tally(bool backward, // all the integers and cbl_inspect_bound_t values, in a strict sequence so // that the library routine can peel them off. - static tree int_size = gg_define_variable(INT, "..pit_size", vs_file_static, 0); - static tree integers = gg_define_variable(SIZE_T_P, "..pit", vs_file_static, null_pointer_node); + tree int_size = gg_define_variable(INT, integer_zero_node); + tree integers = gg_define_variable(SIZE_T_P, null_pointer_node); size_t n_integers = int_index; @@ -10131,10 +10116,10 @@ inspect_replacing(int backward, size_t n_integers = 1 // Room for operations[0].nbound() + operations[0].nbound() // Room for all the cbl_inspect_bound_t values - + n_all_leading_first; // Room for all of the n_identifier_3 counts + + n_all_leading_first; // Room for all of the n_identifier_3 counts - static tree int_size = gg_define_variable(INT, "..pir_size", vs_file_static, 0); - static tree integers = gg_define_variable(SIZE_T_P, "..pir", vs_file_static, null_pointer_node); + tree int_size = gg_define_variable(INT, integer_zero_node); + tree integers = gg_define_variable(SIZE_T_P, null_pointer_node); IF( build_int_cst_type(INT, n_integers), gt_op, int_size ) { @@ -11081,10 +11066,11 @@ parser_intrinsic_call_4( cbl_field_t *tgt, } static void -field_increment(cbl_field_t *fld) +field_increment(cbl_field_t *fld ) { - static tree value = gg_define_variable(INT128, "..fi_value", vs_file_static); - static tree rdigits = gg_define_variable(INT, "..fi_rdigits", vs_file_static); + static tree value = gg_define_variable(INT128); + static tree rdigits = gg_define_variable(INT); + get_binary_value(value, rdigits, fld, size_t_zero_node); gg_assign( value, gg_add(value, gg_cast(SIZE_T, integer_one_node))); @@ -13956,7 +13942,7 @@ parser_match_exception(cbl_field_t *index) TRACE1 { - static tree index_val = gg_define_variable(INT, "..pme_index", vs_file_static); + tree index_val = gg_define_variable(INT); get_binary_value(index_val, NULL, index, size_t_zero_node); TRACE1_INDENT gg_printf("returned value is 0x%x (%d)", index_val, index_val, NULL_TREE); diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index 5dee20f95c64..00c234521fe4 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -617,8 +617,6 @@ void parser_init_list_size(int count_of_variables); void parser_init_list_element(cbl_field_t *field); void parser_init_list(); -tree file_static_variable(tree type, const char *name); - void parser_statement_begin( const cbl_name_t name, tree ecs, tree dcls ); void parser_statement_end( const std::list<cbl_field_t*>& ); diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index 3b1c3b74e0b3..bdbfe8e691bc 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -357,12 +357,9 @@ all_refers_integer(size_t nC, const cbl_refer_t *C) } static tree -largest_binary_term(size_t nA, cbl_refer_t *A) +largest_binary_term(size_t nA, const cbl_refer_t *A) { tree retval = NULL_TREE; - uint32_t max_capacity = 0; - int is_negative = 0; - for(size_t i=0; i<nA; i++) { if( !is_pure_integer(A[i].field) || A[i].field->type == FldFloat ) @@ -381,9 +378,7 @@ largest_binary_term(size_t nA, cbl_refer_t *A) ) { // This is an integer type that can be worked with quickly - is_negative |= ( A[i].field->attr & signable_e ); - max_capacity = std::max(max_capacity, A[i].field->data.capacity()); - retval = tree_type_from_size(max_capacity, is_negative); + retval = tree_type_from_refer(A[i]); } else { @@ -418,8 +413,7 @@ fast_add( size_t nC, cbl_num_result_t *C, tree term_type = largest_binary_term(nA, A); if( term_type ) { - tree dest_type = tree_type_from_size(C[0].refer.field->data.capacity(), - 0); + tree dest_type = tree_type_from_refer(C[0].refer); // All the numbers are integers without rdigits if( nC == 1 && nA == 1 @@ -637,9 +631,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C, ) { // 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 dest_type = tree_type_from_refer(C[0].refer); tree A_value; if( refer_is_clean(A[0]) ) { @@ -743,7 +735,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C, // 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_type = tree_type_from_refer(C[i].refer); 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); @@ -816,7 +808,7 @@ fast_multiply(size_t nC, cbl_num_result_t *C, // We now either multiply into C[n] or assign A * B 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_type = tree_type_from_refer(C[i].refer); 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); @@ -895,8 +887,7 @@ fast_divide(size_t nC, cbl_num_result_t *C, // We now either divide into C[n] or assign dividend/divisor 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_type = tree_type_from_refer(C[i].refer); tree dest_addr = gg_add(member( C[i].refer.field->var_decl_node, "data"), refer_offset(C[i].refer)); @@ -923,7 +914,7 @@ fast_divide(size_t nC, cbl_num_result_t *C, { dest_addr = gg_add( member(remainder.field->var_decl_node, "data"), refer_offset(remainder)); - dest_type = tree_type_from_size(remainder.field->data.capacity(), 0); + dest_type = tree_type_from_refer(remainder); ptr = gg_cast(build_pointer_type(dest_type), dest_addr); gg_assign(gg_indirect(ptr), @@ -2329,7 +2320,7 @@ parser_divide( size_t nC, cbl_num_result_t *C, // C = A / B nB, B, remainder) ) { - + // We were able to do a fast divide operation. } else { diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index e75d1be63eb0..f703951f1697 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -175,60 +175,6 @@ get_scaled_digits(cbl_field_t *field) return retval; } -tree -tree_type_from_digits(size_t digits, uint64_t signable) - { - tree retval = NULL_TREE; - - if( signable ) - { - if(digits <= 2 ) - { - retval = CHAR; - } - else if (digits <= 4 ) - { - retval = SHORT; - } - else if (digits <= 9 ) - { - retval = INT; - } - else if (digits <= 18 ) - { - retval = LONGLONG; - } - else - { - retval = INT128; - } - } - else - { - if(digits <= 2 ) - { - retval = UCHAR; - } - else if (digits <= 4 ) - { - retval = USHORT; - } - else if (digits <= 9 ) - { - retval = UINT; - } - else if (digits <= 18 ) - { - retval = ULONGLONG; - } - else - { - retval = UINT128; - } - } - return retval; - } - void get_integer_value(tree value, // We know this is a LONG cbl_field_t *field, @@ -249,8 +195,8 @@ get_integer_value(tree value, // We know this is a LONG // If the field_i has rdigits, and if any of those rdigits are non-zero, we // return a 1 so that our caller can decide what to do. - static tree temp = gg_define_variable(INT128, "..giv_temp", vs_file_static); - static tree rdigits = gg_define_variable(INT, "..giv_rdigits", vs_file_static); + tree temp = gg_define_variable(INT128); + tree rdigits = gg_define_variable(INT); if( field->attr & intermediate_e ) { @@ -780,9 +726,7 @@ get_data_offset(const cbl_refer_t &refer, int *pflags = NULL) { if( parent->occurs.depending_on ) { - static tree value64 = gg_define_variable( LONG, - ".._gdos_value64", - vs_file_static); + tree value64 = gg_define_variable(LONG); cbl_field_t *odo = symbol_find_odo(parent); get_depending_on_value_from_odo(value64, odo); } @@ -804,8 +748,8 @@ get_data_offset(const cbl_refer_t &refer, int *pflags = NULL) { REFER("refmod refstart"); // We have a refmod to deal with - static tree refstart = gg_define_variable(LONG, "..gdo_refstart", vs_file_static); - static tree reflen = gg_define_variable(LONG, "..gdo_reflen", vs_file_static); + tree refstart = gg_define_variable(LONG); + tree reflen = gg_define_variable(LONG); get_and_check_refstart_and_reflen(refstart, reflen, refer); gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart))); @@ -917,13 +861,9 @@ get_binary_value_tree(tree return_type, get_scaled_rdigits(field))); } // This will be the 128-bit value of the character sequence - static tree val128 = gg_define_variable(INT128, - "..gbv_val128", - vs_file_static); + tree val128 = gg_define_variable(INT128); // This is a pointer to the sign byte - static tree signp = gg_define_variable(UCHAR_P, - "..gbv_signp", - vs_file_static); + tree signp = gg_define_variable(UCHAR_P); // We need to figure out where the sign information, if any is to be // found: if( field->attr & signable_e ) @@ -1029,9 +969,7 @@ get_binary_value_tree(tree return_type, { // Destination is too big. We'll need to fill the high-order bytes with // either 0x00 for positive numbers, or 0xFF for negative - static tree extension = gg_define_variable( UCHAR, - "..gbv_extension", - vs_file_static); + tree extension = gg_define_variable(UCHAR); if( field->attr & signable_e ) { IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)), @@ -1103,8 +1041,7 @@ get_binary_value_tree(tree return_type, } } tree source_address = get_data_address(field, field_offset); - tree source_type = tree_type_from_size( field->data.capacity(), - field->attr & signable_e); + tree source_type = tree_type_from_field(field); if( debugging && rdigits) { gg_printf("get_binary_value bin5 rdigits: %d\n", rdigits, NULL_TREE); @@ -1233,10 +1170,7 @@ get_binary_value( tree value, tree tree_type_from_field(const cbl_field_t *field) { - /* 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 - */ + // This routine comes up with a variable type compatible with the field. tree retval; switch(field->type) @@ -1254,21 +1188,30 @@ tree_type_from_field(const cbl_field_t *field) case FldNumericDisplay: case FldPacked: { + int digits = field->data.digits; + if( (field->attr & scaled_e) + && field->data.rdigits < 0 ) + { + // This is something like PIC 9999PPP, which means that we need a + // variable type that can hold those additional digits: + digits += -field->data.rdigits; + } + if( field->attr & signable_e ) { - if( field->data.digits > 18 ) + if( digits > 18 ) { retval = INT128; } - else if( field->data.digits > 9) + else if( digits > 9) { retval = LONG; } - else if( field->data.digits > 4) + else if( digits > 4) { retval = INT; } - else if( field->data.digits > 2) + else if( digits > 2) { retval = SHORT; } @@ -1279,19 +1222,19 @@ tree_type_from_field(const cbl_field_t *field) } else { - if( field->data.digits > 18 ) + if( digits > 18 ) { retval = UINT128; } - else if( field->data.digits > 9) + else if( digits > 9) { retval = ULONG; } - else if( field->data.digits > 4) + else if( digits > 4) { retval = UINT; } - else if( field->data.digits > 2) + else if( digits > 2) { retval = USHORT; } @@ -1394,6 +1337,12 @@ tree_type_from_field(const cbl_field_t *field) return retval; } +tree +tree_type_from_refer(const cbl_refer_t &refer) + { + return tree_type_from_field(refer.field); + } + tree get_data_address( cbl_field_t *field, tree offset) // Offset is SIZE_T @@ -1513,7 +1462,7 @@ scale_by_power_of_ten(tree value, bool check_for_fractional) { Analyze(); - static tree retval = gg_define_variable(INT, "..sbpot2_retval", vs_file_static); + tree retval = gg_define_variable(INT); if( check_for_fractional ) { @@ -1623,62 +1572,6 @@ hex_dump(tree data, size_t bytes) } } -tree -tree_type_from_size(size_t bytes, uint64_t signable) - { - tree retval = NULL_TREE; - - if( signable ) - { - switch( bytes ) - { - case 1: - retval = SCHAR; - break; - case 2: - retval = SHORT; - break; - case 4: - retval = INT; - break; - case 8: - retval = LONG; - break; - case 16: - retval = INT128; - break; - default: - gcc_unreachable(); - break; - } - } - else - { - switch( bytes ) - { - case 1: - retval = UCHAR; - break; - case 2: - retval = USHORT; - break; - case 4: - retval = UINT; - break; - case 8: - retval = ULONG; - break; - case 16: - retval = UINT128; - break; - default: - gcc_unreachable(); - break; - } - } - return retval; - } - static bool refer_has_depends(const cbl_refer_t &refer, refer_type_t refer_type) @@ -1839,18 +1732,8 @@ copy_little_endian_into_place(cbl_field_t *dest, // 10^(5 - 3 + 2) is 10^4, which is 10000. Because 12345 is >= 10000, the // source can't fit into the destination. - // Note: I am not trying to avoid the use of stack variables, because I am - // not sure how to declare a file-static variable of unknown type. tree abs_value = gg_define_variable(TREE_TYPE(value)); - IF( value, lt_op, build_int_cst_type(TREE_TYPE(value), 0) ) - { - gg_assign(abs_value, gg_negate(value)); - } - ELSE - { - gg_assign(abs_value, value); - } - ENDIF + gg_assign(abs_value, gg_abs(value)); FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( dest->data.digits - dest->data.rdigits @@ -1867,12 +1750,17 @@ copy_little_endian_into_place(cbl_field_t *dest, } scale_by_power_of_ten_N(value, dest->data.rdigits - rhs_rdigits); - tree dest_type = tree_type_from_size( dest->data.capacity(), - dest->attr & signable_e); + // Create a variable of our target type. + tree dest_type = tree_type_from_field(dest); + tree target = gg_define_variable(dest_type); + // Cast the source to the target + gg_assign(target, gg_cast(dest_type, value)); tree dest_pointer = gg_add(member(dest->var_decl_node, "data"), dest_offset); - gg_assign(gg_indirect(gg_cast(build_pointer_type(dest_type), dest_pointer)), - gg_cast(dest_type, value)); + // Copy the target to the destination. + gg_memcpy(dest_pointer, + gg_get_address_of(target), + build_int_cst_type(SIZE_T, gg_sizeof(dest_type))); } tree @@ -1948,7 +1836,7 @@ build_array_of_size_t( size_t N, // This only works because it is used in but one spot. If this routine is // called twice, be careful about how the first one is used. It's a static // variable, you see. - static tree values_p = gg_define_variable(SIZE_T_P, "..baost_values_p", vs_file_static); + tree values_p = gg_define_variable(SIZE_T_P); if( N ) { gg_assign( values_p, @@ -2067,8 +1955,8 @@ refer_refmod_length(const cbl_refer_t &refer) { Analyze(); REFER("refstart and reflen"); - static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static); - static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static); + tree refstart = gg_define_variable(LONG); + tree reflen = gg_define_variable(LONG); get_and_check_refstart_and_reflen( refstart, reflen, refer); @@ -2087,7 +1975,7 @@ refer_fill_depends(const cbl_refer_t &refer) Analyze(); cbl_field_t *odo = symbol_find_odo(refer.field); - static tree value64 = gg_define_variable(LONG, "..rfd_value64", vs_file_static); + tree value64 = gg_define_variable(LONG); get_depending_on_value(value64, refer); @@ -2145,7 +2033,7 @@ refer_size(const cbl_refer_t &refer, refer_type_t refer_type) } else { - static tree retval = gg_define_variable(SIZE_T, "..rs_retval", vs_file_static); + tree retval = gg_define_variable(SIZE_T); if( !refer.field ) { @@ -2232,7 +2120,8 @@ refer_size_source(const cbl_refer_t &refer) // This assignment has to be here. Simply returning refer_size() results // in regression testing errors. - static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static); + ////static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_stactic); + tree retval = gg_define_variable(SIZE_T); gg_assign(retval, refer_size(refer, refer_source)); return retval; } diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index 846c122b7733..56fca1c08241 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -64,8 +64,6 @@ extern tree var_decl_dialects; // void* __gg__dialects int get_scaled_rdigits(cbl_field_t *field); int get_scaled_digits(cbl_field_t *field); -tree tree_type_from_digits(size_t digits, uint64_t signable); -tree tree_type_from_size(size_t bytes, uint64_t signable); void get_binary_value( tree value, tree rdigits, @@ -142,6 +140,7 @@ uint64_t get_time_nanoseconds(); bool is_pure_integer(const cbl_field_t *field); tree tree_type_from_field(const cbl_field_t *field); +tree tree_type_from_refer(const cbl_refer_t &refer); bool get_binary_value(tree &value, const cbl_refer_t &refer, diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt index faf657be8aa8..f629a0447e99 100644 --- a/gcc/cobol/lang.opt +++ b/gcc/cobol/lang.opt @@ -410,6 +410,10 @@ idirafter Cobol Joined Separate ; Documented in c.opt +imultilib +Cobol Joined Separate +; Documented in c.opt + main Cobol -main The first program-id in the next source file is called by a generated main() entry point. diff --git a/gcc/cobol/lang.opt.urls b/gcc/cobol/lang.opt.urls index 69493276ac14..db78cc00164b 100644 --- a/gcc/cobol/lang.opt.urls +++ b/gcc/cobol/lang.opt.urls @@ -43,3 +43,6 @@ UrlSuffix(gcc/Directory-Options.html#index-isystem) LangUrlSuffix_Fortran(gfortr idirafter UrlSuffix(gcc/Directory-Options.html#index-idirafter) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-idirafter) +imultilib +UrlSuffix(gcc/Directory-Options.html#index-imultilib) LangUrlSuffix_D(gdc/Directory-Options.html#index-imultilib) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-imultilib) + diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc index 705d9a032d62..536d471e66ba 100644 --- a/gcc/cobol/move.cc +++ b/gcc/cobol/move.cc @@ -92,33 +92,6 @@ is_figconst(const cbl_refer_t &sourceref) return is_figconst_t(sourceref.field); } -static int -digits_to_bytes(int digits) - { - int retval; - if( digits <= 2 ) - { - retval = 1; - } - else if( digits <= 4 ) - { - retval = 2; - } - else if( digits <= 9 ) - { - retval = 4; - } - else if( digits <= 18 ) - { - retval = 8; - } - else - { - retval = 16; - } - return retval; - } - static tree get_reference_to_data(cbl_field_t *field) { @@ -259,93 +232,11 @@ get_literalN_value(cbl_field_t *var) { // Get the literal N value from the integer var_decl tree retval = NULL_TREE; - tree var_type = tree_type_from_size(var->data.capacity(), - var->attr & signable_e); + tree var_type = tree_type_from_field(var); retval = gg_cast(var_type, var->data_decl_node); return retval; } -static size_t -get_bytes_needed(cbl_field_t *field) - { - size_t retval = 0; - switch(field->type) - { - case FldIndex: - case FldPointer: - case FldFloat: - case FldLiteralN: - retval = field->data.capacity(); - break; - - case FldNumericDisplay: - { - int digits; - if( field->attr & scaled_e && field->data.rdigits<0) - { - digits = field->data.digits + -field->data.rdigits; - } - else - { - digits = field->data.digits; - } - retval = digits_to_bytes(digits); - break; - } - - case FldPacked: - { - int digits; - if( field->attr & scaled_e && field->data.rdigits<0) - { - digits = field->data.digits + -field->data.rdigits; - } - else - { - digits = field->data.digits; - } - if( !(field->attr & separate_e) ) - { - // This is COMP-3, so there is a sign nybble. - digits += 1; - } - retval = (digits+1)/2; - break; - } - - case FldNumericBinary: - case FldNumericBin5: - { - if( field->data.digits ) - { - int digits; - if( field->attr & scaled_e && field->data.rdigits<0) - { - digits = field->data.digits + -field->data.rdigits; - } - else - { - digits = field->data.digits; - } - retval = digits_to_bytes(digits); - } - else - { - retval = field->data.capacity(); - } - break; - } - - default: - cbl_internal_error("%s: Knows not the variable type %s for %s", - __func__, - cbl_field_type_str(field->type), - field->name ); - break; - } - return retval; - } - static void get_binary_value_from_float(tree value, const cbl_refer_t &dest, @@ -517,7 +408,7 @@ mh_source_is_literalN(cbl_refer_t &destref, // There are too few bytes in sourceref if( sourceref.field->attr & signable_e ) { - static tree highbyte = gg_define_variable(UCHAR, "..mh_litN_highbyte", vs_file_static); + tree highbyte = gg_define_variable(UCHAR); // Pick up the source byte that has the sign bit. gg_assign(highbyte, gg_get_indirect_reference(gg_add(member(sourceref.field->var_decl_node, @@ -576,48 +467,47 @@ mh_source_is_literalN(cbl_refer_t &destref, // For now, we are ignoring intermediates: assert( !(destref.field->attr & intermediate_e) ); - - int bytes_needed = std::max(destref.field->data.capacity(), - sourceref.field->data.capacity()); - tree calc_type = tree_type_from_size(bytes_needed, - sourceref.field->attr & signable_e); - tree dest_type = tree_type_from_size( destref.field->data.capacity(), - destref.field->attr & signable_e); + tree calc_type = tree_type_from_refer(sourceref); + tree dest_type = tree_type_from_refer(destref); // Pick up the source data. tree source = gg_define_variable(calc_type); + tree dest = gg_define_variable(dest_type); gg_assign(source, gg_cast(calc_type, sourceref.field->data_decl_node)); // Take the absolute value, if the destination is not signable conditional_abs(source, destref.field); + // Cast our source to the target: + gg_assign(dest, gg_cast(dest_type, source)); + // See if it needs to be scaled: scale_by_power_of_ten_N( - source, - destref.field->data.rdigits-sourceref.field->data.rdigits); + dest, + destref.field->data.rdigits-sourceref.field->data.rdigits); if( check_for_error && size_error ) { Analyzer.Message("Check to see if result fits"); if( destref.field->data.digits ) { - FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(destref.field->data.digits); - IF( gg_abs(source), ge_op, wide_int_to_tree(calc_type, - power_of_ten) ) + FIXED_WIDE_INT(128) power_of_ten = + get_power_of_ten(destref.field->data.digits); + IF( dest, ge_op, wide_int_to_tree(calc_type, power_of_ten) ) { - gg_assign(size_error, gg_bitwise_or(size_error, integer_one_node)); + gg_assign(size_error, + gg_bitwise_or(size_error, integer_one_node)); } ELSE ENDIF } } - Analyzer.Message("Move to destination location"); - tree dest_location = gg_indirect( - gg_cast(build_pointer_type(dest_type), - gg_add(member(destref.field->var_decl_node, "data"), - refer_offset(destref)))); - gg_assign(dest_location, gg_cast(dest_type, source)); + tree dest_location; + get_location(dest_location, destref); + gg_memcpy(dest_location, + gg_get_address_of(dest), + build_int_cst_type(SIZE_T, gg_sizeof(dest))); moved = true; break; } @@ -627,7 +517,7 @@ mh_source_is_literalN(cbl_refer_t &destref, case FldNumericEdited: case FldPacked: { - static tree berror = gg_define_variable(INT, "..mh_litN_berror", vs_file_static); + tree berror = gg_define_variable(INT); gg_assign(berror, integer_zero_node); SHOW_PARSE1 { @@ -1175,27 +1065,15 @@ mh_numeric_display( const cbl_refer_t &destref, charmap_t *charmap_dest = __gg__get_charmap( destref.field->codeset.encoding); - static tree source_sign_loc = gg_define_variable(UCHAR_P, - "..mhnd_sign_loc", - vs_file_static); - static tree dest_sign_loc = gg_define_variable(UCHAR_P, - "..mhnd_dest_sign_loc", - vs_file_static); - static tree source_sign = gg_define_variable(INT, - "..mhnd_sign", - vs_file_static); + tree source_sign_loc = gg_define_variable(UCHAR_P); + tree dest_sign_loc = gg_define_variable(UCHAR_P); + tree source_sign = gg_define_variable(INT); // The destination data pointer - static tree dest_p = gg_define_variable( UCHAR_P, - "..mhnd_dest", - vs_file_static); + tree dest_p = gg_define_variable( UCHAR_P); // The source data pointer - static tree source_p = gg_define_variable( UCHAR_P, - "..mhnd_source", - vs_file_static); + tree source_p = gg_define_variable( UCHAR_P); // When we need an end pointer - static tree source_ep = gg_define_variable( UCHAR_P, - "..mhnd_source_e", - vs_file_static); + tree source_ep = gg_define_variable(UCHAR_P); bool source_is_signable = sourceref.field->attr & signable_e; bool source_is_leading = sourceref.field->attr & leading_e; @@ -1537,7 +1415,6 @@ mh_little_endian( const cbl_refer_t &destref, if( !figconst && !(destref.field->attr & scaled_e) - && !(destref.field->attr & (intermediate_e )) && !(sourceref.field->attr & (intermediate_e )) && sourceref.field->type != FldGroup && sourceref.field->type != FldLiteralA @@ -1556,14 +1433,22 @@ mh_little_endian( const cbl_refer_t &destref, SHOW_PARSE_END } - int bytes_needed = get_bytes_needed(sourceref.field); - tree source_type = tree_type_from_size(bytes_needed, - sourceref.field->attr - & signable_e) ; - tree source = gg_define_variable(source_type); - if( sourceref.field->type == FldFloat ) { + tree source = NULL_TREE; + switch( sourceref.field->data.capacity() ) + { + case 4: + source = gg_define_variable(SHORT); + break; + case 8: + source = gg_define_variable(LONG); + break; + case 16: + source = gg_define_variable(INT128); + break; + } + get_binary_value_from_float(source, destref, sourceref.field, @@ -1581,6 +1466,8 @@ mh_little_endian( const cbl_refer_t &destref, } else { + tree source_type = tree_type_from_refer(sourceref); + tree source = gg_define_variable(source_type); get_binary_value( source, NULL, sourceref.field, @@ -2142,18 +2029,14 @@ mh_numdisp_to_packed(const cbl_refer_t &destref, tree umask = build_int_cst_type(UCHAR, 0x0F); tree ufour = build_int_cst_type(SIZE_T, 4); - tree source_location = gg_define_variable(UCHAR_P); - tree dest_location = gg_define_variable(UCHAR_P); + tree source_location; + tree dest_location; tree dest_p = gg_define_variable(UCHAR_P); tree source_p = gg_define_variable(UCHAR_P); - tree temp; - - get_location(temp, destref); - gg_assign(dest_location, temp); + get_location(dest_location, destref); gg_assign(dest_p, dest_location); - get_location(temp, sourceref); - gg_assign(source_location, temp); + get_location(source_location, sourceref); int source_digits = sourceref.field->data.digits; int source_rdigits = sourceref.field->data.rdigits; @@ -2453,17 +2336,13 @@ mh_packed_to_packed(const cbl_refer_t &destref, // in the dest. We fiddle with the leading digits, the trailing digits, and // the sign nybble as necessary. - tree source_location = gg_define_variable(UCHAR_P); - tree dest_location = gg_define_variable(UCHAR_P); + tree source_location; + tree dest_location; tree source_sign = gg_define_variable(UCHAR_P); tree dest_sign = gg_define_variable(UCHAR_P); - tree temp; - - get_location(temp, destref); - gg_assign(dest_location, temp); - get_location(temp, sourceref); - gg_assign(source_location, temp); + get_location(dest_location, destref); + get_location(source_location, sourceref); if( check_for_error ) { @@ -2799,17 +2678,14 @@ mh_packed_to_numdisp(const cbl_refer_t &destref, tree ufour = build_int_cst_type(SIZE_T, 4); tree uzero = build_int_cst_type(UCHAR, charmap->mapped_character(ascii_zero)); - tree source_location = gg_define_variable(UCHAR_P); - tree dest_location = gg_define_variable(UCHAR_P); + tree source_location; + tree dest_location; tree dest_p = gg_define_variable(UCHAR_P); tree source_p = gg_define_variable(UCHAR_P); - tree temp; - get_location(temp, destref); - gg_assign(dest_location, temp); + get_location(dest_location, destref); gg_assign(dest_p, dest_location); - get_location(temp, sourceref); - gg_assign(source_location, temp); + get_location(source_location, sourceref); // source_digits will be the number of digits extracted from the source that // find their way into the destination. @@ -3037,7 +2913,7 @@ move_helper(tree size_error, // This is an INT gg_assign(size_error, integer_zero_node); } - static tree stash = gg_define_variable(UCHAR_P, "..mh_stash", vs_file_static); + static tree stash = gg_define_variable(UCHAR_P); tree st_data = NULL_TREE; tree st_size = NULL_TREE; diff --git a/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.cob b/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.cob new file mode 100644 index 000000000000..a074f4ed1d8e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + *> { dg-output-file "group2/DIVIDE_binary-long_giving_remainder.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 var1 binary-long. + 01 var2 binary-long. + 01 Q binary-long. + 01 r binary-long. + procedure division. + move 11 to var1 move 2 to var2 + divide var1 by var2 giving Q remainder R + display Q space R + move -11 to var1 move 2 to var2 + divide var1 by var2 giving Q remainder R + display Q space R + move 11 to var1 move -2 to var2 + divide var1 by var2 giving Q remainder R + display Q space R + move -11 to var1 move -2 to var2 + divide var1 by var2 giving Q remainder R + display Q space R + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.out b/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.out new file mode 100644 index 000000000000..50e20e8a1e02 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.out @@ -0,0 +1,5 @@ ++0000000005 +0000000001 +-0000000005 -0000000001 +-0000000005 +0000000001 ++0000000005 -0000000001 + diff --git a/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.cob b/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.cob new file mode 100644 index 000000000000..7b605f058df5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + *> { dg-output-file "group2/DIVIDE_numeric-display_giving_remainder.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 var1 pic s999. + 01 var2 pic s999. + 01 Q pic s999. + 01 r pic s999. + procedure division. + move 11 to var1 move 2 to var2 + divide var1 by var2 giving Q remainder R + display Q space R + move -11 to var1 move 2 to var2 + divide var1 by var2 giving Q remainder R + display Q space R + move 11 to var1 move -2 to var2 + divide var1 by var2 giving Q remainder R + display Q space R + move -11 to var1 move -2 to var2 + divide var1 by var2 giving Q remainder R + display Q space R + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.out b/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.out new file mode 100644 index 000000000000..1016fd0d6220 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.out @@ -0,0 +1,5 @@ ++005 +001 +-005 -001 +-005 +001 ++005 -001 + diff --git a/gcc/testsuite/cobol.dg/group2/GCC_125616_RT3601_-_IBM_incorrect_DISPLAY_of_COMP-1_COMP-2_float.cob b/gcc/testsuite/cobol.dg/group2/GCC_125616_RT3601_-_IBM_incorrect_DISPLAY_of_COMP-1_COMP-2_float.cob new file mode 100644 index 000000000000..0989b212c9c2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/GCC_125616_RT3601_-_IBM_incorrect_DISPLAY_of_COMP-1_COMP-2_float.cob @@ -0,0 +1,20 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. FLTDISP. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 F1 COMP-1 VALUE 1.5. + 01 F2 COMP-1 VALUE 0.1. + 01 F3 COMP-1 VALUE -2.75. + 01 F4 COMP-1 VALUE 1500. + 01 D1 COMP-2 VALUE 2.71828. + PROCEDURE DIVISION. + DISPLAY F1 + DISPLAY F2 + DISPLAY F3 + DISPLAY F4 + DISPLAY D1 + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/PR39_RT3573_-_Parser_issue_w_concat._source_lines.cob b/gcc/testsuite/cobol.dg/group2/PR39_RT3573_-_Parser_issue_w_concat._source_lines.cob new file mode 100644 index 000000000000..124a73c41bc1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PR39_RT3573_-_Parser_issue_w_concat._source_lines.cob @@ -0,0 +1,10 @@ + *> { dg-do compile } + + >>SOURCE FORMAT IS FREE + IDENTIFICATION DIVISION. PROGRAM-ID. issue4. DATA DIVISION. + WORKING-STORAGE SECTION. + 1 hello-string PIC X(12) VALUE "Hello string". + PROCEDURE DIVISION. + DISPLAY hello-string. + EXIT PROGRAM. + diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index e2a25757dead..19ea37029275 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -363,11 +363,12 @@ typedef struct int128 }; }int128; + static int multiply_int256_by_int64(int256 &product, const uint64_t multiplier) { // Typical use of this routine is multiplying a temporary value by - // a factor of ten. This is effectively left-shifting by decimal + // a power of ten. This is effectively left-shifting by decimal // digits. See scale_int256_by_digits uint64_t overflows[5] = {}; int128 temp; @@ -1531,6 +1532,21 @@ int256_as_decimal(int256 val) memset(ach, 0, sizeof(ach)); strcpy(ach, "0"); int index = 0; + bool is_negative = false; + + if( val.data[31] & 0x80 ) + { + // One's complement: + val.i128[0] = ~val.i128[0]; + val.i128[1] = ~val.i128[1]; + // Two's complement: + if( ++val.i128[0] == 0 ) + { + ++val.i128[1]; + } + is_negative = true; + } + while(val.i128[0] || val.i128[1]) { int256 before; @@ -1543,6 +1559,10 @@ int256_as_decimal(int256 val) ach[index++] = digit + '0'; divide_int256_by_int64(val, 10); } + if( is_negative ) + { + ach[index++] = '-'; + } if( !index ) { index = 1; @@ -2081,6 +2101,7 @@ __gg__dividef45(cbl_arith_format_t , compute_error); *compute_error |= squeeze_int256(quotient, quotient_rdigits); + if( !*compute_error ) { // We are going to need the unrounded quotient to calculate the remainder @@ -2154,6 +2175,11 @@ __gg__dividef45(cbl_arith_format_t , temp_rdigits = unrounded_quotient_digits + divisor_rdigits; int256 odividend = {}; + if( dividend < 0 ) + { + memset(&odividend, 0xFF, sizeof(odividend)); + } + memcpy(&odividend, ÷nd, sizeof(dividend)); // We need to line up the rdigits so that we can subtract temp from
