diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 7c3581274..458977bc3 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -208,6 +208,25 @@ * codegen.c (output_perform_call): allow label end to be NULL if there is no PERFORM THRU, adjusted callers to not pass duplicate labels +2022-09-26 Simon Sobisch + + * cobc.c (cobc_abort_msg): use negative cb_source_line to reference + last known position during codegen + * codegen.c (output_stmt): store source reference if generated + statement has one attached + * codegen.c (output_standard_includes): fix bug #708 missing math + header inclusion if first program has no decimal + * codegen.c (output_data, output_call): fix bug #855 CALL generation + when using figurative constants + * codegen.c: correct use of CB_PREFIX_DECIMAL -> generated code now has + "d_" prefix instead of "d" in all places + * cobc.h, tree.h: moved some function declarations + * tree.c, tree.h (cb_literal_value), codegen.c, parser.y: moved double + and identical defined function literal_value to a single place + * codegen.c, tree.h, cobc.c: renamed cb_init_codegen + to clear_local_codegen_vars + * cobc.c: ask user for reporting reallocation memory issues + 2022-09-20 Simon Sobisch * parser.y (examine_format_variant): fix compiler warning diff --git a/cobc/cobc.c b/cobc/cobc.c index 498f2d52f..d6266ecc9 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -172,7 +172,7 @@ int errorcount = 0; int warningcount = 0; int fatal_errors_flag = 0; int no_physical_cancel = 0; -int cb_source_line = 0; +int cb_source_line = 0; /* current source line, when negative: in codegen */ int cb_saveargc = 0; int cb_keycompress_pend = 0; int cb_keycompress_ready = 0; /* Value for cb_keycompress */ @@ -629,7 +629,7 @@ cobc_free_mem (void) cobc_free (repsl); } cobc_mainmem_base = NULL; - cb_init_codegen (); + clear_local_codegen_vars (); ppp_clear_lists (); } @@ -982,7 +982,7 @@ cobc_main_realloc (void *prevptr, const size_t size) /* LCOV_EXCL_START */ if (!curr) { cobc_err_msg (_("attempt to reallocate non-allocated memory")); - cobc_abort_terminate (0); + cobc_abort_terminate (1); } /* LCOV_EXCL_STOP */ m->next = curr->next; @@ -1098,7 +1098,7 @@ cobc_parse_realloc (void *prevptr, const size_t size) /* LCOV_EXCL_START */ if (!curr) { cobc_err_msg (_("attempt to reallocate non-allocated memory")); - cobc_abort_terminate (0); + cobc_abort_terminate (1); } /* LCOV_EXCL_STOP */ m->next = curr->next; @@ -2128,13 +2128,18 @@ cobc_abort_msg (void) } else { prog_type = prog_id = (char *)_("unknown"); } - if (!cb_source_line) { - cobc_err_msg (_("aborting codegen for %s (%s: %s)"), - cb_source_file, prog_type, prog_id); - } else { + if (cb_source_line > 0) { cobc_err_msg (_("aborting compile of %s at line %d (%s: %s)"), cb_source_file, cb_source_line, prog_type, prog_id); + /* LCOV_EXCL_START */ + } else if (cb_source_line) { + cobc_err_msg (_("aborting codegen for %s, last statement at line %d (%s: %s)"), + cb_source_file, -cb_source_line, prog_type, prog_id); + } else { + cobc_err_msg (_("aborting codegen for %s (%s: %s)"), + cb_source_file, prog_type, prog_id); } + /* LCOV_EXCL_STOP */ } else { cobc_err_msg (_("aborting")); } @@ -8780,7 +8785,7 @@ process_file (struct filename *fn, int status) cobc_free (mptrt); } cobc_parsemem_base = NULL; - cb_init_codegen (); + clear_local_codegen_vars (); /* Restore default flags */ cb_odoslide = save_odoslide; } else { diff --git a/cobc/cobc.h b/cobc/cobc.h index 0fd2da136..7e6fc354b 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -643,18 +643,9 @@ extern int yylex (void); extern int yyparse (void); #endif -extern void ylex_clear_all (void); -extern void ylex_call_destroy (void); - /* typeck.c */ extern size_t suppress_warn; /* no warnings for internal generated stuff */ -/* codeoptim.c */ -extern void cob_gen_optim (const enum cb_optim); - -/* codegen.c */ -extern void cb_init_codegen (void); - /* error.c */ #define CB_MSG_STYLE_GCC 0 #define CB_MSG_STYLE_MSC 1U diff --git a/cobc/codegen.c b/cobc/codegen.c index cfb19deea..abb23ec02 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -568,7 +568,7 @@ list_cache_sort (void *inlist, int (*cmpfunc)(const void *mp1, const void *mp2)) /* Clear local variables */ void -cb_init_codegen (void) +clear_local_codegen_vars (void) { attr_cache = NULL; base_cache = NULL; @@ -1411,12 +1411,13 @@ output_data (cb_tree x) field_iteration); break; case CB_TAG_CONST: - /* LCOV_EXCL_START */ - if (x != cb_null) { - CB_TREE_TAG_UNEXPECTED_ABORT (x); + if (x == cb_null) { + output ("NULL"); + } else { + output ("("); + output_param (x, 0); + output (")->data"); } - /* LCOV_EXCL_STOP */ - output ("NULL"); break; /* LCOV_EXCL_START */ default: @@ -1918,6 +1919,16 @@ output_globext_cache (void) static void output_standard_includes (struct cb_program *prog) { + struct cb_program *p; + +#if defined (HAVE_GMP_H) + const char *math_include = "#include "; +#elif defined (HAVE_MPIR_H) + const char *math_include = "#include "; +#else +#error either HAVE_GMP_H or HAVE_MPIR_H needs to be defined +#endif + #if !defined (_GNU_SOURCE) && defined (_XOPEN_SOURCE_EXTENDED) output_line ("#ifndef\t_XOPEN_SOURCE_EXTENDED"); output_line ("#define\t_XOPEN_SOURCE_EXTENDED 1"); @@ -1935,14 +1946,12 @@ output_standard_includes (struct cb_program *prog) if (cb_flag_winmain) { output_line ("#include "); } - if (prog->decimal_index_max || prog->flag_decimal_comp) { - #if defined (HAVE_GMP_H) - output_line ("#include "); - #elif defined (HAVE_MPIR_H) - output_line ("#include "); - #else - #error either HAVE_GMP_H or HAVE_MPIR_H needs to be defined - #endif + /* check if any of the processed programs has any decimal - then include appropriate header */ + for (p = prog; p; p = p->next_program) { + if (p->decimal_index_max || p->flag_decimal_comp) { + output_line (math_include); + break; + } } output_line ("#include "); output_newline (); @@ -4348,7 +4357,7 @@ output_param (cb_tree x, int id) } break; case CB_TAG_DECIMAL: - output ("d%d", CB_DECIMAL (x)->id); + output ("%s%d", CB_PREFIX_DECIMAL, CB_DECIMAL (x)->id); break; case CB_TAG_DECIMAL_LITERAL: output ("%s%d", CB_PREFIX_DEC_CONST, CB_DECIMAL_LITERAL (x)->id); @@ -7322,8 +7331,10 @@ output_call (struct cb_call *p) } if (x == cb_null) { output ("NULL /*OMITTED*/"); - break; + } else { + output_param (x, 0); } + break; default: output ("NULL"); break; @@ -8397,13 +8408,15 @@ output_goto (struct cb_goto *p) output_block_close (); } else if (p->target == NULL || p->target == cb_int1) { - /* EXIT PROGRAM/FUNCTION */ needs_exit_prog = 1; + /* EXIT FUNCTION */ if (current_prog->prog_type == COB_MODULE_TYPE_FUNCTION) { output_line ("goto exit_function;"); + /* GOBACK (target = cb_int1), possibly implied */ } else if (p->target == cb_int1 || cb_flag_implicit_init || current_prog->nested_level) { output_line ("goto exit_program;"); + /* EXIT PROGRAM */ } else { /* Ignore if not a callee */ output_line ("if (module->next)"); @@ -9005,6 +9018,12 @@ output_stmt (cb_tree x) } } + if (x->source_line) { + cb_source_file = x->source_file; + cb_source_line = -x->source_line; + /* cb_source_column = x->source_column; */ + } + switch (CB_TREE_TAG (x)) { case CB_TAG_STATEMENT: { const struct cb_statement *p = CB_STATEMENT (x); @@ -11523,28 +11542,6 @@ output_report_source_move (struct cb_report *rep) /* Alphabet-name */ -static int -literal_value (cb_tree x) -{ - if (x == cb_space) { - return ' '; - } else if (x == cb_zero) { - return '0'; - } else if (x == cb_quote) { - return cb_flag_apostrophe ? '\'' : '"'; - } else if (x == cb_norm_low) { - return 0; - } else if (x == cb_norm_high) { - return 255; - } else if (x == cb_null) { - return 0; - } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) { - return cb_get_int (x) - 1; - } else { - return CB_LITERAL (x)->data[0]; - } -} - static void output_alphabet_name_definition (struct cb_alphabet_name *p) { @@ -11603,14 +11600,14 @@ output_class_name_definition (struct cb_class_name *p) for (l = p->list; l; l = CB_CHAIN (l)) { x = CB_VALUE (l); if (CB_PAIR_P (x)) { - lower = literal_value (CB_PAIR_X (x)); - upper = literal_value (CB_PAIR_Y (x)); + lower = cb_literal_value (CB_PAIR_X (x)); + upper = cb_literal_value (CB_PAIR_Y (x)); for (n = lower; n <= upper; ++n) { vals[n] = 1; } } else { if (CB_NUMERIC_LITERAL_P (x)) { - vals[literal_value (x)] = 1; + vals[cb_literal_value (x)] = 1; } else if (x == cb_space) { vals[' '] = 1; } else if (x == cb_zero) { @@ -12343,7 +12340,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) if (prog->decimal_index_max) { output_local ("/* Decimal structures */\n"); for (inc = 0; inc < prog->decimal_index_max; inc++) { - output_local ("cob_decimal\t*d%d = NULL;\n", inc); + output_local ("cob_decimal\t*%s%d = NULL;\n", CB_PREFIX_DECIMAL, inc); } output_local ("\n"); } @@ -12641,7 +12638,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output ("cob_decimal_alloc (%u", prog->decimal_index_max); } for (inc = 0; inc < prog->decimal_index_max; inc++) { - output (", &d%u", inc); + output (", &%s%u", CB_PREFIX_DECIMAL, inc); } output (");"); output_newline (); @@ -13002,8 +12999,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_line ("if (%s%d) {", CB_PREFIX_BASE, f->id); output_line ("\tcob_free_alloc (&%s%d, NULL);", CB_PREFIX_BASE, f->id); - output_line ("\t%s%d = NULL;", - CB_PREFIX_BASE, f->id); + output_line ("\t%s%d = NULL;", CB_PREFIX_BASE, f->id); output_line ("}"); } } @@ -13015,7 +13011,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_prefix (); output ("cob_decimal_pop (%u", prog->decimal_index_max); for (inc = 0; inc < prog->decimal_index_max; inc++) { - output (", d%u", inc); + output (", %s%u", CB_PREFIX_DECIMAL, inc); } output (");"); output_newline (); @@ -13191,7 +13187,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) seen = 1; output_line ("/* Set Decimal Constant values */"); } - output_line ("%s%d = &%s%d;", CB_PREFIX_DEC_CONST, m->id, + 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_set_field (%s%d, (cob_field *)&%s%d);", diff --git a/cobc/error.c b/cobc/error.c index 62bf3690c..15931aab7 100644 --- a/cobc/error.c +++ b/cobc/error.c @@ -53,8 +53,7 @@ print_error_prefix (const char *file, int line, const char *prefix) if (file) { if (line <= 0) { fprintf (stderr, "%s: ", file); - } else - if (cb_msg_style == CB_MSG_STYLE_MSC) { + } else if (cb_msg_style == CB_MSG_STYLE_MSC) { fprintf (stderr, "%s(%d): ", file, line); } else { fprintf (stderr, "%s:%d: ", file, line); diff --git a/cobc/parser.y b/cobc/parser.y index 763a93b24..b8ba7cb6b 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -632,28 +632,6 @@ terminator_clear (cb_tree stmt, const unsigned int termid) } } -static int -literal_value (cb_tree x) -{ - if (x == cb_space) { - return ' '; - } else if (x == cb_zero) { - return '0'; - } else if (x == cb_quote) { - return cb_flag_apostrophe ? '\'' : '"'; - } else if (x == cb_null) { - return 0; - } else if (x == cb_low) { - return 0; - } else if (x == cb_high) { - return 255; - } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) { - return cb_get_int (x); - } else { - return CB_LITERAL (x)->data[0]; - } -} - static void setup_use_file (struct cb_file *fileptr) { @@ -4831,7 +4809,7 @@ class_item: CB_LITERAL_P ($3) && CB_LITERAL ($3)->size != 1) { cb_error (_("CLASS literal with THRU must have size 1")); } - if (literal_value ($1) <= literal_value ($3)) { + if (cb_literal_value ($1) <= cb_literal_value ($3)) { $$ = CB_BUILD_PAIR ($1, $3); } else { $$ = CB_BUILD_PAIR ($3, $1); @@ -5561,11 +5539,11 @@ _suppress_clause: } | SUPPRESS WHEN ALL basic_value { - $$ = cb_int (literal_value ($4)); + $$ = cb_int (cb_literal_value ($4)); } | SUPPRESS WHEN space_or_zero { - $$ = cb_int (literal_value ($3)); + $$ = cb_int (cb_literal_value ($3)); } | SUPPRESS WHEN LITERAL { diff --git a/cobc/tree.c b/cobc/tree.c index 68525b758..003948db1 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -4328,6 +4328,29 @@ cb_build_symbolic_chars (const cb_tree sym_list, const cb_tree alphabet) } } +/* resolve literal value from tree as integer */ +int +cb_literal_value (cb_tree x) +{ + if (x == cb_space) { + return ' '; + } else if (x == cb_zero) { + return '0'; + } else if (x == cb_quote) { + return cb_flag_apostrophe ? '\'' : '"'; + } else if (x == cb_norm_low) { + return 0; + } else if (x == cb_norm_high) { + return 255; + } else if (x == cb_null) { + return 0; + } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) { + return cb_get_int (x) - 1; + } else { + return CB_LITERAL (x)->data[0]; + } +} + /* Report */ struct cb_report * diff --git a/cobc/tree.h b/cobc/tree.h index 9c01f78a8..1d231742e 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2161,6 +2161,7 @@ extern cb_tree cb_build_ml_tree (struct cb_field *, const int, cb_tree); extern cb_tree cb_build_ml_suppress_checks (struct cb_ml_generate_tree *); +extern int cb_literal_value (cb_tree); /* parser.y */ extern int non_const_word; @@ -2502,12 +2503,15 @@ extern cb_tree cobc_tree_cast_check (const cb_tree, const char *, const int, const enum cb_tag); #endif +/* codeoptim.c */ +extern void cob_gen_optim (const enum cb_optim); /* codegen.c */ extern void codegen (struct cb_program *, const char *); +extern void clear_local_codegen_vars (void); extern struct cb_field *chk_field_variable_size (struct cb_field *f); extern unsigned int chk_field_variable_address (struct cb_field *fld); -extern struct cb_field * cb_code_field (cb_tree x); +extern struct cb_field *cb_code_field (cb_tree x); extern int cb_wants_dump_comments; /* likely to be removed later */ /* scanner.l */ @@ -2523,6 +2527,10 @@ extern struct cb_program *cb_find_defined_program_by_id (const char *); extern void cb_validate_parameters_and_returning (struct cb_program *, cb_tree); extern void cb_check_definition_matches_prototype (struct cb_program *); +/* parser (in scanner.l) */ +extern void ylex_clear_all (void); +extern void ylex_call_destroy (void); + /* cobc.c */ #ifndef COB_EXTERNAL_XREF #define COB_INTERNAL_XREF diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index bbc56de7a..69e316eaa 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -878,22 +878,28 @@ AT_CLEANUP ## OCCURS clause -AT_SETUP([Level 01 subscripts]) -AT_KEYWORDS([runmisc]) +AT_SETUP([OCCURS on level 01]) +AT_KEYWORDS([runmisc VALUE SET ADDRESS]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 X PIC X OCCURS 10. + 01 X PIC X OCCURS 10 VALUE "A". + LINKAGE SECTION. + 01 X-ALL PIC X(10). PROCEDURE DIVISION. + INITIALIZE X(1) X(3) X(5) X(7) + MOVE ZERO TO X(2) X(4) X(6) X(8) + SET ADDRESS OF X-ALL TO ADDRESS OF X(1) + IF X-ALL NOT = " 0 0 0 0AA" + DISPLAY X-ALL UPON SYSERR STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -std=cobol2014 prog.cob], [1], [], -[prog.cob:6: error: 01/77 OCCURS does not conform to COBOL 2014 -]) +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], []) AT_CLEANUP @@ -6748,6 +6754,46 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP +AT_SETUP([compilation-group with decimal]) +AT_KEYWORDS([runmisc function numval]) + +# bug 708 - decimal codegen in generated header when only +# a later program (nested/contained) has decimals + +AT_DATA([prog.cob], [ + identification division. + program-id. cbug. + procedure division. + mainline. + call 'bug' + goback + . + end program cbug. + * + identification division. + program-id. bug. + data division. + working-storage section. + 01 pw pic 9(02). + 01 px pic x value '3'. + procedure division. + mainline. + compute pw = function numval(px). + if pw <> 3 + display 'bad calc: ' pw. + goback + . + end program bug. +]) + +# we're mostly interested in the codegen, but as we have compiled +# that we can execute it, too +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + AT_SETUP([C/C++ reserved words/predefined identifiers]) AT_KEYWORDS([runmisc])