https://gcc.gnu.org/g:0c0a5d99500afd023c3dd0cd1909889cae954f6f
commit r17-3194-g0c0a5d99500afd023c3dd0cd1909889cae954f6f Author: Robert Dubner <[email protected]> Date: Mon Aug 10 17:27:42 2026 -0400 cobol: Repair COBOL EXTERNAL data definition. COBOL provides the EXTERNAL clause for data definitions. The behavior is the same as for Fortran COMMON data. Until now, we have mistakenly treated those as if they were C global variable definitions, which resulted in errors unless modules were linked with -allow-multiple-definition. These changes instead cause the variable containing the run-time metadata (and its constructor) for a COBOL symbol to be a DECL_WEAK reference, and for the variable's data area to have the DECL_COMMON attribute. This provides for correct COBOL behavior. In addition, giving the COMMON data area the variable's name means that it can be linked with a C module that has an extern declaration or a global data definition of the same name, and they will all refer to the same memory area. gcc/cobol/ChangeLog: * gcobol.1: Documentation * genapi.cc (create_cblc_string_variable): Use new vs_global enum instead of old vs_external. (SET_VAR_DECL): Use new vs_extern instead of vs_external_reference. (parser_division): Likewise. (parser_file_add): Use vs_weak instead of vs_external. (psa_global): Likewise. (psa_new_var_decl): Likewise; Use new naming convention. (parser_symbol_add): Use vs_common instead of vs_external. * gengen.cc (gg_declare_variable): Clean up VAR_DECL attibute assignments; use new variable_scope constants. * gengen.h (enum gg_variable_scope_t): Update the enum constants. libgcobol/ChangeLog: * common-defs.h (enum cbl_field_attr_t): Update comments. * libgcobol.cc (init_var_both): Modify how EXTERNAL variables are initialized. gcc/testsuite/ChangeLog: * cobol.dg/group2/INITIALIZE_EXTERNAL_data_items_with_VALUE.cob: New test. * cobol.dg/group2/INITIALIZE_EXTERNAL_data_items_with_VALUE.out: New test. Diff: --- gcc/cobol/gcobol.1 | 54 +++++++++++++++++++--- gcc/cobol/genapi.cc | 24 +++++----- gcc/cobol/gengen.cc | 33 +++++++++++-- gcc/cobol/gengen.h | 16 +++++-- .../INITIALIZE_EXTERNAL_data_items_with_VALUE.cob | 21 +++++++++ .../INITIALIZE_EXTERNAL_data_items_with_VALUE.out | 5 ++ libgcobol/common-defs.h | 4 +- libgcobol/libgcobol.cc | 10 +++- 8 files changed, 138 insertions(+), 29 deletions(-) diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1 index de968bd02bc1..8ad63202b8c4 100644 --- a/gcc/cobol/gcobol.1 +++ b/gcc/cobol/gcobol.1 @@ -863,7 +863,7 @@ is a gcc compiler, and follows gcc conventions where applicable. Sometimes those conventions (and user expectations) conflict with common Mainframe practice. Unless required of the compiler by the ISO specification, any such conflicts are resolved in favor of gcc. -.Ss Linking +.Ss Linking Functions Unlike, C, the \*[lang] .Sy CALL statement implies dynamic linking, because for @@ -897,11 +897,6 @@ option. That forces all .Sy CALL statements to be resolved dynamically, at runtime. .ig -Programs that are expected to execute -correctly in the presence of an unresolved symbol (perhaps because the -program logic won't require that particular -.Sy CALL ) -can use linker options to produce an executable anyway. .Pp One corner case yet remains. The .Sy CALL @@ -937,6 +932,53 @@ linking for all statement, regardless of compile-time constants. .. . +.Ss Linking to C +.Nm +can be called from C and can call C functions. Additionally, 01-level +data items can be defined by and/or referenced as C global variables. +.Pp +A top-level +.Sy PROGRAM-ID +has external linkage, just like a non-static C function. The name is +exported in lowercase. Hyphens, being disallowed by the linker, are +encoded; simplest is not to use such names if they are to be +referenced outside \*[lang]. Contained programs do not have external +linkage. +.Pp +A +.Sy CALL +statement invokes the target following the C ABI for the platform. That means for +.D1 CALL Dq FOO +the generated code is the same, no matter if +.Sy FOO +was compiled with C or \*[lang]. Alphanumeric and group parameters +are passed as +.Sy "char *" +pointers (not NUL-terminated). Binary numeric types are passed by +value, as with C. See the CDF +.Sy CALL-CONVENTION +directive to control how the external reference is rendered. +.Pp +A \*[lang] +.Sy EXTERNAL +data item is similar to a Fortran COMMON variable. Many programs may +define an item by the same name, preferably with identical +definitions. The linker recognizes the multiple definitions as defining a single variable. (This is unlike C, where there is one definition and potentially N +.Sy extern +references.) +C can participate when COBOL describes a variable as +.Sy EXTERNAL +in one of two ways: +.Bl -enum +.It +C can declare an +.Sy extern +variable with the same name. +. +.It +C can define a global nonstatic variable (with or without an initializer) at file scope and the COBOL variables +will refer to it. +. .Ss Implemented Exception Conditions By default, per ISO, no EC is enabled. Implemented ECs may be enabled on the command line or via the diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 41f46036df98..5fc6c8d726e8 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -235,7 +235,7 @@ create_cblc_string_variable(const char *var_name, const char *var_contents) tree entry_point = gg_declare_variable(array_of_characters, var_name, constr, - vs_external); + vs_global); gg_define_from_declaration(entry_point); } @@ -2799,7 +2799,7 @@ parser_enter_file(const char *filename) // Establish our variable declarations for global variables in libgcobol: #define SET_VAR_DECL(A, B, C) \ - A = gg_declare_variable(B, C, NULL_TREE, vs_external_reference) + A = gg_declare_variable(B, C, NULL_TREE, vs_extern) SET_VAR_DECL(var_decl_exception_code , INT , "__gg__exception_code"); SET_VAR_DECL(var_decl_exception_file_status , INT , "__gg__exception_file_status"); @@ -6822,7 +6822,7 @@ parser_division(cbl_division_t division, tree globals_are_initialized = gg_declare_variable( INT, "__gg__globals_are_initialized", NULL, - vs_external_reference); + vs_extern); IF( globals_are_initialized, eq_op, integer_zero_node ) { // one-time initialization happens here @@ -8970,7 +8970,7 @@ parser_file_add(struct cbl_file_t *file) gg_variable_scope_t scope; if( file->attr & external_e ) { - scope = vs_external; + scope = vs_weak; } else { @@ -14445,7 +14445,7 @@ psa_global(cbl_field_t *new_var) } } - new_var->var_decl_node = gg_declare_variable(cblc_field_type_node, ach, NULL, vs_external_reference); + new_var->var_decl_node = gg_declare_variable(cblc_field_type_node, ach, NULL, vs_extern); // global variables already have a .data area defined. We can find that // variable from the new_var->name. It's lower-case, with hyphens @@ -14460,7 +14460,7 @@ psa_global(cbl_field_t *new_var) ach[i] = '_'; } } - new_var->data_decl_node = gg_declare_variable(UCHAR, ach, NULL, vs_external_reference); + new_var->data_decl_node = gg_declare_variable(UCHAR, ach, NULL, vs_extern); } static tree @@ -14478,7 +14478,7 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base) strcat(ach, "_ra"); // For "Record Area" new_var_decl = gg_define_variable( cblc_field_type_node, ach, - vs_external); + vs_weak); SET_DECL_MODE(new_var_decl, BLKmode); } else @@ -14511,7 +14511,7 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base) if( new_var->attr & external_e ) { // For external variables, just stick with the original name - sprintf(base_name, "%s_cblc_field", new_var->name); + sprintf(base_name, "%s.cblc", new_var->name); } else { @@ -14569,7 +14569,7 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base) //fprintf(stderr, "external_e base name is %s\n", base_name); new_var_decl = gg_define_variable( cblc_field_type_node, base_name, - vs_external); + vs_weak); SET_DECL_MODE(new_var_decl, BLKmode); } else if( new_var->attr & (intermediate_e) @@ -15150,7 +15150,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) new_var->data_decl_node = gg_define_variable( array_type, achDataName, - vs_external); + vs_common); data_area = gg_pointer_to_array(new_var->data_decl_node); goto actual_allocate; } @@ -15255,7 +15255,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) new_var->data_decl_node = gg_define_variable( array_type, achDataName, - vs_external); + vs_common); data_area = gg_pointer_to_array(new_var->data_decl_node); } else @@ -15299,7 +15299,7 @@ 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; diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc index 67386ad0a36b..e41302c5ef72 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -868,16 +868,43 @@ gg_declare_variable(tree type_decl, DECL_EXTERNAL(var_decl) = 0; DECL_CONTEXT (var_decl) = gg_trans_unit.trans_unit_decl; break; - case vs_external: + case vs_weak: + DECL_CONTEXT (var_decl) = gg_trans_unit.trans_unit_decl; + TREE_USED(var_decl) = 1; + TREE_STATIC( var_decl ) = 1; + TREE_PUBLIC( var_decl ) = 1; + DECL_EXTERNAL( var_decl ) = 0; + DECL_COMMON( var_decl ) = 0; + DECL_WEAK( var_decl ) = 1; + // We are not allowed to try to create a COMMON variable more than once + // in a translation unit. + seen[unique_name] = var_decl; + break; + case vs_common: + DECL_CONTEXT (var_decl) = gg_trans_unit.trans_unit_decl; + TREE_USED(var_decl) = 1; + TREE_STATIC( var_decl ) = 1; + TREE_PUBLIC( var_decl ) = 1; + DECL_EXTERNAL( var_decl ) = 0; + DECL_COMMON( var_decl ) = 1; + DECL_WEAK( var_decl ) = 0; + // We are not allowed to try to create a COMMON variable more than once + // in a translation unit. + seen[unique_name] = var_decl; + // A COMMON value with an initializer gets converted to a .data or .bss. + // So, we make sure it has no initializer. + gcc_assert(!initial_value); + initial_value = NULL_TREE; + break; + case vs_global: // This is for defining variables with global scope DECL_CONTEXT (var_decl) = gg_trans_unit.trans_unit_decl; TREE_USED(var_decl) = 1; TREE_STATIC(var_decl) = 1; TREE_PUBLIC(var_decl) = 1; DECL_EXTERNAL(var_decl) = 0; - seen[unique_name] = var_decl; break; - case vs_external_reference: + case vs_extern: // This is for referencing variables defined elsewhere DECL_CONTEXT (var_decl) = gg_trans_unit.trans_unit_decl; TREE_USED(var_decl) = 1; diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h index ea2f2812a3a9..88acf00f70fa 100644 --- a/gcc/cobol/gengen.h +++ b/gcc/cobol/gengen.h @@ -109,11 +109,17 @@ */ enum gg_variable_scope_t { - vs_stack, - vs_static, - vs_file_static, // static variable of file scope - vs_external, // Creates a PUBLIC STATIC variable of file scope - vs_external_reference, // References a vs_external variable. + // These scopes reference the GCC world rather than the COBOL world. + // This is in contrast to the cbl_field_attr_t bits, where external_e means + // the variable had the COBOL EXTERNAL clause, which causes a variable to + // have a weak cblc_field_t and a common cblc_field_t::data. + vs_stack, // An automatic variable. + vs_static, // A static variable of function scope. + vs_file_static, // static variable of file scope. + vs_weak, // A "weak" variable. + vs_common, // A COMMON variable. + vs_global, // A global variable, e.g. "int xxx;" in C + vs_extern, // A declaration for a global; "extern int xxx;" }; struct gg_function_t diff --git a/gcc/testsuite/cobol.dg/group2/INITIALIZE_EXTERNAL_data_items_with_VALUE.cob b/gcc/testsuite/cobol.dg/group2/INITIALIZE_EXTERNAL_data_items_with_VALUE.cob new file mode 100644 index 000000000000..81fd61b2cfed --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INITIALIZE_EXTERNAL_data_items_with_VALUE.cob @@ -0,0 +1,21 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-output-file "group2/INITIALIZE_EXTERNAL_data_items_with_VALUE.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 ext-var pic x(6) external. + 01 ext-vari pic x(6) external value "absurd". + procedure division. + initialize ext-var + display "ext-var is " """"ext-var"""" + initialize ext-var all to value + display "ext-var is " """"ext-var"""" + initialize ext-vari + display "ext-vari is " """"ext-vari"""" + initialize ext-vari all to value + display "ext-vari is " """"ext-vari"""" + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/INITIALIZE_EXTERNAL_data_items_with_VALUE.out b/gcc/testsuite/cobol.dg/group2/INITIALIZE_EXTERNAL_data_items_with_VALUE.out new file mode 100644 index 000000000000..618946409702 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INITIALIZE_EXTERNAL_data_items_with_VALUE.out @@ -0,0 +1,5 @@ +ext-var is " " +ext-var is " " +ext-vari is " " +ext-vari is "absurd" + diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h index 78eb03c8fd7d..5c1375414c88 100644 --- a/libgcobol/common-defs.h +++ b/libgcobol/common-defs.h @@ -215,8 +215,8 @@ enum cbl_field_attr_t : uint64_t { refmod_e = 0x0000040000, // Runtime; indicates a refmod is active based_e = 0x0000080000, // pointer capacity, for ADDRESS OF or ALLOCATE any_length_e = 0x0000100000, // inferred length of linkage in nested program - global_e = 0x0000200000, // field has global scope - external_e = 0x0000400000, // field has external scope + global_e = 0x0000200000, // field is COBOL GLOBAL (not GCC global scope) + external_e = 0x0000400000, // field is COBOL EXTERNAL (not GCC extern) blank_zero_e = 0x0000800000, // BLANK WHEN ZERO // data division uses 2 low bits of high byte linkage_e = 0x0001000000, // field is in linkage section diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index a5c9b4b4ad16..cdc65d6b488c 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -5911,12 +5911,20 @@ init_var_both(cblc_field_t *var, return; } - if( !(var->attr & based_e) && (var->attr & external_e) ) + if( !(var->attr & based_e) && (var->attr & external_e) && !var->initial) { // These types can't be initialized return; } + if( flag_bits & JUST_ONCE_BIT && var->attr & external_e ) + { + // This is an EXTERNAL variable with a VALUE clause. We don't initialize + // that on startup. The value is applicable only for explicit INITIALIZE + // statements. + return; + } + // There are times, for example, when we are table with OCCURS, that we // look like a variable with no initial, and we might be tempted to set our // memory to the default. But if a parent has been initialized, we must not
