diff --git a/ChangeLog b/ChangeLog index d6ea24103..bd816f51d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -3,15 +3,24 @@ * configure.ac: replace AC_ARG_VAR by AC_SUBST where appropriate -2023-07-24 Simon Sobisch - - * configure.ac: fix for resolving COBCRUN_NAME - 2024-05-14 David Declerck * configure.ac: update flags for building dynamic libraries on macOS (helps fixing testsuite issues on recent macOS versions) +2023-08-22 Simon Sobisch + + * configure.ac: add -fstack-clash-protection to --enable-hardening[=no] + +2023-07-28 Simon Sobisch + + * configure.ac, NEWS: updated for 3.2 + * configure.ac: check for mousemask and mmask_t + +2023-07-24 Simon Sobisch + + * configure.ac: fix for resolving COBCRUN_NAME + 2023-05-25 Chuck Haatvedt * configure.ac: added test for HAVE_RESIZE_TERM function @@ -1682,7 +1691,7 @@ * Version 0.9 released. -Copyright 2002-2023 Free Software Foundation, Inc. +Copyright 2002-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/NEWS b/NEWS index 8154630e9..4ff27fce3 100644 --- a/NEWS +++ b/NEWS @@ -94,7 +94,39 @@ Open Plans: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - GnuCOBOL 3.2 + GnuCOBOL 3.3 (planned January 2023) + + work in progress + +* New GnuCOBOL features + +** cobc now checks for binary files and early exit parsing those; + the error output for format errors (for example invalid indicator column) + is now limitted to 5 per source file + + more work in progress + +* Important Bugfixes + +** #904: MOVE PACKED-DECIMAL unsigned to signed led to bad sign + +* Changes to the COBOL compiler (cobc) options: + +** output of unlimited errors may be requested by -fmax-errors=0, + to stop compiliation at first error use -Wfatal-errors +** default value for -fmax-errors was changed from 128 to 20 + +* More notable changes + +** execution times were significantly reduced for the following: + INSPECT CONVERTING (and "simple" INSPECT REPLACING), in general + and especially if both from and to are constants + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + GnuCOBOL 3.2 (20230728) + GnuCOBOL 3.2rc1 (20230118) + GnuCOBOL 3.2rc2 (20230210) * New GnuCOBOL features @@ -436,7 +468,7 @@ Open Plans: ** the -P flag accepts - as argument for stdout -* Important Bugfixes: +* Important Bugfixes ** for dialects other than the GnuCOBOL default different reserved "alias" words were not usable, for example SYNCHRONIZED or COMPUTATIONAL. This was fixed diff --git a/build_windows/config.h.in b/build_windows/config.h.in index bae1a2791..b389ad811 100644 --- a/build_windows/config.h.in +++ b/build_windows/config.h.in @@ -411,6 +411,9 @@ /* #undef HAVE_ATTRIBUTE_CONSTRUCTOR - using DllMain */ #endif +/* Has __attribute__((pure)) */ +/* #undef HAVE_ATTRIBUTE_PURE */ + /* Define to 1 if you have the `canonicalize_file_name' function. */ #if defined(__ORANGEC__) #define HAVE_CANONICALIZE_FILE_NAME 1 @@ -659,6 +662,13 @@ /* #undef HAVE_MOUSEINTERVAL */ #endif +/* curses has mousemask function and mmask_t definition */ +#if CONFIGURED_CURSES != NOCURSES +#define HAVE_MOUSEMASK 1 +#else +/* #undef HAVE_MOUSEMASK */ +#endif + /* Define to 1 if you have the header file. */ #if USED_MATHLIB == MATHLIB_MPIR #define HAVE_MPIR_H 1 diff --git a/cobc/ChangeLog b/cobc/ChangeLog index dcaf54268..a47365521 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -36,10 +36,52 @@ * typeck.c (cb_emit, cb_emit_list): changed from defines to inline functions, now returning the tree that was emitted +2023-09-12 Simon Sobisch + + * codegen.c (literal_list): removed self-reference as tree + * replace.c (ppecho_replace): now inline + * replace.c (cb_free_replace): removed setting child to zero before free + * replace.c: style adjustment + +2023-09-07 Simon Sobisch + + * typeck.c (cb_build_converting): protoype (disabled) to pre-generate + conversion table and call new function cob_inspect_translating instead + of cob_inspect_converting if both operands are literals/alphabets + +2023-09-06 Simon Sobisch + + * typeck.c (validate_inspect): check for identical operands, + check for invalid combination of operands + * typeck.c (cb_build_converting): shortcut when identical operands + are used + * tree.h: change alphabet_target and alphabet_type from defines to enums + 2023-09-01 Simon Sobisch + * pplex.l (ppopen_get_file): test for binary file and directly error out + * cobc.c (cobc_terminate_exit), cobc.h: split cobc_terminate and make + the new function available + * pplex.l: check for format errors per file and skip format related + warnings if the file reached a max. of 5 such errors * error.c, cobc.c (print_program_trailer), flag.def: implemented -fmax-errors=0 as unlimited + * flag.def (max_errors): reduced default from 128 to 20 + * config.c (cb_load_conf), error.c (configuration_error): count missing + definitions as single error + * cobc.c (process_command_line): passing -O0 by defaut for -g as some + C compilers raise warnings otherwise, breaking the testsuite + +2023-08-25 Simon Sobisch + + * codeoptim.c (cob_gen_optim): fixed to actually skip leading zeros + for COB_GET_NUMDISP and COB_GET_NUMDISPS + +2023-08-22 Simon Sobisch + + * typeck.c (emit_definition_note): renamed from warning_destination + * typeck.c (emit_definition_note), tree.h (cb_field): prevent output + of the same field multiple times by new flag_had_definition_note 2023-07-26 Simon Sobisch diff --git a/cobc/cobc.c b/cobc/cobc.c index 3a290de56..e8368b694 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -2256,18 +2256,18 @@ set_listing_date (void) LISTING_TIMESTAMP_FORMAT, ¤t_compile_tm); } - -DECLNORET static void COB_A_NORETURN -cobc_terminate (const char *str) +void +cobc_terminate_exit (const char *filename, const char *error) { if (cb_src_list_file) { set_listing_date (); set_standard_title (); cb_listing_linecount = cb_lines_per_page; - cobc_elided_strcpy (cb_listing_filename, str, sizeof (cb_listing_filename), 0); + cobc_elided_strcpy (cb_listing_filename, filename, sizeof (cb_listing_filename), 0); print_program_header (); } - cb_perror (0, "cobc: %s: %s", str, cb_get_strerror ()); + cb_source_line = 0; /* no context output for fatal open input/output errors */ + cb_perror (0, "cobc: %s: %s", filename, error); if (cb_src_list_file) { print_program_trailer (); } @@ -2275,6 +2275,12 @@ cobc_terminate (const char *str) exit (EXIT_FAILURE); } +DECLNORET static void COB_A_NORETURN +cobc_terminate (const char *filename) +{ + cobc_terminate_exit (filename, cb_get_strerror ()); +} + static void cobc_abort_msg (void) { @@ -3284,6 +3290,10 @@ process_command_line (const int argc, char **argv) #ifdef COB_DEBUG_FLAGS COBC_ADD_STR (cobc_cflags, " ", cobc_debug_flags, NULL); #endif + if (copt == NULL) { + /* some compilers warn if not explicit passed, so default to -O0 for -g */ + copt = CB_COPT_0; + } break; case 'G': diff --git a/cobc/cobc.h b/cobc/cobc.h index f14538442..e0d27b4dd 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -628,6 +628,8 @@ extern void cb_add_error_to_listing (const char *, int, const char *, char *); DECLNORET extern void flex_fatal_error (const char *, const char *, const int) COB_A_NORETURN; +DECLNORET extern void cobc_terminate_exit (const char *, const char *) COB_A_NORETURN; + extern void cobc_set_listing_header_code (void); /* reserved.c */ diff --git a/cobc/codegen.c b/cobc/codegen.c index 42849c1c5..227f0efae 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -104,7 +104,6 @@ struct attr_list { struct literal_list { struct literal_list *next; struct cb_literal *literal; - cb_tree x; int id; int make_decimal; }; @@ -720,7 +719,12 @@ output_string (const unsigned char *s, const int size, const cob_u32_t llit) } else #endif if (!isprint (c)) { +#if 1 /* octal */ output ("\\%03o", c); +#else /* hex (can be useful for a small amount of non-printable characters, + but gets really uggly if the string has a lot of those */ + output ("\" \"\\x%X\" \"", c); +#endif } else if (c == '\"') { output ("\\%c", c); } else if ((c == '\\' || c == '?') && !llit) { @@ -825,7 +829,7 @@ chk_field_variable_address (struct cb_field *fld) if (!cb_odoslide) return 0; if (!fld->flag_vaddr_done) { - /* Note: this is called _very_ often and takes 15-20% of parse + codegen time, + /* Note: this was called _very_ often and took 15-20% of parse + codegen time, with about half the time in chk_field_variable_size; so try to not call this function if not necessary (according to the testsuite: as long as cb_odoslide is not set, but the caller's coverage is not that well...) */ @@ -833,10 +837,9 @@ chk_field_variable_address (struct cb_field *fld) struct cb_field *p; for (p = f->parent; p; f = f->parent, p = f->parent) { for (p = p->children; p != f; p = p->sister) { - /* Skip PIC L fields as their representation - have constant length */ - if (p->depending || - (!p->flag_picture_l && chk_field_variable_size (p))) { + if (p->depending /* ODO leads to variable size */ + || (!p->flag_picture_l && chk_field_variable_size (p)) /* skipping PIC L fields */ + ) { fld->flag_vaddr_done = 1; fld->vaddr = 1; return 1; @@ -3177,7 +3180,7 @@ output_literals_figuratives_and_constants (void) for (lit = literal_cache; lit; lit = lit->next) { output ("static const cob_field %s%d\t= ", CB_PREFIX_CONST, lit->id); - output_field (lit->x); + output_field (CB_TREE(lit->literal)); output (";"); output_newline (); } @@ -3379,7 +3382,6 @@ cb_lookup_literal (cb_tree x, int make_decimal) l->id = cb_literal_id; l->literal = literal; l->make_decimal = make_decimal; - l->x = x; l->next = literal_cache; literal_cache = l; @@ -5579,8 +5581,8 @@ output_initialize_uniform (cb_tree x, struct cb_field *f, output_size (x); output (");"); } else if (!gen_init_working - && (f->flag_unbounded || !(cb_complex_odo || cb_odoslide)) - && chk_field_variable_size (f) != NULL) { + && (f->flag_unbounded || !(cb_complex_odo || cb_odoslide)) + && chk_field_variable_size (f) != NULL) { out_odoslide_size (f); output (");"); } else { @@ -13568,7 +13570,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) /* Check matching version */ #if !defined (HAVE_ATTRIBUTE_CONSTRUCTOR) #ifdef _WIN32 - if (prog->flag_main) /* otherwise we generate that in DllMain*/ + if (prog->flag_main) /* otherwise we generate that in DllMain */ #else if (!prog->nested_level) #endif @@ -13667,8 +13669,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) seen = 0; for (m = literal_cache; m; m = m->next) { - if (CB_TREE_CLASS (m->x) == CB_CLASS_NUMERIC - && m->make_decimal) { + if (m->make_decimal) { if (!seen) { seen = 1; output_line ("/* Set Decimal Constant values */"); @@ -13887,8 +13888,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_line ("P_clear_decimal:"); seen = 0; for (m = literal_cache; m; m = m->next) { - if (CB_TREE_CLASS (m->x) == CB_CLASS_NUMERIC - && m->make_decimal) { + if (m->make_decimal) { if (!seen) { seen = 1; output_line ("/* Clear Decimal Constant values */"); @@ -14972,8 +14972,7 @@ codegen_finalize (void) struct literal_list* m; int comment_gen = 0; for (m = literal_cache; m; m = m->next) { - if (CB_TREE_CLASS (m->x) == CB_CLASS_NUMERIC - && m->make_decimal) { + if (m->make_decimal) { if (!comment_gen) { comment_gen = 1; output_storage ("\n/* Decimal constants */\n"); diff --git a/cobc/codeoptim.c b/cobc/codeoptim.c index 30a731c47..92e1cf8a7 100644 --- a/cobc/codeoptim.c +++ b/cobc/codeoptim.c @@ -235,18 +235,14 @@ cob_gen_optim (const enum cb_optim val) output_storage (" register int n;"); output_storage (" register int val = 0;"); /* Improve performance by skipping leading ZEROs */ - output_storage (" for (n = 0; n < val; ++n, ++p) {"); + output_storage (" for (n = 0; n < size; ++n) {"); output_storage (" if (*p > '0' && *p <= '9')"); output_storage (" break;"); - output_storage (" }"); - /* Improve performance by skipping leading ZEROs */ - output_storage (" for (n = 0; n < size; ++n, ++p) {"); - output_storage (" if (*p > '0' && *p <= '9')"); - output_storage (" break;"); + output_storage (" p++;"); output_storage (" }"); output_storage (" for (; n < size; ++n, ++p) {"); - output_storage (" val = (val * 10)"); - output_storage (" + ((*p > '0' && *p <= '9') ? (*p - '0') : 0);"); + output_storage (" val = (val * 10)"); + output_storage (" + ((*p > '0' && *p <= '9') ? (*p - '0') : 0);"); output_storage (" }"); output_storage (" return val;"); output_storage ("}"); @@ -260,20 +256,22 @@ cob_gen_optim (const enum cb_optim val) output_storage (" register int n;"); output_storage (" register int val = size - 1;"); /* Improve performance by skipping leading ZEROs */ - output_storage (" for (n = 0; n < val; ++n, ++p) {"); + output_storage (" for (n = 0; n < val; ++n) {"); output_storage (" if (*p > '0' && *p <= '9')"); output_storage (" break;"); + output_storage (" p++;"); output_storage (" }"); output_storage (" val = 0;"); - output_storage (" for (; n < size; ++n, ++p) {"); - output_storage (" val *= 10;"); - output_storage (" if (*p > '0' && *p <= '9') {"); - output_storage (" val += (*p - '0');"); - output_storage (" } else if ((*p & 0x40) && (n + 1) == size) {"); - output_storage (" val += (*p & 0x0F);"); - output_storage (" val = -val;"); - output_storage (" }"); - output_storage (" }"); + output_storage (" for (; n < size; ++n, ++p) {"); + output_storage (" val *= 10;"); + output_storage (" if (*p > '0' && *p <= '9') {"); + output_storage (" val += (*p - '0');"); + output_storage (" } else if ((*p & 0x40) && (n + 1) == size) {"); + output_storage (" val += (*p & 0x0F);"); + output_storage (" val = -val;"); + output_storage (" }"); + output_storage (" }"); + output_storage (" return val;"); output_storage ("}"); return; @@ -282,18 +280,18 @@ cob_gen_optim (const enum cb_optim val) output_storage ("static cob_s64_t COB_INLINE COB_A_INLINE"); output_storage ("cob_get_numdisp64 (const void *data, const int size)"); output_storage ("{"); - output_storage (" register const unsigned char *p;"); + output_storage (" register const unsigned char *p = (const unsigned char *)data;"); output_storage (" register int n;"); output_storage (" register cob_s64_t val = 0;"); - output_storage (" p = (const unsigned char *)data;"); - /* Improve performance by skipping leading ZEROs */ - output_storage (" for (n = 0; n < size; ++n, ++p) {"); + /* Improve performance by skipping leading ZEROs */ + output_storage (" for (n = 0; n < size; ++n) {"); output_storage (" if (*p > '0' && *p <= '9')"); - output_storage (" break;"); + output_storage (" break;"); + output_storage (" p++;"); output_storage (" }"); output_storage (" for (; n < size; ++n, ++p) {"); - output_storage (" val = (val * 10)"); - output_storage (" + ((*p > '0' && *p <= '9') ? (*p - '0') : 0);"); + output_storage (" val = (val * 10)"); + output_storage (" + ((*p > '0' && *p <= '9') ? (*p - '0') : 0);"); output_storage (" }"); output_storage (" return val;"); output_storage ("}"); @@ -303,25 +301,25 @@ cob_gen_optim (const enum cb_optim val) output_storage ("static cob_s64_t COB_INLINE COB_A_INLINE"); output_storage ("cob_get_numdisps64 (const void *data, const int size)"); output_storage ("{"); - output_storage (" register const unsigned char *p;"); + output_storage (" register const unsigned char *p = (const unsigned char *)data;"); output_storage (" register cob_s64_t n;"); output_storage (" register cob_s64_t val = size - 1;"); - output_storage (" p = (const unsigned char *)data;"); - /* Improve performance by skipping leading ZEROs */ - output_storage (" for (n = 0; n < val; ++n, ++p) {"); + /* Improve performance by skipping leading ZEROs */ + output_storage (" for (n = 0; n < val; ++n) {"); output_storage (" if (*p > '0' && *p <= '9')"); output_storage (" break;"); + output_storage (" p++;"); output_storage (" }"); output_storage (" val = 0;"); - output_storage (" for (; n < size; ++n, ++p) {"); - output_storage (" val *= 10;"); - output_storage (" if (*p > '0' && *p <= '9') {"); - output_storage (" val += (*p - '0');"); - output_storage (" } else if ((*p & 0x40) && (n + 1) == size) {"); - output_storage (" val += (*p & 0x0F);"); - output_storage (" val = -val;"); - output_storage (" }"); - output_storage (" }"); + output_storage (" for (; n < size; ++n, ++p) {"); + output_storage (" val *= 10;"); + output_storage (" if (*p > '0' && *p <= '9') {"); + output_storage (" val += (*p - '0');"); + output_storage (" } else if ((*p & 0x40) && (n + 1) == size) {"); + output_storage (" val += (*p & 0x0F);"); + output_storage (" val = -val;"); + output_storage (" }"); + output_storage (" }"); output_storage (" return val;"); output_storage ("}"); return; diff --git a/cobc/config.c b/cobc/config.c index cf690fe8b..83ff709f7 100644 --- a/cobc/config.c +++ b/cobc/config.c @@ -451,7 +451,7 @@ cb_load_conf (const char *fname, const int prefix_dir) /* Checks for missing definitions */ if (ret == 0) { - for (i = 10U; i < CB_CONFIG_SIZE; i++) { + for (i = 10; i < CB_CONFIG_SIZE; i++) { #if COBC_STORES_CONFIG_VALUES if (config_table[i].val == NULL) { #else @@ -461,7 +461,7 @@ cb_load_conf (const char *fname, const int prefix_dir) if (ret == 0) { configuration_error (fname, 0, 1, _("missing definitions:")); } - configuration_error (fname, 0, 1, _("\tno definition of '%s'"), + configuration_error (fname, 0, 2, _("\tno definition of '%s'"), config_table[i].name); ret = -1; } @@ -623,8 +623,15 @@ cb_config_entry (char *buff, const char *fname, const int line) snprintf (buff, (size_t)COB_NORMAL_MAX, "%s.words", val); /* check if name.words exists and store the resolved name to words_file */ if (cb_load_conf_file (buff, CB_INCLUDE_RESOLVE_WORDS) != 0) { +#if 0 + /* must be executed before anything that may adjust errno, ... + ...like function call below. */ + const char *errno_str = cb_get_strerror (); configuration_error (fname, line, 1, _("Could not access word list for '%s'"), val); - /*cb_perror (1, "%s: %s", words_file, cb_get_strerror ()); */ + cb_perror (1, "%s: %s", words_file, errno_str); +#else + configuration_error (fname, line, 1, _("Could not access word list for '%s'"), val); +#endif return -1; }; } diff --git a/cobc/error.c b/cobc/error.c index 98461073b..7dcc3b004 100644 --- a/cobc/error.c +++ b/cobc/error.c @@ -553,7 +553,7 @@ cb_perror (const int config_error, const char *fmt, ...) va_list ap; if (config_error) { - configuration_error_head(); + configuration_error_head (); } va_start (ap, fmt); @@ -721,7 +721,7 @@ configuration_error (const char *fname, const int line, putc ('\n', stderr); fflush (stderr); - if (sav_lst_file) { + if (sav_lst_file || finish_error == 2) { return; } @@ -1227,7 +1227,7 @@ ambiguous_error (cb_tree x) /* error routine for flex */ void -flex_fatal_error (const char *msg, const char * filename, const int line_num) +flex_fatal_error (const char *msg, const char *filename, const int line_num) { /* LCOV_EXCL_START */ cobc_err_msg (_("fatal error: %s"), msg); diff --git a/cobc/field.c b/cobc/field.c index f30d20c62..c16f740d3 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -416,8 +416,6 @@ cb_build_field_tree (const int level, cb_tree name, struct cb_field *last_field, struct cb_reference *r; struct cb_field *f; struct cb_field *p; - struct cb_field *field_fill; - cb_tree dummy_fill; cb_tree l; cb_tree x; int lv; @@ -452,6 +450,7 @@ cb_build_field_tree (const int level, cb_tree name, struct cb_field *last_field, } else { f->level = lv; } + /* copy EXTERNAL / GLOBAL attribute from file to record */ if (storage == CB_STORAGE_FILE && fn && f->level == 01) { if (fn->flag_external) { f->flag_external = 1; @@ -527,7 +526,8 @@ cb_build_field_tree (const int level, cb_tree name, struct cb_field *last_field, last_field->children = f; f->parent = last_field; } else if (f->level == last_field->level) { - /* Same level */ + /* Same level; note: + last_field is a group if coming from "goto" */ same_level: last_field->sister = f; f->parent = last_field->parent; @@ -545,8 +545,8 @@ cb_build_field_tree (const int level, cb_tree name, struct cb_field *last_field, /* always generate dummy filler field to prevent parsing of follow-on fields to fail the same way */ if (p) /* <- silence warnings */ { - dummy_fill = cb_build_filler (); - field_fill = CB_FIELD (cb_build_field (dummy_fill)); + cb_tree dummy_fill = cb_build_filler (); + struct cb_field *field_fill = CB_FIELD (cb_build_field (dummy_fill)); field_fill->level = f->level; field_fill->flag_filler = 1; field_fill->storage = storage; @@ -1253,7 +1253,7 @@ create_implicit_picture (struct cb_field *f) && !f->flag_usage_defined) { for (p = f->parent; p; p = p->parent) { if (p->flag_usage_defined - && (p->usage == CB_USAGE_FLOAT + && (p->usage == CB_USAGE_FLOAT || p->usage == CB_USAGE_DOUBLE || p->usage == CB_USAGE_POINTER || p->usage == CB_USAGE_INDEX)) { @@ -1568,7 +1568,7 @@ validate_pic (struct cb_field *f) } if (f->pic && f->pic->size > f->size) - f->size = f->pic->size; + f->size = f->pic->size; } /* ACUCOBOL/RM-COBOL-style COMP-1 ignores the PICTURE clause. */ @@ -2379,7 +2379,7 @@ validate_elementary_item (struct cb_field *f) pstr->times_repeated = 1; ++pstr; } - } + } x = CB_TREE (f); switch (f->usage) { @@ -2660,7 +2660,7 @@ setup_parameters (struct cb_field *f) case CB_USAGE_COMP_N: f->flag_real_binary = 1; case CB_USAGE_COMP_5: - if (f->pic + if (f->pic && f->pic->orig && f->pic->orig[0] == 'X') { f->usage = CB_USAGE_COMP_X; @@ -3001,7 +3001,7 @@ compute_size (struct cb_field *f) c->offset = c->redefines->offset; compute_size (c); /* Increase the size if redefinition is larger */ - if (c->level != 66 + if (c->level != 66 && c->size * c->occurs_max > c->redefines->size * c->redefines->occurs_max) { if (cb_verify_x (CB_TREE (c), cb_larger_redefines, _("larger REDEFINES"))) { @@ -3076,7 +3076,7 @@ compute_size (struct cb_field *f) if (c->size == 2 || c->size == 4) { align_size = c->size; - } else if (c->size == 8 + } else if (c->size == 8 || c->size == 16) { if (cb_binary_size == CB_BINARY_SIZE_2_4_8) { if (c->usage == CB_USAGE_DOUBLE) @@ -3365,8 +3365,8 @@ compute_size (struct cb_field *f) } } - if (f->storage == CB_STORAGE_LOCAL - || f->storage == CB_STORAGE_LINKAGE + if (f->storage == CB_STORAGE_LOCAL + || f->storage == CB_STORAGE_LINKAGE || f->flag_item_based) { /* Can not depend on the data being aligned */ } else @@ -3594,8 +3594,8 @@ cb_validate_field (struct cb_field *f) } /* Set up parameters */ - if (f->storage == CB_STORAGE_LOCAL - || f->storage == CB_STORAGE_LINKAGE + if (f->storage == CB_STORAGE_LOCAL + || f->storage == CB_STORAGE_LINKAGE || f->flag_item_based) { f->flag_local = 1; } diff --git a/cobc/flag.def b/cobc/flag.def index 46cbb2cb6..54e291b08 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -56,10 +56,10 @@ CB_FLAG_RQ (cb_fold_call, 1, "fold-call", 0, CB_FLAG_GETOPT_FOLD_CALL, _(" -ffold-call=[UPPER|LOWER]\tfold PROGRAM-ID, CALL, CANCEL subject to value\n" " * default: no transformation")) -CB_FLAG_RQ (cb_max_errors, 1, "max-errors", 128, CB_FLAG_GETOPT_MAX_ERRORS, +CB_FLAG_RQ (cb_max_errors, 1, "max-errors", 20, CB_FLAG_GETOPT_MAX_ERRORS, _(" -fmax-errors=\tmaximum number of errors to report before\n" " compilation is aborted\n" - " * default: 128\n" + " * default: 20\n" " * if is 0, there's no limit")) /* Flags with required parameter and no associated variable */ diff --git a/cobc/parser.y b/cobc/parser.y index 2e4784061..5b370fafa 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -371,8 +371,8 @@ build_colseq_tree (const char *alphabet_name, int alphabet_target) { const cb_tree name = cb_build_reference (alphabet_name); - struct cb_alphabet_name * alpha; - alpha = CB_ALPHABET_NAME (cb_build_alphabet_name (name)); + struct cb_alphabet_name *alpha + = CB_ALPHABET_NAME (cb_build_alphabet_name (name)); alpha->alphabet_type = alphabet_type; alpha->alphabet_target = alphabet_target; return name; @@ -399,7 +399,6 @@ build_colseq (enum cb_colseq colseq) COBC_ABORT (); } /* LCOV_EXCL_STOP */ - } diff --git a/cobc/pplex.l b/cobc/pplex.l index f800499a2..ae8f40073 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -121,6 +121,7 @@ struct copy_info { int line; int quotation_mark; int source_format; + int indicator_error; }; struct plex_stack { @@ -151,6 +152,7 @@ static int listing_line = 0; static int requires_listing_line; static enum cb_format source_format = CB_FORMAT_AUTO; static int indicator_column = 7; +static int indicator_error = 0; static int text_column = 72; /* end of area B (in single-byte characters) */ static int floating_area_b = 0; /* whether indicator is optional */ @@ -1293,24 +1295,58 @@ ppopen_get_file (const char *name) /* Check for BOM and, if source-format was not specified, also for free-form */ { - int fseek_to = 0 ; + unsigned char fseek_to = 0 ; #define COBC_LOOKAHEAD 20 unsigned char buffer[COBC_LOOKAHEAD]; - int nread = fread (buffer, 1, COBC_LOOKAHEAD, ppin); + const int nread = fread (buffer, 1, COBC_LOOKAHEAD, ppin); /* check for and skip UTF-8 BOM */ if (nread >= 3 && buffer[0] == 0xEF && buffer[1] == 0xBB && buffer[2] == 0xBF) { fseek_to = 3; + } else + /* check for binary */ + if (nread > 5) { +#if 0 + if ((buffer[0] == 0x7F && buffer[1] == 0x45 && buffer[2] == 0x4C + && buffer[3] == 0x46 && (buffer[4] & 0xF0) == 0x00 /* ELF */) + || (buffer[0] == 0x4D && buffer[1] == 0x5A && buffer[3] == 0x00 + && (buffer[4] & 0xF0) == 0x00 /* PE */)) { + cb_error ("%s: %s", name, _("source file is binary")); + close (ppin); + return 0; + } +#endif + { + int chck_pos = nread - 2; + while (chck_pos > 0) { + unsigned char test = buffer[chck_pos--]; + if (test != 0x00 && test != 0x80 && test != 0x90) { + continue; + } + test = buffer[chck_pos--]; + if (test == 0x00 || test == 0x80 || test == 0x90) { + /* two consecutive NULL / invalid ASCII/EBCDIC -> must be binary */ + fclose (ppin); + ppin = NULL; + if (cb_source_line == 0) { + /* if this is a "main" source, terminate with an error */ + cobc_terminate_exit (name, _("source file is binary")); + } + cb_error ("%s: %s", name, _("source file is binary")); + return 0; + } + } + } } /* try to deduce source format */ if (source_format == CB_FORMAT_AUTO) { - int pos = fseek_to; + unsigned char pos = fseek_to; /* if indicator is wrong on first line with source, switch to free format */ /* skip empty lines */ char last_pos_7 = ' '; - int amount_of_0a_seen = 0; - int line_pos = 0; + unsigned char amount_of_0a_seen = 0; + unsigned char line_pos = 0; while (nread - pos > 7) { switch (buffer[pos]) { case '\r': @@ -1321,7 +1357,7 @@ ppopen_get_file (const char *name) break; case '\t': buffer[pos] = ' '; - line_pos++; + line_pos++; /* move test from run_extensions.at 1809 to -fformat */ while (line_pos % cb_tab_width != 0) { line_pos++; } @@ -1404,6 +1440,7 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) current_copy_info->line = cb_source_line; current_copy_info->quotation_mark = quotation_mark; current_copy_info->source_format = cobc_get_source_format (); + current_copy_info->indicator_error = indicator_error; current_copy_info->next = copy_stack; current_copy_info->containing_files = old_list_file; @@ -1439,7 +1476,8 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) #endif /* switch to new buffer */ - switch_to_buffer (1, dname, yy_create_buffer (ppin, YY_BUF_SIZE)); + switch_to_buffer (1, current_copy_info->dname, yy_create_buffer (ppin, YY_BUF_SIZE)); + indicator_error = 0; /* postponed errror handling */ if (!ppin) { @@ -1632,7 +1670,7 @@ ppcopy (const char *name, const char *lib, struct cb_replace_list *replace_list) /* expected case: filename found */ if (filename) { if (ppopen (filename, replace_list) == 0) { - /* expected case: copybook could be processed */ + /* expected case: copybook could be processed */ return 0; } /* otherwise fall-trough to error handling */ @@ -2531,9 +2569,18 @@ start: break; } /* Invalid indicator */ - cb_plex_error (newline_count, - _("invalid indicator '%c' at column %d"), - buff[indicator_column - 1], indicator_column); + if (indicator_error++ < 5) { + cb_plex_error (newline_count, + _("invalid indicator '%c' at column %d"), + buff[indicator_column - 1], indicator_column); + } + if (indicator_error == 5) { + int sav_line = cb_source_line; + cb_source_line = 0; + cb_error (_("too many format errors in file, skip output of further errors")); + cb_source_line = sav_line; + } + /* Note: Treat as comment line to allow further parsing instead of aborting compilation */ newline_count++; @@ -2590,8 +2637,16 @@ start: if (bp[0] == quotation_mark && bp[1] == quotation_mark) { bp++; } else { - cb_plex_error (newline_count, + if (indicator_error++ < 5) { + cb_plex_error (newline_count, _("invalid line continuation")); + } + if (indicator_error == 5) { + int sav_line = cb_source_line; + cb_source_line = 0; + cb_error (_("too many format errors in file, skip output of further errors")); + cb_source_line = sav_line; + } return YY_NULL; } quotation_mark = 0; @@ -2601,16 +2656,33 @@ start: if (*bp == quotation_mark) { bp++; } else { - cb_plex_error (newline_count, + if (indicator_error++ < 5) { + cb_plex_error (newline_count, _("invalid line continuation")); + } + if (indicator_error == 5) { + int sav_line = cb_source_line; + cb_source_line = 0; + cb_error (_("too many format errors in file, skip output of further errors")); + cb_source_line = sav_line; + } return YY_NULL; } } } else { /* Normal line */ if (need_continuation) { - cb_plex_error (newline_count, + /* CHECKME: close the last literal */ + if (indicator_error++ < 5) { + cb_plex_error (newline_count, _("continuation character expected")); + } + if (indicator_error == 5) { + int sav_line = cb_source_line; + cb_source_line = 0; + cb_error (_("too many format errors in file, skip output of further errors")); + cb_source_line = sav_line; + } need_continuation = 0; } quotation_mark = 0; diff --git a/cobc/replace.c b/cobc/replace.c index 49e28619e..cabaa372d 100644 --- a/cobc/replace.c +++ b/cobc/replace.c @@ -200,7 +200,7 @@ static struct cb_replacement_state * replace_repls; static struct cb_replacement_state * copy_repls; /* forward definitions */ -static void ppecho_replace (WITH_DEPTH const char *text, const char* token); +static COB_INLINE COB_A_INLINE void ppecho_replace (WITH_DEPTH const char *text, const char* token); static void do_replace (WITH_DEPTH struct cb_replacement_state* repls); static void check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls); static void check_replace_all (WITH_DEPTH struct cb_replacement_state *repls, @@ -220,8 +220,7 @@ token_list_add (WITH_DEPTH struct cb_token_list *list, adding on the same head, other `last` fields in the middle of the list not being correctly updated... */ -static -struct cb_token_list * +static struct cb_token_list * token_list_add (WITH_DEPTH struct cb_token_list *list, const char *text, const char *token) { @@ -250,8 +249,8 @@ token_list_add (WITH_DEPTH struct cb_token_list *list, } } -static -void pop_token (WITH_DEPTH struct cb_replacement_state *repls, +static void +pop_token (WITH_DEPTH struct cb_replacement_state *repls, const char **text, const char **token) { const struct cb_token_list *q = repls->token_queue; @@ -264,8 +263,8 @@ void pop_token (WITH_DEPTH struct cb_replacement_state *repls, if (token) *token = q->token; } -static -void ppecho_switch (WITH_DEPTH struct cb_replacement_state *repls, +static void +ppecho_switch (WITH_DEPTH struct cb_replacement_state *repls, const char* text, const char* token) { #ifdef DEBUG_REPLACE_TRACE @@ -283,8 +282,8 @@ void ppecho_switch (WITH_DEPTH struct cb_replacement_state *repls, } } -static -void ppecho_switch_text_list (WITH_DEPTH struct cb_replacement_state *repls, +static void +ppecho_switch_text_list (WITH_DEPTH struct cb_replacement_state *repls, const struct cb_text_list *p) { #ifdef DEBUG_REPLACE_TRACE @@ -298,8 +297,8 @@ void ppecho_switch_text_list (WITH_DEPTH struct cb_replacement_state *repls, } -static -void ppecho_switch_token_list (WITH_DEPTH struct cb_replacement_state *repls, +static void +ppecho_switch_token_list (WITH_DEPTH struct cb_replacement_state *repls, const struct cb_token_list *p) { #ifdef DEBUG_REPLACE_TRACE @@ -312,8 +311,8 @@ void ppecho_switch_token_list (WITH_DEPTH struct cb_replacement_state *repls, } } -static -int is_leading_or_trailing (WITH_DEPTH int leading, +static int +is_leading_or_trailing (WITH_DEPTH int leading, const char* src_text, const char* text, int strict) @@ -342,8 +341,8 @@ int is_leading_or_trailing (WITH_DEPTH int leading, /* after a LEADING or TRAILING match, perform the replacement within the text, and pass the resulting new text to the next stream */ -static -void ppecho_leading_or_trailing (WITH_DEPTH struct cb_replacement_state *repls, +static void +ppecho_leading_or_trailing (WITH_DEPTH struct cb_replacement_state *repls, int leading, const char *src_text, const char *text, @@ -384,8 +383,8 @@ void ppecho_leading_or_trailing (WITH_DEPTH struct cb_replacement_state *repls, * * `replace_list`: the current list of possible replacements on check */ -static -void check_replace (WITH_DEPTH struct cb_replacement_state* repls, +static void +check_replace (WITH_DEPTH struct cb_replacement_state* repls, const struct cb_replace_list *replace_list) { #ifdef DEBUG_REPLACE_TRACE @@ -471,8 +470,8 @@ is_space_or_nl (const char c) * * `src` is the list of texts from the replacement to be matched * * `replace_list` is the next replacements to try in case of failure */ -static -void check_replace_all (WITH_DEPTH +static void +check_replace_all (WITH_DEPTH struct cb_replacement_state *repls, const struct cb_text_list *new_text, struct cb_token_list *texts, @@ -553,8 +552,8 @@ void check_replace_all (WITH_DEPTH } } -static -void check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls) +static void +check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls) { #ifdef DEBUG_REPLACE_TRACE fprintf (stderr, "%scheck_replace_after_match(%s)\n", @@ -574,8 +573,8 @@ void check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls) } } -static -void do_replace (WITH_DEPTH struct cb_replacement_state* repls) +static void +do_replace (WITH_DEPTH struct cb_replacement_state* repls) { #ifdef DEBUG_REPLACE_TRACE fprintf (stderr, "%sdo_replace(%s)\n",DEPTH, repls->name); @@ -599,34 +598,39 @@ void do_replace (WITH_DEPTH struct cb_replacement_state* repls) } /* Whether a word matches the definition of WORD in pplex.l */ -static -int is_word (WITH_DEPTH const char* s) { - int i; - size_t len = strlen (s); +static int +is_word (WITH_DEPTH const char *s) { + for (;;) { + unsigned char c = (unsigned char) *s++; - for (i = 0; i= '0' && c <= '9' ) || ( c >= 'A' && c <= 'Z' ) || ( c >= 'a' && c <= 'z' ) - || ( c >= 128 && c <= 255 ) ) { - /* word character, just go on */ - } else { + || ( c >= 128) ) { + continue; + } + + /* end of string, no previous bad character -> is a word */ + if (c == 0) { #ifdef DEBUG_REPLACE_TRACE - fprintf (stderr, "%sis_word('%s') -> 0\n", DEPTH, s); + fprintf (stderr, "%sis_word('%s') -> 1\n", DEPTH, s); #endif - return 0; + return 1; } - } + + /* string 's' contains non-word characters -> isn't a word */ #ifdef DEBUG_REPLACE_TRACE - fprintf (stderr, "%sis_word('%s') -> 1\n", DEPTH, s); + fprintf (stderr, "%sis_word('%s') -> 0\n", DEPTH, s); #endif - return 1; + return 0; + } } -static void add_text_to_replace (WITH_DEPTH struct cb_replacement_state *repls, +static void +add_text_to_replace (WITH_DEPTH struct cb_replacement_state *repls, int prequeue, const char* text, const char* token ) { @@ -690,7 +694,8 @@ static void add_text_to_replace (WITH_DEPTH struct cb_replacement_state *repls, stream). Use prequeue = 1 so that texts of the same kind are merged into a single text. */ -static void ppecho_replace (WITH_DEPTH const char *text, const char *token) +static void +ppecho_replace (WITH_DEPTH const char *text, const char *token) { #ifdef DEBUG_REPLACE fprintf (stderr, "%sppecho_replace('%s')\n", DEPTH, text); @@ -702,7 +707,8 @@ static void ppecho_replace (WITH_DEPTH const char *text, const char *token) pplex.l). Use prequeue = 0 as texts of the same kind from the source file should not be merged. */ -void cb_ppecho_copy_replace (const char *text, const char *token) +void +cb_ppecho_copy_replace (const char *text, const char *token) { #ifdef DEBUG_REPLACE fprintf (stderr, "cb_ppecho_copy_replace('%s')\n", text); @@ -711,12 +717,11 @@ void cb_ppecho_copy_replace (const char *text, const char *token) } -static -struct cb_replacement_state * create_replacements (enum cb_ppecho ppecho) +static struct cb_replacement_state * +create_replacements (enum cb_ppecho ppecho) { - struct cb_replacement_state * s; - - s = cobc_malloc (sizeof(struct cb_replacement_state)); + struct cb_replacement_state *s + = cobc_malloc (sizeof(struct cb_replacement_state)); s->text_prequeue = NULL; s->token_queue = NULL; @@ -735,48 +740,46 @@ struct cb_replacement_state * create_replacements (enum cb_ppecho ppecho) return s; } -static void reset_replacements (struct cb_replacement_state * s) +#if 0 /* no use in just setting the child elements to zero */ +static void +reset_replacements (struct cb_replacement_state * s) { s->text_prequeue = NULL; s->token_queue = NULL; - s->replace_list = NULL ; - s->current_list = NULL ; + s->replace_list = NULL; + s->current_list = NULL ; } - -static -void init_replace( void ) -{ -#ifdef DEBUG_REPLACE_TRACE - for(int i=0; ireplace_list ; } @@ -784,10 +787,11 @@ struct cb_replace_list *cb_get_copy_replacing_list (void) /* Called by pplex.l, either at the end of a file to restore the previous stack of active copy-replacing, or when a new file is open to set additional copy replacing */ -void cb_set_copy_replacing_list (struct cb_replace_list *list) +void +cb_set_copy_replacing_list (struct cb_replace_list *list) { copy_repls->current_list = NULL; - copy_repls->replace_list = list ; + copy_repls->replace_list = list; #ifdef DEBUG_REPLACE fprintf (stderr, "set_copy_replacing_list(\n"); for(;list != NULL; list=list->next){ diff --git a/cobc/tree.h b/cobc/tree.h index 95ff84d5d..4fd76801e 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -140,18 +140,22 @@ enum cb_tag { }; /* Alphabet target */ -#define CB_ALPHABET_ALPHANUMERIC 0 -#define CB_ALPHABET_NATIONAL 1 +enum cb_alphabet_target { + CB_ALPHABET_ALPHANUMERIC = 0, + CB_ALPHABET_NATIONAL = 1 +}; /* Alphabet type */ -#define CB_ALPHABET_NATIVE 0 -#define CB_ALPHABET_ASCII 1 -#define CB_ALPHABET_EBCDIC 2 -#define CB_ALPHABET_CUSTOM 3 -#define CB_ALPHABET_LOCALE 4 -#define CB_ALPHABET_UTF_8 5 -#define CB_ALPHABET_UTF_16 6 -#define CB_ALPHABET_UCS_4 7 +enum cb_alphabet_type { + CB_ALPHABET_NATIVE = 0, + CB_ALPHABET_ASCII = 1, + CB_ALPHABET_EBCDIC = 2, + CB_ALPHABET_CUSTOM = 3, + CB_ALPHABET_LOCALE = 4, + CB_ALPHABET_UTF_8 = 5, + CB_ALPHABET_UTF_16 = 6, + CB_ALPHABET_UCS_4 = 7 +}; /* Call convention bits */ /* Bit number Meaning Value */ @@ -324,46 +328,46 @@ enum cb_storage { /* Field types */ enum cb_usage { - CB_USAGE_BINARY = 0, /* 0 */ - CB_USAGE_BIT, /* 1 */ - CB_USAGE_COMP_5, /* 2 */ - CB_USAGE_COMP_X, /* 3 */ - CB_USAGE_DISPLAY, /* 4 */ - CB_USAGE_FLOAT, /* 5 */ - CB_USAGE_DOUBLE, /* 6 */ - CB_USAGE_INDEX, /* 7 */ - CB_USAGE_NATIONAL, /* 8 */ - CB_USAGE_OBJECT, /* 9 */ - CB_USAGE_PACKED, /* 10 */ - CB_USAGE_POINTER, /* 11 */ - CB_USAGE_LENGTH, /* 12 */ - CB_USAGE_PROGRAM_POINTER, /* 13 */ - CB_USAGE_UNSIGNED_CHAR, /* 14 */ - CB_USAGE_SIGNED_CHAR, /* 15 */ - CB_USAGE_UNSIGNED_SHORT, /* 16 */ - CB_USAGE_SIGNED_SHORT, /* 17 */ - CB_USAGE_UNSIGNED_INT, /* 18 */ - CB_USAGE_SIGNED_INT, /* 19 */ - CB_USAGE_UNSIGNED_LONG, /* 20 */ - CB_USAGE_SIGNED_LONG, /* 21 */ - CB_USAGE_COMP_6, /* 22 */ - CB_USAGE_FP_DEC64, /* 23 */ - CB_USAGE_FP_DEC128, /* 24 */ - CB_USAGE_FP_BIN32, /* 25 */ - CB_USAGE_FP_BIN64, /* 26 */ - CB_USAGE_FP_BIN128, /* 27 */ - CB_USAGE_LONG_DOUBLE, /* 28 */ - CB_USAGE_HNDL, /* 29 */ - CB_USAGE_HNDL_WINDOW, /* 30 */ - CB_USAGE_HNDL_SUBWINDOW, /* 31 */ - CB_USAGE_HNDL_FONT, /* 32 */ - CB_USAGE_HNDL_THREAD, /* 33 */ - CB_USAGE_HNDL_MENU, /* 34 */ - CB_USAGE_HNDL_VARIANT, /* 35 */ - CB_USAGE_HNDL_LM, /* 36 */ - CB_USAGE_COMP_N, /* 37 */ - CB_USAGE_CONTROL, /* 38 */ - CB_USAGE_ERROR /* 39, always last */ + CB_USAGE_BINARY = 0, + CB_USAGE_BIT, + CB_USAGE_COMP_5, + CB_USAGE_COMP_X, + CB_USAGE_DISPLAY, + CB_USAGE_FLOAT, + CB_USAGE_DOUBLE, + CB_USAGE_INDEX, + CB_USAGE_NATIONAL, + CB_USAGE_OBJECT, + CB_USAGE_PACKED, + CB_USAGE_POINTER, + CB_USAGE_LENGTH, + CB_USAGE_PROGRAM_POINTER, + CB_USAGE_UNSIGNED_CHAR, + CB_USAGE_SIGNED_CHAR, + CB_USAGE_UNSIGNED_SHORT, + CB_USAGE_SIGNED_SHORT, + CB_USAGE_UNSIGNED_INT, + CB_USAGE_SIGNED_INT, + CB_USAGE_UNSIGNED_LONG, + CB_USAGE_SIGNED_LONG, + CB_USAGE_COMP_6, + CB_USAGE_FP_DEC64, + CB_USAGE_FP_DEC128, + CB_USAGE_FP_BIN32, + CB_USAGE_FP_BIN64, + CB_USAGE_FP_BIN128, + CB_USAGE_LONG_DOUBLE, + CB_USAGE_HNDL, + CB_USAGE_HNDL_WINDOW, + CB_USAGE_HNDL_SUBWINDOW, + CB_USAGE_HNDL_FONT, + CB_USAGE_HNDL_THREAD, + CB_USAGE_HNDL_MENU, + CB_USAGE_HNDL_VARIANT, + CB_USAGE_HNDL_LM, + CB_USAGE_COMP_N, + CB_USAGE_CONTROL, + CB_USAGE_ERROR /* always last */ }; @@ -707,8 +711,8 @@ struct cb_alphabet_name { const char *name; /* Original name */ char *cname; /* Name used in C */ cb_tree custom_list; /* Custom ALPHABET / LOCALE reference */ - unsigned int alphabet_target; /* ALPHANUMERIC or NATIONAL */ - unsigned int alphabet_type; /* ALPHABET type */ + enum cb_alphabet_target alphabet_target; /* ALPHANUMERIC or NATIONAL */ + enum cb_alphabet_type alphabet_type; /* ALPHABET type */ int low_val_char; /* LOW-VALUE */ int high_val_char; /* HIGH-VALUE */ int values[256]; /* Collating values */ @@ -983,7 +987,7 @@ struct cb_field { unsigned int flag_field : 1; /* Has been internally cached */ unsigned int flag_chained : 1; /* CHAINING item */ unsigned int flag_data_set : 1; /* The data address was set in entry code */ - unsigned int flag_is_verified : 1; /* Has been verified */ + unsigned int flag_is_typedef : 1; /* TYPEDEF */ unsigned int flag_is_c_long : 1; /* Is BINARY-C-LONG */ unsigned int flag_is_pdiv_parm : 1; /* Is PROC DIV USING */ unsigned int flag_is_pdiv_opt : 1; /* Is PROC DIV USING OPTIONAL */ @@ -1031,9 +1035,11 @@ struct cb_field { unsigned int flag_occurs_multi_col: 1; /* OCCURS and multi COLUMNs reported */ unsigned int flag_set_col_offset: 1; /* offset was set based on COLUMN */ - unsigned int flag_is_typedef : 1; /* TYPEDEF */ unsigned int flag_picture_l : 1; /* Is USAGE PICTURE L */ unsigned int flag_comp_1 : 1; /* Is USAGE COMP-1 */ + unsigned int flag_is_verified : 1; /* Has been verified */ + + unsigned int flag_had_definition_note : 1; /* had its defintion output */ }; #define CB_FIELD(x) (CB_TREE_CAST (CB_TAG_FIELD, struct cb_field, x)) @@ -1244,7 +1250,7 @@ struct cb_reference { cb_tree value; /* Item referred to */ cb_tree subs; /* List of subscripts */ cb_tree offset; /* Reference mod offset */ - cb_tree length; /* Reference mod length */ + cb_tree length; /* Reference mod length, only set if offset set */ cb_tree check; /* Runtime checks */ enum cob_statement statement; /* statement that uses this reference */ struct cb_word *word; /* Pointer to word list */ diff --git a/cobc/typeck.c b/cobc/typeck.c index 7ea71c7b5..39e9e7714 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2570,7 +2570,7 @@ cb_build_name_reference (struct cb_field *f1, struct cb_field *f2) static void refmod_checks (cb_tree x, struct cb_field *f, struct cb_reference *r) { - const char *name = r->word->name; + const char *name = r->word->name; const int adjusted_at_runtime = -1; int offset; int length; @@ -3626,7 +3626,7 @@ items_have_same_data_clauses (const struct cb_field * const field_1, } } else { /* only one has any length -> ensure it is the prototype and - that the othr has the same numeric/nonnumeric type */ + that the other has the same numeric/nonnumeric type */ if (!field_1->flag_any_length) { return 1; } @@ -6263,9 +6263,9 @@ cb_build_expr (cb_tree list) } v = CB_VALUE (l); if (op == 'x') { - if( has_var && v == cb_zero ){ - has_rel = 1; - } + if (has_var && v == cb_zero) { + has_rel = 1; + } has_var = 1; if (CB_TREE_TAG (v) == CB_TAG_BINARY_OP) { has_rel = 1; @@ -6273,7 +6273,7 @@ cb_build_expr (cb_tree list) if (CB_TREE_TAG (v) == CB_TAG_FUNCALL) { has_rel = 1; } else - if (CB_REF_OR_FIELD_P (v)) { + if (CB_REF_OR_FIELD_P (v)) { f = CB_FIELD_PTR (v); if (f->level == 88) { has_rel = 1; @@ -6696,18 +6696,18 @@ decimal_expand (cb_tree d, cb_tree x) } break; case CB_TAG_REFERENCE: - /* Set d, X */ + /* set d, X */ f = CB_FIELD_PTR (x); /* Check numeric */ if (cb_flag_correct_numeric && f->usage == CB_USAGE_DISPLAY) { cb_emit (CB_BUILD_FUNCALL_1 ("cob_correct_numeric", x)); } if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE)) { - if (f->usage == CB_USAGE_DISPLAY || - f->usage == CB_USAGE_PACKED || - f->usage == CB_USAGE_COMP_6) { + if (f->usage == CB_USAGE_DISPLAY + || f->usage == CB_USAGE_PACKED + || f->usage == CB_USAGE_COMP_6) { dpush (CB_BUILD_FUNCALL_2 ("cob_check_numeric", - x, CB_BUILD_STRING0 (f->name))); + x, CB_BUILD_STRING0 (f->name))); } } decimal_align (); @@ -6958,8 +6958,8 @@ cb_emit_arithmetic (cb_tree vars, const int op, cb_tree val) cb_tree l; cb_emit_incompat_data_checks (x); for (l = vars; l; l = CB_CHAIN (l)) { - const cb_tree target = CB_VALUE(l); - const cb_tree round_and_trunc = CB_PURPOSE(l); + const cb_tree target = CB_VALUE (l); + const cb_tree round_and_trunc = CB_PURPOSE (l); cb_emit_incompat_data_checks (target); switch (op) { case '+': @@ -6978,6 +6978,7 @@ cb_emit_arithmetic (cb_tree vars, const int op, cb_tree val) } cb_emit_list (vars); cb_check_list (vars); + return; } else { cb_check_list (vars); if (op == 0 @@ -6990,8 +6991,10 @@ cb_emit_arithmetic (cb_tree vars, const int op, cb_tree val) cb_emit (cb_build_assign (CB_VALUE (vars), val)); return; } - cb_emit_list (build_decimal_assign (vars, op, x)); } + + /* no optimization - needs decimal */ + cb_emit_list (build_decimal_assign (vars, op, x)); } /* Condition */ @@ -8608,15 +8611,15 @@ cb_emit_accept (cb_tree var, cb_tree pos, struct cb_attr_struct *attr_ptr) cb_tree cursor = NULL; /* CURSOR (position within the field) */ cob_flags_t disp_attrs = 0; - if (current_program->flag_screen) { #ifndef WITH_EXTENDED_SCREENIO - if (!warn_screen_done) { - warn_screen_done = 1; - cb_warning (cb_warn_unsupported, - _("runtime is not configured to support %s"), "SCREEN SECTION"); + if (current_program->flag_screen) { + if (!warn_screen_done) { + warn_screen_done = 1; + cb_warning (cb_warn_unsupported, + _("runtime is not configured to support %s"), "SCREEN SECTION"); + } } #endif - } if (cb_validate_one (var)) { return; } @@ -8689,7 +8692,8 @@ cb_emit_accept (cb_tree var, cb_tree pos, struct cb_attr_struct *attr_ptr) } if (CB_REF_OR_FIELD_P (var) && CB_FIELD_PTR (var)->storage == CB_STORAGE_SCREEN) { - output_screen_from (CB_FIELD_PTR (var), 0); + struct cb_field *var_field = CB_FIELD_PTR (var); + output_screen_from (var_field, 0); gen_screen_ptr = 1; if (pos) { if (CB_LIST_P (pos)) { @@ -8709,7 +8713,7 @@ cb_emit_accept (cb_tree var, cb_tree pos, struct cb_attr_struct *attr_ptr) cb_int (line_col_zero_is_supported ()))); } gen_screen_ptr = 0; - output_screen_to (CB_FIELD (cb_ref (var)), 0); + output_screen_to (var_field, 0); return; } } @@ -10713,14 +10717,12 @@ cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value, } } -static size_t calc_reference_size (cb_tree xr) +static size_t +calc_reference_size (cb_tree xr, cb_tree ref) { - cb_tree ref = cb_ref (xr); - if (ref == cb_error_node) { - return 0; - } - if (CB_REF_OR_FIELD_P (ref)) { - struct cb_reference *r = CB_REFERENCE (xr); + if (CB_FIELD_P (ref)) { + const struct cb_reference *r = CB_REFERENCE (xr); + const struct cb_field *f = CB_FIELD (ref); if (r->offset) { if (r->length) { if (CB_LITERAL_P (r->length)) { @@ -10728,12 +10730,11 @@ static size_t calc_reference_size (cb_tree xr) } } else { if (CB_LITERAL_P (r->offset)) { - return (size_t)CB_FIELD_PTR (xr)->size - - cb_get_int (r->offset) + 1; + return f->size - cb_get_int (r->offset) + 1; } } } else { - return CB_FIELD_PTR (xr)->size; + return f->size; } } else if (CB_ALPHABET_NAME_P (ref)) { return 256; @@ -10744,15 +10745,25 @@ static size_t calc_reference_size (cb_tree xr) /* INSPECT statement */ -static void +/* validating FROM and TO references and their size to be matching + returns non-zero on error */ +static int validate_inspect (cb_tree x, cb_tree y, const unsigned int replacing_or_converting) { - size_t size1; - size_t size2; + cb_tree refx = NULL, refy = NULL; + int size1, size2; + + const enum cb_tag tag_x = CB_TREE_TAG (x); + const enum cb_tag tag_y = CB_TREE_TAG (y); - switch (CB_TREE_TAG(x)) { + /* get FROM size */ + switch (tag_x) { case CB_TAG_REFERENCE: - size1 = calc_reference_size (x); + refx = cb_ref (x); + if (refx == cb_error_node) { + return -1; + } + size1 = calc_reference_size (x, refx); break; case CB_TAG_LITERAL: size1 = CB_LITERAL(x)->size; @@ -10764,29 +10775,69 @@ validate_inspect (cb_tree x, cb_tree y, const unsigned int replacing_or_converti size1 = 0; break; } - if (size1) { - switch (CB_TREE_TAG(y)) { - case CB_TAG_REFERENCE: - size2 = calc_reference_size (y); - break; - case CB_TAG_LITERAL: - size2 = CB_LITERAL(y)->size; - break; - /* note: in case of CONST the original size is used */ - default: - size2 = 0; - break; + + /* get TO size for comparison with FROM size */ + switch (tag_y) { + case CB_TAG_REFERENCE: + refy = cb_ref (y); + if (refy == cb_error_node) { + return -1; } - if (size2 && size1 != size2) { + size2 = calc_reference_size (y, refy); + /* check for identical reference */ + if (refx == refy) { if (replacing_or_converting == 1) { - cb_error_x (CB_TREE (current_statement), - _("%s operands differ in size"), "REPLACING"); + cb_warning_x (COBC_WARN_FILLER, CB_TREE (current_statement), + _("%s operands are the same"), "REPLACING"); + return 0; } else { - cb_error_x (CB_TREE (current_statement), - _("%s operands differ in size"), "CONVERTING"); + cb_warning_x (COBC_WARN_FILLER, CB_TREE (current_statement), + _("%s operands are the same"), "CONVERTING"); + return 2; /* converting without change, decrease to no-op */ } } + break; + case CB_TAG_LITERAL: + size2 = CB_LITERAL (y)->size; + break; + case CB_TAG_CONST: + /* note: in case of CONST (like SPACES or LOW-VALUES) + the original size is used in libcob */ + /* Fall-through */ + default: + size2 = 0; + break; } + + if (tag_y != CB_TAG_CONST + && size1 != size2) { + if (replacing_or_converting == 1) { + cb_error_x (CB_TREE (current_statement), + _("%s operands incompatible"), "REPLACING"); + } else { + cb_error_x (CB_TREE (current_statement), + _("%s operands incompatible"), "CONVERTING"); + } + cb_note_x (COB_WARNOPT_NONE, CB_TREE (current_statement), + _("operands differ in size")); + return 1; + } + + if (tag_x == CB_TAG_LITERAL + && tag_y == CB_TAG_LITERAL + && memcmp (CB_LITERAL (x)->data, CB_LITERAL (y)->data, size1) == 0) { + if (replacing_or_converting == 1) { + cb_warning_x (COBC_WARN_FILLER, CB_TREE (current_statement), + _ ("%s operands are the same"), "REPLACING"); + return 0; + } else { + cb_warning_x (COBC_WARN_FILLER, CB_TREE (current_statement), + _ ("%s operands are the same"), "CONVERTING"); + return 2; /* converting without change, decrease to no-op */ + } + } + + return 0; } static void @@ -10949,35 +11000,164 @@ cb_build_replacing_characters (cb_tree x, cb_tree l) cb_tree cb_build_replacing_all (cb_tree x, cb_tree y, cb_tree l) { - validate_inspect (x, y, 1); + (void) validate_inspect (x, y, 1); return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_all", y, x)); } cb_tree cb_build_replacing_leading (cb_tree x, cb_tree y, cb_tree l) { - validate_inspect (x, y, 1); + (void) validate_inspect (x, y, 1); return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_leading", y, x)); } cb_tree cb_build_replacing_first (cb_tree x, cb_tree y, cb_tree l) { - validate_inspect (x, y, 1); + (void) validate_inspect (x, y, 1); return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_first", y, x)); } cb_tree cb_build_replacing_trailing (cb_tree x, cb_tree y, cb_tree l) { - validate_inspect (x, y, 1); + (void) validate_inspect (x, y, 1); return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_trailing", y, x)); } +/* pre-filled conversion table */ +static const unsigned char char_tab_0x00_to_0xff[256] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, + 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, + 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, + 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, + 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, + 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, + 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 +}; + cb_tree cb_build_converting (cb_tree x, cb_tree y, cb_tree l) { - validate_inspect (x, y, 2); + const enum cb_tag tag_x = CB_TREE_TAG (x); + const enum cb_tag tag_y = CB_TREE_TAG (y); + + const int ret = validate_inspect (x, y, 2); + if (ret) { + /* assume 2 - if there was another one (=error) we don't use the tree below */ + /* identical FROM/TO - we still need the func call if the variable + is signed-numeric and not sign separate, but don't need to convert anything */ + /* FIXME: add test case ! */ + return cb_list_add (l, CB_BUILD_FUNCALL_0 ("cob_inspect_finish")); + } + +#if 0 /* Simon: unfinished prototype, get back to it later */ + if (tag_x == tag_y) { + switch (tag_x) { + case CB_TAG_LITERAL: + { + unsigned char conv_tab[256]; + const struct cb_literal *lit_x = CB_LITERAL (x); + const unsigned char *conv_to = (tag_y == CB_TAG_CONST) + ? (unsigned char *)CB_CONST (y)->val + : CB_LITERAL (y)->data; + const unsigned char *conv_from = lit_x->data; + const unsigned char *const conv_from_end = conv_from + lit_x->size; + char conv_set[256] = { 0 }; + + /* pre-fill conversion table */ + memcpy (conv_tab, char_tab_0x00_to_0xff, 256); + /* update conversion table with from/to, skipping duplicates */ + while (conv_from < conv_from_end) { + if (conv_set[*conv_from] == 0) { + conv_set[*conv_from] = 1; + conv_tab[*conv_from] = *conv_to; + } + conv_from++; + if (tag_y != CB_TAG_CONST) { + conv_to++; + } + } + /* TODO: not use an alphanumeric literal - generates a cob_field + for the call - possibly a new type that will be used with an own prefix + for generating general collation, too */ + return cb_list_add (l, + CB_BUILD_FUNCALL_1 ("cob_inspect_translating", + cb_build_alphanumeric_literal (conv_tab, 256))); + } + break; + case CB_TAG_REFERENCE: + if (CB_ALPHABET_NAME_P (cb_ref (x)) + && CB_ALPHABET_NAME_P (cb_ref (y))) { + const struct cb_alphabet_name *alph_x = CB_ALPHABET_NAME (cb_ref (x)); + const struct cb_alphabet_name *alph_y = CB_ALPHABET_NAME (cb_ref (y)); + + /* TODO: see note above */ + if ( (alph_x->alphabet_type == CB_ALPHABET_EBCDIC + && alph_y->alphabet_type == CB_ALPHABET_ASCII) + || (alph_y->alphabet_type == CB_ALPHABET_EBCDIC + && alph_x->alphabet_type == CB_ALPHABET_ASCII)) { + /* use the existing and configurable translation table */ + return cb_list_add (l, + CB_BUILD_FUNCALL_1 ("cob_inspect_translating", CB_TREE (alph_y))); + } else { + + // TODO: create conversion tab + struct cb_alphabet_name *alph_conv; + char conv_name[COB_MAX_WORDLEN * 2 + 2 + 1] = { 0 }; + unsigned int i; + + const int *conv_to = alph_y->values; + const int *conv_from = alph_x->values; + /* note: after (validate_alphabet) we have an entry of 256 integer elements */ + const int *const conv_from_end = conv_from + 256; + char conv_set[256] = { 0 }; + + strcat (conv_name, alph_x->name); + strcat (conv_name, "--"); + strcat (conv_name, alph_y->name); + alph_conv = CB_ALPHABET_NAME (cb_build_alphabet_name (cb_build_reference (conv_name))); + + alph_conv->alphabet_type = CB_ALPHABET_CUSTOM; + + /* setup conversion table with from/to, skipping duplicates */ + while (conv_from < conv_from_end) { + const unsigned char to = (unsigned char) *conv_to; + if (conv_set[to] == 0) { + conv_set[to] = 1; + alph_conv->values[to] = *conv_from; + } + conv_from++; + conv_to++; + } + for (i = 0; i < 256; i++) { + if (conv_set[i] == 0) { + alph_conv->values[i] = i; + } + } + return cb_list_add (l, + CB_BUILD_FUNCALL_1 ("cob_inspect_translating", CB_TREE (alph_conv))); + } + + } + break; + default: + cobc_err_msg (_("call to '%s' with invalid parameter '%s'"), + "cb_build_converting", "x"); + CB_TREE_TAG_UNEXPECTED_ABORT (x); + } + } +#endif + return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_converting", x, y)); } @@ -10990,7 +11170,7 @@ cb_build_inspect_region_start (void) /* MOVE statement */ static void -warning_destination (const enum cb_warn_opt warning_opt, cb_tree x) +emit_definition_note (const enum cb_warn_opt warning_opt, cb_tree x) { struct cb_field *f; const char *usage; @@ -11006,10 +11186,15 @@ warning_destination (const enum cb_warn_opt warning_opt, cb_tree x) f = CB_FIELD (x); } else { cobc_err_msg (_("call to '%s' with invalid parameter '%s'"), - "warning_destination", "x"); + "emit_definition_note", "x"); CB_TREE_TAG_UNEXPECTED_ABORT (x); } + if (f->flag_had_definition_note) { + return; + } + f->flag_had_definition_note = 1; + #if 1 /* FIXME: this is wrong, should be removed and register building be adjusted, for example ACU has RETURN-CODE as SIGNED-LONG, EXTERNAL */ if (f->flag_internal_register) { @@ -11083,7 +11268,7 @@ move_warning (cb_tree src, cb_tree dst, const unsigned int value_flag, /* note: src_flag is -1 for numeric literals, contains literal size otherwise */ if (!CB_LITERAL_P (src)) { - warning_destination (warning_opt, src); + emit_definition_note (warning_opt, src); } else if (src_flag == -1) { if (CB_LITERAL_P (src)) { if (CB_LITERAL (src)->size < 40) { @@ -11109,7 +11294,7 @@ move_warning (cb_tree src, cb_tree dst, const unsigned int value_flag, _("value size is %d"), src_flag); } } - warning_destination (warning_opt, dst); + emit_definition_note (warning_opt, dst); } } @@ -13317,6 +13502,7 @@ cb_check_move (cb_tree src, cb_tree dsts, const int emit_error) x = CB_VALUE (l); if (CB_LITERAL_P (x) || CB_CONST_P (x)) { if (emit_error) { + /* this may should be raised in the parser already */ cb_error_x (CB_TREE (current_statement), _("invalid MOVE target: %s"), cb_name (x)); @@ -13345,7 +13531,7 @@ cb_emit_move (cb_tree src, cb_tree dsts) return; } - /* Validate source, if requested. */ + /* validate / fix-up source, if requested */ cb_emit_incompat_data_checks (src); /* FIXME: this is way to much to cater for sum field */ @@ -14261,7 +14447,7 @@ cb_emit_set_to (cb_tree vars, cb_tree src) return; } - /* Validate source, if requested. */ + /* validate / fix-up source, if requested */ cb_emit_incompat_data_checks (src); /* Emit statements. */ diff --git a/config/ChangeLog b/config/ChangeLog index a59f82c20..1ac29c6d2 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -8,6 +8,10 @@ * runtime.cfg: dropped not available "varfix_format", see "fixrel_format" instead; minor reformatting/rewording +2023-09-19 Simon Sobisch + + * rm-strict.conf (perform-osvs): enabled as noted in MF docs + 2023-06-25 Chuck Haatvedt FR #439: dialect option to support justify for IBM compatibility diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 733d2cc86..e1907407d 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -118,7 +118,8 @@ ref-mod-zero-length: no # Perform type OSVS - If yes, the exit point of any currently # executing perform is recognized if reached. -perform-osvs: no # TO-DO: Any potentially undefined (i.e. overlapping) PERFORMS prohibited (see p. 374) +perform-osvs: yes # according to MF docs; +# CHECKME: R/M docs say (see p. 374) "Any potentially undefined (i.e. overlapping) PERFORMS prohibited" # Compute intermediate decimal results like IBM OSVS arithmetic-osvs: no diff --git a/configure.ac b/configure.ac index 21d012a63..2f3e9c46a 100644 --- a/configure.ac +++ b/configure.ac @@ -186,6 +186,7 @@ AH_TEMPLATE([HAVE_RESIZE_TERM], [curses has resize_term function]) AH_TEMPLATE([HAVE_DEFINE_KEY], [curses has define_key function]) AH_TEMPLATE([HAVE_MOUSEINTERVAL], [curses has mouseinterval function]) AH_TEMPLATE([HAVE_HAS_MOUSE], [curses has has_mouse function]) +AH_TEMPLATE([HAVE_MOUSEMASK], [curses has mousemask function and mmask_t definition]) AH_TEMPLATE([HAVE_CURSES_FREEALL], [curses provides function to free all memory]) AH_TEMPLATE([HAVE_USE_LEGACY_CODING], [ncurses has use_legacy_coding function]) AH_TEMPLATE([HAVE_DESIGNATED_INITS], [Has designated initializers]) @@ -213,7 +214,9 @@ AC_ARG_ENABLE([debug], AC_ARG_ENABLE([hardening], [AS_HELP_STRING([--enable-hardening, --disable-hardening], - [Enable GNU C "hardening" options: define _FORTIFY_SOURCE and use -fstack-protector. + [Enable GNU C "hardening" options: define _FORTIFY_SOURCE and use, + depending on the availability -fstack-protector-strong / -fstack-protector, + as well as -fstack-clash-protection. If disabled, these are explicit removed from CFLAGS for building GnuCOBOL. Defaults to "defined by CFLAGS".])],, [enable_hardening="unset"]) @@ -1567,6 +1570,28 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then [AC_DEFINE([HAVE_HAS_MOUSE], [1]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no])], []) + + AC_MSG_CHECKING([for curses mousemask function and mmask_t]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([[ + #ifdef HAVE_NCURSESW_NCURSES_H + #include + #elif defined (HAVE_NCURSESW_CURSES_H) + #include + #elif defined (HAVE_NCURSES_H) + #include + #elif defined (HAVE_NCURSES_NCURSES_H) + #include + #elif defined (HAVE_PDCURSES_H) + #include + #elif defined (HAVE_CURSES_H) + #include + #endif]], [[ + mmask_t dummy = { 0 }; + mousemask (dummy, NULL); + ]])], + [AC_DEFINE([HAVE_MOUSEMASK], [1]) AC_MSG_RESULT([yes])], + [AC_MSG_RESULT([no])], + []) fi LIBS="$curr_libs $LIBCOB_LIBS" @@ -2368,11 +2393,25 @@ AS_IF([test "$enable_hardening" = yes], [ [CFLAGS="$curr_cflags"; cob_temp_flags=""; AC_MSG_RESULT([no])]) ]) if test "x$cob_temp_flags" != x; then - if test "x$COB_LDFLAGS" != x; then - COB_LDFLAGS="$COB_LDFLAGS $cob_temp_flags" - else - COB_LDFLAGS="$cob_temp_flags" - fi + if test "x$COB_LDFLAGS" != x; then + COB_LDFLAGS="$COB_LDFLAGS $cob_temp_flags" + else + COB_LDFLAGS="$cob_temp_flags" + fi + curr_cflags="$curr_cflags $cob_temp_flags" + fi + cob_temp_flags="-fstack-clash-protection" + CFLAGS="$curr_cflags $cob_temp_flags $ERRWARN" + AC_MSG_CHECKING([for $cob_temp_flags option]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[return 0;]])], + [AC_MSG_RESULT([yes])], + [CFLAGS="$curr_cflags"; cob_temp_flags=""; AC_MSG_RESULT([no])]) + if test "x$cob_temp_flags" != x; then + if test "x$COB_LDFLAGS" != x; then + COB_LDFLAGS="$COB_LDFLAGS $cob_temp_flags" + else + COB_LDFLAGS="$cob_temp_flags" + fi CFLAGS="$curr_cflags $cob_temp_flags" else CFLAGS="$curr_cflags" @@ -2481,6 +2520,7 @@ if test "$enable_hardening" = no; then -e 's/-fstack-protector-strong//g' \ -e 's/-fstack-protector-all//g' \ -e 's/-fstack-protector//g' \ + -e 's/-fstack-clash-protection//g' \ ) fi diff --git a/libcob/ChangeLog b/libcob/ChangeLog index ce441dfc7..36ed9cbd4 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -74,11 +74,55 @@ * fisam.c: Updated to set index field type for 'short' & 'int' Enabled support for variable length records is using V-ISAM/D-ISAM +2023-09-07 Simon Sobisch + + * strings.c (alloc_figurative): optimized handling for SPACES and ZEROES + * strings.c (cob_inspect_translating), common.h: variant of + cob_inspect_converting that is called with a pre-computed translation + table (COBOL source using only constants) + * strings.c (cob_inspect_converting): replaced partial conversion table + with full table, which saves a check on each replaced byte + * strings.c (cob_inspect_converting): also call cob_real_put_sign for + early exits + +2023-09-04 Simon Sobisch + + * numeric.c (cob_add_int): minor adjustment to scale handling + * numeric.c (packed_is_negative): optimized by memcmp instead of loop + * numeric.c (cob_decimal_get_display): fixed broken sign in + diff calculation + +2023-08-30 Simon Sobisch + + * move.c (cob_move_display_to_packed), numeric.c (cob_decimal_get_packed): + fix C RTS check raising overflow by replacing casting to char by "& 0xFF" + * cconv.c (cob_field_to_string): fix analyzer warnings + +2023-08-22 Simon Sobisch + + * version.h: bump to 3.3 + +2023-08-17 Simon Sobisch + + * numeric.c (cob_move_bcd): fix bug #904 unsigned to signed must write + positive sign + +2023-07-28 Simon Sobisch + + * screenio.c, common.c: replace use of NCURSES_MOUSE_VERSION by + HAVE_MOUSEMASK + * fileio.c (cob_file_sort_giving_internal): fix memory cleanup + 2023-07-27 Chuck Haatvedt * move.c (cob_move_display_to_packed): fix data corruption caused by packing one extra digit from the input display field +2023-07-24 Simon Sobisch + + * fileio.c: only check -1 as invalid fd; return fileio status for + invalid file state in CBL_ routines, instead of fixed -1 / 35 + 2023-07-22 Simon Sobisch * coblocal.h (COB_MAX_FIELD_SIZE_LINKAGE): new definition @@ -161,6 +205,7 @@ after suggestions by Chuck Haatvedt otherwise it is lost on first CLOSE * fileio.c->fextfh.c: disable setting of record min/max size outside of OPEN, disable setting of record size in some places + * fileio.c: adjusted setting of SORT-RETURN register 2023-06-01 Simon Sobisch @@ -6497,7 +6542,7 @@ after suggestions by Chuck Haatvedt 2005-04-13 Keisuke Nishida * byteswap.h: #include . Use u_int16_t, u_int32_t, and - u_int64_t instead of unsigned short, etc. + u_int64_t instead of unsigned short, etc. 2005-03-03 Roger While diff --git a/libcob/call.c b/libcob/call.c index d5c51b88f..df0ea8d0b 100644 --- a/libcob/call.c +++ b/libcob/call.c @@ -52,13 +52,15 @@ FILE *fmemopen (void *buf, size_t size, const char *mode); #define COB_LIB_EXPIMP #include "coblocal.h" -/* NOTE - The following variable should be uncommented when - it is known that dlopen(NULL) is borked. - This is known to be true for some PA-RISC HP-UX 11.11 systems. +/* NOTE: + COB_BORKED_DLOPEN should be set with LIBCOB_CFFLAGS=-DCOB_BORKED_DLOPEN + when it is known that either dlopen(NULL) is borked or dlclose is a no-op. + The first is known to be true for some PA-RISC HP-UX 11.11 systems. This is fixed with HP patch PHSS_28871. (There are newer but this fixes dlopen/dlsym problems) + The second (no-op dlclose) is the case with musl, see + https://wiki.musl-libc.org/functional-differences-from-glibc.html#Unloading_libraries */ -/* #define COB_BORKED_DLOPEN */ #ifdef _WIN32 @@ -305,7 +307,6 @@ cob_set_library_path () char *p; char *pstr; size_t i; - struct stat st; int flag; @@ -396,9 +397,12 @@ cob_set_library_path () /* check if directory (note: entries like X:\ _must_ be specified with trailing slash !) */ - if (stat (p, &st) || !(S_ISDIR (st.st_mode))) { - /* possibly raise a warning, maybe only if explicit asked */ - continue; + { + struct stat st; + if (stat (p, &st) || !(S_ISDIR (st.st_mode))) { + /* possibly raise a warning, maybe only if explicit asked */ + continue; + } } /* remove trailing slash from entry (always added on use) */ diff --git a/libcob/cconv.c b/libcob/cconv.c index 9d41a8fbc..6a674958b 100644 --- a/libcob/cconv.c +++ b/libcob/cconv.c @@ -107,8 +107,8 @@ cob_convert_hex_digit (char h) static int cob_convert_hex_byte (const char *h) { - int d1 = cob_convert_hex_digit (h[0]); - int d2 = cob_convert_hex_digit (h[1]); + const int d1 = cob_convert_hex_digit (h[0]); + const int d2 = cob_convert_hex_digit (h[1]); if (d1 < 0 || d2 < 0) { return -1; } else { @@ -325,17 +325,18 @@ cob_field_to_string (const cob_field *f, void *str, const size_t maxsize, break; case CCM_LOWER_LOCALE: while (data <= end) { - *s++ = tolower (*data++); + *s++ = (unsigned char)tolower (*data++); } break; case CCM_UPPER_LOCALE: while (data <= end) { - *s++ = toupper (*data++); + *s++ = (unsigned char)toupper (*data++); } break; } *s = 0; - return end + 1 - f->data; + /* note: we limit individual fields to be of size < INT_MAX in the compiler */ + return (int)(end + 1 - f->data); } diff --git a/libcob/common.c b/libcob/common.c index c50f910ad..6d93f221c 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -116,8 +116,6 @@ #include #define COB_GEN_SCREENIO #elif defined (HAVE_PDCURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #define COB_GEN_SCREENIO @@ -130,6 +128,12 @@ #endif #endif +#if defined (__PDCURSES__) +/* Note: PDC will internally define NCURSES_MOUSE_VERSION with + a recent version when PDC_NCMOUSE was defined; + for older version define manually! */ +#endif + #if defined (WITH_XML2) #include #include @@ -1638,21 +1642,20 @@ cob_get_sign_ebcdic (unsigned char *p) *p = sign_nibble; } switch (sign_nibble) { - /* negative */ + /* positive */ case 0xC0: - /* negative, non-preferred */ + /* positive, non-preferred */ case 0xA0: case 0xE0: return 1; - /* positive */ + /* negative */ case 0xD0: - /* positive, non-preferred */ + /* negative, non-preferred */ case 0xB0: return -1; /* unsigned */ case 0xF0: return 0; - return -1; default: /* What to do here outside of sign nibbles? */ return 1; @@ -4344,25 +4347,28 @@ cob_is_numeric (const cob_field *f) { const char sign = *end & 0x0F; if (COB_FIELD_NO_SIGN_NIBBLE (f)) { - /* COMP-6 - Check last nibble */ + /* COMP-6 - check low nibble as digit */ if (sign > 0x09) { return 0; } } else if (COB_FIELD_HAVE_SIGN (f)) { if (COB_MODULE_PTR->flag_host_sign && sign == 0x0F) { - /* all fine, go on */ + /* hostsign: "no sign" == "positive", so go on */ } else if (sign != 0x0C && sign != 0x0D) { + /* expect explicit "positive" 0x0C + or "negative" 0x0D sign */ return 0; } } else if (sign != 0x0F) { + /* unsigned must be "no sign" 0x0F */ return 0; } } - /* Check high nibble of last byte */ + /* Check high nibble of last byte for digit */ if ((*end & 0xF0) > 0x90) { return 0; } @@ -6605,7 +6611,7 @@ cob_sys_system (const void *cmdline) while GNU/Linux returns -1 */ status = system (command); if (cobglobptr->cob_screen_initialized) { - cob_screen_set_mode (1U); + cob_screen_set_mode (1); } #ifdef WIFSIGNALED if (WIFSIGNALED (status)) { @@ -7184,7 +7190,7 @@ get_sleep_nanoseconds_from_seconds (cob_field *decimal_seconds) { } if (seconds >= MAX_SLEEP_TIME) { return (cob_s64_t)MAX_SLEEP_TIME * 1000000000; -} else { + } else { cob_s64_t nanoseconds; cob_field temp; temp.size = 8; @@ -9470,8 +9476,10 @@ get_screenio_and_mouse_info (char *version_buffer, size_t size, const int verbos mouse_support = _("no"); } } -#elif defined (NCURSES_MOUSE_VERSION) +#elif defined (HAVE_MOUSEMASK) #if defined (__PDCURSES__) + /* CHECKME: that looks wrong - can't we test as above? + Double check with older PDCurses! */ mouse_support = _("yes"); #endif #else diff --git a/libcob/common.h b/libcob/common.h index 94b647050..fc9eda95b 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1481,19 +1481,19 @@ struct cob_func_loc { #define COB_MAX_KEYCOMP 16 /* max number of parts in a compound key (disam.h :: NPARTS ) */ typedef struct __cob_file_key { - unsigned int offset; /* Offset of field within record */ - short len_suppress; /* length of SUPPRESS "string" */ - short count_components; /* 0..1::simple-key 2..n::split-key */ - unsigned char keyn; /* Index Number */ - unsigned char tf_duplicates; /* WITH DUPLICATES (for RELATIVE/INDEXED) */ - /* 0=NO DUPS, 1=DUPS OK, 2=NO DUPS precheck */ - unsigned char tf_ascending; /* ASCENDING/DESCENDING (for SORT)*/ - unsigned char tf_suppress; /* supress keys where all chars = char_suppress */ - unsigned char char_suppress; /* key supression character */ - unsigned char tf_compress; /* $SET KEYCOMPRESS value */ - cob_field *field; /* Key field (or SPLIT key save area) */ - unsigned char *str_suppress; /* Complete SUPPRESS "string" */ - cob_field *component[COB_MAX_KEYCOMP];/* key-components iff split-key */ + unsigned int offset; /* Offset of field within record */ + short len_suppress; /* length of SUPPRESS "string" */ + short count_components; /* 0..1::simple-key 2..n::split-key */ + unsigned char keyn; /* Index Number */ + unsigned char tf_duplicates; /* WITH DUPLICATES (for RELATIVE/INDEXED) */ + /* 0=NO DUPS, 1=DUPS OK, 2=NO DUPS precheck */ + unsigned char tf_ascending; /* ASCENDING/DESCENDING (for SORT) */ + unsigned char tf_suppress; /* supress keys where all chars = char_suppress (for INDEXED) */ + unsigned char char_suppress; /* key supression character (for INDEXED) */ + unsigned char tf_compress; /* $SET KEYCOMPRESS value */ + cob_field *field; /* Key field (or SPLIT key save area) */ + unsigned char *str_suppress; /* Complete SUPPRESS "string" */ + cob_field *component[COB_MAX_KEYCOMP]; /* key-components iff split-key */ #if 0 /* TODO (for file keys, not for SORT/MERGE) */ const unsigned char *collating_sequence; /* COLLATING */ #endif @@ -2143,6 +2143,7 @@ COB_EXPIMP void cob_inspect_leading (cob_field *, cob_field *); COB_EXPIMP void cob_inspect_first (cob_field *, cob_field *); COB_EXPIMP void cob_inspect_trailing (cob_field *, cob_field *); COB_EXPIMP void cob_inspect_converting (const cob_field *, const cob_field *); +COB_EXPIMP void cob_inspect_translating (const unsigned char *); COB_EXPIMP void cob_inspect_finish (void); COB_EXPIMP void cob_string_init (cob_field *, cob_field *); diff --git a/libcob/fextfh.c b/libcob/fextfh.c index 19a3ec6b4..ca790e1a0 100644 --- a/libcob/fextfh.c +++ b/libcob/fextfh.c @@ -42,8 +42,6 @@ static const cob_field_attr compx_attr = {COB_TYPE_NUMERIC_BINARY, 0, 0, 0, NULL static void copy_keys_fcd_to_file (FCD3 *fcd, cob_file *f, int doall); static int EXTFH3 (unsigned char *opcode, FCD3 *fcd); -extern unsigned int eop_status; - /* * Free up allocated memory */ @@ -319,23 +317,12 @@ update_fcd_to_file (FCD3* fcd, cob_file *f, cob_field *fnstatus, int wasOpen) if (wasOpen >= 0) { const int status_code_1 = isdigit(fcd->fileStatus[0]) ? COB_D2I (fcd->fileStatus[0]) : 9; - if (status_code_1 == 0) { + if (status_code_1 != 0 + || cob_last_exception_is (COB_EC_I_O_EOP)) { /* EOP is non-fatal therefore 00 status but needs exception; - note that this global variable is only set if GnuCOBOL is used + note that the global exception is only set if GnuCOBOL is used as EXTFH, in every other case we currently can't set EOP; also note that fcd->lineCount is never read/set */ - if (eop_status == 0) { - cobglobptr->cob_exception_code = 0; - } else { -#if 0 /* correct thing to do, but then also needs to have codegen adjusted - --> module-incompatibility --> 4.x */ - cob_set_exception (eop_status); -#else - cob_set_exception (COB_EC_I_O_EOP); -#endif - eop_status = 0; - } - } else { cob_set_exception (status_exception[status_code_1]); } if (f->file_status) { diff --git a/libcob/fileio.c b/libcob/fileio.c index 3a0b6d4d5..840067555 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -4150,6 +4150,9 @@ cob_fd_file_open (cob_file *f, char *filename, errno = 0; fd = open (filename, fdmode, fperms); + if (fd != -1) { + errno = 0; + } ret = errno; switch (ret) { @@ -8250,9 +8253,10 @@ open_cbl_file (cob_u8_ptr file_name, int file_access, cob_chk_file_mapping (NULL, NULL); fd = open (file_open_name, flag, COB_FILE_MODE); - if (fd < 0) { + if (fd == -1) { + int ret = errno_cob_sts (COB_STATUS_35_NOT_EXISTS); memset (file_handle, -1, (size_t)4); - return 35; + return ret; } memcpy (file_handle, &fd, (size_t)4); return 0; @@ -8466,9 +8470,9 @@ cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) flag |= O_RDONLY; fd1 = open (file_open_name, flag, 0); - if (fd1 < 0) { + if (fd1 == -1) { cob_free (fn2); - return -1; + return errno_cob_sts (COB_STATUS_35_NOT_EXISTS); } strncpy (file_open_name, fn2, (size_t)COB_FILE_MAX); @@ -8479,9 +8483,10 @@ cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) flag &= ~O_RDONLY; flag |= O_CREAT | O_TRUNC | O_WRONLY; fd2 = open (file_open_name, flag, COB_FILE_MODE); - if (fd2 < 0) { + if (fd2 == -1) { + int ret = errno_cob_sts (COB_STATUS_35_NOT_EXISTS); close (fd1); - return -1; + return ret; } ret = 0; @@ -9010,7 +9015,7 @@ cob_create_tmpfile (const char *ext) fd = open (filename, O_CREAT | O_TRUNC | O_RDWR | O_BINARY | COB_OPEN_TEMPORARY, COB_FILE_MODE); - if (fd < 0) { + if (fd == -1) { cob_free (filename); return NULL; } @@ -9493,6 +9498,11 @@ cob_file_sort_using_extfh (cob_file *sort_file, cob_file *data_file, if (data_file->file_status[0] == '4') { cob_set_exception (COB_EC_SORT_MERGE_FILE_OPEN); } + if (hp->sort_return) { + *(int *)(hp->sort_return) = 16; /* TODO: recheck with MF */ + } else { + /* IBM doc: if not used then a runtime message is displayed */ + } return; } for (;;) { @@ -9552,6 +9562,9 @@ cob_file_sort_giving_internal (cob_file *sort_file, const size_t giving_cnt, if (using_file->file_status[0] == '4') { cob_set_exception (COB_EC_SORT_MERGE_FILE_OPEN); } + if (!hp->sort_return) { + /* IBM doc: if not used then a runtime message is displayed */ + } opt[i] = -1; } } @@ -9596,6 +9609,9 @@ cob_file_sort_giving_internal (cob_file *sort_file, const size_t giving_cnt, if (using_file->file_status[0] == '3') { int j; opt[i] = -2; + if (!hp->sort_return) { + /* IBM doc: if not used then a runtime message is displayed */ + } /* early exit if no GIVING file left */ for (j = 0; j < giving_cnt; ++j) { if (opt[i] >= 0) { @@ -9626,6 +9642,16 @@ cob_file_sort_giving_internal (cob_file *sort_file, const size_t giving_cnt, } } + /* if any error happened with the GIVING files update SORT-RETURN */ + if (hp->sort_return) { + for (i = 0; i < giving_cnt; ++i) { + if (opt[i] < 0) { + *(int *)(hp->sort_return) = 16; + break; + } + } + } + /* cleanup temporary arrays */ cob_free (opt); cob_free (fbase); @@ -9716,8 +9742,6 @@ cob_file_release (cob_file *f) } if (hp->sort_return) { *(int *)(hp->sort_return) = 16; - } else { - /* IBM doc: if not used then a runtime message is displayed */ } cob_file_save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR); } else { @@ -9743,8 +9767,6 @@ cob_file_return (cob_file *f) } if (hp->sort_return) { *(int *)(hp->sort_return) = 16; - } else { - /* IBM doc: if not used then a runtime message is displayed */ } cob_file_save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR); } else { diff --git a/libcob/move.c b/libcob/move.c index 9a76e7059..17c7898fa 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -515,7 +515,7 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) memset (f2->data, 0, f2->size); { register unsigned char *q = f2->data + i / 2; - const unsigned int i_end = f2->size; + const unsigned int i_end = (unsigned int)f2->size; /* a packed field always has small size */ /* FIXME: get rid of that, adjust i_end to handle both truncation of the source to the right and zero-fill because of scale differences (zero-fill wa s already done) */ const unsigned char *p_end = data1 + digits1; @@ -537,7 +537,7 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) /* check for necessary loop (until we not need the p_end check) */ if (i_end - i < (unsigned int)(p_end - p + 1) / 2) { while (i < i_end) { - *q = (unsigned char) (*p << 4) /* -> dropping the higher bits = no use in COB_D2I */ + *q = ((*p << 4) & 0xFF) /* -> dropping the higher bits = no use in COB_D2I */ + COB_D2I (*(p + 1)); q++; i++; @@ -545,7 +545,7 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) } } else { while (p < p_end) { - *q = (unsigned char) (*p << 4) /* -> dropping the higher bits = no use in COB_D2I */ + *q = ((*p << 4) & 0xFF) /* -> dropping the higher bits = no use in COB_D2I */ + COB_D2I (*(p + 1)); q++; p += 2; diff --git a/libcob/numeric.c b/libcob/numeric.c index ad8d7dc12..2bcc5b01c 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -455,7 +455,7 @@ cob_mul_by_pow_10 (mpz_t mexp, unsigned int n) mpz_mul (mexp, mexp, cob_mexp); } -/* scale - multiplicate mpz_t by power of 10 */ +/* scale - divide mpz_t by power of 10 */ static COB_INLINE COB_A_INLINE void cob_div_by_pow_10 (mpz_t mexp, unsigned int n) { @@ -1058,7 +1058,7 @@ cob_set_packed_zero (cob_field *f) static void cob_decimal_set_packed (cob_decimal *d, cob_field *f) { - register unsigned char *p = f->data; + register unsigned char *p = f->data; const int nibtest = !!COB_FIELD_NO_SIGN_NIBBLE (f); const unsigned char *endp = p + f->size - 1 + nibtest; cob_uli_t byteval; @@ -1091,13 +1091,6 @@ cob_decimal_set_packed (cob_decimal *d, cob_field *f) p++; } } - if (byteval == 0) { - while (p < endp - && *p == 0x00) { /* Skip leading ZEROs */ - digits -= 2; - p++; - } - } if (digits < MAX_LLI_DIGITS_PLUS_1) { /* note: similar logic in move.c (packed_get_long_long, packed_get_int) so for all adjustments here - check there, too */ @@ -1109,7 +1102,7 @@ cob_decimal_set_packed (cob_decimal *d, cob_field *f) if (!nibtest) { val = val * 10 - + (*p >> 4); + + (*p >> 4); } #ifdef COB_LI_IS_LL mpz_set_ui (d->value, (cob_uli_t)val); @@ -1264,7 +1257,7 @@ cob_decimal_get_packed (cob_decimal *d, cob_field *f, const int opt) i++; } while (i < size) { - *p++ = (unsigned char) (*q << 4) /* -> dropping the higher bits = no use in COB_D2I */ + *p++ = ((*q << 4) & 0xFF) /* -> dropping the higher bits = no use in COB_D2I */ + COB_D2I (*(q + 1)); q += 2; i += 2; } @@ -1383,7 +1376,8 @@ cob_decimal_set_display (cob_decimal *d, cob_field *f) return; } - /* Skip leading zeros (also invalid space/low-value) */ + /* Skip leading zeros (also invalid space/low-value + and valid positive/negative zero overpunch) */ while (size > 1 && (COB_D2I (*data) == 0)) { size--; data++; @@ -1442,7 +1436,7 @@ cob_decimal_set_display (cob_decimal *d, cob_field *f) these fields _must_ be _internal_ so there's no need to handle invalid data via COB_D2I + COB_I2D and we can copy as-is; this code has shown to be faster than mpz ui multiplication */ - char *buff = cob_fast_malloc (size + 1U); + char *buff = cob_fast_malloc ((size_t)size + 1U); memcpy (buff, data, size); /* still we may need to unpunch the sign, which in this internal case will always be at the last digit */ @@ -1464,6 +1458,7 @@ cob_decimal_set_display (cob_decimal *d, cob_field *f) COB_PUT_SIGN_ADJUSTED (f, sign); } +/* store value from decimal into field of type numeric DISPLAY */ static int cob_decimal_get_display (cob_decimal *d, cob_field *f, const int opt) { @@ -1484,11 +1479,13 @@ cob_decimal_get_display (cob_decimal *d, cob_field *f, const int opt) /* Build string, note: we can't check the decimal size with mpz_sizeinbase, as its result is "either exact or one too big" */ - /* huge data, only for internal operations like intrinsic functions */ + /* huge data, only for internal operations like intrinsic functions, + for example when directly called within intrinsic.c by + cob_alloc_field, cob_decimal_get_field -> cob_decimal_get_display */ if (fsize > COB_MAX_BINARY) { char *p = mpz_get_str (NULL, 10, d->value); const size_t size = strlen (p); - const size_t diff = fsize - size; + const long long diff = fsize - size; if (diff < 0) { /* Overflow */ if ((opt & COB_STORE_NO_SIZE_ERROR) == 0) { @@ -2352,7 +2349,6 @@ cob_addsub_optimized (cob_field *f1, cob_field *f2, return 0; } - void cob_add (cob_field *f1, cob_field *f2, const int opt) { @@ -2473,8 +2469,8 @@ cob_shift_left_nibble (unsigned char *ptr_buff, unsigned char *ptr_start_data_by unsigned char carry_nibble; unsigned char move_nibble = 0xFF; - /* calculate the length of data to be shifted */ - const int len1 = 48 - (ptr_start_data_byte - ptr_buff); + /* calculate the length of data to be shifted, never much */ + const int len1 = 48 - (int)(ptr_start_data_byte - ptr_buff); /* add one to ensure the carry nibble is moved */ register int shift_cntr = len1 + 1; @@ -2536,8 +2532,8 @@ cob_shift_right_nibble (unsigned char *ptr_buff, unsigned char *ptr_start_data_b cob_u64_t carry_nibble; cob_u64_t move_nibble = 0xFF; - /* calculate the length of data to be shifted */ - const int len1 = 48 - (ptr_start_data_byte - ptr_buff); + /* calculate the length of data to be shifted, never much */ + const int len1 = 48 - (int)(ptr_start_data_byte - ptr_buff); register int shift_cntr = len1; @@ -2614,7 +2610,7 @@ cob_move_bcd (cob_field *f1, cob_field *f2) if (COB_FIELD_NO_SIGN_NIBBLE (f1)) { fld1_sign = 0x00; } else { - fld1_sign = *(fld1 + fld1_size - 1) & 0X0F; + fld1_sign = *(fld1 + fld1_size - 1) & 0x0F; } /************************************************************/ @@ -2706,26 +2702,21 @@ cob_move_bcd (cob_field *f1, cob_field *f2) } if (f2_has_no_sign_nibble) { - /************************************************************/ - /* The following will clear the "pad" nibble if present */ - /************************************************************/ + /* clear pad nibble, if present */ if (COB_FIELD_DIGITS (f2) & 1 /* -> digits % 2 == 1 */) { *fld2 &= 0x0F; } } else { + /* set sign nibble */ unsigned char *pos = fld2 + fld2_size - 1; - if (COB_FIELD_HAVE_SIGN (f2)) { - if (!fld1_sign) { - *pos &= 0xF0; - *pos |= 0x0C; - } else { - *pos &= 0xF0; - *pos |= fld1_sign; - } - } else { - *pos &= 0xF0; + if (!COB_FIELD_HAVE_SIGN (f2)) { *pos |= 0x0F; + } else if (fld1_sign == 0x0D) { + *pos = (*pos & 0xF0) | 0x0D; + } else { + *pos = (*pos & 0xF0) | 0x0C; } + /* clear pad nibble, if present */ if (!(COB_FIELD_DIGITS (f2) & 1) /* -> digits % 2 == 0 */) { *fld2 &= 0x0F; } @@ -2908,7 +2899,7 @@ static int check_overflow_and_set_sign (cob_field *f, const int opt, int final_positive, unsigned char *buff, unsigned char *pos) { - const int buff_size = 48 - (pos - buff); + const int buff_size = 48 - (int)(pos - buff); const int fsize = (int)f->size; int cmp_size = buff_size - fsize; unsigned char *last_buff_pos = buff + 48 - 1; @@ -3026,9 +3017,9 @@ cob_add_bcd (cob_field *fdst, const unsigned char *src2_data = COB_FIELD_DATA (fsrc2); unsigned char fld1_sign = COB_FIELD_NO_SIGN_NIBBLE (fsrc1) ? 0x00 - : *(src1_data + fld1_size - 1) & 0X0F; + : *(src1_data + fld1_size - 1) & 0x0F; const unsigned char fld2_sign = COB_FIELD_NO_SIGN_NIBBLE (fsrc2) ? 0x00 - : *(src2_data + fld2_size - 1) & 0X0F; + : *(src2_data + fld2_size - 1) & 0x0F; const signed short src1_scale = COB_FIELD_SCALE (fsrc1); const signed short src2_scale = COB_FIELD_SCALE (fsrc2); @@ -3156,9 +3147,9 @@ cob_add_bcd (cob_field *fdst, /* find the length of the longer buffer data */ if (fld1 - fld1_buff > fld2 - fld2_buff) { - loop_limit = 48 - (fld2 - fld2_buff) + 1; + loop_limit = 48 - (int)(fld2 - fld2_buff) + 1; } else { - loop_limit = 48 - (fld1 - fld1_buff) + 1; + loop_limit = 48 - (int)(fld1 - fld1_buff) + 1; } /* note: both fl1 and fld2 point at the _last_ position of the @@ -3486,7 +3477,8 @@ cob_display_add_int (cob_field *f, int n, const int opt) } if (scale < 0) { - /* PIC 9(n)P(m) */ + /* PIC 9(n)P(m) -> adjust "val" + by applying the same scale (cut integer positions) */ if (-scale < 10) { /* Fix optimizer bug */ while (scale) { @@ -3494,9 +3486,9 @@ cob_display_add_int (cob_field *f, int n, const int opt) n /= 10; } } else { + scale = 0; n = 0; } - scale = 0; if (n == 0) { return 0; } @@ -3671,25 +3663,30 @@ cob_add_int (cob_field *f, const int n, const int opt) int scale = COB_FIELD_SCALE (f); int val = n; if (scale < 0) { - /* PIC 9(n)P(m) */ - if (-scale < 10) { - while (scale++) { - val /= 10; - } - } else { - val = 0; + /* PIC 9(n)P(m) -> adjust "val" + by applying the same scale (cut integer positions) */ + if (scale <= -10) { + /* an int cannot have > 10 digit positions, so + no need to do anything if scale is too small */ + return 0; + } + while (scale++) { + val /= 10; } - scale = 0; if (!val) { return 0; } + /* not used anymore, but logically: scale = 0 here */ } cob_decimal_set_field (&cob_d1, f); mpz_set_si (cob_d2.value, (cob_sli_t)val); - cob_d2.scale = 0; - if (scale > 0) { - cob_mul_by_pow_10 (cob_d2.value, scale); + if (cob_d1.scale > 0) { + cob_mul_by_pow_10 (cob_d2.value, cob_d1.scale); +#if 0 /* second scale is unused, these are just the "logic" values */ cob_d2.scale = cob_d1.scale; + } else { + cob_d2.scale = 0; +#endif } mpz_add (cob_d1.value, cob_d1.value, cob_d2.value); return cob_decimal_get_field (&cob_d1, f, opt); @@ -3863,19 +3860,15 @@ packed_is_negative (cob_field *f) { if (cob_packed_get_sign (f) == -1) { /* negative sign, validate for nonzero data */ - unsigned char *data = COB_FIELD_DATA (f); - register unsigned char *end = data + f->size - 1; + unsigned char nullbuff[(COB_MAX_DIGITS / 2) + 1] = { 0 }; + /* nonzero "really negative" if any data is nonzero */ + if (memcmp (f->data, nullbuff, f->size - 1)) { + return 1; + } /* nonzero if byte with sign nibble has other data */ - if ((*end != 0x0D)) { + if ((*(f->data + f->size - 1) != 0x0D)) { return 1; /* extra data -> really negative */ } - /* nonzero "really negative" if any other data is nonzero, - checking backwards from before sign until end == start */ - while (data != end) { - if (*--end != 0) { - return 1; - } - } /* all zero -> not negative, even with the sign telling so */ return 0; } @@ -4100,16 +4093,6 @@ cob_numeric_cmp (cob_field *f1, cob_field *f2) const int f1_type = COB_FIELD_TYPE (f1); const int f2_type = COB_FIELD_TYPE (f2); - /* float needs special comparison */ - if (f1_type == COB_TYPE_NUMERIC_FLOAT - || f1_type == COB_TYPE_NUMERIC_DOUBLE - || f1_type == COB_TYPE_NUMERIC_L_DOUBLE - || f2_type == COB_TYPE_NUMERIC_FLOAT - || f2_type == COB_TYPE_NUMERIC_DOUBLE - || f2_type == COB_TYPE_NUMERIC_L_DOUBLE) { - return cob_cmp_float (f1, f2); - } - #ifndef NO_BCD_COMPARE /* do bcd compare if possible */ if (f1_type == COB_TYPE_NUMERIC_PACKED @@ -4118,9 +4101,19 @@ cob_numeric_cmp (cob_field *f1, cob_field *f2) if (COB_FIELD_SCALE (f1) >= 0 && COB_FIELD_SCALE (f2) >= 0) { return cob_bcd_cmp (f1, f2); } + /* CHECKME: possible create temporary bcd2 if only one is packed + and the other isn't float - then compare as BCD */ } #endif + /* float needs special comparison */ + if ( (f1_type >= COB_TYPE_NUMERIC_FLOAT + && f1_type <= COB_TYPE_NUMERIC_L_DOUBLE) + || (f2_type >= COB_TYPE_NUMERIC_FLOAT + && f2_type <= COB_TYPE_NUMERIC_L_DOUBLE)) { + return cob_cmp_float (f1, f2); + } + /* otherwise - preferably compare as integers */ if (COB_FIELD_SCALE (f1) == COB_FIELD_SCALE (f2) && COB_FIELD_DIGITS (f1) < 19 @@ -4373,12 +4366,8 @@ cob_cmp_numdisp (const unsigned char *data, const size_t size, return (val < n) ? -1 : (val > n); } - /* safe-guard, should never happen */ - if (!size) { - return 0; - } p_end = p + size - 1; - while (p != p_end) { + while (p < p_end) { val = val * 10 + COB_D2I (*p++); } val *= 10; diff --git a/libcob/screenio.c b/libcob/screenio.c index da1211cda..dc3442696 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -53,23 +53,15 @@ #elif defined (HAVE_NCURSES_NCURSES_H) #include #elif defined (HAVE_PDCURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #elif defined (HAVE_PDCURSES_CURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #elif defined (HAVE_XCURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #elif defined (HAVE_XCURSES_CURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #elif defined (HAVE_CURSES_H) @@ -80,6 +72,12 @@ #endif #endif +#if defined (__PDCURSES__) +/* Note: PDC will internally define NCURSES_MOUSE_VERSION with + a recent version when PDC_NCMOUSE was defined; + for older version define manually! */ +#endif + /* work around broken system headers or compile flags defining NCURSES_WIDECHAR / PDC_WIDE but not including the actual definitions */ #if defined (NCURSES_WIDECHAR) && !defined (WACS_HLINE) @@ -99,7 +97,7 @@ #ifdef HAVE_CURSES_FREEALL extern void _nc_freeall (void); #endif -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK static mmask_t cob_mask_accept; /* mask that is returned to COBOL ACCEPT */ static mmask_t cob_mask_routine; /* mask that is returned to COBOL routines (reserved) */ #if defined BUTTON5_PRESSED /* added in NCURSES_MOUSE_VERSION 2 */ @@ -157,7 +155,7 @@ static int accept_cursor_x; static int pending_accept; static int got_sys_char; static unsigned int curr_setting_insert_mode = INT_MAX; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK static unsigned int curr_setting_mouse_flags = UINT_MAX; #endif #endif @@ -2141,7 +2139,7 @@ find_field_by_pos (const int initial_curs, const int line, const int column) { return -1; } -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK static int mouse_to_exception_code (mmask_t mask) { int fret = -1; @@ -2391,7 +2389,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) int integer_part_end; char sign; int fix_position = 0; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK MEVENT mevent; #endif @@ -2423,7 +2421,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) } } -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK /* prevent warnings about not intialized structure */ memset (&mevent, 0, sizeof (MEVENT)); #endif @@ -2452,7 +2450,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) goto screen_return; } -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK /* get mouse event here, handle later */ if (keyp == KEY_MOUSE) { getmouse (&mevent); @@ -2716,7 +2714,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) /* Enter sign */ break; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK case KEY_MOUSE: { int mline = mevent.y; @@ -3404,7 +3402,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum int status; chtype prompt_char; /* prompt character */ chtype default_prompt_char; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK MEVENT mevent; #endif @@ -3424,7 +3422,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum origin_y = 0; origin_x = 0; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK /* prevent warnings about not intialized structure */ memset (&mevent, 0, sizeof (MEVENT)); #endif @@ -3639,7 +3637,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum continue; } -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK /* get mouse event here, handle later */ if (keyp == KEY_MOUSE) { getmouse (&mevent); @@ -3725,7 +3723,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum /* End key. */ fret = 2015; goto field_return; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK case KEY_MOUSE: { int mline = mevent.y; @@ -3952,7 +3950,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum cob_move_cursor (cline, ccolumn); continue; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK case KEY_MOUSE: { int mline = mevent.y; @@ -4976,7 +4974,7 @@ cob_settings_screenio (void) #ifdef HAVE_MOUSEINTERVAL mouseinterval (COB_MOUSE_INTERVAL); #endif -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK if (curr_setting_mouse_flags != COB_MOUSE_FLAGS) { mmask_t mask_applied = cob_mask_routine; if (COB_MOUSE_FLAGS) { diff --git a/libcob/strings.c b/libcob/strings.c index 488aa9007..51f0d1b8d 100644 --- a/libcob/strings.c +++ b/libcob/strings.c @@ -115,13 +115,20 @@ cob_str_memcpy (cob_field *dst, unsigned char *src, const int size) static void alloc_figurative (const cob_field *f1, const cob_field *f2) { + const size_t size2 = f2->size; - unsigned char *s; - size_t size1; - size_t size2; - size_t n; +#if 1 /* size1 is always 1 here, so several optimizations possible */ + if (*f1->data == ' ' && size2 <= COB_SPACES_ALPHABETIC_BYTE_LENGTH) { + alpha_fld.size = size2; + alpha_fld.data = (unsigned char *) COB_SPACES_ALPHABETIC; + return; + } + if (*f1->data == '0' && size2 <= COB_ZEROES_ALPHABETIC_BYTE_LENGTH) { + alpha_fld.size = size2; + alpha_fld.data = (unsigned char *) COB_ZEROES_ALPHABETIC; + return; + } - size2 = f2->size; if (size2 > figurative_size) { if (figurative_ptr) { cob_free (figurative_ptr); @@ -129,15 +136,31 @@ alloc_figurative (const cob_field *f1, const cob_field *f2) figurative_ptr = cob_malloc (size2); figurative_size = size2; } - size1 = 0; - s = figurative_ptr; - for (n = 0; n < size2; ++n, ++s) { - *s = f1->data[size1]; - size1++; - if (size1 >= f1->size) { - size1 = 0; + + memset (figurative_ptr, *f1->data, size2); +#else + if (size2 > figurative_size) { + if (figurative_ptr) { + cob_free (figurative_ptr); } + figurative_ptr = cob_malloc (size2); + figurative_size = size2; } + + { + unsigned char *s = figurative_ptr; + size_t n = size2; + size_t size1 = 0; + while (n != 0) { + if (size1 >= f1->size) { + size1 = 0; + } + *s++ = f1->data[size1++]; + --n; + } + } +#endif + alpha_fld.size = size2; alpha_fld.data = figurative_ptr; } @@ -520,7 +543,7 @@ cob_inspect_init (cob_field *var, const cob_u32_t replacing) cob_inspect_start (setting inspect_start/end) cob_inspect_before (optional, adjusting inspect_end) cob_inspect_after (optional, adjusting inspect_start) - one-time cob_inspect_converting (actual converstion) */ + one-time cob_inspect_converting/cob_inspect_translating (actual converstion) */ void cob_inspect_init_converting (cob_field *var) @@ -571,7 +594,7 @@ cob_inspect_characters (cob_field *f1) } if (inspect_replacing) { - /* INSPECT REPLACING CHARACTERS BY f1 */ + /* INSPECT REPLACING CHARACTERS BY f1 (= size 1) */ const unsigned char repl_by = *f1->data; unsigned char *repdata; setup_repdata (); @@ -645,7 +668,7 @@ cob_inspect_converting (const cob_field *f1, const cob_field *f2) if (inspect_len == 0) { /* our task is to convert either a zero-length field or AFTER ... has not found a place to start the conversion */ - return; + goto end; } if (!f1) { @@ -660,7 +683,7 @@ cob_inspect_converting (const cob_field *f1, const cob_field *f2) f2 = &alpha_fld; } else { cob_set_exception (COB_EC_RANGE_INSPECT_SIZE); - return; + goto end; } } @@ -671,14 +694,32 @@ cob_inspect_converting (const cob_field *f1, const cob_field *f2) unsigned char * const cur_data_end = cur_data + inspect_len; #if 1 /* table-approach, _much faster_, _should_ be portable */ - char conv_tab[256] = { 0 }; /* using 256 to remove the need to use offset */ - char conv_set[256] = { 0 }; + /* pre-filled conversion table */ + unsigned char conv_tab[256] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, + 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, + 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, + 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, + 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, + 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, + 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 + }; - /* pre-fill conversion table, skipping duplicates */ + /* update conversion table with from/to, skipping duplicates */ { const unsigned char *conv_to = f2->data; const unsigned char *conv_from = f1->data; - const unsigned char * const conv_from_end = f1->data + f1->size; + const unsigned char * const conv_from_end = conv_from + f1->size; + char conv_set[256] = { 0 }; while (conv_from < conv_from_end) { if (conv_set[*conv_from] == 0) { conv_set[*conv_from] = 1; @@ -687,11 +728,9 @@ cob_inspect_converting (const cob_field *f1, const cob_field *f2) conv_from++, conv_to++; } } - /* iterate over target converting with table */ + /* iterate over target converting with full table */ while (cur_data < cur_data_end) { - if (conv_set[*cur_data]) { - *cur_data = conv_tab[*cur_data]; - } + *cur_data = conv_tab[*cur_data]; cur_data++; } #else @@ -718,8 +757,39 @@ cob_inspect_converting (const cob_field *f1, const cob_field *f2) #endif } +end: /* note: copied here for 3.2+ as cob_inspect_finish is not generated for TRANSFORM/INSPECT CONVERTING any more */ + if (inspect_var) { + /* FIXME: needs test cases for all "goto end" cases above, + ideally with a SIGN SEPARATE variable */ + cob_real_put_sign (inspect_var, inspect_sign); + } +} + +/* note: currently not used by cobc (disabled unfinished prototype) */ +void +cob_inspect_translating (const unsigned char *conv_table) +{ + const size_t inspect_len = inspect_end - inspect_start; + + if (inspect_len == 0) { + /* our task is to convert either a zero-length field or + AFTER ... has not found a place to start the conversion + --> nothing to do here */ + } else { + /* directly convert _all_ positions of the inspect target using the + pre-generated conversion table */ + unsigned char * cur_data = inspect_data + (inspect_start - inspect_data); + unsigned char * const cur_data_end = cur_data + inspect_len; + + /* iterate over target converting with full table */ + while (cur_data < cur_data_end) { + *cur_data = conv_table[*cur_data]; + cur_data++; + } + } + if (inspect_var) { cob_real_put_sign (inspect_var, inspect_sign); } @@ -756,6 +826,13 @@ cob_inspect_finish (void) } /* STRING */ +/* a STRING is split into multiple parts: + one-time cob_string_init (setting up memory and static variables) + 1..n : + cob_string_delimited (setting delimiter struct entries) + 1..n: + cob_string_append (to handle a single source) + one-time cob_string_finish (setting the string pointer) */ void cob_string_init (cob_field *dst, cob_field *ptr) @@ -782,10 +859,11 @@ cob_string_init (cob_field *dst, cob_field *ptr) void cob_string_delimited (cob_field *dlm) { - string_dlm = NULL; if (dlm) { string_dlm_copy = *dlm; string_dlm = &string_dlm_copy; + } else { + string_dlm = NULL; } } diff --git a/libcob/version.h b/libcob/version.h index c0b186bb7..80aa980c0 100644 --- a/libcob/version.h +++ b/libcob/version.h @@ -1,5 +1,5 @@ /* - Copyright (C) 2020-2022 Free Software Foundation, Inc. + Copyright (C) 2020-2023 Free Software Foundation, Inc. Written by Simon Sobisch This file is part of GnuCOBOL. diff --git a/tests/testsuite.src/data_packed.at b/tests/testsuite.src/data_packed.at index 4fdcce8ff..8ddd31df6 100644 --- a/tests/testsuite.src/data_packed.at +++ b/tests/testsuite.src/data_packed.at @@ -5781,7 +5781,7 @@ AT_DATA([prog.cob], [ MOVE FLD0498A TO FLD0498C. MOVE FLD0499A TO FLD0499C. - 4000-COMPARE. + *4000-COMPARE. IF FLD0001C (1:) NOT EQUAL XPC-FLD0001C DISPLAY 'FLD0001C ==> ' HEX-OF (FLD0001C) @@ -10821,7 +10821,7 @@ AT_DATA([prog2.cob], [ MOVE FLD0998A TO FLD0998C. MOVE FLD0999A TO FLD0999C. - 4000-COMPARE. + *4000-COMPARE. IF FLD0500C (1:) NOT EQUAL XPC-FLD0500C DISPLAY 'FLD0500C ==> ' HEX-OF (FLD0500C) diff --git a/tests/testsuite.src/listings.at b/tests/testsuite.src/listings.at index db0c1a373..bdcc855e4 100644 --- a/tests/testsuite.src/listings.at +++ b/tests/testsuite.src/listings.at @@ -3344,7 +3344,7 @@ AT_DATA([prog.cob], [ OCCURS 8 TIMES PIC 1(8) BIT. ]) -AT_CHECK([$COMPILE_LISTING0 -t prog.lst -ftsymbols -Wno-pending -Wno-unfinished -fword-continuation=ok prog.cob], [1], [], [ignore]) +AT_CHECK([$COMPILE_LISTING0 -t prog.lst -ftsymbols -Wno-pending -Wno-unfinished -fmax-errors=0 -fword-continuation=ok prog.cob], [1], [], [ignore]) AT_DATA([expected.lst], [GnuCOBOL V.R.P prog.cob diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 97b2907b8..e1c315b29 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -552,7 +552,6 @@ AT_CHECK([$COMPILE_ONLY -Wstrict-typing -fdiagnostics-show-option prog.cob], [0] [prog.cob:8: warning: alphanumeric value is expected [[-Wtyping]] prog.cob:6: note: 'X' defined here as PIC X(04) [[-Wtyping]] prog.cob:10: warning: alphanumeric value is expected [[-Wstrict-typing]] -prog.cob:6: note: 'X' defined here as PIC X(04) [[-Wstrict-typing]] ]) AT_CHECK([$COMPILE_ONLY -Wextra -Wno-strict-typing -fdiagnostics-show-option prog.cob], [0], [], [prog.cob:8: warning: alphanumeric value is expected [[-Wtyping]] @@ -6246,25 +6245,35 @@ AT_DATA([caller.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. - 77 INT IS TYPEDEF BINARY-LONG. + 01 INT IS TYPEDEF BINARY-LONG. + 88 INT-ZERO VALUE 0. + 88 INT-ONE VALUE 1. 77 EXT-INT IS TYPEDEF BINARY-LONG EXTERNAL. *> should this be possible? *>77 INT-VAL IS TYPEDEF USAGE INT VALUE 12. 77 INT-VAL IS TYPEDEF BINARY-LONG VALUE 12. - 77 SOMEVAR USAGE INT VALUE 10. + 01 SOMEVAR USAGE INT VALUE 10. + 01 SOMEVAR2 USAGE INT VALUE 11. 77 SOMEVAL USAGE INT-VAL. 77 SOMEEXT USAGE EXT-INT. PROCEDURE DIVISION. IF SOMEVAR <> 10 - DISPLAY "SOMEVAR (INT) wrong: " SOMEVAR - END-IF + DISPLAY "SOMEVAR (INT) wrong: " SOMEVAR. IF SOMEVAL <> 12 - DISPLAY "SOMEVAR (INT-VAL) wrong: " SOMEVAL - END-IF + DISPLAY "SOMEVAL (INT-VAL) wrong: " SOMEVAL. + SET INT-ZERO OF SOMEVAR TO TRUE + SET INT-ONE OF SOMEVAR2 TO TRUE + IF SOMEVAR <> 0 + DISPLAY "SOMEVAR (INT) by SET wrong: " SOMEVAR. + IF SOMEVAR2 <> 1 + DISPLAY "SOMEVAR2 (INT) by SET wrong: " SOMEVAR2. + IF INT-ONE OF SOMEVAR + OR NOT INT-ONE OF SOMEVAR2 + DISPLAY "CHECK BY condition-nam wrong". MOVE 42 TO SOMEEXT CALL "callee" - . + GOBACK. ]) AT_DATA([callee.cob], [ diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index a96a6f9ac..b6b3a383b 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -4428,7 +4428,7 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 MYOCC PIC 9(8) COMP VALUE 0. + 01 MYOCC PIC 9(8) VALUE 0. PROCEDURE DIVISION. ASTART SECTION. A01. @@ -4447,6 +4447,7 @@ AT_DATA([prog.cob], [ END-IF. B99. EXIT. + *> expected without -fperform-osvs: fall through here _SHOULD_ abort with -fsection-exit-check ]) AT_CHECK([$COMPILE -fperform-osvs prog.cob], [0], [], []) @@ -7910,7 +7911,6 @@ AT_CHECK([$COMPILE -std=mf -fno-move-non-numeric-lit-to-numeric-is-zero prog.cob prog.cob:28: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:34: warning: numeric value is expected -prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:52: warning: numeric value is expected prog.cob:7: note: 'BIGFLT' defined here as USAGE FLOAT ]) @@ -18362,13 +18362,13 @@ note: TooSmall2 has version 2.0.0 ], []) AT_DATA([testdata.h], [[ - { "TooSmall3", "3.2", 0 }, + { "TooSmall3", "3.4", 0 }, ]]) AT_CHECK([$COMPILE -o small3 prog.c], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./small3 2>small3.log], [1], [], []) AT_CHECK([$GREP -v "libcob has" small3.log], [0], [libcob: error: version mismatch -note: TooSmall3 has version 3.2.0 +note: TooSmall3 has version 3.4.0 ], []) AT_DATA([testdata.h], [[ diff --git a/tests/testsuite.src/syn_definition.at b/tests/testsuite.src/syn_definition.at index dcf4286d8..27920ac59 100644 --- a/tests/testsuite.src/syn_definition.at +++ b/tests/testsuite.src/syn_definition.at @@ -1598,7 +1598,7 @@ AT_DATA([prog.cob], [ OCCURS 8 TIMES PIC 1(8) BIT. ]) -AT_CHECK([$COMPILE_ONLY -std=cobol2014 prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -std=cobol2014 -fmax-errors=0 prog.cob], [1], [], [prog.cob:9: warning: continuation of COBOL words is archaic in COBOL 2014 prog.cob:11: warning: continuation of COBOL words is archaic in COBOL 2014 prog.cob:12: warning: continuation of COBOL words is archaic in COBOL 2014 @@ -1677,7 +1677,7 @@ prog.cob:93: warning: USAGE BIT is not implemented prog.cob:96: warning: USAGE BIT is not implemented ]) -AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -fmax-errors=0 prog.cob], [1], [], [prog.cob:9: warning: continuation of COBOL words used prog.cob:11: warning: continuation of COBOL words used prog.cob:12: warning: continuation of COBOL words used diff --git a/tests/testsuite.src/syn_file.at b/tests/testsuite.src/syn_file.at index e9b700991..8eb17b04e 100644 --- a/tests/testsuite.src/syn_file.at +++ b/tests/testsuite.src/syn_file.at @@ -1733,13 +1733,11 @@ prog.cob:13: note: 'f-rec' defined here as PIC 999999 prog.cob:24: error: figurative constants not allowed in FROM clause prog.cob:24: error: literal in FROM clause must be alphanumeric, utf-8, national or boolean prog.cob:25: warning: numeric value is expected -prog.cob:13: note: 'f-rec' defined here as PIC 999999 ]) AT_CHECK([$COMPILE_ONLY -frelax-syntax-checks prog.cob], [0], [], [prog.cob:22: warning: numeric value is expected prog.cob:13: note: 'f-rec' defined here as PIC 999999 prog.cob:25: warning: numeric value is expected -prog.cob:13: note: 'f-rec' defined here as PIC 999999 ]) AT_CHECK([$COMPILE_ONLY -std=mf-strict prog.cob], [0], [], [prog.cob:22: warning: source is non-numeric - substituting zero diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 23763dab1..bd93997e5 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -929,12 +929,18 @@ AT_DATA([prog.cob], [ ]) AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], -[prog.cob:14: error: REPLACING operands differ in size -prog.cob:15: error: REPLACING operands differ in size -prog.cob:17: error: CONVERTING operands differ in size -prog.cob:18: error: CONVERTING operands differ in size -prog.cob:20: error: CONVERTING operands differ in size -prog.cob:23: error: CONVERTING operands differ in size +[prog.cob:14: error: REPLACING operands incompatible +prog.cob:14: note: operands differ in size +prog.cob:15: error: REPLACING operands incompatible +prog.cob:15: note: operands differ in size +prog.cob:17: error: CONVERTING operands incompatible +prog.cob:17: note: operands differ in size +prog.cob:18: error: CONVERTING operands incompatible +prog.cob:18: note: operands differ in size +prog.cob:20: error: CONVERTING operands incompatible +prog.cob:20: note: operands differ in size +prog.cob:23: error: CONVERTING operands incompatible +prog.cob:23: note: operands differ in size ]) AT_CLEANUP @@ -1538,7 +1544,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY prog.cob -fmax-errors=0], [1], [], [prog.cob:7: error: invalid system-name 'SW1' prog.cob:8: error: ON/OFF usage requires a SWITCH name prog.cob:9: error: ON/OFF usage requires a SWITCH name @@ -2087,8 +2093,7 @@ prog3.cob:3: error: invalid indicator 'M' at column 7 prog3.cob:4: error: invalid indicator 'N' at column 7 prog3.cob:5: error: invalid indicator 'U' at column 7 prog3.cob:7: error: invalid indicator 'G' at column 7 -prog3.cob:8: error: invalid indicator 'U' at column 7 -prog3.cob:15: error: invalid indicator 'x' at column 7 +prog3.cob: error: too many format errors in file, skip output of further errors prog3.cob:6: error: PROGRAM-ID header missing prog3.cob:6: error: PROCEDURE DIVISION header missing prog3.cob:6: error: syntax error, unexpected DIVISION @@ -4133,7 +4138,8 @@ prog.cob:20: error: 'not-a-num' is not numeric prog.cob:20: error: 3 is not an alphanumeric literal prog.cob:20: error: invalid target for TALLYING prog.cob:21: error: 'not-display' is not USAGE DISPLAY -prog.cob:20: error: REPLACING operands differ in size +prog.cob:20: error: REPLACING operands incompatible +prog.cob:20: note: operands differ in size prog.cob:20: error: invalid target for REPLACING prog.cob:22: error: 'f' is not a field prog.cob:22: error: 3 is not an alphanumeric literal @@ -6236,7 +6242,7 @@ AT_DATA([prog.cob], [ GOBACK. ]) -AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -fmax-errors=0 prog.cob], [1], [], [prog.cob:12: warning: USAGE BIT is not implemented prog.cob:37: warning: USAGE BIT is not implemented prog.cob:49: error: JSON/XML GENERATE receiving item must be alphanumeric or national @@ -8259,7 +8265,7 @@ free.cob:3: error: invalid indicator 'R' at column 7 free.cob:4: error: invalid indicator 'E' at column 7 free.cob:5: error: invalid indicator 'I' at column 7 free.cob:6: error: invalid indicator 'N' at column 7 -free.cob:7: error: invalid indicator 'T' at column 7 +free.cob: error: too many format errors in file, skip output of further errors free.cob:8: error: PROGRAM-ID header missing ]) @@ -8269,7 +8275,7 @@ domfree.cob:3: error: invalid indicator 'R' at column 7 domfree.cob:4: error: invalid indicator 'E' at column 7 domfree.cob:5: error: invalid indicator 'I' at column 7 domfree.cob:6: error: invalid indicator 'N' at column 7 -domfree.cob:7: error: invalid indicator 'T' at column 7 +domfree.cob: error: too many format errors in file, skip output of further errors domfree.cob:8: error: PROGRAM-ID header missing ]) diff --git a/tests/testsuite.src/syn_move.at b/tests/testsuite.src/syn_move.at index 02a8ea0be..82a4704eb 100644 --- a/tests/testsuite.src/syn_move.at +++ b/tests/testsuite.src/syn_move.at @@ -691,7 +691,6 @@ prog.cob:14: warning: MOVE of figurative constant QUOTE to numeric item is archa prog.cob:15: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:17: warning: numeric value is expected -prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:19: error: an integer, INDEX, or a POINTER is expected here prog.cob:20: error: an integer, INDEX, or a POINTER is expected here prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in COBOL 2002 @@ -709,7 +708,6 @@ prog.cob:14: warning: MOVE of figurative constant QUOTE to numeric item is archa prog.cob:15: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:17: warning: numeric value is expected -prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:19: error: an integer, INDEX, or a POINTER is expected here prog.cob:20: error: an integer, INDEX, or a POINTER is expected here prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in IBM COBOL (lax) @@ -743,7 +741,6 @@ prog.cob:14: warning: MOVE of figurative constant to numeric item is archaic in prog.cob:15: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:17: warning: numeric value is expected -prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:19: error: an integer, INDEX, or a POINTER is expected here prog.cob:20: error: an integer, INDEX, or a POINTER is expected here prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in GnuCOBOL diff --git a/tests/testsuite.src/syn_refmod.at b/tests/testsuite.src/syn_refmod.at index df720a543..07eb6ce12 100644 --- a/tests/testsuite.src/syn_refmod.at +++ b/tests/testsuite.src/syn_refmod.at @@ -145,13 +145,17 @@ AT_DATA([prog.cob], [ ]) AT_CHECK([$COMPILE_ONLY -fdiagnostics-show-option -Wno-constant-numlit-expression prog.cob], [0], [], -[prog.cob:10: warning: offset of 'X' out of bounds: 0 [[-Wignored-error]] -prog.cob:11: warning: length of 'X' out of bounds: 0 [[-Wignored-error]] -prog.cob:12: warning: offset of 'X' out of bounds: 5 [[-Wadditional]] -prog.cob:13: warning: length of 'X' out of bounds: 5 [[-Wadditional]] -prog.cob:15: warning: CONVERTING operands differ in size [[-Wignored-error]] +[[prog.cob:10: warning: offset of 'X' out of bounds: 0 [-Wignored-error] +prog.cob:11: warning: length of 'X' out of bounds: 0 [-Wignored-error] +prog.cob:12: warning: offset of 'X' out of bounds: 5 [-Wadditional] +prog.cob:13: warning: length of 'X' out of bounds: 5 [-Wadditional] +prog.cob:15: warning: CONVERTING operands incompatible [-Wignored-error] +prog.cob:15: note: operands differ in size +]]) +AT_CHECK([$COMPILE_ONLY -Wno-constant-numlit-expression -fno-constant-folding prog.cob], [1], [], +[prog.cob:15: error: CONVERTING operands incompatible +prog.cob:15: note: operands differ in size ]) -AT_CHECK([$COMPILE_ONLY -Wno-constant-numlit-expression -fno-constant-folding prog.cob], [0], [], []) AT_CLEANUP diff --git a/tests/testsuite.src/syn_screen.at b/tests/testsuite.src/syn_screen.at index bc4153e72..b9aeea88a 100644 --- a/tests/testsuite.src/syn_screen.at +++ b/tests/testsuite.src/syn_screen.at @@ -685,7 +685,7 @@ prog.cob:25: error: cannot have PIC without FROM, TO or USING prog.cob:30: error: VALUE item may not be numeric ]) -AT_CHECK([$COMPILE_ONLY -fscreen-section-rules=mf prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -fscreen-section-rules=mf -fmax-errors=0 prog.cob], [1], [], [prog.cob:12: error: 'no-clauses' needs a PIC, COL, LINE, VALUE, BELL or BLANK clause prog.cob:13: error: 'no-required-clauses' needs a PIC, COL, LINE, VALUE, BELL or BLANK clause prog.cob:15: error: cannot specify both PIC and VALUE @@ -730,7 +730,7 @@ prog.cob:30: error: VALUE item may not be numeric prog.cob:36: error: cannot use AUTO, FULL, REQUIRED or SECURE on elementary item without FROM, TO or USING ]) -AT_CHECK([$COMPILE_ONLY -fscreen-section-rules=xopen prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -fscreen-section-rules=xopen -fmax-errors=0 prog.cob], [1], [], [prog.cob:12: error: 'no-clauses' needs a PIC, COL, LINE, VALUE, BELL or BLANK clause prog.cob:13: error: 'no-required-clauses' needs a PIC, COL, LINE, VALUE, BELL or BLANK clause prog.cob:15: error: cannot specify both PIC and VALUE diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 058f8a054..da9753f42 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -44,8 +44,7 @@ AT_CHECK([$COBC -std=acu --list-registers], [0], [ignore], []) AT_CHECK([$COBC -std=cobol2002 --list-intrinsics], [0], [ignore], []) AT_CHECK([$COBC -std=ibm --list-mnemonics], [0], [ignore], []) AT_CHECK([$COBC --list-system], [0], [ignore], []) -#TODO: merge exception-io.def and everything related -#AT_CHECK([$COBC --list-exceptions], [0], [ignore], []) +AT_CHECK([$COBC --list-exceptions], [0], [ignore], []) AT_CLEANUP @@ -149,18 +148,29 @@ AT_DATA([prog2.cob], [ DISPLAY TEST-VAR NO ADVANCING END-DISPLAY STOP RUN. + COPY 'CRUD2.CPY'. ]) AT_CHECK([$COBC -fsyntax-only -fdiagnostics-plain-output -Wall prog2.cob], [1], [], [prog2.cob:7: error: CRUD.CPY: No such file or directory +prog2.cob:15: error: CRUD2.CPY: No such file or directory prog2.cob:6: warning: numeric value is expected [[-Wothers]] ]) -AT_CHECK([$COBC -fsyntax-only -fdiagnostics-plain-output -fmax-errors=0 prog2.cob], [1], [], +AT_CHECK([$COBC -fsyntax-only -fdiagnostics-plain-output -fmax-errors=0 -Wall prog2.cob], [1], [], [prog2.cob:7: error: CRUD.CPY: No such file or directory +prog2.cob:15: error: CRUD2.CPY: No such file or directory prog2.cob:6: warning: numeric value is expected [[-Wothers]] ]) +AT_CHECK([$COBC -fsyntax-only -fdiagnostics-plain-output -fmax-errors=1 prog2.cob], [97], [], +[prog2.cob:7: error: CRUD.CPY: No such file or directory +prog2.cob:15: error: CRUD2.CPY: No such file or directory +cobc: too many errors [[-fmax-errors=1]] + +cobc: aborting compile of prog2.cob at line 15 (unknown: unknown) +]) + AT_CHECK([$COBC -fsyntax-only -fdiagnostics-plain-output -Wfatal-errors prog2.cob], [97], [], [prog2.cob:7: error: CRUD.CPY: No such file or directory cobc: too many errors [[-Wfatal-errors]]