https://gcc.gnu.org/g:5f39942ffd6ad0ec21126d172ea883e3a3589dfc
commit r17-5208-g5f39942ffd6ad0ec21126d172ea883e3a3589dfc Author: Robert Dubner <[email protected]> Date: Wed Oct 14 14:43:24 2026 -0400 cobol: Fix MOVE bug; change LEVEL 78 naming and scope. A user noticed a problem with MOVE numeric-display to numeric-display when the variables had refmods. That's fixed here. GDB-COBOL development exposed problems with accessing LEVEL78 text and numeric variables. That's fixed here. gcc/cobol/ChangeLog: * genapi.cc (dirty_to_binary): Formatting. (psa_FldLiteralN): Change name of data area for GDB-COBOL. (psa_FldLiteralA): Make LEVEL78 variables static with function scope for GDB-COBOL. (parser_symbol_add): Put data.original into cblc_field_t::initial for FldLiteralN variables; needed for GDB-COBOL. * move.cc (mh_numeric_display): Bug fix: Pass refmodded numeric- display moves on to __gg__move(). gcc/testsuite/ChangeLog: * cobol.dg/group2/move_numdisp_with_refmods.cob: New test. * cobol.dg/group2/move_numdisp_with_refmods.out: New test. Diff: --- gcc/cobol/genapi.cc | 41 +++++++++++++++------- gcc/cobol/move.cc | 2 ++ .../cobol.dg/group2/move_numdisp_with_refmods.cob | 21 +++++++++++ .../cobol.dg/group2/move_numdisp_with_refmods.out | 3 ++ 4 files changed, 55 insertions(+), 12 deletions(-) diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 5c14b9b98657..13538e0b2ec4 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -3770,7 +3770,6 @@ dirty_to_binary(const char *instring, return value; } - static void psa_FldLiteralN(struct cbl_field_t *field ) { @@ -3807,8 +3806,10 @@ psa_FldLiteralN(struct cbl_field_t *field ) static size_t our_index = 0; - sprintf(id_string, "." HOST_SIZE_T_PRINT_DEC, (fmt_size_t)++our_index); - strcpy(base_name, field->name); + sprintf(id_string, HOST_SIZE_T_PRINT_DEC, (fmt_size_t)++our_index); + strcpy(base_name, "_"); + strcat(base_name, field->name); + strcat(base_name, "_data_"); strcat(base_name, id_string); tree var_type; @@ -14925,16 +14926,28 @@ psa_FldLiteralA(struct cbl_field_t *field ) tree converted = convert_data_initial(field); - static const char name_base[] = "_literal_a_"; - static int nvar = 0; - nvar += 1; + char *name; + if( field->level == 78 ) + { + name = xasprintf("%s.%d.%d", + field->name, + static_cast<int>(field->our_index), + static_cast<int>(current_function->program_id_number)); + } + else + { + name = xasprintf("%s_%d", + "_literal_a_", + nvar++); + } + + gg_variable_scope_t vs = field->level == 78 ? vs_static : vs_file_static ; + field->var_decl_node = gg_define_variable(cblc_field_type_node, + name, + vs); + free(name); - char ach[32]; - sprintf(ach, "%s%d", name_base, nvar); - field->var_decl_node = gg_define_variable( cblc_field_type_node, - ach, - vs_file_static); TREE_READONLY(field->var_decl_node) = 1; TREE_USED(field->var_decl_node) = 1; TREE_STATIC(field->var_decl_node) = 1; @@ -15595,7 +15608,11 @@ parser_symbol_add(struct cbl_field_t *new_var ) // At this point, new_initial might have been set by // get_class_condition_string. If not, we set it another way: - if( !level_88_string && !class_string) + if( new_var->type == FldLiteralN ) + { + new_initial = new_var->data.original(); + } + else if( !level_88_string && !class_string ) { new_initial = const_cast<char *>(new_var->data.initial); length_of_initial_string = new_var->data.capacity(); diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc index 088be4233ca6..8e49365111d0 100644 --- a/gcc/cobol/move.cc +++ b/gcc/cobol/move.cc @@ -865,6 +865,8 @@ mh_numeric_display( const cbl_refer_t &destref, && !(sourceref.field->attr & scaled_e) && charmap_source->stride() == 1 && sourceref.field->codeset.encoding == destref.field->codeset.encoding + && !destref.refmod.from + && !sourceref.refmod.from ) { // We can do simple moves of single-byte same-encoding numeric display. diff --git a/gcc/testsuite/cobol.dg/group2/move_numdisp_with_refmods.cob b/gcc/testsuite/cobol.dg/group2/move_numdisp_with_refmods.cob new file mode 100644 index 000000000000..afa6b3cbc0e8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/move_numdisp_with_refmods.cob @@ -0,0 +1,21 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-output-file "group2/move_numdisp_with_refmods.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. MOVEPROBE. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SOURCE-GROUP. + 05 SOURCE-FIELD PIC 9(9). + 01 SOURCE-RAW REDEFINES SOURCE-GROUP PIC X(9). + 01 TARGET-GROUP. + 05 TARGET-FIELD PIC 9(5). + 01 TARGET-RAW REDEFINES TARGET-GROUP PIC X(5). + PROCEDURE DIVISION. + MOVE "A0A1B0000" TO SOURCE-RAW + MOVE ZERO TO TARGET-FIELD + MOVE SOURCE-FIELD(1:5) TO TARGET-FIELD(1:5) + DISPLAY "SOURCE=[" SOURCE-RAW "]" + DISPLAY "TARGET=[" TARGET-RAW "]" + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/move_numdisp_with_refmods.out b/gcc/testsuite/cobol.dg/group2/move_numdisp_with_refmods.out new file mode 100644 index 000000000000..8e514b958eaa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/move_numdisp_with_refmods.out @@ -0,0 +1,3 @@ +SOURCE=[A0A1B0000] +TARGET=[A0A1B] +
