From: Robert Dubner <[email protected]>
Date: Wed, 14 Oct 2026 14:43:24 -0400
Subject: [PATCH] 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.
---
gcc/cobol/genapi.cc | 41 +++++++++++++------
gcc/cobol/move.cc | 2 +
.../group2/move_numdisp_with_refmods.cob | 21 ++++++++++
.../group2/move_numdisp_with_refmods.out | 3 ++
4 files changed, 55 insertions(+), 12 deletions(-)
create mode 100644
gcc/testsuite/cobol.dg/group2/move_numdisp_with_refmods.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/move_numdisp_with_refmods.out
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 5c14b9b9865..13538e0b2ec 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 088be4233ca..8e49365111d 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 00000000000..afa6b3cbc0e
--- /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 00000000000..8e514b958ea
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/move_numdisp_with_refmods.out
@@ -0,0 +1,3 @@
+SOURCE=[A0A1B0000]
+TARGET=[A0A1B]
+
--
2.34.1
