From 7fb136f62c18ffd33d3b26f1a6cf197265fd8b60 Mon Sep 17 00:00:00 2001 From: David Declerck Date: Tue, 24 Sep 2024 15:08:24 +0200 Subject: [PATCH] Merge SVN 4935 --- NEWS | 11 ++-- build_windows/ChangeLog.txt | 8 ++- cobc/ChangeLog | 17 ++++++ cobc/codegen.c | 74 +++++++++++++++------------ cobc/config.c | 8 +-- cobc/field.c | 5 +- cobc/parser.y | 20 +++++++- cobc/tree.c | 6 +-- cobc/tree.h | 10 ++-- cobc/typeck.c | 15 ++++-- config/ChangeLog | 6 ++- config/cobol2002.conf | 2 +- config/cobol2014.conf | 2 +- config/cobol85.conf | 2 +- config/default.conf | 5 +- config/gcos-strict.conf | 2 +- config/realia-strict.conf | 4 +- configure.ac | 2 +- libcob/ChangeLog | 4 ++ libcob/coblocal.h | 7 +-- libcob/common.c | 6 +-- libcob/common.h | 3 +- libcob/statement.def | 12 +++-- tests/testsuite.src/run_misc.at | 62 ++++++++++++++++++---- tests/testsuite.src/run_subscripts.at | 2 +- 25 files changed, 206 insertions(+), 89 deletions(-) diff --git a/NEWS b/NEWS index db6681d79..e03385f8e 100644 --- a/NEWS +++ b/NEWS @@ -306,12 +306,15 @@ Open Plans: affected programs (with OCCURS DEPENDING ON) or compile with additional -fno-odoslide to get the same results as with older GnuCOBOL versions -** the compile flag -fdefaultbyte was moved to a dialect configuration, +** the compile flag -fdefaultbyte (initializarion for data-items without + an explicit VALUE) was moved to a dialect configuration; while -fdefaultbyte still works as before it is now implied as binary - zero with -std=ibm/mvs/bs2000, space for -std=mf/acu/rm/realia, and + zero with -std=ibm/mvs/bs2000/realia, space for -std=mf/acu/rm, and no defined initialization for -std=cobol85/cobol2002/cobol2014/xopen, - it is unchanged for -std=default (initialize to PICTURE/USAGE) - for compatibility to previous behavior compile with -fdefaultbyte=init + it is unchanged for -std=default (initialize to PICTURE/USAGE); + for compatibility to previous behavior compile with -fdefaultbyte=init; + note that initialization for INDEXED BY items honors the defaultbyte + configuration now, too ** the dialect configuration option larger-redefines-ok was changed to a support option larger-redefines; if specified on the command-line diff --git a/build_windows/ChangeLog.txt b/build_windows/ChangeLog.txt index 81f5388d7..371eb2303 100644 --- a/build_windows/ChangeLog.txt +++ b/build_windows/ChangeLog.txt @@ -13,6 +13,10 @@ * makedist.cmd: first addition for CI output * version_cobc.rc, version_libcob.rc: updated date + rev +2023-01-16 Simon Sobisch + + * version_cobc.rc, version_libcob.rc: updated date + rev + 2022-12-17 Simon Sobisch * general for libcob+cobc: handle move of cconv module @@ -43,7 +47,7 @@ 2021-11-06 Simon Sobisch - * config.h.in: moved references to PACKACAGE_defines after the define, + * config.h.in: moved references to PACKAGE_defines after the define, fixing dist builds since 2020-10-27 * makedist.cmd: explicit search for "define PACKAGE_define" which fixes the multiple results @@ -346,7 +350,7 @@ version_libcob.rc, version_cobcrun.rc provided by Simon) -Copyright 2014-2021 Free Software Foundation, Inc. +Copyright 2014-2023 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 91955f695..098323f54 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -197,6 +197,23 @@ * reserved.c (SEQUENCE): setting CB_CS_ALPHABET to allow code-name parsing * parser.y, reserved.c: changed reference from 202x to 2023 +2023-01-16 Simon Sobisch + + * parser.y (occurs_index): only set VALUE 1 for defaultbyte == INIT + * tree.h (CB_DEFAULT_BYTE_INIT, CB_DEFAULT_BYTE_NONE), config.c, field.c, + codegen.c: explicit defines instead of "only magic numbers" + * tree.c (cb_build_initialize), tree.h (struct cb_initialize), codegen.c + (output_initialize_to_value): replaced flag_init_statement with statement + * parser.y (setup_occurs_min_max): validate occurs_max limit + * codegen.c (output_initialize_uniform): pass code-field instead of + re-evaluating it + * codegen.c (output_initialize_multi_values): removed variable + "total_occurs" fixing Wunused-but-set-variable + * codegen.c (output_stmt): dropped unused msgid + * typeck.c (cb_build_index): add internal index variables in LINKAGE to + internal WORKING-STORAGE or internal LOCAL-STORAGE items depending on + program->flag_recursive + 2023-01-15 Ron Norman * cobc.c: Make sure the 'schema' directory is created for -fsql diff --git a/cobc/codegen.c b/cobc/codegen.c index f1c344a6a..3a344c208 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -2865,7 +2865,7 @@ output_local_field_cache (struct cb_program *prog) output ("/* %s is not local */", f->name); output_newline (); } - if (f->storage == CB_STORAGE_REPORT + if (f->storage == CB_STORAGE_REPORT && f->flag_occurs && f->occurs_max > 1) { /* generate sub-fields and a comment each */ @@ -2941,7 +2941,7 @@ output_local_fields (struct cb_program *prog) for (f = rep->records; f; f = f->sister) { if (f->storage == CB_STORAGE_WORKING && !(f->report_flag & COB_REPORT_REF_EMITTED)) { - output_emit_field(cb_build_field_reference (f, NULL), NULL); + output_emit_field (cb_build_field_reference (f, NULL), NULL); } } } @@ -5047,11 +5047,11 @@ deduce_initialize_type (struct cb_initialize *p, struct cb_field *f, return INITIALIZE_ONE; } - if (f->flag_external && !p->flag_init_statement) { + if (f->flag_external && p->statement == STMT_INIT_STORAGE) { return INITIALIZE_NONE; } - if (f->redefines && (!topfield || !p->flag_init_statement)) { + if (f->redefines && (!topfield || p->statement != STMT_INITIALIZE)) { return INITIALIZE_NONE; } @@ -5096,7 +5096,7 @@ deduce_initialize_type (struct cb_initialize *p, struct cb_field *f, } if (p->flag_default) { - if (cb_default_byte >= 0 && !p->flag_init_statement) { + if (p->statement == STMT_INIT_STORAGE && cb_default_byte >= 0) { return INITIALIZE_DEFAULT; } switch (f->usage) { @@ -5211,7 +5211,7 @@ static int initialize_uniform_char (const struct cb_field *f, const struct cb_initialize *p) { - if (cb_default_byte >= 0 && !p->flag_init_statement) { + if (p->statement == STMT_INIT_STORAGE && cb_default_byte >= 0) { return cb_default_byte; } @@ -5425,10 +5425,9 @@ output_initialize_fp (cb_tree x, struct cb_field *f) } static void -output_initialize_uniform (cb_tree x, const unsigned char cc, const int size) +output_initialize_uniform (cb_tree x, struct cb_field *f, + const unsigned char cc, const int size) { - struct cb_field *f = cb_code_field (x); - /* REPORT lines are cleared to SPACES */ if (f->storage == CB_STORAGE_REPORT && cc == ' ') { @@ -5484,7 +5483,7 @@ static void output_initialize_chaining (struct cb_field *f, struct cb_initialize *p) { /* only handle CHAINING for program initialization */ - if (p->flag_init_statement) { + if (p->statement == STMT_INITIALIZE) { return; } /* Note: CHAINING must be an extra initialization step as parameters not passed @@ -5500,7 +5499,7 @@ output_initialize_chaining (struct cb_field *f, struct cb_initialize *p) static void output_initialize_to_value (struct cb_field *f, cb_tree x, - const int flag_init_statement) + const enum cob_statement statement) { cb_tree value; struct cb_literal *l; @@ -5529,7 +5528,7 @@ output_initialize_to_value (struct cb_field *f, cb_tree x, } /* Check for non-standard OCCURS */ if ((f->level == 1 || f->level == 77) - && f->flag_occurs && !flag_init_statement) { + && f->flag_occurs && statement == STMT_INIT_STORAGE) { init_occurs = 1; } else { init_occurs = 0; @@ -5813,13 +5812,11 @@ output_initialize_to_default (struct cb_field *f, cb_tree x) static void output_initialize_one (struct cb_initialize *p, cb_tree x) { - struct cb_field *f; - - f = cb_code_field (x); + struct cb_field *f = cb_code_field (x); /* Initialize TO VALUE */ if (p->val && f->values) { - output_initialize_to_value (f, x, p->flag_init_statement); + output_initialize_to_value (f, x, p->statement); return; } @@ -5902,7 +5899,7 @@ output_initialize_multi_values (struct cb_initialize *p, cb_tree x, struct cb_fi struct cb_field *pftbl[COB_MAX_SUBSCRIPTS+1] = { NULL }; int idxtbl[COB_MAX_SUBSCRIPTS+1] = { 0 }; int occtbl[COB_MAX_SUBSCRIPTS+1] = { 0 }; - int idx, idx_clr, total_occurs; + int idx, idx_clr; #if 0 /* CHECKME: the init above should be fine */ for (idx=0; idx <= COB_MAX_SUBSCRIPTS; idx++) { @@ -5910,14 +5907,12 @@ output_initialize_multi_values (struct cb_initialize *p, cb_tree x, struct cb_fi pftbl[idx] = NULL; } #endif - total_occurs = 1; idx_clr = 0; for (idx = 0, pf = f; pf; pf = pf->parent) { if (pf->flag_occurs && pf->occurs_max > 1) { pftbl [idx] = pf; occtbl[idx] = pf->occurs_max; - total_occurs *= pf->occurs_max; idx++; } } @@ -6034,7 +6029,7 @@ output_initialize_compound (struct cb_initialize *p, cb_tree x) } else { size = ff->offset + ff->size - last_field->offset; } - output_initialize_uniform (c, (unsigned char)last_char, size); + output_initialize_uniform (c, last_field, (unsigned char)last_char, size); } break; } @@ -6161,7 +6156,7 @@ static void output_initialize_values_table_format (struct cb_initialize *p) { if (needs_table_format_value - && (!p->flag_init_statement || p->val == cb_true)) { + && (p->statement == STMT_INIT_STORAGE || p->val == cb_true)) { struct cb_field *f = cb_code_field (p->var); const cb_tree c = cb_build_field_reference (f, NULL); CB_REFERENCE(c)->subs = CB_BUILD_CHAIN (cb_int1, CB_REFERENCE(c)->subs); @@ -6185,7 +6180,7 @@ output_initialize_values_table_format (struct cb_initialize *p) static void output_initialize (struct cb_initialize *p) { - struct cb_field *f = cb_code_field (p->var); + struct cb_field *f = cb_code_field (p->var); int c; const enum cobc_init_type type @@ -6207,15 +6202,15 @@ output_initialize (struct cb_initialize *p) /* TODO: if cb_default_byte >= 0 do a huge memset first, then only emit setting for fields that need it (VALUE clause or special category - in general: not matching cb_default_byte); - similar for cb_default_byte == -2 (just without the - initial huge memset) */ + similar for cb_default_byte == CB_DEFAULT_BYTE_NONE (-2), + just without the initial huge memset */ needs_table_format_value = 0; /* Check for non-standard OCCURS */ if ((f->level == 1 || f->level == 77) && f->flag_occurs - && !p->flag_init_statement) { + && p->statement == STMT_INIT_STORAGE) { cb_tree x; switch (type) { case INITIALIZE_ONE: @@ -6226,7 +6221,7 @@ output_initialize (struct cb_initialize *p) case INITIALIZE_DEFAULT: c = initialize_uniform_char (f, p); if (c != -1) { - output_initialize_uniform (p->var, (unsigned char)c, f->occurs_max); + output_initialize_uniform (p->var, f, (unsigned char)c, f->size * f->occurs_max); output_initialize_chaining (f, p); return; } @@ -6271,7 +6266,7 @@ output_initialize (struct cb_initialize *p) case INITIALIZE_DEFAULT: c = initialize_uniform_char (f, p); if (c != -1) { - output_initialize_uniform (p->var, (unsigned char)c, f->size); + output_initialize_uniform (p->var, f, (unsigned char)c, f->size); output_initialize_chaining (f, p); return; } @@ -8994,7 +8989,7 @@ output_line_and_trace_info (cb_tree x, const enum cob_statement stmnt) if ( (cb_flag_c_line_directives || cb_flag_source_location || cb_cob_line_num) - && x->source_file) { + && x->source_line) { output_cobol_info (x); if (cb_flag_source_location) { output_line ("module->statement = %s;", stmnt_enum); @@ -9582,7 +9577,8 @@ output_stmt (cb_tree x) } /* LCOV_EXCL_START */ if (x == cb_error_node) { - cobc_err_msg (_("unexpected error_node parameter")); + /* untranslated as unexpected */ + cobc_err_msg ("unexpected error_node parameter"); COBC_ABORT (); } /* LCOV_EXCL_STOP */ @@ -10470,7 +10466,7 @@ output_report_data (struct cb_field *p) { if (p->storage == CB_STORAGE_REPORT) { output_emit_field (cb_build_field_reference (p, NULL), NULL); - if(p->report_sum_counter) { + if (p->report_sum_counter) { output_emit_field (p->report_sum_counter, "SUM"); } if (p->report_control) { @@ -11855,8 +11851,22 @@ output_initial_values (struct cb_field *f) if (p->flag_no_init && !p->count) { continue; } + /* note: the initial value of INDEXED BY items is undefined per standard, + but earlier versions always set this explict to 1 on first entry; + we now make this depending on its value, set depending on cb_init_indexed_by + and on cb_implicit_init */ + if (p->flag_indexed_by && cb_default_byte == CB_DEFAULT_BYTE_NONE) { + continue; + } x = cb_build_field_reference (p, NULL); - output_stmt (cb_build_initialize (x, cb_true, NULL, 1, 0, 0)); + /* output comment and source location for each 01/77 */ + output_line ("/* initialize field %s */", p->name); + if (cb_flag_c_line_directives && p->common.source_line) { + output_cobol_info (CB_TREE (p)); + output_line ("cob_nop ();"); + output_c_info (); + } + output_stmt (cb_build_initialize (x, cb_true, NULL, 1, STMT_INIT_STORAGE, 0)); output_newline (); } } @@ -13377,7 +13387,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) } output_line ("%s%d = &%s%d;", CB_PREFIX_DEC_CONST, m->id, CB_PREFIX_DEC_FIELD, m->id); - output_line ("cob_decimal_init(%s%d);", CB_PREFIX_DEC_CONST, m->id); + output_line ("cob_decimal_init (%s%d);", CB_PREFIX_DEC_CONST, m->id); output_line ("cob_decimal_set_field (%s%d, (cob_field *)&%s%d);", CB_PREFIX_DEC_CONST, m->id, CB_PREFIX_CONST, m->id); diff --git a/cobc/config.c b/cobc/config.c index 1b5b51ac3..cf690fe8b 100644 --- a/cobc/config.c +++ b/cobc/config.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2003-2012, 2014-2017, 2019-2022 Free Software Foundation, Inc. + Copyright (C) 2003-2012, 2014-2017, 2019-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch This file is part of GnuCOBOL. @@ -772,11 +772,11 @@ cb_config_entry (char *buff, const char *fname, const int line) } else if (strcmp (name, "defaultbyte") == 0) { if (strcmp (val, "init") == 0) { /* generate default initialization per INITIALIZE rules */ - cb_default_byte = -1; + cb_default_byte = CB_DEFAULT_BYTE_INIT; break; } if (strcmp (val, "none") == 0) { - cb_default_byte = -2; + cb_default_byte = CB_DEFAULT_BYTE_NONE; #if 1 /* TODO: do not generate any default initialization for fields without VALUE, only the storage (best performance, least reproducibility); for now warn if specified on command line (allowing config files be correct already) */ @@ -795,7 +795,7 @@ cb_config_entry (char *buff, const char *fname, const int line) } else /* convert character to number (as quotes will commonly be removed when given on shell) */ - if (val[1] == 0 && (val[0] <= '0' || val[0] >= '9')) { + if (val[1] == 0 && (val[0] < '0' || val[0] > '9')) { cb_default_byte = val[0]; break; } diff --git a/cobc/field.c b/cobc/field.c index 96d4cda19..8c61e726c 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -3220,7 +3220,7 @@ cleanup_field_value (struct cb_field* f, cb_tree *val) } if (*val == cb_zero && !f->flag_internal_register - && cb_default_byte == -1 + && cb_default_byte == CB_DEFAULT_BYTE_INIT && ( f->storage == CB_STORAGE_WORKING || f->storage == CB_STORAGE_LOCAL) && !f->flag_sign_separate) { @@ -3241,7 +3241,8 @@ cleanup_field_value (struct cb_field* f, cb_tree *val) } if (*val == cb_space && !f->flag_internal_register - && (cb_default_byte == -1 || cb_default_byte == ' ') + && ( cb_default_byte == CB_DEFAULT_BYTE_INIT + || cb_default_byte == ' ') && ( f->storage == CB_STORAGE_WORKING || f->storage == CB_STORAGE_LOCAL) && !f->children) { diff --git a/cobc/parser.y b/cobc/parser.y index d30b3810a..4502eab1a 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -40,6 +40,7 @@ #define COB_IN_PARSER 1 #include "cobc.h" #include "tree.h" +#include "libcob/coblocal.h" #define _PARSER_H /* work around bad Windows SDK header */ @@ -801,9 +802,10 @@ setup_occurs_min_max (cb_tree occurs_min, cb_tree occurs_max) } if (current_field->occurs_max <= current_field->occurs_min) { cb_error (_("OCCURS TO must be greater than OCCURS FROM")); + current_field->occurs_max = current_field->occurs_min; } } else { - current_field->occurs_max = 0; + current_field->occurs_max = 0; /* UNBOUNDED */ } } else { current_field->occurs_min = 1; /* CHECKME: why using 1 ? */ @@ -812,6 +814,17 @@ setup_occurs_min_max (cb_tree occurs_min, cb_tree occurs_max) cb_verify (cb_odo_without_to, _("OCCURS DEPENDING ON without TO phrase")); } } + /* LCOV_EXCL_START */ + if (current_field->occurs_max > COB_MAX_FIELD_SIZE) { + /* testing here to give an early error; unlikely to be reached + with 64bit compilers so no own msgid for now; should be added + when the maximum field size is changed to be configurable */ + cb_error_x (CB_TREE (current_field), + _("'%s' cannot be larger than %d bytes"), + current_field->name, COB_MAX_FIELD_SIZE); + current_field->occurs_min = current_field->occurs_max = 1; + } + /* LCOV_EXCL_STOP */ } static void @@ -7917,6 +7930,7 @@ usage: } | INDEX { + /* TODO: second type which is 0-based, depending on dialect option */ check_and_set_usage (CB_USAGE_INDEX); } | PACKED_DECIMAL @@ -8421,7 +8435,9 @@ occurs_index: unqualified_word { const enum cb_storage storage = current_field->storage; - $$ = cb_build_index ($1, cb_int1, 1U, current_field); + const cb_tree init_val = cb_default_byte == CB_DEFAULT_BYTE_INIT + ? cb_int1 : NULL; + $$ = cb_build_index ($1, init_val, 1U, current_field); if (storage == CB_STORAGE_LOCAL) { CB_FIELD_PTR ($$)->storage = CB_STORAGE_LOCAL; CB_FIELD_PTR ($$)->index_type = CB_INT_INDEX; diff --git a/cobc/tree.c b/cobc/tree.c index a5026ce06..13daee1d6 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, Edward Hart @@ -6929,7 +6929,7 @@ cb_build_assign (const cb_tree var, const cb_tree val) cb_tree cb_build_initialize (const cb_tree var, const cb_tree val, const cb_tree rep, const unsigned int def, - const unsigned int is_statement, + const enum cob_statement statement, const unsigned int no_filler_init) { struct cb_initialize *p; @@ -6940,7 +6940,7 @@ cb_build_initialize (const cb_tree var, const cb_tree val, const cb_tree rep, p->val = val; p->rep = rep; p->flag_default = (cob_u8_t)def; - p->flag_init_statement = (cob_u8_t)is_statement; + p->statement = statement; p->flag_no_filler_init = (cob_u8_t)no_filler_init; return CB_TREE (p); } diff --git a/cobc/tree.h b/cobc/tree.h index 40492616c..fc9ba0223 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman This file is part of GnuCOBOL. @@ -1035,6 +1035,10 @@ struct cb_field { #define CB_FIELD_PTR(x) \ (CB_REFERENCE_P (x) ? CB_FIELD (cb_ref (x)) : CB_FIELD (x)) +/* special values for cb_default_byte */ +#define CB_DEFAULT_BYTE_INIT -1 /* init by PICTURE/USAGE; INDEXED BY as 1 */ +#define CB_DEFAULT_BYTE_NONE -2 /* no explicit init at all */ + /* Index */ #define CB_INDEX_OR_HANDLE_P(x) cb_check_index_or_handle_p (x) @@ -1388,8 +1392,8 @@ struct cb_initialize { cb_tree var; /* Field */ cb_tree val; /* ALL (cb_true) or category (cb_int) TO VALUE */ cb_tree rep; /* Replacing */ + enum cob_statement statement; /* INITIALIZE statement */ unsigned char flag_default; /* Default */ - unsigned char flag_init_statement; /* INITIALIZE statement */ unsigned char flag_no_filler_init; /* No FILLER initialize */ unsigned char padding; /* Padding */ }; @@ -2261,7 +2265,7 @@ extern cb_tree cb_build_schema_name (cb_tree); extern cb_tree cb_build_initialize (const cb_tree, const cb_tree, const cb_tree, const unsigned int, - const unsigned int, + const enum cob_statement, const unsigned int); struct cb_literal *build_literal (enum cb_category, diff --git a/cobc/typeck.c b/cobc/typeck.c index 0ab4a666f..9197fe0cb 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2425,6 +2425,8 @@ cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by, enum cb_storage storage = CB_STORAGE_WORKING; struct cb_field *f = CB_FIELD (cb_build_field (x)); + /* TODO: possibly second type which is 0-based, depending on dialect option, + see FR #428 */ f->usage = CB_USAGE_INDEX; cb_validate_field (f); f->values = values; @@ -2438,10 +2440,17 @@ cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by, } switch (storage) { case CB_STORAGE_FILE: - case CB_STORAGE_LINKAGE: /* explicit: not passed -> program local -> WS */ case CB_STORAGE_WORKING: CB_FIELD_ADD (current_program->working_storage, f); break; + case CB_STORAGE_LINKAGE: + /* explicit: not passed -> program local -> WS / LO */ + if (current_program->flag_recursive) { + CB_FIELD_ADD (current_program->local_storage, f); + } else { + CB_FIELD_ADD (current_program->working_storage, f); + } + break; case CB_STORAGE_SCREEN: CB_FIELD_ADD (current_program->screen_storage, f); break; @@ -8788,7 +8797,7 @@ cb_emit_allocate_identifier (cb_tree allocate_identifier, cb_tree returning, con INITIALIZE identifier WITH FILLER ALL TO VALUE THEN TO DEFAULT */ if (init_flag) { current_statement->not_ex_handler = - cb_build_initialize (allocate_identifier, cb_true, NULL, 1, 0, 0); + cb_build_initialize (allocate_identifier, cb_true, NULL, 1, STMT_ALLOCATE, 0); } } @@ -10414,7 +10423,7 @@ cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value, CB_REFERENCE (x)->length = temp; } cb_emit (cb_build_initialize (x , value, replacing, - def_init, 1, no_fill_init)); + def_init, STMT_INITIALIZE, no_fill_init)); } } diff --git a/config/ChangeLog b/config/ChangeLog index 9a8377dbe..99ca32132 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -43,6 +43,10 @@ * gcos.words: complete update * general: added missing alias JUST=JUSTIFIED +2023-01-16 Simon Sobisch + + * realia-strict.conf: change defaultbyte from space to zero + 2022-12-07 Nicolas Berthier * general: rename partial-replacing-with-literal into @@ -829,7 +833,7 @@ * default.inc, Makefile.am: New files. -Copyright 2003,2005-2007-2010,2014-2022,2024 Free Software Foundation, Inc. +Copyright 2003,2005-2007-2010,2014-2024 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 4e93e0e13..07b6808e5 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -286,7 +286,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: none # "undefined" +defaultbyte: none # initial storage is undefined picture-l: unconformable # archaic in COBOL2002 and currently not available as dialect features: diff --git a/config/cobol2014.conf b/config/cobol2014.conf index b4754036d..5e2f19ba6 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -286,7 +286,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: none # "undefined" +defaultbyte: none # initial storage is undefined picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/cobol85.conf b/config/cobol85.conf index 47ab1d50d..b8320d0aa 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -286,7 +286,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: none # "undefined" +defaultbyte: none # initial storage is undefined picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: diff --git a/config/default.conf b/config/default.conf index 3354f8460..5058325e2 100644 --- a/config/default.conf +++ b/config/default.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -309,7 +309,8 @@ self-call-recursive: skip record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: init +defaultbyte: init # GC inits as INITIALIZE ALL TO VALUE THEN TO DEFAULT, + # with INDEXED BY variables initialized to 1 picture-l: ok # use complete word list; synonyms and exceptions are specified below diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 67c5fb1c5..a2000119c 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -272,7 +272,7 @@ sequential-delimiters: ok record-sequential-advancing: ok # TODO: verify record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable diff --git a/config/realia-strict.conf b/config/realia-strict.conf index f354fcccb..f9c7d6bbf 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -291,7 +291,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: " " # not verified, but possibly like ACU/MF +defaultbyte: 0 # not verified, but likely like IBM picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/configure.ac b/configure.ac index 353650e5f..e7c6d7942 100644 --- a/configure.ac +++ b/configure.ac @@ -61,7 +61,7 @@ AC_CONFIG_FILES([tests/run_prog_manual.sh], # Note for SUN Solaris (gcc) # options to configure: CC="gcc -m64" --libdir=/usr/local/lib/sparcv9 # or: -# options to configure: CFLAGS=-m64 and LDFLAGS="-m64 -L/usr/local/lib/sparcv9" +# options to configure: CFLAGS=-m64 LDFLAGS="-m64 -L/usr/local/lib/sparcv9" # # Hack for AIX 64 bit (gcc) # Required - diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 8380db246..3c826378b 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -206,6 +206,10 @@ code to inline functions * numeric.c (cob_s32_pow, cob_s64_pow): use of register type +2023-01-16 Simon Sobisch + + * statement.def (STMT_INIT_STORAGE): new internal statement + 2023-01-15 Ron Norman * screenio.c: renamed max_pairs_available as this is defined on HPUX diff --git a/libcob/coblocal.h b/libcob/coblocal.h index fb520c5ae..eca804123 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -365,9 +365,10 @@ struct config_tbl { /* max sizes */ -/* Maximum bytes in a single/group field, - which doesn't contain UNBOUNDED items */ - /* TODO: add compiler configuration for limiting this */ +/* Maximum bytes in a single/group field and for OCCURS, + which doesn't contain UNBOUNDED items, + along with maximum number of OCCURS; + TODO: add compiler configuration for limiting this */ #ifndef COB_64_BIT_POINTER #define COB_MAX_FIELD_SIZE 268435456 #else diff --git a/libcob/common.c b/libcob/common.c index ccb9d2f0e..8a1422a54 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -6013,12 +6013,10 @@ cob_allocate (unsigned char **dataptr, cob_field *retptr, void cob_free_alloc (unsigned char **ptr1, unsigned char *ptr2) { - struct cob_alloc_cache *cache_ptr; - struct cob_alloc_cache *prev_ptr; + struct cob_alloc_cache *cache_ptr = cob_alloc_base; + struct cob_alloc_cache *prev_ptr = cob_alloc_base; cobglobptr->cob_exception_code = 0; - cache_ptr = cob_alloc_base; - prev_ptr = cob_alloc_base; if (ptr1 && *ptr1) { void *vptr1; vptr1 = *ptr1; diff --git a/libcob/common.h b/libcob/common.h index cdaf2c5ff..cddf6f72b 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -585,7 +585,8 @@ only usable with COB_USE_VC2013_OR_GREATER */ /* Maximum length of COBOL program names */ #define COB_MAX_NAMELEN 31 -/* Maximum number of subscripts */ +/* Maximum number of subscripts; + TODO: add compiler configuration for limiting this */ #define COB_MAX_SUBSCRIPTS 16 /* Memory size for sorting */ diff --git a/libcob/statement.def b/libcob/statement.def index f8cb62756..3d43f5e3d 100644 --- a/libcob/statement.def +++ b/libcob/statement.def @@ -1,5 +1,5 @@ /* - Copyright (C) 2022 Free Software Foundation, Inc. + Copyright (C) 2022-2023 Free Software Foundation, Inc. Written by Simon Sobisch This file is part of GnuCOBOL. @@ -20,9 +20,10 @@ /* COB_STATEMENT (name, string representation) - the order of these definitions may not change and - new entries must always be added to the end, as - those are used as enum entries and indexes + the order of these definitions may not change and new entries + must always be added to the end, as those are used both as enums + (cobc + libcob intern) _and_ as their integer values in generated + modules: cob_trace_statement (STMT_ADD) -> cob_trace_statement (1) */ COB_STATEMENT (STMT_ADD, "ADD") @@ -164,3 +165,6 @@ COB_STATEMENT (STMT_JSON_PARSE, "JSON GENERATE") COB_STATEMENT (STMT_XML_GENERATE, "XML GENERATE") COB_STATEMENT (STMT_XML_PARSE, "XML GENERATE") + +/* codegen intern only */ +COB_STATEMENT (STMT_INIT_STORAGE, "INIT STORAGE") diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 41e1ab0b9..3b0e33034 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -1,4 +1,4 @@ -## Copyright (C) 2003-2012, 2014-2022 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2014-2023 Free Software Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, ## Ron Norman ## @@ -349,9 +349,11 @@ AT_SETUP([LOCAL-STORAGE (3)]) AT_KEYWORDS([runmisc OCCURS INDEX INDEXED]) # Note: this tests undefined behaviour, because the initial value -# of index values are undefined, but should be identical in principle -# for LS/WS, and in the standard explicit "... is treated as a static -# item [for WS] and as an automatic item [for LS]"; see bug #794 +# of index-names are undefined per standard; where they are +# explicit defined to be "... treated as a static item [for WS] +# and as an automatic item [for LS]"; see bug #794 +# for GnuCOBOL that is defined depending on dialect options +# init-indexed-by and defaultbyte AT_DATA([callee.cob], [ IDENTIFICATION DIVISION. @@ -367,15 +369,15 @@ AT_DATA([callee.cob], [ 01 LCL-X. 05 LCL-VAR PIC 9 VALUE 0 OCCURS 1 INDEXED BY LCL-IDX. PROCEDURE DIVISION. - DISPLAY SPACE WITH NO ADVANCING. - ADD 1 to WRK-VAR(1) WRK-IDX, - LCL-VAR(1) LCL-IDX. + DISPLAY SPACE WITH NO ADVANCING UPON SYSOUT. + ADD 1 TO WRK-VAR(1) LCL-VAR(1) + SET WRK-IDX, LCL-IDX UP BY 1 SET DISP-IDX TO WRK-IDX. MOVE WRK-VAR(1) TO DISP-VAL. - DISPLAY DISP-VALS WITH NO ADVANCING. + DISPLAY DISP-VALS WITH NO ADVANCING UPON SYSOUT. SET DISP-IDX TO LCL-IDX. MOVE LCL-VAR(1) TO DISP-VAL. - DISPLAY DISP-VALS WITH NO ADVANCING. + DISPLAY DISP-VALS WITH NO ADVANCING UPON SYSOUT. GOBACK. ]) @@ -392,6 +394,37 @@ AT_DATA([caller.cob], [ AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) AT_CHECK([$COMPILE -o prog caller.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 1212 2312 3412], []) +AT_CHECK([$COMPILE_MODULE -fdefaultbyte=0 callee.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 1111 2211 3311], []) + +# note: this is the tested MF result (INDEXED BY are USAGE COMP 9(08), 0-based !): +#AT_CHECK([$COMPILE_MODULE -std=mf-strict callee.cob], [0], [], []) +#AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 1018 2117 3216], []) + +AT_DATA([callee.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 DISP-VALS. + 05 DISP-VAL PIC 9 VALUE 0. + 05 DISP-IDX PIC 9 VALUE 0. + 01 WRK-X. + 05 WRK-VAR PIC 9 VALUE 0 OCCURS 1 INDEXED BY WRK-IDX. + PROCEDURE DIVISION. + DISPLAY SPACE WITH NO ADVANCING UPON SYSOUT. + ADD 1 TO WRK-VAR(1) + SET WRK-IDX UP BY 1 + SET DISP-IDX TO WRK-IDX. + MOVE WRK-VAR(1) TO DISP-VAL. + DISPLAY DISP-VALS WITH NO ADVANCING UPON SYSOUT. + GOBACK. +]) + + +AT_CHECK([$COMPILE_MODULE -std=acu-strict callee.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 19 20 31], []) +# note: tested result with 2 byte: AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 15 26 37], []) AT_CLEANUP @@ -8896,6 +8929,10 @@ AT_DATA([prog.cob], [ MOVE "You" TO GRP-2A (1010:3) MOVE "$$" TO FLD-5-4 (5) MOVE "Something else!" TO FLD-1-X (5). + * + * "the initial value of an index-name at runtime is undefined" + * Old OpenCOBOL/GnuCOBOL did that as "1" + SET TAB-ADR-IND TO 1. * SET P2 TO NULL SET ADDRESS OF A-TABLE TO NULL @@ -8912,7 +8949,7 @@ $COBCRUN_DIRECT ./prog "param 1" param 'param 3'], [1], GRP-3:***ABC00D99D99D99D99XXABC00D99D99D99D99XXABC00D99 00D99D99XX*** GRP-5:***Mon49eyMon49eyMon49eyMon49eyMon49eyMon49eyMon49ey ], -[libcob: prog.cob:102: error: BASED/LINKAGE item 'A-TABLE' has NULL address +[libcob: prog.cob:106: error: BASED/LINKAGE item 'A-TABLE' has NULL address dump written to dumpall.txt ]) @@ -8922,7 +8959,7 @@ AT_CAPTURE_FILE([dumpall.txt]) AT_DATA([reference], [ Module dump due to BASED/LINKAGE item 'A-TABLE' has NULL address - Last statement of "prog" was MOVE at line 102 of prog.cob + Last statement of "prog" was MOVE at line 106 of prog.cob ENTRY prog at prog.cob:75 Started by ./prog param 1 @@ -11431,6 +11468,9 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION. MAIN. + *> "the initial value of an index-name at runtime is undefined" + *> Old OpenCOBOL/GnuCOBOL did that as "1" + SET REC-NAME-IDX TO 1. MOVE 'A-F-GEN-LEDGER-ZGL' TO REC-NAME. PERFORM FINDIT. MOVE 'JUNK' TO REC-NAME. diff --git a/tests/testsuite.src/run_subscripts.at b/tests/testsuite.src/run_subscripts.at index 4c0930748..d13425b85 100644 --- a/tests/testsuite.src/run_subscripts.at +++ b/tests/testsuite.src/run_subscripts.at @@ -642,7 +642,7 @@ AT_DATA([prog.cob], [ END PROGRAM SUBN. ]) -AT_CHECK([$COMPILE -x -std=mf -debug -Wall -debug -O prog.cob ], [0], [], [prog.cob:25: warning: SET TO should be an integer +AT_CHECK([$COMPILE -x -std=mf -debug -Wall -debug -fdefaultbyte=init -O prog.cob ], [0], [], [prog.cob:25: warning: SET TO should be an integer prog.cob:26: warning: source is non-numeric - substituting zero prog.cob:27: warning: SET IB2 TO 10 is out of bounds prog.cob:56: warning: SET IB1 TO -9 is out of bounds