From 879654ddcbbb7b67283c10902ca5939cac69daba Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 8 Dec 2022 16:34:24 +0000 Subject: [PATCH 01/18] work on prototype handling - fixing [bugs:#851] cobc: * typeck.c (items_have_same_data_clauses): fix handling for ANY LENGTH parameters * typeck.c: work on warning messages for prototype checking * typeck.c (error_if_signatures_differ): add check for ENTRY-CONVENTION * parser.y: fixes for prototype checking additional: libcob/common.h (cob_module_type): module type as enum instead of defines only cobc: * tree.h (prog_type) changed to cob_module_type * typeck.c (cb_validate_program_environment): fixed bad test of warning option for CLASS check * typeck.c (cb_emit_sort_init): minor refactoring --- cobc/ChangeLog | 13 ++- cobc/parser.y | 26 ++++-- cobc/tree.h | 2 +- cobc/typeck.c | 152 ++++++++++++++++++++++---------- libcob/ChangeLog | 4 + libcob/common.h | 6 +- tests/testsuite.src/run_misc.at | 9 +- tests/testsuite.src/syn_misc.at | 33 +++---- 8 files changed, 161 insertions(+), 84 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index e7299b553..6592f0eaa 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,15 @@ +2022-12-08 Simon Sobisch + + * typeck.c (items_have_same_data_clauses): fix handling for ANY LENGTH + parameters, fixing bug #851 + * parser.y: fixes for prototype checking + * typeck.c: work on warning messages for prototype checking + * typeck.c (error_if_signatures_differ): add check for ENTRY-CONVENTION + * typeck.c (cb_validate_program_environment): fixed bad test of warning + option for CLASS check + * typeck.c (cb_emit_sort_init): minor refactoring + 2022-12-05 Nicolas Berthier * cobc.c: replace some incorrect '%d' format indicators with '%lu' @@ -698,7 +709,7 @@ 2022-02-10 Samuel Belondrade * pplex.l (ppecho, ppecho_replace): add a loop to check all data queue - after a partial match [bugs:#778] + after a partial match bug #778 2022-02-07 David Declerck diff --git a/cobc/parser.y b/cobc/parser.y index 3fc0039ec..1b353697f 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -1244,7 +1244,8 @@ setup_program (cb_tree id, cb_tree as_literal, const unsigned char type, const i = cb_build_program_id (external_name, type == COB_MODULE_TYPE_FUNCTION); if (type == COB_MODULE_TYPE_PROGRAM) { - if (!main_flag_set) { + if (!main_flag_set + && !current_program->flag_prototype) { main_flag_set = 1; current_program->flag_main = !!cobc_flag_main; } @@ -3345,13 +3346,14 @@ set_record_size (cb_tree min, cb_tree max) start: { - backup_source_file = cb_source_file; clear_initial_values (); - current_program = NULL; defined_prog_list = NULL; cobc_cs_check = 0; main_flag_set = 0; + current_program = cb_build_program (NULL, 0); + + backup_source_file = cb_source_file; cb_source_file = "register-definition"; cb_set_intr_when_compiled (); cb_build_registers (); @@ -3482,8 +3484,8 @@ program_prototype: { /* Error if program_id_name is a literal */ - /* Check that previous program was also a prototype */ - if (!current_program->flag_prototype) { + /* Check that we either have no previous program or it was also a prototype */ + if (current_program->next_program && !current_program->flag_prototype) { /* Technically, prototypes must come before all other *source units*. */ cb_error (_("prototypes must be come before any program/function definitions")); } @@ -3514,6 +3516,11 @@ program_prototype: */ } _prototype_environment_division + { + if (!current_program->entry_convention) { + current_program->entry_convention = cb_int (CB_CONV_COBOL); + } + } _prototype_data_division _prototype_procedure_division_header end_program @@ -3558,6 +3565,11 @@ function_prototype: */ } _prototype_environment_division + { + if (!current_program->entry_convention) { + current_program->entry_convention = cb_int (CB_CONV_COBOL); + } + } _prototype_data_division _prototype_procedure_division_header end_function @@ -10602,8 +10614,6 @@ procedure_division: current_program->entry_convention = cb_int (CB_CONV_COBOL); } header_check |= COBC_HD_PROCEDURE_DIVISION; - - cb_check_definition_matches_prototype (current_program); } _dot_or_else_area_a _procedure_declaratives @@ -10614,6 +10624,8 @@ procedure_division: } emit_main_entry (current_program, $7); + + cb_check_definition_matches_prototype (current_program); } _procedure_list { diff --git a/cobc/tree.h b/cobc/tree.h index 13ab75e81..51da2196c 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1773,7 +1773,7 @@ struct cb_program { unsigned char decimal_point; /* '.' or ',' */ unsigned char currency_symbol; /* '$' or user-specified */ unsigned char numeric_separator; /* ',' or '.' */ - unsigned char prog_type; /* Program type (program = 0, function = 1) */ + enum cob_module_type prog_type; /* Program type (program = 0, function = 1) */ cb_tree entry_convention; /* ENTRY convention / PROCEDURE convention */ unsigned int flag_main : 1; /* Gen main function */ diff --git a/cobc/typeck.c b/cobc/typeck.c index da3a3d1b9..b0b3315f9 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -3174,7 +3174,8 @@ static void emit_definition_prototype_error_header (const char *name) { /* FIXME: move to error.c and cleanup similar to configuration_error */ - cb_warning (cb_warn_repository_checks, _("prototype and definition of '%s' do not match"), name); + cb_warning (cb_warn_repository_checks, + _("prototype and definition of '%s' do not match"), name); } static void @@ -3187,7 +3188,20 @@ emit_definition_prototype_error (const char *name, const char *error, *prototype_error_header_shown = 1; } - cb_note (COB_WARNOPT_NONE, 0, "%s", error); + cb_note (cb_warn_repository_checks, 0, "%s", error); +} + +static void +emit_definition_prototype_clause_mismatch (const char *name, const char *clause, + int * const prototype_error_header_shown) +{ + /* FIXME: move to error.c and cleanup similar to configuration_error */ + if (!*prototype_error_header_shown) { + emit_definition_prototype_error_header (name); + *prototype_error_header_shown = 1; + } + + cb_note (cb_warn_repository_checks, 0, "%s clauses differ", clause); } static int @@ -3195,20 +3209,48 @@ items_have_same_data_clauses (const struct cb_field * const field_1, const struct cb_field * const field_2, const int check_any_length) { - const int same_pic = - ((field_1->pic && field_2->pic) - && !strcmp (field_1->pic->orig, field_2->pic->orig)) - || (!field_1->pic && !field_2->pic); const int any_length_check = !check_any_length || (field_1->flag_any_length == field_2->flag_any_length); + int same_pic; - return same_pic && any_length_check + if (!any_length_check) { + return 1; + } + + if (field_1->pic && field_2->pic) { + if (check_any_length + || field_1->flag_any_length == field_2->flag_any_length) { + if (field_1->usage != field_2->usage) { + same_pic = 0; + } else { + same_pic = strcmp (field_1->pic->orig, field_2->pic->orig) == 0; + } + } else { + /* only one has any length -> ensure it is the prototype and + that the othr has the same numeric/nonnumeric type */ + if (!field_1->flag_any_length) { + return 1; + } + if (field_1->flag_any_numeric) { + same_pic = CB_TREE_CATEGORY (field_2) == CB_CATEGORY_NUMERIC; + } else { + same_pic = field_1->pic->orig[1] == field_2->pic->orig[1]; + } + } + } else { + if (field_1->pic || field_2->pic) { + same_pic = 0; + } else { + same_pic = field_1->usage == field_2->usage; + } + } + + return same_pic && (field_1->flag_blank_zero == field_2->flag_blank_zero) && (field_1->flag_justified == field_2->flag_justified) && (field_1->flag_sign_separate == field_2->flag_sign_separate - && field_1->flag_sign_leading == field_2->flag_sign_leading) - && (field_1->usage == field_2->usage); + && field_1->flag_sign_leading == field_2->flag_sign_leading); } static int @@ -3253,10 +3295,12 @@ error_if_items_differ (const char *element_name, /* To-do: Indicate location of the items in error. */ if (is_parameter) { - cb_note (COB_WARNOPT_NONE, 0, _("parameters #%d ('%s' in the definition and '%s' in the prototype) differ"), + cb_note (cb_warn_repository_checks, 0, + _("parameters #%d ('%s' in the definition and '%s' in the prototype) differ"), parameter_num, def_item->name, proto_item->name); } else { /* RETURNING item */ - cb_note (COB_WARNOPT_NONE, 0, _("returning items ('%s' in the definition and '%s' in the prototype) differ"), + cb_note (cb_warn_repository_checks, 0, + _("returning items ('%s' in the definition and '%s' in the prototype) differ"), def_item->name, proto_item->name); } } @@ -3292,25 +3336,37 @@ error_if_signatures_differ (struct cb_program *prog1, struct cb_program *prog2) if (definition->prog_type != prototype->prog_type) { if (definition->prog_type == COB_MODULE_TYPE_PROGRAM) { emit_definition_prototype_error (element_name, - _("definition is a program but the prototype is a function"), - &prototype_error_header_shown); + _("definition is a program but the prototype is a function"), + &prototype_error_header_shown); } else { /* function */ emit_definition_prototype_error (element_name, - _("definition is a function but the prototype is a program"), - &prototype_error_header_shown); + _("definition is a function but the prototype is a program"), + &prototype_error_header_shown); } } if (definition->decimal_point != prototype->decimal_point) { - emit_definition_prototype_error (element_name, - _("DECIMAL-POINT IS COMMA clauses differ"), - &prototype_error_header_shown); + emit_definition_prototype_clause_mismatch ( + element_name, "DECIMAL-POINT IS COMMA", + &prototype_error_header_shown); } if (definition->currency_symbol != prototype->currency_symbol) { - emit_definition_prototype_error (element_name, - _("CURRENCY clauses differ"), - &prototype_error_header_shown); + emit_definition_prototype_clause_mismatch ( + element_name, "CURRENCY", + &prototype_error_header_shown); + } + + /* + prototype is a COBOL 2002 feature, which dropped the ENTRY statement, + we therefore only check the number of its "main" entry point and + also check the call-convention using that + */ + if (cb_get_int (definition->entry_convention) + != cb_get_int (prototype->entry_convention)) { + emit_definition_prototype_clause_mismatch ( + element_name, "ENTRY-CONVENTION", + &prototype_error_header_shown); } /* @@ -3336,17 +3392,19 @@ error_if_signatures_differ (struct cb_program *prog1, struct cb_program *prog2) if ((CB_PURPOSE_INT (def_item) != CB_PURPOSE_INT (proto_item)) || (def_field->flag_is_pdiv_opt != proto_field->flag_is_pdiv_opt)) { - /* To-do: Improve error message. */ - cb_note (COB_WARNOPT_NONE, 0, "parameters #%d have different clauses in the procedure division header", - parameter_num); + cb_note (cb_warn_repository_checks, 0, + _("parameters #%d ('%s' in the definition and '%s' in the prototype) differ"), + parameter_num, def_field->name, proto_field->name); + emit_definition_prototype_clause_mismatch ( + element_name, "OPTIONAL", &prototype_error_header_shown); } } } } else { emit_definition_prototype_error (element_name, - _("number of parameters differ"), - &prototype_error_header_shown); + _("number of parameters differ"), + &prototype_error_header_shown); } /* Compare returning items. */ @@ -3355,12 +3413,12 @@ error_if_signatures_differ (struct cb_program *prog1, struct cb_program *prog2) && !(definition->returning && prototype->returning)) { if (definition->returning) { emit_definition_prototype_error (element_name, - _("definition has a RETURNING item but prototype does not"), - &prototype_error_header_shown); + _("definition has a RETURNING item but prototype does not"), + &prototype_error_header_shown); } else { emit_definition_prototype_error (element_name, - _("definition does not have a RETURNING item but prototype does"), - &prototype_error_header_shown); + _("definition does not have a RETURNING item but prototype does"), + &prototype_error_header_shown); } } else if (definition->returning && prototype->returning) { error_if_items_differ (element_name, @@ -3430,12 +3488,14 @@ check_argument_conformance (struct cb_program *program, cb_tree argument_tripple if ((arg_mode == CB_CALL_BY_REFERENCE || arg_mode == CB_CALL_BY_CONTENT) && param_mode != CB_CALL_BY_REFERENCE) { /* TO-DO: Improve name of CB_VALUE (argument_tripple) */ - cb_warning_x (cb_warn_repository_checks, arg_tree, _("expected argument #%d, %s, to be passed BY VALUE"), - param_num, cb_name (arg_tree)); + cb_warning_x (cb_warn_repository_checks, arg_tree, + _("expected argument #%d, %s, to be passed BY VALUE"), + param_num, cb_name (arg_tree)); } else if (arg_mode == CB_CALL_BY_VALUE && param_mode != CB_CALL_BY_VALUE) { - cb_warning_x (cb_warn_repository_checks, arg_tree, _("expected argument #%d, %s, to be passed BY REFERENCE/CONTENT"), - param_num, cb_name (arg_tree)); + cb_warning_x (cb_warn_repository_checks, arg_tree, + _("expected argument #%d, %s, to be passed BY REFERENCE/CONTENT"), + param_num, cb_name (arg_tree)); } if (CB_REF_OR_FIELD_P (arg_tree)) { @@ -3452,7 +3512,8 @@ check_argument_conformance (struct cb_program *program, cb_tree argument_tripple if (arg_mode == CB_CALL_BY_REFERENCE && arg_tree == cb_null && !param_field->flag_is_pdiv_opt) { - cb_warning_x (cb_warn_repository_checks, arg_tree, _("argument #%d is not optional"), param_num); + cb_warning_x (cb_warn_repository_checks, arg_tree, + _("argument #%d is not optional"), param_num); return; } @@ -3465,7 +3526,8 @@ check_argument_conformance (struct cb_program *program, cb_tree argument_tripple || is_alphanum_group (param_field)) { if (param_mode == CB_CALL_BY_REFERENCE) { if (get_size (arg_tree) < param_field->size) { - cb_warning_x (cb_warn_repository_checks, arg_tree, _("argument #%d must be at least %d bytes long"), + cb_warning_x (cb_warn_repository_checks, arg_tree, + _("argument #%d must be at least %d bytes long"), param_num, param_field->size); } return; @@ -3595,12 +3657,14 @@ cb_check_conformance (cb_tree prog_ref, cb_tree using_list, if (prog_returning_field->flag_any_length && !call_returning_field->flag_any_length) { /* To-do: Check! */ - cb_warning_x (cb_warn_repository_checks, returning, _("the RETURNING item is of a fixed size, not ANY LENGTH")); + cb_warning_x (cb_warn_repository_checks, returning, + _("the RETURNING item is of a fixed size, not ANY LENGTH")); } if (!items_have_same_data_clauses (call_returning_field, prog_returning_field, 0)) { /* TO-DO: Improve message! */ - cb_warning_x (cb_warn_repository_checks, returning, _("RETURNING item %s is not a valid type"), + cb_warning_x (cb_warn_repository_checks, returning, + _("RETURNING item %s is not a valid type"), cb_name (CB_TREE (call_returning_field))); } } else if (returning && !program->returning) { @@ -4081,7 +4145,7 @@ cb_validate_program_environment (struct cb_program *prog) } /* Check CLASS clauses for duplicates */ - if (cb_warn_additional) { + if (cb_warn_opt_val[cb_warn_additional] != COBC_WARN_DISABLED) { for (l = prog->class_name_list; l; l = CB_CHAIN (l)) { check_class_duplicates (CB_VALUE (l)); } @@ -9668,7 +9732,6 @@ cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value, PIC L fields are initialized up to length indicated by DEPENDING var. */ cb_tree temp; - struct cb_field *f; temp = cb_build_index (cb_build_filler (), NULL, 0, NULL); f = CB_FIELD (cb_ref (temp)); f->usage = CB_USAGE_LENGTH; @@ -12955,7 +13018,6 @@ cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col, cb_tree nat_col) { cb_tree l; cb_tree rtree; - struct cb_field *f; if (cb_validate_list (keys)) { return; @@ -13010,6 +13072,7 @@ cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col, cb_tree nat_col) cb_int (CB_FIELD_PTR (CB_VALUE(l))->offset))); } } else { + struct cb_field * const fr = CB_FIELD (rtree); cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort_init", cb_int ((int)cb_list_length (keys)), col)); /* TODO: pass key-specific collation to libcob */ @@ -13021,11 +13084,10 @@ cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col, cb_tree nat_col) cb_int(f->offset - (f->parent ? f->parent->offset : 0)))); } - f = CB_FIELD (rtree); cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort", name, - (f->depending - ? cb_build_cast_int (f->depending) - : cb_int (f->occurs_max)))); + (fr->depending + ? cb_build_cast_int (fr->depending) + : cb_int (fr->occurs_max)))); } } diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 76d498dc9..96d1efb81 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,8 @@ +2022-12-08 Simon Sobisch + + * common.h (cob_module_type): module type as enum instead of defines only + 2022-12-06 Simon Sobisch * fileio.c (cob_sys_read_file): if called with flag value 128 only resolve diff --git a/libcob/common.h b/libcob/common.h index d27e28265..f8e83ab7c 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1190,8 +1190,10 @@ typedef struct __cob_screen { } cob_screen; /* Module structure */ -#define COB_MODULE_TYPE_PROGRAM 0 -#define COB_MODULE_TYPE_FUNCTION 1 +enum cob_module_type { + COB_MODULE_TYPE_PROGRAM = 0, + COB_MODULE_TYPE_FUNCTION = 1 +}; /* For backwards compatibility of the libcob ABI, the size of existing members diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index cbae347f3..dbd935cfb 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -992,11 +992,10 @@ AT_DATA([prog.cob], [ 01 X-X PIC XXXX VALUE "0001". 01 X-9 PIC 9999 COMP VALUE 1. PROCEDURE DIVISION. - IF X-X = X-9 - STOP RUN - END-IF. - DISPLAY "NG" NO ADVANCING - END-DISPLAY + IF X-X NOT = X-9 + DISPLAY "NG X-X <> X-9". + IF X-9 NOT = X-X + DISPLAY "NG X-9 <> X-X". STOP RUN. ]) diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 722337706..f5d888385 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -5455,29 +5455,16 @@ AT_DATA([prog.cob], [ END PROGRAM invalid-3. ]) -# TODO message handling has to be adjusted -#AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], -#[prog.cob:59: error: prototype and definition of 'invalid-1' do not match -# definition is a program but the prototype is a function; -# DECIMAL-POINT IS COMMA clauses differ; -# CURRENCY clauses differ; -# parameters #1 ('a-1' in the definition an 'x1' in the prototype) differ; -# returning items ('b' in the definition an 'y' in the prototype) differ -#prog.cob:72: error: prototype and definition of 'invalid-2' do not match -# number of parameters differ; -# definition has a RETURNING item but protoype does not; -#prog.cob:106: error: prototypes must be come before any program/function definitions -#]) -AT_CHECK([$COMPILE_ONLY -Wno-unfinished prog.cob], [1], [], -[prog.cob:59: error: prototype and definition of 'invalid-1' do not match -prog.cob:59: note: definition is a program but the prototype is a function -prog.cob:59: note: DECIMAL-POINT IS COMMA clauses differ -prog.cob:59: note: CURRENCY clauses differ -prog.cob:59: note: parameters #1 ('a-1' in the definition an 'x1' in the prototype) differ -prog.cob:59: note: returning items ('b' in the definition an 'y' in the prototype) differ -prog.cob:72: error: prototype and definition of 'invalid-2' do not match -prog.cob:72: note: number of parameters differ -prog.cob:72: note: definition has a RETURNING item but protoype does not +AT_CHECK([$COMPILE_ONLY -Wno-unfinished -Wno-pending prog.cob], [1], [], +[prog.cob:60: warning: prototype and definition of 'invalid-1' do not match +prog.cob:60: note: definition is a program but the prototype is a function +prog.cob:60: note: DECIMAL-POINT IS COMMA clauses differ +prog.cob:60: note: CURRENCY clauses differ +prog.cob:60: note: parameters #1 ('a-1' in the definition and 'x1' in the prototype) differ +prog.cob:60: note: returning items ('b' in the definition and 'y' in the prototype) differ +prog.cob:73: warning: prototype and definition of 'invalid-2' do not match +prog.cob:73: note: number of parameters differ +prog.cob:73: note: definition has a RETURNING item but protoype does not prog.cob:106: error: prototypes must be come before any program/function definitions ]) AT_CLEANUP From 9574417e46ea79c008a0fe16e1eb3b58b4974394 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 8 Dec 2022 16:58:50 +0000 Subject: [PATCH 02/18] fixing minor compiler warnings and an (old) error for [!HAVE_SETLOCALE] --- libcob/common.c | 20 ++++++++++++-------- libcob/intrinsic.c | 7 +++---- libcob/numeric.c | 14 +++++--------- libcob/termio.c | 2 +- 4 files changed, 21 insertions(+), 22 deletions(-) diff --git a/libcob/common.c b/libcob/common.c index 1180daefa..5931a40d0 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -418,7 +418,6 @@ static struct config_tbl gc_conf[] = { {"COB_DEBUG_LOG", "debug_log", NULL, NULL, GRP_HIDE, ENV_FILE, SETPOS (cob_debug_log)}, {"COB_DISABLE_WARNINGS", "disable_warnings", "0", NULL, GRP_MISC, ENV_BOOL | ENV_NOT, SETPOS (cob_display_warn)}, {"COB_ENV_MANGLE", "env_mangle", "0", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_env_mangle)}, - {"COB_COL_JUST_LRC", "col_just_lrc", "true", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_col_just_lrc)}, {"COB_REDIRECT_DISPLAY", "redirect_display", "0", NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_disp_to_stderr)}, {"COB_SCREEN_ESC", "screen_esc", "0", NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_use_esc)}, {"COB_SCREEN_EXCEPTIONS", "screen_exceptions", "0", NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_extended_status)}, @@ -469,6 +468,7 @@ static struct config_tbl gc_conf[] = { #ifdef WITH_DB {"DB_HOME", "db_home", NULL, NULL, GRP_FILE, ENV_FILE, SETPOS (bdb_home)}, #endif + {"COB_COL_JUST_LRC", "col_just_lrc", "true", NULL, GRP_FILE, ENV_BOOL, SETPOS (cob_col_just_lrc)}, {"COB_DISPLAY_PRINT_PIPE", "display_print_pipe", NULL, NULL, GRP_SCREEN, ENV_STR, SETPOS (cob_display_print_pipe)}, {"COBPRINTER", "printer", NULL, NULL, GRP_HIDE, ENV_STR, SETPOS (cob_display_print_pipe)}, {"COB_DISPLAY_PRINT_FILE", "display_print_file", NULL, NULL, GRP_SCREEN, ENV_STR,SETPOS (cob_display_print_filename)}, @@ -2735,8 +2735,8 @@ call_exit_handlers_and_terminate (void) while (h != NULL) { h->proc (); h = h->next; - } } + } cob_terminate_routines (); } @@ -4131,7 +4131,7 @@ get_function_ptr_for_precise_time (void) /* split the timep to cob_time and set the offset from UTC */ void static set_cob_time_from_localtime (time_t curtime, - struct cob_time *cb_time, const enum cob_datetime_res res) { + struct cob_time *cb_time) { struct tm *tmptr; #if !defined (_BSD_SOURCE) && !defined (HAVE_TIMEZONE) @@ -4250,7 +4250,7 @@ cob_get_current_date_and_time_from_os (const enum cob_datetime_res res) struct cob_time cb_time; curtime = time (NULL); - set_cob_time_from_localtime (curtime, &cb_time, res); + set_cob_time_from_localtime (curtime, &cb_time); if (res <= DTR_TIME_NO_NANO) { cb_time.nanosecond = 0; @@ -4298,7 +4298,7 @@ cob_get_current_date_and_time_from_os (const enum cob_datetime_res res) curtime = time (NULL); #endif - set_cob_time_from_localtime (curtime, &cb_time, res); + set_cob_time_from_localtime (curtime, &cb_time); /* Get nanoseconds or microseconds, if possible */ #if defined (HAVE_CLOCK_GETTIME) @@ -6680,19 +6680,23 @@ cob_sys_printable (void *p1, ...) } else { dotrep = (unsigned char)'.'; } +#ifdef HAVE_SETLOCALE if (cobglobptr->cob_locale_ctype) { previous_locale = setlocale (LC_CTYPE, NULL); setlocale (LC_CTYPE, cobglobptr->cob_locale_ctype); } +#endif data = p1; for (n = 0; n < datalen; ++n) { if (!isprint (data[n])) { data[n] = dotrep; } } +#ifdef HAVE_SETLOCALE if (previous_locale) { setlocale (LC_CTYPE, previous_locale); } +#endif return 0; } @@ -9918,13 +9922,13 @@ cob_stack_trace_internal (FILE *target, int verbose, int count) } if (verbose && cob_argc != 0) { - size_t i; + size_t ia; write_or_return_arr (file_no, " Started by "); write_or_return_str (file_no, cob_argv[0]); write_or_return_arr (file_no, "\n"); - for (i = 1; i < (size_t)cob_argc; ++i) { + for (ia = 1; ia < (size_t)cob_argc; ++ia) { write_or_return_arr (file_no, "\t"); - write_or_return_str (file_no, cob_argv[i]); + write_or_return_str (file_no, cob_argv[ia]); write_or_return_arr (file_no, "\n"); } } diff --git a/libcob/intrinsic.c b/libcob/intrinsic.c index a798da3d8..6ba911620 100644 --- a/libcob/intrinsic.c +++ b/libcob/intrinsic.c @@ -5494,9 +5494,9 @@ cob_intr_random (const int params, ...) va_list args; double val; #ifdef DISABLE_GMP_RANDOM - unsigned int seed; + unsigned int seed = 0; #else - unsigned long seed; + unsigned long seed = 0; #endif cob_field_attr attr; cob_field field; @@ -5508,9 +5508,8 @@ cob_intr_random (const int params, ...) specified_seed = cob_get_llint (f); if (specified_seed < 0) { cob_set_exception (COB_EC_ARGUMENT_FUNCTION); - seed = 0; } else { - seed = specified_seed; + seed = (unsigned long)specified_seed; } rand_needs_seeding++; #ifdef DISABLE_GMP_RANDOM diff --git a/libcob/numeric.c b/libcob/numeric.c index d87d594da..ec30fedb9 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -1631,16 +1631,12 @@ static void cob_decimal_do_round (cob_decimal *d, cob_field *f, const int opt) { cob_uli_t adj; - int sign; - int scale; + const int sign = mpz_sgn (d->value); + const int scale = COB_FIELD_SCALE (f); - sign = mpz_sgn (d->value); - /* Returns 0 when value is 0 */ - if (!sign) { - return; - } - scale = COB_FIELD_SCALE(f); - if (scale >= d->scale) { + /* Nothing to do when value is 0 or when target has >= scale */ + if (!sign + || scale >= d->scale) { return; } diff --git a/libcob/termio.c b/libcob/termio.c index 44116d937..8e4172da0 100644 --- a/libcob/termio.c +++ b/libcob/termio.c @@ -166,7 +166,7 @@ pretty_display_numeric (cob_field *f, FILE *fp) cob_move (f, &temp); while (q != end) { - unsigned int chr = *q++; + const int chr = *q++; if (putc (chr, fp) != chr) { break; } From 1b5fa89452ae8aba124a5376c705fbba808ea847 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 8 Dec 2022 22:17:52 +0000 Subject: [PATCH 03/18] optimization for CALL and for executing modules generated with 2.2 - 3.1 libcob: * call.c (cob_call_field): speedup of consecutive CALLs by doing the lookup in called programs before testing the system routines * call.c (cob_call_field, cob_call_init): speedup of first CALL by using comparing name hash against newly added hash of system routines before doing an expensive strcmp against their names * call.c [COB_ALT_HASH]: removed * common.c (cob_field_to_string), call.c (cob_chk_call_path): optimized * call.c (hash): optimized, especially for debug builds * common.c: added hashing for resolving the statement from a given string, instead of heavy use of strcmp; note: this is only used for backward compatibilty and then reduces the previously overhead to the minimum tests: * atlocal.in, atlocal_win, atlocal_valgrind: added COB_MODULE_EXT * added a multitude of missing tests related to CALL cobc (fixing the newly added prototype related tests): * typeck.c (cb_build_ppointer), tree.c (cb_name_1): added missing handling for prototype * codegen.c (output_param): added handling for prototype name, returning its name as literal --- NEWS | 31 ++-- cobc/ChangeLog | 4 + cobc/codegen.c | 13 +- cobc/tree.c | 4 + cobc/typeck.c | 17 +- libcob/ChangeLog | 14 ++ libcob/call.c | 170 +++++++++---------- libcob/common.c | 79 ++++++--- tests/ChangeLog | 4 + tests/atlocal.in | 4 +- tests/atlocal_valgrind | 4 +- tests/atlocal_win | 5 +- tests/testsuite.src/run_fundamental.at | 223 ++++++++++++++++++++++++- tests/testsuite.src/run_misc.at | 64 ++++++- tests/testsuite.src/used_binaries.at | 2 +- 15 files changed, 486 insertions(+), 152 deletions(-) diff --git a/NEWS b/NEWS index dae7a2d94..77d772e5a 100644 --- a/NEWS +++ b/NEWS @@ -288,8 +288,8 @@ NEWS - user visible changes -*- outline -*- this has been fixed so that all modules compiled with GnuCOBOL 2.2 can be executed with GnuCOBOL 3.2 -** FUNCTION RANDOM could return 1 in rare cases (more often in win32), it now - returns, as defined, a value in the range 0 <= x < 1 +** FUNCTION RANDOM could return 1 in rare cases (more likely on win32), + it now returns a value in the range 0 <= x < 1, as defined ** the internal signal handler could crash or deadlock the process on hard errors (either in called library functions or when running COBOL without @@ -336,8 +336,10 @@ NEWS - user visible changes -*- outline -*- ** cobc's parsing time was significantly reduced for big programs -** execution times of INSPECT that use big COBOL fields (multiple KB) were - significantly reduced +** execution times were significantly reduced for the following: + INSPECT that use big COBOL fields (multiple KB) + CALL data-item, and first time for each CALL + ACCEPT DATE/TIME/DAY and datetime related FUNCTIONs ** execution times for programs that are new generated with -fsource-location (implied with --debug/-fec) are cut down, especially when many "simple" @@ -522,24 +524,25 @@ NEWS - user visible changes -*- outline -*- * Changes in the COBOL runtime (libcob) -** Messages from the COBOL runtime are also translated now (if installed). - To prevent this disable translations in general with using the configure - option --disable-nls (or by deactivating ENABLE_NLS in config.h). +** messages from the COBOL runtime are also translated now (if installed); + to prevent this, disable translations in general with using the configure + option --disable-nls (or by deactivating ENABLE_NLS in config.h) + +** first-time file-locking under Win32 + +** handle CRT STATUS either numerically, alphanumerically (4 digits) or as 3 + bytes according to X/Open standard, depending on format and size + +** execution times of INSPECT and INITIALIZE with OCCURS were heavily cut down, + to fully benefit from this a recompile is necessary ** libcob.h does no longer auto-include gmp.h (behavior since 2.x), if you link against libcob and need cob_decimal include gmp.h/mpir.h yourself before; otherwise you do not need it in your include path anymore -** execution times of INSPECT and INITIALIZE with OCCURS were heavily cut down - ** convenience functions for direct C access to COBOL fields and for debugging were added, see new C-API documentation -** first-time file-locking under Win32 - -** handle CRT STATUS either numerically, alphanumerically (4 digits) or as 3 - bytes according to X/Open standard, depending on format and size - ** Breaking change: previously the return-code of registered error handlers (by CBL_ERROR_PROC) were ignored. This was changed according to the documentation for CBL_ERROR_PROC -> a RETURN-VALUE of ZERO skips further diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 6592f0eaa..c218e21a3 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -9,6 +9,10 @@ * typeck.c (cb_validate_program_environment): fixed bad test of warning option for CLASS check * typeck.c (cb_emit_sort_init): minor refactoring + * typeck.c (cb_build_ppointer), tree.c (cb_name_1): added missing + handling for prototype + * codegen.c (output_param): added handling for prototype name, + returning its name as literal 2022-12-05 Nicolas Berthier diff --git a/cobc/codegen.c b/cobc/codegen.c index 95f6d209c..21a165d52 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -3697,13 +3697,20 @@ output_param (cb_tree x, int id) case CB_TAG_REFERENCE: r = CB_REFERENCE (x); if (CB_LOCALE_NAME_P (r->value)) { - output_param (CB_LOCALE_NAME(r->value)->list, id); + output_param (CB_LOCALE_NAME (r->value)->list, id); break; } if (CB_REPORT_P (r->value)) { output ("&%s%s", CB_PREFIX_REPORT, CB_REPORT_PTR (r->value)->cname); break; } + if (CB_PROTOTYPE_P (r->value)) { + const char *name = CB_PROTOTYPE (r->value)->ext_name; + const size_t len = strlen (name); + cb_tree lit = cb_build_alphanumeric_literal (name, len); + output_param (lit, 0); + break; + } if (r->check) { int n; int sav_stack_id; @@ -3741,7 +3748,7 @@ output_param (cb_tree x, int id) break; } if (CB_ALPHABET_NAME_P (r->value)) { - struct cb_alphabet_name *rbp = CB_ALPHABET_NAME (r->value); + const struct cb_alphabet_name *rbp = CB_ALPHABET_NAME (r->value); switch (rbp->alphabet_type) { case CB_ALPHABET_ASCII: #ifdef COB_EBCDIC_MACHINE @@ -3790,7 +3797,7 @@ output_param (cb_tree x, int id) f = CB_FIELD (r->value); { - struct cb_field *ff = real_field_founder (f); + const struct cb_field *ff = real_field_founder (f); if (ff->flag_external || ff->flag_item_based) { f->flag_local = 1; diff --git a/cobc/tree.c b/cobc/tree.c index ef03fbd9b..2700c5480 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -670,6 +670,10 @@ cb_name_1 (char *s, cb_tree x, const int size) size_real = snprintf (s, size, "%s", CB_LOCALE_NAME (x)->name); break; + case CB_TAG_PROTOTYPE: + size_real = snprintf (s, size, "%s", (char*)(CB_PROTOTYPE (x)->name)); + break; + case CB_TAG_BINARY_OP: { const struct cb_binary_op *cbop = CB_BINARY_OP (x); char buff [COB_SMALL_BUFF]; diff --git a/cobc/typeck.c b/cobc/typeck.c index b0b3315f9..52ae17067 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2981,16 +2981,21 @@ cb_build_length (cb_tree x) cb_tree cb_build_ppointer (cb_tree x) { - struct cb_field *f; - - if (x == cb_error_node || - (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node)) { + if (x == cb_error_node) { return cb_error_node; } if (CB_REFERENCE_P (x)) { - f = CB_FIELD_PTR (cb_ref(x)); - f->count++; + /* we get here with either a field reference + (then increment use), or by prototpye; + CHECKME, count should be incremented by reference already */ + cb_tree xf = cb_ref (x); + if (xf == cb_error_node) { + return cb_error_node; + } + if (CB_FIELD_P (xf)) { + CB_FIELD (xf)->count++; + } } return CB_BUILD_CAST_PPOINTER (x); } diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 96d1efb81..ba6131fda 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -2,6 +2,20 @@ 2022-12-08 Simon Sobisch * common.h (cob_module_type): module type as enum instead of defines only + * call.c (cob_call_field, cob_call_init): speedup of first CALL by using + comparing name hash against newly added hash of system routines before + doing an expensive strcmp against their names + * call.c [COB_ALT_HASH]: removed + * common.c (cob_field_to_string), call.c (cob_chk_call_path): optimized + * call.c (hash): optimized, especially for debug builds + * common.c: added hashing for resolving the statement from a given string, + instead of heavy use of strcmp; note: this is only used for backward + compatibilty and then reduces the previously overhead to the minimum + +2022-12-07 Simon Sobisch + + * call.c (cob_call_field): speedup of consecutive CALLs by doing the + lookup in called programs before testing the system routines 2022-12-06 Simon Sobisch diff --git a/libcob/call.c b/libcob/call.c index dfd7d1b2b..389513502 100644 --- a/libcob/call.c +++ b/libcob/call.c @@ -126,9 +126,6 @@ lt_dlerror (void) #define HASH_SIZE 131U /* Call table */ -#if 0 /* Alternative hash structure */ -#define COB_ALT_HASH -#endif struct call_hash { struct call_hash *next; /* Linked list next pointer */ @@ -148,16 +145,13 @@ struct struct_handle { struct system_table { const char *syst_name; + int syst_hash_val; cob_call_union syst_call; }; /* Local variables */ -#ifdef COB_ALT_HASH -static struct call_hash *call_table; -#else static struct call_hash **call_table; -#endif static struct struct_handle *base_preload_ptr; static struct struct_handle *base_dynload_ptr; @@ -188,11 +182,11 @@ static cob_field_attr const_binull_attr = #undef COB_SYSTEM_GEN #define COB_SYSTEM_GEN(cob_name, pmin, pmax, c_name) \ - { cob_name, {(void *(*)(void *))c_name} }, + { cob_name, 0, {(void *(*)(void *))c_name} }, -static const struct system_table system_tab[] = { +static struct system_table system_tab[] = { #include "system.def" - { NULL, {NULL} } + { NULL, 0, {NULL} } }; #undef COB_SYSTEM_GEN @@ -603,16 +597,11 @@ cache_preload (const char *path) on calls of cob_try_preload later on (only expected when done via interactive debugger) */ if (call_buffer -#ifndef COB_ALT_HASH && call_table) { struct call_hash *p; size_t i; for (i = 0; i < HASH_SIZE; ++i) { p = call_table[i]; -#else - ) { - p = call_table; -#endif for (; p;) { if ((p->path && !strcmp (path, p->path)) || (p->name && !strcmp (path, p->name))) { @@ -623,9 +612,7 @@ cache_preload (const char *path) p = p->next; } } -#ifndef COB_ALT_HASH } -#endif if (access (path, R_OK) != 0) { return 0; @@ -641,18 +628,17 @@ cache_preload (const char *path) return 1; } -#ifndef COB_ALT_HASH static COB_INLINE unsigned int hash (const unsigned char *s) { - unsigned int val = 0; + register const unsigned char *p = s; + register unsigned int val = 0; - while (*s) { - val += *s++; + while (*p) { + val += *p++; } return val % HASH_SIZE; } -#endif static void insert (const char *name, void *func, lt_dlhandle handle, @@ -660,9 +646,7 @@ insert (const char *name, void *func, lt_dlhandle handle, const unsigned int nocanc) { struct call_hash *p; -#ifndef COB_ALT_HASH unsigned int val; -#endif p = cob_malloc (sizeof (struct call_hash)); p->name = cob_strdup (name); @@ -690,14 +674,9 @@ insert (const char *name, void *func, lt_dlhandle handle, } } p->no_phys_cancel = nocanc; -#ifdef COB_ALT_HASH - p->next = call_table; - call_table = p; -#else val = hash ((const unsigned char *)name); p->next = call_table[val]; call_table[val] = p; -#endif } static void * @@ -705,11 +684,7 @@ lookup (const char *name) { struct call_hash *p; -#ifdef COB_ALT_HASH - p = call_table; -#else p = call_table[hash ((const unsigned char *)name)]; -#endif for (; p; p = p->next) { if (strcmp (name, p->name) == 0) { return p->func; @@ -811,7 +786,7 @@ cob_encode_program_id (const unsigned char *const name, static void * cob_resolve_internal (const char *name, const char *dirent, - const int fold_case, int module_type) + const int fold_case, int module_type, int cache_check) { void *func; struct struct_handle *preptr; @@ -821,17 +796,14 @@ cob_resolve_internal (const char *name, const char *dirent, unsigned char call_module_buff[COB_MAX_NAMELEN + 1]; const unsigned char *s; - /* LCOV_EXCL_START */ - if (unlikely(!cobglobptr)) { - cob_fatal_error (COB_FERROR_INITIALIZED); - } - /* LCOV_EXCL_STOP */ cobglobptr->cob_exception_code = 0; /* Search the cache */ - func = lookup (name); - if (func) { - return func; + if (cache_check) { + func = lookup (name); + if (func) { + return func; + } } if (strlen (name) > COB_MAX_NAMELEN) { @@ -1019,26 +991,22 @@ cob_chk_dirp (const char *name) return name; } +/* split buffer into potential directory and entry name */ static char * cob_chk_call_path (const char *name, char **dirent) { - char *p; + register char *p; char *q; - size_t size1; - size_t size2; *dirent = NULL; q = NULL; - size2 = 0; - for (p = (char *)name, size1 = 0; *p; p++, size1++) { + for (p = (char *)name; *p; p++) { if (*p == '/' || *p == '\\') { q = p + 1; - size2 = size1 + 1; } } if (q) { - p = cob_strdup (name); - p[size2] = 0; + p = cob_strndup (name, q - name); *dirent = p; for (; *p; p++) { #ifdef _WIN32 @@ -1084,11 +1052,7 @@ cob_set_cancel (cob_module *m) { struct call_hash *p; -#ifdef COB_ALT_HASH - p = call_table; -#else p = call_table[hash ((const unsigned char *)(m->module_name))]; -#endif for (; p; p = p->next) { if (strcmp (m->module_name, p->name) == 0) { p->module = m; @@ -1109,8 +1073,14 @@ cob_resolve (const char *name) char *entry; char *dirent; + /* LCOV_EXCL_START */ + if (unlikely (!cobglobptr)) { + cob_fatal_error (COB_FERROR_INITIALIZED); + } + /* LCOV_EXCL_STOP */ + entry = cob_chk_call_path (name, &dirent); - p = cob_resolve_internal (entry, dirent, 0, COB_MODULE_TYPE_PROGRAM); + p = cob_resolve_internal (entry, dirent, 0, COB_MODULE_TYPE_PROGRAM, 1); if (dirent) { cob_free (dirent); } @@ -1124,8 +1094,14 @@ cob_resolve_cobol (const char *name, const int fold_case, const int errind) char *entry; char *dirent; + /* LCOV_EXCL_START */ + if (unlikely (!cobglobptr)) { + cob_fatal_error (COB_FERROR_INITIALIZED); + } + /* LCOV_EXCL_STOP */ + entry = cob_chk_call_path (name, &dirent); - p = cob_resolve_internal (entry, dirent, fold_case, COB_MODULE_TYPE_PROGRAM); + p = cob_resolve_internal (entry, dirent, fold_case, COB_MODULE_TYPE_PROGRAM, 1); if (dirent) { cob_free (dirent); } @@ -1143,7 +1119,13 @@ cob_resolve_func (const char *name) { void *p; - p = cob_resolve_internal (name, NULL, 0, COB_MODULE_TYPE_FUNCTION); + /* LCOV_EXCL_START */ + if (unlikely (!cobglobptr)) { + cob_fatal_error (COB_FERROR_INITIALIZED); + } + /* LCOV_EXCL_STOP */ + + p = cob_resolve_internal (name, NULL, 0, COB_MODULE_TYPE_FUNCTION, 1); if (unlikely(!p)) { /* Note: exception raised above */ cob_runtime_error (_("user-defined FUNCTION '%s' not found"), name); @@ -1156,12 +1138,8 @@ void * cob_call_field (const cob_field *f, const struct cob_call_struct *cs, const unsigned int errind, const int fold_case) { - void *p; - const struct cob_call_struct *s; - const struct system_table *psyst; - char *buff; - char *entry; - char *dirent; + char *buff, *entry, *dirent; + void *p; /* LCOV_EXCL_START */ if (unlikely(!cobglobptr)) { @@ -1187,28 +1165,44 @@ cob_call_field (const cob_field *f, const struct cob_call_struct *cs, entry = cob_chk_call_path (buff, &dirent); - /* Check if system routine */ - for (psyst = system_tab; psyst->syst_name; ++psyst) { - if (!strcmp (entry, psyst->syst_name)) { - if (dirent) { - cob_free (dirent); + /* Check if contained program - which may override otherwise + loaded programs */ + { + const struct cob_call_struct *s = cs; + while (s && s->cob_cstr_name) { + if (!strcmp (entry, s->cob_cstr_name)) { + if (dirent) { + cob_free (dirent); + } + return s->cob_cstr_call.funcvoid; } - return psyst->syst_call.funcvoid; + s++; } } + /* Search the cache */ + p = lookup (entry); + if (p) { + return p; + } - /* Check if contained program */ - for (s = cs; s && s->cob_cstr_name; s++) { - if (!strcmp (entry, s->cob_cstr_name)) { - if (dirent) { - cob_free (dirent); + /* Check if system routine */ + { + const struct system_table *psyst = system_tab; + const int entry_hash = hash ((unsigned char *)entry); + while (psyst->syst_name) { + if (psyst->syst_hash_val == entry_hash + && !strcmp (psyst->syst_name, entry)) { + if (dirent) { + cob_free (dirent); + } + return psyst->syst_call.funcvoid; } - return s->cob_cstr_call.funcvoid; + ++psyst; } } - p = cob_resolve_internal (entry, dirent, fold_case, COB_MODULE_TYPE_PROGRAM); + p = cob_resolve_internal (entry, dirent, fold_case, COB_MODULE_TYPE_PROGRAM, 0); if (dirent) { cob_free (dirent); } @@ -1253,13 +1247,8 @@ cob_cancel (const char *name) entry = cob_chk_dirp (name); -#ifdef COB_ALT_HASH - q = &call_table; - p = *q; -#else q = &call_table[hash ((const unsigned char *)entry)]; p = *q; -#endif r = NULL; for (; p; p = p->next) { if (strcmp (entry, p->name) == 0) { @@ -1510,16 +1499,12 @@ cob_exit_call (void) resolve_size = 0; } -#ifndef COB_ALT_HASH if (call_table) { struct call_hash *p; struct call_hash *q; size_t i; for (i = 0; i < HASH_SIZE; ++i) { p = call_table[i]; -#else - p = call_table; -#endif for (; p;) { q = p; p = p->next; @@ -1531,14 +1516,12 @@ cob_exit_call (void) } cob_free (q); } -#ifndef COB_ALT_HASH } if (call_table) { cob_free (call_table); } call_table = NULL; } -#endif for (h = base_preload_ptr; h;) { j = h; @@ -1643,11 +1626,16 @@ cob_init_call (cob_global *lptr, cob_settings* sptr, const int check_mainhandle) /* Big enough for anything from libdl/libltdl */ resolve_error_buff = cob_malloc ((size_t)CALL_BUFF_SIZE); -#ifndef COB_ALT_HASH call_table = cob_malloc (sizeof (struct call_hash *) * HASH_SIZE); -#else - call_table = NULL; -#endif + + /* setup hash for system routines (modifying "const table" here) */ + { + struct system_table *psyst = system_tab; + while (psyst->syst_name) { + psyst->syst_hash_val = hash ((const unsigned char *)psyst->syst_name); + ++psyst; + } + } /* set static vars resolve_path (data in resolve_alloc) and resolve_size */ cob_set_library_path (); diff --git a/libcob/common.c b/libcob/common.c index 5931a40d0..6d7fdc35f 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -308,6 +308,7 @@ const char *cob_statement_name[STMT_MAX_ENTRY] = { const char *cob_statement_name[STMT_MAX_ENTRY]; static void init_statement_list (void); #endif +int cob_statement_hash[STMT_MAX_ENTRY] = { 0 }; #ifdef COB_DEBUG_LOG static int cob_debug_log_time = 0; @@ -2330,6 +2331,31 @@ cob_cache_free (void *ptr) } } +static COB_INLINE int +hash (const char *s) +{ + register const char *p = s; + register int val = 0; + + while (*p) { + val += *p++; + } + return val; +} + +static COB_INLINE void +init_statement_hashlist (void) +{ + if (cob_statement_hash[STMT_UNKNOWN] != 0) { + return; + } + cob_statement_hash[STMT_UNKNOWN] = hash("UNKNOWN"); +#define COB_STATEMENT(ename,str) \ + cob_statement_hash[ename] = hash(str); +#include "statement.def" /* located and installed next to common.h */ +#undef COB_STATEMENT +} + /* cob_set_location is kept for backward compatibility (pre 3.0); it stored the location for exception handling and related intrinsic functions and did tracing, depending on a global flag */ @@ -2341,16 +2367,20 @@ cob_set_location (const char *sfile, const unsigned int sline, enum cob_statement stmt; cob_module *mod = COB_MODULE_PTR; const char *s; + const int stmt_hash = hash (cstatement); mod->section_name = csect; mod->paragraph_name = cpara; cob_source_file = sfile; cob_source_line = sline; + init_statement_hashlist (); + if (!cstatement) { stmt = STMT_UNKNOWN; #define COB_STATEMENT(ename,str) \ - } else if (strcmp (str, cstatement) == 0) { \ + } else if (stmt_hash == cob_statement_hash[ename] \ + && strcmp (str, cstatement) == 0) { \ stmt = ename; #include "statement.def" /* located and installed next to common.h */ #undef COB_STATEMENT @@ -2614,17 +2644,21 @@ cob_trace_exit (const char *name) } } -/* this functin is alltogether a compat-only function for pre 3.2, +/* this function is alltogether a compat-only function for pre 3.2, later versions use cob_trace_statement(enum cob_statement) */ void cob_trace_stmt (const char *stmt_name) { enum cob_statement stmt; + const int stmt_hash = hash (stmt_name); + + init_statement_hashlist (); if (!stmt_name) { stmt = STMT_UNKNOWN; #define COB_STATEMENT(ename,str) \ - } else if (strcmp (str, stmt_name) == 0) { \ + } else if (stmt_hash == cob_statement_hash[ename] \ + && strcmp (str, stmt_name) == 0) { \ stmt = ename; #include "statement.def" /* located and installed next to common.h */ #undef COB_STATEMENT @@ -2690,41 +2724,43 @@ cob_get_pointer (const void *srcptr) void cob_field_to_string (const cob_field *f, void *str, const size_t maxsize) { - unsigned char *s; - size_t count; - size_t i; + register unsigned char *end, *data, *s; if (unlikely (f == NULL)) { snprintf (str, maxsize, "%s", ("NULL field")); return; } - count = 0; if (unlikely (f->size == 0)) { return; } + data = f->data; /* check if field has data assigned (may be a BASED / LINKAGE item) */ - if (unlikely (f->data == NULL)) { + if (data == NULL) { snprintf (str, maxsize, "%s", ("field with NULL address")); return; } - for (i = f->size - 1; ; i--) { - if (f->data[i] && f->data[i] != (unsigned char)' ') { - count = i + 1; - break; - } - if (!i) { + end = data + f->size - 1; + while (end > data) { + if (*end != ' ' && *end) { break; } - } - if (count > maxsize) { - count = maxsize; + end--; } s = (unsigned char *)str; - for (i = 0; i < count; ++i) { - s[i] = f->data[i]; + if (*end == ' ' || *end == 0) { + *s = 0; + return; + } + + /* note: the specified max does not contain the low-value */ + if (end - data > maxsize) { + end = data + maxsize; + } + while (data <= end) { + *s++ = *data++; } - s[i] = 0; + *s = 0; } static void @@ -10383,7 +10419,8 @@ void init_statement_list (void) { cob_statement_name[STMT_UNKNOWN] = "UNKNOWN"; -#define COB_STATEMENT(ename,str) cob_statement_name[ename] = str; +#define COB_STATEMENT(ename,str) \ + cob_statement_name[ename] = str; #include "statement.def" /* located and installed next to common.h */ #undef COB_STATEMENT } diff --git a/tests/ChangeLog b/tests/ChangeLog index 4467c79fc..bb3255d28 100644 --- a/tests/ChangeLog +++ b/tests/ChangeLog @@ -1,4 +1,8 @@ +2022-12-08 Simon Sobisch + + * atlocal.in, atlocal_win, atlocal_valgrind: added COB_MODULE_EXT + 2022-12-02 Simon Sobisch * atlocal.in, atlocal_win: do not disable PDCurses screenio diff --git a/tests/atlocal.in b/tests/atlocal.in index 6bac9a1c3..a8002ce50 100644 --- a/tests/atlocal.in +++ b/tests/atlocal.in @@ -204,6 +204,7 @@ export COB_STACKTRACE if test "$GNUCOBOL_TEST_LOCAL" != "1"; then COB_OBJECT_EXT="@COB_OBJECT_EXT@" COB_EXE_EXT="@COB_EXE_EXT@" + COB_MODULE_EXT="@COB_MODULE_EXT@" COB_BIGENDIAN="@COB_BIGENDIAN@" COB_HAS_64_BIT_POINTER="@COB_HAS_64_BIT_POINTER@" COB_HAS_ISAM="@COB_HAS_ISAM@" @@ -214,6 +215,7 @@ else COB_OBJECT_EXT="$(grep COB_OBJECT_EXT info.out | cut -d: -f2 | cut -b2-)" COB_EXE_EXT="$(grep COB_EXE_EXT info.out | cut -d: -f2 | cut -b2-)" + COB_MODULE_EXT="$(grep COB_MODULE_EXT info.out | cut -d: -f2 | cut -b2-)" if test $(grep -i -c "little-endian" info.out) = 0; then COB_BIGENDIAN="yes" @@ -282,7 +284,7 @@ rm -rf info.out # NIST tests (tests/cobol85) are executed in a separate perl process with a new environment --> export needed export COB_HAS_ISAM COB_HAS_XML2 COB_HAS_JSON COB_HAS_CURSES COB_HAS_64_BIT_POINTER export COBC COBCRUN COBCRUN_DIRECT RUN_PROG_MANUAL -export COB_OBJECT_EXT COB_EXE_EXT +export COB_OBJECT_EXT COB_EXE_EXT COB_MODULE_EXT # to ensure that no external DB_HOME is polluted: unset DB_HOME="" && export DB_HOME diff --git a/tests/atlocal_valgrind b/tests/atlocal_valgrind index 8c72ad0af..59c4ea52f 100644 --- a/tests/atlocal_valgrind +++ b/tests/atlocal_valgrind @@ -203,6 +203,7 @@ export COB_STACKTRACE if test "$GNUCOBOL_TEST_LOCAL" != "1"; then COB_OBJECT_EXT="@COB_OBJECT_EXT@" COB_EXE_EXT="@COB_EXE_EXT@" + COB_MODULE_EXT="@COB_MODULE_EXT@" COB_BIGENDIAN="@COB_BIGENDIAN@" COB_HAS_64_BIT_POINTER="@COB_HAS_64_BIT_POINTER@" COB_HAS_ISAM="@COB_HAS_ISAM@" @@ -213,6 +214,7 @@ else COB_OBJECT_EXT="$(grep COB_OBJECT_EXT info.out | cut -d: -f2 | cut -b2-)" COB_EXE_EXT="$(grep COB_EXE_EXT info.out | cut -d: -f2 | cut -b2-)" + COB_MODULE_EXT="$(grep COB_MODULE_EXT info.out | cut -d: -f2 | cut -b2-)" if test $(grep -i -c "little-endian" info.out) = 0; then COB_BIGENDIAN="yes" @@ -258,7 +260,7 @@ rm -rf info.out # NIST tests (tests/cobol85) are executed in a separate perl process with a new environment --> export needed export COB_HAS_ISAM COB_HAS_XML2 COB_HAS_JSON COB_HAS_CURSES COB_HAS_64_BIT_POINTER export COBC COBCRUN COBCRUN_DIRECT RUN_PROG_MANUAL -export COB_OBJECT_EXT COB_EXE_EXT +export COB_OBJECT_EXT COB_EXE_EXT COB_MODULE_EXT # to ensure that no external DB_HOME is polluted: unset DB_HOME="" && export DB_HOME diff --git a/tests/atlocal_win b/tests/atlocal_win index 12fa92fc5..a7c22ccff 100644 --- a/tests/atlocal_win +++ b/tests/atlocal_win @@ -137,7 +137,8 @@ export COB_MSG_FORMAT # note: kept intended to ease merge from atlocal.in COB_OBJECT_EXT="$(grep COB_OBJECT_EXT info.out | cut -d: -f2 | cut -b2-)" - COB_EXE_EXT="$(grep COB_EXE_EXT info.out | cut -d: -f2 | cut -b2-)" + COB_EXE_EXT=".exe" + COB_MODULE_EXT="dll" if test $(grep -i -c "little-endian" info.out) = 0; then COB_BIGENDIAN="yes" @@ -206,7 +207,7 @@ rm -rf info.out # NIST tests (tests/cobol85) are executed in a separate perl process with a new environment --> export needed export COB_HAS_ISAM COB_HAS_XML2 COB_HAS_JSON COB_HAS_CURSES COB_HAS_64_BIT_POINTER export COBC COBCRUN COBCRUN_DIRECT RUN_PROG_MANUAL -export COB_OBJECT_EXT COB_EXE_EXT +export COB_OBJECT_EXT COB_EXE_EXT COB_MODULE_EXT # to ensure that no external DB_HOME is polluted: unset DB_HOME="" && export DB_HOME diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 63155db23..c880819b3 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -1635,13 +1635,202 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], AT_CLEANUP -AT_SETUP([CALL/CANCEL with program-prototype-name]) -AT_KEYWORDS([fundamental]) +AT_SETUP([CALL alphanumeric data-name]) +AT_KEYWORDS([fundamental CANCEL]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 prgm PIC X(32) VALUE "recursion-test". + + PROCEDURE DIVISION. + CALL prgm + DISPLAY "<" + + MOVE "cancel-test" TO prgm + CALL prgm + CALL prgm + CANCEL prgm + CALL prgm + DISPLAY "<" + + MOVE "dummy-call" TO prgm + PERFORM 500000 TIMES + CALL prgm + END-PERFORM + . + END PROGRAM prog. + + + IDENTIFICATION DIVISION. + PROGRAM-ID. recursion-test RECURSIVE. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x PIC 9 VALUE 0. + + PROCEDURE DIVISION. + ADD 1 TO x + DISPLAY x NO ADVANCING + IF x = 1 + CALL "recursion-test" + END-IF + . + END PROGRAM recursion-test. + + + IDENTIFICATION DIVISION. + PROGRAM-ID. cancel-test. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x PIC 9 VALUE 1. + + PROCEDURE DIVISION. + DISPLAY x NO ADVANCING + ADD 1 TO x + . + END PROGRAM cancel-test. + + + IDENTIFICATION DIVISION. + PROGRAM-ID. dummy-call. + + PROCEDURE DIVISION. + CONTINUE + . + END PROGRAM dummy-call. +]) + +AT_CHECK([$COMPILE -fno-program-name-redefinition prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[12< +121< +]) +AT_CHECK([COB_PHYSICAL_CANCEL=Y $COBCRUN_DIRECT ./prog], [0], +[12< +121< +]) +AT_CLEANUP + + +AT_SETUP([CALL program-pointer]) +AT_KEYWORDS([fundamental CANCEL SET ADDRESS POINTER]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 prog-ptr USAGE PROGRAM-POINTER. + 77 num PIC 9 VALUE 0. + + PROCEDURE DIVISION. + SET prog-ptr TO ADDRESS OF PROGRAM "recursion-test" + CALL prog-ptr USING num + DISPLAY "<" + + SET prog-ptr TO ADDRESS OF PROGRAM "cancel-test" + CALL prog-ptr + CALL prog-ptr + CANCEL "cancel-test" + *> NOTE: the following results in the previous address + *> if physical cancel is not active, otherwise _likely_ + *> in a different one + SET prog-ptr TO ADDRESS OF PROGRAM "cancel-test" + CALL prog-ptr + DISPLAY "<" + + SET prog-ptr TO ADDRESS OF PROGRAM "dummy-call" + PERFORM 500000 TIMES + CALL prog-ptr + END-PERFORM + . + END PROGRAM prog. + + + IDENTIFICATION DIVISION. + PROGRAM-ID. recursion-test RECURSIVE. + + DATA DIVISION. + LINKAGE SECTION. + 01 x PIC 9. + + PROCEDURE DIVISION USING x. + ADD 1 TO x + DISPLAY x NO ADVANCING + IF x = 1 + CALL "recursion-test" USING x + END-IF + . + END PROGRAM recursion-test. + + + IDENTIFICATION DIVISION. + PROGRAM-ID. cancel-test. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 self-ptr USAGE PROGRAM-POINTER VALUE NULL. + 01 x PIC 9 VALUE 1. + + PROCEDURE DIVISION. + SET self-ptr TO ENTRY "cancel-test" + IF self-ptr = NULL + DISPLAY 'self-address not set' UPON SYSERR. + DISPLAY x NO ADVANCING + ADD 1 TO x + . + END PROGRAM cancel-test. + + + IDENTIFICATION DIVISION. + PROGRAM-ID. dummy-call. + + PROCEDURE DIVISION. + CONTINUE + . + END PROGRAM dummy-call. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[12< +121< +]) +AT_CHECK([COB_PHYSICAL_CANCEL=Y $COBCRUN_DIRECT ./prog], [0], +[12< +121< +]) +AT_CLEANUP + + +AT_SETUP([CALL/CANCEL/SET ADDRESS program-prototype-name]) +AT_KEYWORDS([fundamental CALL CANCEL SET]) + +AT_DATA([prog.cob], [ + *> simple prototypes + IDENTIFICATION DIVISION. + PROGRAM-ID. recursion-test PROTOTYPE. + DATA DIVISION. + LINKAGE SECTION. + 01 n PIC 9. + PROCEDURE DIVISION USING n. + END PROGRAM recursion-test. + + IDENTIFICATION DIVISION. + PROGRAM-ID. cancel-test IS PROTOTYPE. + PROCEDURE DIVISION. + END PROGRAM cancel-test. + + *> program referencing those prototpyes + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. CONFIGURATION SECTION. REPOSITORY. @@ -1650,6 +1839,7 @@ AT_DATA([prog.cob], [ . DATA DIVISION. WORKING-STORAGE SECTION. + 77 prog-ptr USAGE PROGRAM-POINTER VALUE NULL. 01 num PIC 9 VALUE 0. PROCEDURE DIVISION. @@ -1661,10 +1851,22 @@ AT_DATA([prog.cob], [ CANCEL cancel-test CALL cancel-test DISPLAY "<" + SET prog-ptr TO ADDRESS OF PROGRAM recursion-test + IF prog-ptr = NULL + DISPLAY 'address of recursion-prog not set' UPON SYSERR + ELSE + SET prog-ptr TO NULL + END-IF + SET prog-ptr TO ADDRESS OF PROGRAM cancel-test + IF prog-ptr = NULL + DISPLAY 'address of cancel-prog not set' UPON SYSERR + ELSE + SET prog-ptr TO NULL + END-IF . END PROGRAM prog. - + *> actual implementation of the prototyped programs IDENTIFICATION DIVISION. PROGRAM-ID. recursion-test RECURSIVE. @@ -1676,7 +1878,9 @@ AT_DATA([prog.cob], [ ADD 1 TO x DISPLAY x NO ADVANCING IF x = 1 - CALL recursion-test USING x + *> CHECKME: Should this work (disabled for now...) ? + *> CALL recursion-test USING x + CALL "recursion-test" USING x END-IF . END PROGRAM recursion-test. @@ -1696,15 +1900,16 @@ AT_DATA([prog.cob], [ END PROGRAM cancel-test. ]) -# TO-DO: Fix these warnings when program prototypes are added. -AT_CHECK([$COMPILE -fno-program-name-redefinition prog.cob], [0], [], -[prog.cob:8: warning: no definition/prototype seen for PROGRAM 'recursion-test' -prog.cob:9: warning: no definition/prototype seen for PROGRAM 'cancel-test' -]) +# TODO: +AT_CHECK([$COMPILE -Wno-unfinished prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [12< 121< ]) +AT_CHECK([COB_PHYSICAL_CANCEL=Y $COBCRUN_DIRECT ./prog], [0], +[12< +121< +]) AT_CLEANUP diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index dbd935cfb..2ba1fa374 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -11393,7 +11393,7 @@ AT_CLEANUP AT_SETUP([PROGRAM-ID / CALL literal/variable with spaces]) -AT_KEYWORDS([CALL]) +AT_KEYWORDS([runmisc]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -11460,8 +11460,66 @@ libcob: prog.cob:16: warning: ' S U B' literal includes leading spaces which are AT_CLEANUP +AT_SETUP([CALL with directory]) +AT_KEYWORDS([runmisc]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 MYRTN PIC X(9) VALUE "DIR/SUB". + + PROCEDURE DIVISION. + *> doesn't exist there... + CALL "SUB" USING '0' + ON EXCEPTION CONTINUE. + *> go by variable + CALL MYRTN USING 'X'. + CALL "DIR/SUB" USING 'Y'. + *> as it is already loaded - should work as-is + CALL "SUB" USING 'Z'. + CANCEL "SUB" + *> the following will only show if physical cancel is not off... + CALL "SUB" USING '0' + ON EXCEPTION CONTINUE. + STOP RUN. +]) + +AT_DATA([sub.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. "SUB". + + DATA DIVISION. + LINKAGE SECTION. + 01 x PIC X. + + PROCEDURE DIVISION USING x. + DISPLAY "SUB GOT " X. + GOBACK. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([mkdir DIR], [0], [], []) +AT_CHECK([$COMPILE_MODULE sub.cob -o DIR/SUB.$COB_MODULE_EXT], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[SUB GOT X +SUB GOT Y +SUB GOT Z +SUB GOT 0 +], []) +AT_CHECK([COB_PHYSICAL_CANCEL=Y $COBCRUN_DIRECT ./prog], [0], +[SUB GOT X +SUB GOT Y +SUB GOT Z +], []) + +AT_CLEANUP + + AT_SETUP([C-API (param based)]) -AT_KEYWORDS([CALL api]) +AT_KEYWORDS([runmisc CALL api]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -11696,7 +11754,7 @@ AT_CLEANUP AT_SETUP([C-API (field based)]) -AT_KEYWORDS([CALL api]) +AT_KEYWORDS([runmisc CALL api]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 8c08cab5e..15e539314 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -240,7 +240,7 @@ AT_DATA([sub/copy/PROC.cpy],[ AT_CHECK([$COBC -I sub/copy prog.cob -o prog.c], [0], [], []) AT_CHECK([$COBC -I sub/copy prog.c -o prog.$COB_OBJECT_EXT], [0], [], []) -AT_CHECK([$COBC -I sub/copy prog.$COB_OBJECT_EXT -o prog]) +AT_CHECK([$COBC -I sub/copy prog.$COB_OBJECT_EXT -o prog.$COB_MODULE_EXT]) AT_CHECK([$COBCRUN prog], [0], [bluBb], []) AT_CHECK([$COBC -I sub/copy -x prog.cob -o prog.c], [0], [], []) AT_CHECK([$COBC -I sub/copy -x prog.c -o prog.$COB_OBJECT_EXT], [0], [], []) From e58157384f3cd77f74a5229380fc29d509e4f623 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 9 Dec 2022 21:43:54 +0000 Subject: [PATCH 04/18] minor optimizations and bugfixes libcob: * common.c (cob_cmp, cob_cmp_all, cob_cmp_alnum): use buffer to drop the overpunch sign, removing the need to add it back later; which solves both issues of "changing invalid data by DISPLAY", see [f8d18b9c88] and raising strange watchpoints during debugging * common.c (common_cmpc, common_cmps, locate_sign): minor optimization * numeric.c (cob_decimal_set_display): prefer local buffer over dynamic allocation * numeric.c (cob_cmp_int, cob_cmp_uint, cob_cmp_llint): pre-comparision by checking sign/zero and reduced number of decimal shifting dynamic allocation * move.c (store_common_region): minor optimization * fileio.c (cob_str_from_fld): applied optimization similar to common.c (cob_field_to_string) in [r4857] --- libcob/ChangeLog | 13 ++ libcob/common.c | 294 +++++++++++++++++---------- libcob/fileio.c | 63 +++--- libcob/move.c | 39 ++-- libcob/numeric.c | 150 ++++++++++---- tests/testsuite.src/run_functions.at | 25 ++- 6 files changed, 388 insertions(+), 196 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index ba6131fda..e0d7d114e 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -11,6 +11,8 @@ * common.c: added hashing for resolving the statement from a given string, instead of heavy use of strcmp; note: this is only used for backward compatibilty and then reduces the previously overhead to the minimum + * fileio.c (cob_str_from_fld): applied optimization similar + to common.c (cob_field_to_string) 2022-12-07 Simon Sobisch @@ -72,12 +74,23 @@ * numeric.c: refactoring of floating-point usages to not use a union for re-re-definition of float/double where not necessary * numeric.c: refactoring of bit-wise functions for readability + * numeric.c (cob_decimal_set_display): prefer local buffer over + dynamic allocation + * numeric.c (cob_cmp_int, cob_cmp_uint, cob_cmp_llint): pre-comparision + by checking sign/zero and reduced number of decimal shifting + dynamic allocation + * move.c (store_common_region): minor optimization 2022-11-04 Simon Sobisch * screenio.c [__PDCURSES__]: drop use of PDC_free_memory_allocations as testing showed it raising memory errors and the function was removed in PDCursesMod + * common.c (cob_cmp, cob_cmp_all, cob_cmp_alnum): use buffer to drop the + overpunch sign, removing the need to add it back later; which solves + both issues of "changing invalid data by DISPLAY" and raising strange + watchpoints during debugging + * common.c (common_cmpc, common_cmps, locate_sign): minor optimization 2022-10-22 Simon Sobisch diff --git a/libcob/common.c b/libcob/common.c index 6d7fdc35f..02e7b414a 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -1684,24 +1684,30 @@ cob_put_sign_ebcdic (unsigned char *p, const int sign) } } +/* compare up to 'size' characters from buffer 'p' + against a single character 'c', + optionally using collation 'col' */ static int -common_cmpc (const unsigned char *s1, const unsigned int c, +common_cmpc (const unsigned char *p, const unsigned int c, const size_t size, const unsigned char *col) { - size_t i; + register const unsigned char *end = p + size; int ret; if (unlikely (col)) { - for (i = 0; i < size; ++i) { - if ((ret = col[s1[i]] - col[c]) != 0) { + const unsigned char c_col = col[c]; + while (p < end) { + if ((ret = col[*p] - c_col) != 0) { return ret; } + p++; } } else { - for (i = 0; i < size; ++i) { - if ((ret = s1[i] - c) != 0) { + while (p < end) { + if ((ret = *p - c) != 0) { return ret; } + p++; } } return 0; @@ -1711,20 +1717,22 @@ static int common_cmps (const unsigned char *s1, const unsigned char *s2, const size_t size, const unsigned char *col) { - size_t i; + register const unsigned char *end = s1 + size; int ret; if (unlikely (col)) { - for (i = 0; i < size; ++i) { - if ((ret = col[s1[i]] - col[s2[i]]) != 0) { + while (s1 < end) { + if ((ret = col[*s1] - col[*s2]) != 0) { return ret; } + s1++, s2++; } } else { - for (i = 0; i < size; ++i) { - if ((ret = s1[i] - s2[i]) != 0) { + while (s1 < end) { + if ((ret = *s1 - *s2) != 0) { return ret; } + s1++, s2++; } } return 0; @@ -1733,75 +1741,68 @@ common_cmps (const unsigned char *s1, const unsigned char *s2, static int cob_cmp_all (cob_field *f1, cob_field *f2) { + const unsigned char *s = COB_MODULE_PTR->collating_sequence; unsigned char *data; - const unsigned char *s; - size_t size; - int ret; - int sign; + unsigned char buff[COB_MAX_DIGITS + 1]; + + if (COB_FIELD_HAVE_SIGN (f1)) { + /* drop sign for comparision, using a copy to not change + the field during comparision */ + /* CHECKME: What should be returned if f1 is negative? */ + unsigned char *real_data = f1->data; + f1->data = data = buff; + memcpy (buff, real_data, f1->size); + (void)cob_real_get_sign (f1); + f1->data = real_data; + } else { + data = f1->data; + } - size = f1->size; - data = f1->data; - sign = COB_GET_SIGN (f1); - s = COB_MODULE_PTR->collating_sequence; + /* check for IF VAR = ALL "9" */ if (f2->size == 1) { - ret = common_cmpc (data, f2->data[0], size, s); - goto end; + return common_cmpc (data, f2->data[0], f1->size, s); } - ret = 0; - while (size >= f2->size) { - if ((ret = common_cmps (data, f2->data, f2->size, s)) != 0) { - goto end; + + /* check for IF VAR = ALL "AB" ... */ + { + size_t size = f1->size; + int ret; + + while (size >= f2->size) { + if ((ret = common_cmps (data, f2->data, f2->size, s)) != 0) { + return ret; + } + size -= f2->size; + data += f2->size; + } + if (size > 0) { + return common_cmps (data, f2->data, size, s); } - size -= f2->size; - data += f2->size; - } - if (size > 0) { - ret = common_cmps (data, f2->data, size, s); } -end: - if (COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_PACKED) { - COB_PUT_SIGN (f1, sign); - } - return ret; + return 0; } static int cob_cmp_alnum (cob_field *f1, cob_field *f2) { - const unsigned char *s; - size_t min; - int ret; - int sign1; - int sign2; - - /* FIXME later: must cater for national fields, too */ - - sign1 = COB_GET_SIGN (f1); - sign2 = COB_GET_SIGN (f2); - min = (f1->size < f2->size) ? f1->size : f2->size; - s = COB_MODULE_PTR->collating_sequence; + const unsigned char *s = COB_MODULE_PTR->collating_sequence; + const size_t min = (f1->size < f2->size) ? f1->size : f2->size; + int ret; /* Compare common substring */ if ((ret = common_cmps (f1->data, f2->data, min, s)) != 0) { - goto end; + return ret; } /* Compare the rest (if any) with spaces */ if (f1->size > f2->size) { - ret = common_cmpc (f1->data + min, ' ', f1->size - min, s); + return common_cmpc (f1->data + min, ' ', f1->size - min, s); } else if (f1->size < f2->size) { - ret = -common_cmpc (f2->data + min, ' ', f2->size - min, s); + return -common_cmpc (f2->data + min, ' ', f2->size - min, s); } -end: - if (COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_PACKED) { - COB_PUT_SIGN (f1, sign1); - } - if (COB_FIELD_TYPE (f2) != COB_TYPE_NUMERIC_PACKED) { - COB_PUT_SIGN (f2, sign2); - } - return ret; + return 0; } static int @@ -2721,6 +2722,8 @@ cob_get_pointer (const void *srcptr) return (cob_u8_ptr)tmptr; } +/* stores the field's rtrimmed string content into the given buffer + with maxlength */ void cob_field_to_string (const cob_field *f, void *str, const size_t maxsize) { @@ -3485,6 +3488,15 @@ cob_check_numdisp (const cob_field *f) /* Sign */ +static COB_INLINE COB_A_INLINE unsigned char * +locate_sign (cob_field *f) +{ + if (COB_FIELD_SIGN_LEADING (f)) { + return f->data; + } + return f->data + f->size - 1; +} + int cob_real_get_sign (cob_field *f) { @@ -3492,12 +3504,7 @@ cob_real_get_sign (cob_field *f) switch (COB_FIELD_TYPE (f)) { case COB_TYPE_NUMERIC_DISPLAY: - /* Locate sign */ - if (unlikely (COB_FIELD_SIGN_LEADING (f))) { - p = f->data; - } else { - p = f->data + f->size - 1; - } + p = locate_sign (f); /* Get sign */ if (unlikely (COB_FIELD_SIGN_SEPARATE (f))) { @@ -3530,26 +3537,22 @@ void cob_real_put_sign (cob_field *f, const int sign) { unsigned char *p; - unsigned char c; switch (COB_FIELD_TYPE (f)) { case COB_TYPE_NUMERIC_DISPLAY: - /* Locate sign */ - if (unlikely (COB_FIELD_SIGN_LEADING (f))) { - p = f->data; - } else { - p = f->data + f->size - 1; - } - - /* Put sign */ + /* Note: we only locate the sign if needed, + as the common case will be "nothing to do" */ if (unlikely (COB_FIELD_SIGN_SEPARATE (f))) { - c = (sign < 0) ? (cob_u8_t)'-' : (cob_u8_t)'+'; + const unsigned char c = (sign < 0) ? (cob_u8_t)'-' : (cob_u8_t)'+'; + p = locate_sign (f); if (*p != c) { *p = c; } } else if (unlikely (COB_MODULE_PTR->ebcdic_sign)) { + p = locate_sign (f); cob_put_sign_ebcdic (p, sign); } else if (sign < 0) { + p = locate_sign (f); cob_put_sign_ascii (p); } return; @@ -3604,48 +3607,129 @@ cob_set_switch (const int n, const int flag) int cob_cmp (cob_field *f1, cob_field *f2) { - cob_field temp; - cob_field_attr attr; - unsigned char buff[256]; + unsigned short f1_type = COB_FIELD_TYPE (f1); + unsigned short f2_type = COB_FIELD_TYPE (f2); + + const int f1_is_numeric = f1_type & COB_TYPE_NUMERIC; + const int f2_is_numeric = f2_type & COB_TYPE_NUMERIC; - if (COB_FIELD_IS_NUMERIC (f1) && COB_FIELD_IS_NUMERIC (f2)) { + /* both numeric -> direct compare */ + if (f1_is_numeric && f2_is_numeric) { return cob_numeric_cmp (f1, f2); } - if (COB_FIELD_TYPE (f2) == COB_TYPE_ALPHANUMERIC_ALL) { - if (f2->size == 1 && f2->data[0] == '0' && - COB_FIELD_IS_NUMERIC (f1)) { + + /* one is an internal ALL field (ZERO,LOW-VALUE, ...) */ + if (f2_type == COB_TYPE_ALPHANUMERIC_ALL) { + if (f2->size == 1 && f2->data[0] == '0' + && f1_is_numeric) { return cob_cmp_int (f1, 0); } return cob_cmp_all (f1, f2); } - if (COB_FIELD_TYPE (f1) == COB_TYPE_ALPHANUMERIC_ALL) { - if (f1->size == 1 && f1->data[0] == '0' && - COB_FIELD_IS_NUMERIC (f2)) { + if (f1_type == COB_TYPE_ALPHANUMERIC_ALL) { + if (f1->size == 1 && f1->data[0] == '0' + && f2_is_numeric) { return -cob_cmp_int (f2, 0); } return -cob_cmp_all (f2, f1); } - if (COB_FIELD_IS_NUMERIC (f1) && - COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_DISPLAY) { - temp.size = COB_FIELD_DIGITS (f1); - temp.data = buff; - temp.attr = &attr; - attr = *f1->attr; - attr.type = COB_TYPE_NUMERIC_DISPLAY; - attr.flags &= ~COB_FLAG_HAVE_SIGN; - cob_move (f1, &temp); - f1 = &temp; - } - if (COB_FIELD_IS_NUMERIC (f2) && - COB_FIELD_TYPE (f2) != COB_TYPE_NUMERIC_DISPLAY) { - temp.size = COB_FIELD_DIGITS (f2); - temp.data = buff; - temp.attr = &attr; - attr = *f2->attr; - attr.type = COB_TYPE_NUMERIC_DISPLAY; - attr.flags &= ~COB_FLAG_HAVE_SIGN; - cob_move (f2, &temp); - f2 = &temp; + +#if 0 /* FIXME later: must cater for national fields, too, + at least if that is numeric NATIONAL */ + if (COB_FIELD_IS_NATIONAL (f1)) { + ... + } +#endif + + /* all else -> alphanumeric comparision */ + + /* if one is numeric (cannot be "both", as checked above), then + convert that to alphanumeric for final test; + note: this is _very_ seldom the case, during "make checkall" + only in test "Alphanumeric and binary numeric" */ + + if (f1_is_numeric || f2_is_numeric) { + /* CHECKME: What should be returned if field is negative? + We suspicously change -12 to 12 here... */ + cob_field temp; + cob_field_attr attr; + unsigned char buff[COB_MAX_DIGITS + 10]; + + /* CHECKME: may need to abort if we ever get here with float data */ + + /* FIXME: must be converted to COB_TYPE_NUMERIC_EDITED with an + internal PIC of COB_FIELD_DIGITS '9's and leading sign, + otherwise we'll fail as soon as we enable COB_MAX_BINARY */ + if (f1_is_numeric + && f1_type != COB_TYPE_NUMERIC_DISPLAY) { + temp.size = COB_FIELD_DIGITS (f1); + temp.data = buff; + temp.attr = &attr; + attr = *f1->attr; + attr.type = COB_TYPE_NUMERIC_DISPLAY; + attr.flags &= ~COB_FLAG_HAVE_SIGN; + cob_move (f1, &temp); + f1 = &temp; + } + if (f2_is_numeric + && f2_type != COB_TYPE_NUMERIC_DISPLAY) { + temp.size = COB_FIELD_DIGITS (f2); + temp.data = buff; + temp.attr = &attr; + attr = *f2->attr; + attr.type = COB_TYPE_NUMERIC_DISPLAY; + attr.flags &= ~COB_FLAG_HAVE_SIGN; + cob_move (f2, &temp); + f2 = &temp; + } + + if (COB_FIELD_HAVE_SIGN (f1)) { + /* Note: if field is numeric then it is always + USAGE DISPLAY here */ + + if (f1 != &temp) { + /* drop sign for comparision, using a copy to not change + the field during comparision */ + unsigned char buff2[COB_MAX_DIGITS + 10]; + const size_t size = f1->size; + int ret; + unsigned char *real_data = f1->data; + memcpy (buff2, real_data, size); + f1->data = buff2; + (void)cob_real_get_sign (f1); + ret = cob_cmp_alnum (f1, f2); + f1->data = real_data; + return ret; + } else { + /* we operate on a buffer already, just go on */ + (void)cob_real_get_sign (f1); + return cob_cmp_alnum (f1, f2); + } + } + + if (COB_FIELD_HAVE_SIGN (f2)) { + /* Note: if field is numeric then it is always + USAGE DISPLAY here */ + + if (f2 != &temp) { + /* drop sign for comparision, using a copy to not change + the field during comparision */ + unsigned char buff2[COB_MAX_DIGITS + 10]; + const size_t size = f2->size; + int ret; + unsigned char *real_data = f2->data; + memcpy (buff2, real_data, size); + f2->data = buff2; + (void)cob_real_get_sign (f2); + ret = cob_cmp_alnum (f1, f2); + f2->data = real_data; + return ret; + } else { + /* we operate on a buffer already, just go on */ + (void)cob_real_get_sign (f2); + return cob_cmp_alnum (f1, f2); + } + } } return cob_cmp_alnum (f1, f2); } diff --git a/libcob/fileio.c b/libcob/fileio.c index 846cbda02..83abe5419 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -6782,53 +6782,58 @@ cob_savekey (cob_file *f, int idx, unsigned char *data) /* System routines */ +/* stores the field's rtrimmed string content into a fresh allocated + string, which later needs to be passed to cob_free */ static void * cob_str_from_fld (const cob_field *f) { - void *mptr; - unsigned char *s; - size_t i, n, j; #if 0 /* Quotes in file */ - int quote_switch; - - quote_switch = 0; + register int quote_switch = 0; #endif + register unsigned char *end, *data, *s; + void *mptr; - if (!f) { + + if (!f || f->size == 0 || !f->data) { return cob_malloc ((size_t)1); } - for (i = f->size - 1; i > 0; --i) { - if (f->data[i] != ' ' && f->data[i] != 0) { - i++; + + data = f->data; + end = data + f->size - 1; + while (end > data) { + if (*end != ' ' && *end) { break; } + end--; } - /* i is 0 or > 0 */ - mptr = cob_malloc (i + 1); - s = mptr; - j = 0; - for (n = 0; n < i; ++n) { - if (f->data[n] == '"') { - continue; - } - s[j++] = f->data[n]; -#if 0 /* Quotes in file */ - if (f->data[n] == '"') { + s = mptr = cob_fast_malloc (end - data + 1); + if (*end == ' ' || *end == 0) { + *s = 0; + return s; + } + + while (data <= end) { +#if 0 /* Quotes in file */ + if (*s == '"') { quote_switch = !quote_switch; + s++; continue; } - s[j] = f->data[n]; - if (quote_switch) { - j++; - continue; - } - if (s[j] == ' ' || s[j] == 0) { - s[j] = 0; + if (!quote_switch + && (*data == ' ' + || *data == 0)) { break; } - j++; +#else + if (*s == '"') { + s++; + continue; + } #endif + *s++ = *data++; } + *s = 0; + return mptr; } diff --git a/libcob/move.c b/libcob/move.c index 9e8e23d8b..64468abbd 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -123,30 +123,39 @@ static void store_common_region (cob_field *f, const unsigned char *data, const size_t size, const int scale) { + const int fsize = (int) COB_FIELD_SIZE (f); + unsigned char *fdata = COB_FIELD_DATA (f); + const int lf1 = -scale; const int lf2 = -COB_FIELD_SCALE (f); const int lcf = cob_max_int (lf1, lf2); const int hf1 = (int) size + lf1; - const int hf2 = (int) COB_FIELD_SIZE (f) + lf2; + const int hf2 = fsize + lf2; const int gcf = cob_min_int (hf1, hf2); - memset (COB_FIELD_DATA (f), '0', COB_FIELD_SIZE (f)); + /* the target may have leading/trailing additional + zeros are, in rare cases, be out of scale competely; + we pre-set all positions as this saves a bunch of + calculations which outweight the benefits of not + writing over the data two times */ + memset (fdata, '0', fsize); if (gcf > lcf) { - const size_t csize = (size_t)gcf - lcf; - size_t cinc; - const unsigned char *p; - unsigned char *q; - - p = data + hf1 - gcf; - q = COB_FIELD_DATA (f) + hf2 - gcf; - for (cinc = 0; cinc < csize; ++cinc, ++p, ++q) { - if (unlikely (*p == ' ' || *p == 0)) { - *q = (unsigned char)'0'; - } else { - *q = *p; - } + unsigned char *dst = fdata + hf2 - gcf; + const unsigned char *end = dst + gcf - lcf; + const unsigned char *src = data + hf1 - gcf; + + while (dst < end) { +#if 0 /* seems to be the best result, ..." */ + /* we don't want to set bad data, so + only take the half byte */ + *dst = COB_I2D (COB_D2I (*src)); +#else /* but does not match the "expected" MF result, which is: */ + if (*src == ' ' || *src == 0) /* already set: *dst = '0'; */ ; + else *dst = COB_I2D (*src - '0'); +#endif + ++src, ++dst; } } } diff --git a/libcob/numeric.c b/libcob/numeric.c index ec30fedb9..a1ce8f8d1 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -1242,7 +1242,6 @@ static void cob_decimal_set_display (cob_decimal *d, cob_field *f) { unsigned char *data; - unsigned char *p; size_t size; int sign; cob_uli_t n; @@ -1262,34 +1261,60 @@ cob_decimal_set_display (cob_decimal *d, cob_field *f) } sign = COB_GET_SIGN (f); /* Skip leading zeros (also invalid space/low-value) */ - while (size > 1 && (*data & 0x0FU) == 0) { + while (size > 1 && COB_D2I (*data) == 0) { size--; data++; } /* Set value */ - n = 0; #ifdef COB_LI_IS_LL if (size < 20) { #else if (size < 10) { #endif - while (size--) { - if (n) { - n *= 10; - } - n += COB_D2I (*data); + /* note: we skipped leading zeros above, so n > 0 afterwards */ + n = COB_D2I (*data); + data++; + while (--size) { + n = n * 10 + + COB_D2I (*data); data++; } mpz_set_ui (d->value, n); - } else { - p = cob_fast_malloc (size + 1U); - for (; n < size; ++n) { - p[n] = (data[n] & 0x0FU) + '0'; + + } else if (size <= COB_MAX_DIGITS) { + + char p[COB_MAX_DIGITS + 1]; + for (n = 0; n < size; ++n) { + p[n] = COB_I2D (COB_D2I (data[n])); + } + p[size] = 0; + mpz_set_str (d->value, (char *)p, 10); + + } else if (size <= COB_MAX_INTERMEDIATE_FLOATING_SIZE) { + + /* Note: we can get here for example when resolving + a decimal from huge internal fields like the + numeric functions sin/asin/... which have 96 digits + or during computations with division */ + char p[COB_MAX_INTERMEDIATE_FLOATING_SIZE + 1]; + for (n = 0; n < size; ++n) { + p[n] = COB_I2D (COB_D2I (data[n])); } p[size] = 0; mpz_set_str (d->value, (char *)p, 10); + + } else { + + /* Note: we get very seldom get here, commonly for + computations with functions like cob_intr_variance */ + char *p = cob_fast_malloc (size + 1U); + for (n = 0; n < size; ++n) { + p[n] = COB_I2D (COB_D2I (data[n])); + } + p[size] = 0; + mpz_set_str (d->value, p, 10); cob_free (p); } @@ -1634,7 +1659,7 @@ cob_decimal_do_round (cob_decimal *d, cob_field *f, const int opt) const int sign = mpz_sgn (d->value); const int scale = COB_FIELD_SCALE (f); - /* Nothing to do when value is 0 or when target has >= scale */ + /* Nothing to do when value is 0 or when target has ge scale */ if (!sign || scale >= d->scale) { return; @@ -2266,48 +2291,94 @@ cob_sub_int (cob_field *f, const int n, const int opt) int cob_cmp_int (cob_field *f1, const int n) { + int sign; cob_decimal_set_field (&cob_d1, f1); - mpz_set_si (cob_d2.value, (cob_sli_t)n); - cob_d2.scale = 0; - return cob_decimal_cmp (&cob_d1, &cob_d2); + sign = mpz_sgn (cob_d1.value); + if (sign == 0) { + return -n; + } else if (sign == 1) { + if (n <= 0) return 1; + } else { + if (n >= 0) return -1; + } + mpz_set_si (cob_d2.value, n); + if (cob_d1.scale < 0) { + shift_decimal (&cob_d1, -cob_d1.scale); + } else if (cob_d1.scale > 0) { +#if 0 /* if we ever add a "cob_equ_int" + then this is to be added there */ + if (has_decimal_places (cob_d1)) { + return 1; + } +#endif + shift_decimal (&cob_d2, cob_d1.scale); + } + return mpz_cmp (cob_d1.value, cob_d2.value); } int cob_cmp_uint (cob_field *f1, const unsigned int n) { + int sign; cob_decimal_set_field (&cob_d1, f1); - mpz_set_ui (cob_d2.value, (cob_uli_t)n); - cob_d2.scale = 0; - return cob_decimal_cmp (&cob_d1, &cob_d2); + sign = mpz_sgn (cob_d1.value); + if (sign == 0) { + return -n; + } else if (sign == 1) { + if (n <= 0) return 1; + } else { + return -1; + } + mpz_set_ui (cob_d2.value, n); + if (cob_d1.scale < 0) { + shift_decimal (&cob_d1, -cob_d1.scale); + } else if (cob_d1.scale > 0) { + shift_decimal (&cob_d2, cob_d1.scale); + } + return mpz_cmp (cob_d1.value, cob_d2.value); } int cob_cmp_llint (cob_field *f1, const cob_s64_t n) { + int sign; + cob_decimal_set_field (&cob_d1, f1); + sign = mpz_sgn (cob_d1.value); + if (sign == 0) { + return -n; + } else if (sign == 1) { + if (n <= 0) return 1; + } else { + if (n >= 0) return -1; + } #ifdef COB_LI_IS_LL mpz_set_si (cob_d2.value, (cob_sli_t)n); #else - cob_u64_t uval; - cob_u32_t negative; - - if (n < 0) { - negative = 1; - uval = (cob_u64_t)-n; - } else { - negative = 0; - uval = (cob_u64_t)n; - } - mpz_set_ui (cob_d2.value, (cob_uli_t)(uval >> 32)); - mpz_mul_2exp (cob_d2.value, cob_d2.value, 32); - mpz_add_ui (cob_d2.value, cob_d2.value, (cob_uli_t)(uval & 0xFFFFFFFFU)); - if (negative) { - mpz_neg (cob_d2.value, cob_d2.value); + { + cob_u64_t uval; + cob_u32_t negative; + + if (n < 0) { + negative = 1; + uval = (cob_u64_t)-n; + } else { + negative = 0; + uval = (cob_u64_t)n; + } + mpz_set_ui (cob_d2.value, (cob_uli_t)(uval >> 32)); + mpz_mul_2exp (cob_d2.value, cob_d2.value, 32); + mpz_add_ui (cob_d2.value, cob_d2.value, (cob_uli_t)(uval & 0xFFFFFFFFU)); + if (negative) { + mpz_neg (cob_d2.value, cob_d2.value); + } } #endif - - cob_d2.scale = 0; - cob_decimal_set_field (&cob_d1, f1); - return cob_decimal_cmp (&cob_d1, &cob_d2); + if (cob_d1.scale < 0) { + shift_decimal (&cob_d1, -cob_d1.scale); + } else if (cob_d1.scale > 0) { + shift_decimal (&cob_d2, cob_d1.scale); + } + return mpz_cmp (cob_d1.value, cob_d2.value); } #ifdef COB_FLOAT_DELTA @@ -2413,12 +2484,13 @@ cob_cmp_packed (cob_field *f, const cob_s64_t val) } } if (n != last_packed_val) { + /* otherwise we just leave the already packed value as-is */ last_packed_val = n; memset (packed_value, 0, sizeof(packed_value)); if (n) { p = &packed_value[19]; if (!COB_FIELD_NO_SIGN_NIBBLE (f)) { - *p = (n % 10) << 4; + *p = (n % 10) << 4; p--; n /= 10; } diff --git a/tests/testsuite.src/run_functions.at b/tests/testsuite.src/run_functions.at index aa6058f01..b4427d8e3 100644 --- a/tests/testsuite.src/run_functions.at +++ b/tests/testsuite.src/run_functions.at @@ -103,9 +103,12 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION. MOVE FUNCTION ASIN ( -0.2345 ) TO Y. IF Y NOT = -0.23670419431334681587017874688345882 - DISPLAY Y - END-DISPLAY - END-IF. + DISPLAY Y. + *> cheating: we compare a huge internal field + *> (96 digits) here for the testsuite + IF FUNCTION ASIN ( -00000.2345 ) NOT = + FUNCTION ASIN ( -.234500000 ) + DISPLAY "ASIN IS NOT ITSELF". STOP RUN. ]) @@ -4122,20 +4125,26 @@ AT_CLEANUP AT_SETUP([FUNCTION VARIANCE]) -AT_KEYWORDS([functions]) +AT_KEYWORDS([functions compute decimal]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 Z PIC S9(4)V9(4) COMP-5. + 01 Z PIC S9(4)V9(8). PROCEDURE DIVISION. MOVE FUNCTION VARIANCE ( 3 -14 0 8 -3 ) TO Z. IF Z NOT = 54.16 - DISPLAY Z - END-DISPLAY - END-IF. + DISPLAY 'EXP 54.16 GOT ' Z. + *> COMPUTE has maximum possible intermediate + *> results via GMP - and thefore a different + *> set of function calls to set Z - this one + *> here is used for "huge decimal number from + *> display" + COMPUTE Z = FUNCTION VARIANCE(4, 0, 5). + IF Z NOT = 4.66666666 + DISPLAY 'EXP 4.66666666 GOT ' Z. STOP RUN. ]) From dc940733a16f5314b14c8780ea492e1c7b6ad083 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 10 Dec 2022 14:14:00 +0000 Subject: [PATCH 05/18] build_aux/create_mingw_bindist.sh: * MSYS2 builds now working with use of previously added MINGWDIR * optional installation of locales and manpages * deletion of some unnecessary files --- build_aux/ChangeLog | 7 ++- build_aux/create_mingw_bindist.sh | 82 +++++++++++++++++++++++-------- 2 files changed, 67 insertions(+), 22 deletions(-) diff --git a/build_aux/ChangeLog b/build_aux/ChangeLog index 9f5c046ff..70bc27127 100644 --- a/build_aux/ChangeLog +++ b/build_aux/ChangeLog @@ -1,4 +1,9 @@ +2022-12-09 Simon Sobisch + + * create_mingw_bindist.sh: optional installation of locales and manpages; + MSYS2 builds now working with use of previously added MINGWDIR + 2022-12-01 Simon Sobisch * bootstrap: drop tarstamp.h generation, done via make @@ -14,7 +19,7 @@ 2022-05-30 Simon Sobisch * create_mingw_bindist.sh: explicit call cobc.exe in the generated - set_env.cmd to allowwrapper scripts cobc.cmd/cobc.bat to call it; + set_env.cmd to allow wrapper scripts cobc.cmd/cobc.bat to call it; add (untested) option to use this in MSYS2 builds 2022-03-29 Simon Sobisch diff --git a/build_aux/create_mingw_bindist.sh b/build_aux/create_mingw_bindist.sh index d740fa978..14abfe2f1 100755 --- a/build_aux/create_mingw_bindist.sh +++ b/build_aux/create_mingw_bindist.sh @@ -26,10 +26,10 @@ # Check we're in a MinGW environment if test -d "$MSYSTEM_PREFIX/bin"; then - MINGWDIR="$MSYSTEM_PREFIX/bin" + MINGWDIR="$MSYSTEM_PREFIX" echo "generating binary ${MINGW_PREFIX:1} dist package..." elif test -d "/mingw/bin"; then - MINGWDIR="/mingw/bin" + MINGWDIR="/mingw" echo "generating binary mingw dist package..." else echo "binary mingw dist packages can only be created from MSYS/MinGW or MSYS2" @@ -63,7 +63,7 @@ fi # getting version information, testing the current build works versinfo=$($EXTBUILDDIR/pre-inst-env cobcrun -v --version | tail -n2) -versinfo_cmds=$(echo "echo. $(echo "$versinfo" | sed -e 's/^/\&\& echo /')" | tr '\n' ' ') +versinfo_cmds=$(echo "echo. $(echo "$versinfo" | sed -e 's/^/\&\& echo /')" | tr '\n' ' ') # Create folder echo @@ -83,23 +83,29 @@ fi mkdir "$target_dir" || (echo "cannot create target directory" && exit 97) pushd "$target_dir" 1>/dev/null if test "$target_dir" != "$(pwd)"; then - target_dir="$(pwd)" + target_dir="$(pwd)" echo "target (resolved): $target_dir" fi popd 1>/dev/null echo && echo copying MinGW files... echo " bin..." -cp -pr "/mingw/bin" "$target_dir/" +cp -pr "$MINGWDIR/bin" "$target_dir/" echo " include..." -cp -pr "/mingw/include" "$target_dir/" +cp -pr "$MINGWDIR/include" "$target_dir/" echo " lib..." -cp -pr "/mingw/lib" "$target_dir/" +cp -pr "$MINGWDIR/lib" "$target_dir/" echo " libexec..." -cp -pr "/mingw/libexec" "$target_dir/" -echo " share/locale..." +cp -pr "$MINGWDIR/libexec" "$target_dir/" +echo " share... (locale and friends)" # note: possible copying more of share later -cp -pr "/mingw/share/locale" "$target_dir/" +cp -pr "$MINGWDIR/share/locale" "$target_dir/" +cp -pr "$MINGWDIR/share/gdb" "$target_dir/share/" +cp -pr "$MINGWDIR/share/gcc"* "$target_dir/share/" +cp -pr "$MINGWDIR/share/man" "$target_dir/share/" +if test -f "$MINGWDIR/share/zoneinfo"; then + cp -pr "$MINGWDIR/share/zoneinfo" "$target_dir/share/" +fi echo && echo copying GnuCOBOL files... cp -pr "$EXTBUILDDIR/extras" "$target_dir/" @@ -110,7 +116,7 @@ cp -p $EXTBUILDDIR/cobc/.libs/cobc.exe "$target_dir/bin/" cp -p $EXTBUILDDIR/bin/.libs/cobcrun.exe "$target_dir/bin/" cp -p $EXTBUILDDIR/libcob/.libs/libcob*.dll "$target_dir/bin/" cp -p $EXTBUILDDIR/libcob/.libs/libcob.* "$target_dir/lib/" -mkdir "$target_dir/include/libcob" +mkdir -p "$target_dir/include/libcob" cp -p $EXTSRCDIR/libcob.h "$target_dir/include/" cp -p $EXTSRCDIR/libcob/*.h "$target_dir/include/libcob" cp -p $EXTSRCDIR/libcob/*.def "$target_dir/include/libcob" @@ -134,14 +140,22 @@ sed -e 's/\r*$/\r/' "bin/ChangeLog" > "$target_dir/ChangeLog_bin.txt" sed -e 's/\r*$/\r/' "cobc/ChangeLog" > "$target_dir/ChangeLog_cobc.txt" sed -e 's/\r*$/\r/' "libcob/ChangeLog" > "$target_dir/ChangeLog_libcob.txt" -# copy manpages (checkme) ... -#cp bin/cobcrun.1 -#cp cobc/cobc.1 -##cp libcob/libcob.3 -# ... and locales +if test -f "$EXTBUILDDIR/cobc/cobc.1"; then + echo && echo installing manpages... + make -C "$EXTBUILDDIR/bin" install-man1 datarootdir="$target_dir/share" + make -C "$EXTBUILDDIR/cobc" install-man1 datarootdir="$target_dir/share" + #make -C "$EXTBUILDDIR/libcob" install-man3 datarootdir="$target_dir/share" +else + echo "WARNING: GnuCOBOL manpages not found!" +fi -echo && echo installing locales... -make -C "$EXTBUILDDIR/po" install-data-yes localedir="$target_dir/locale" +# note: locales are configured to be created in the srcdir +if test -f "$EXTSRCDIR/po/fr.po"; then + echo && echo installing locales... + make -C "$EXTBUILDDIR/po" install-data-yes datarootdir="$target_dir" +else + echo "WARNING: GnuCOBOL locales not found!" +fi popd 1>/dev/null @@ -191,7 +205,7 @@ cat > "$target_dir/set_env.cmd" << _FEOF @echo off :: Check if called already -:: if yes, check if called from here - exit, in any other case +:: if yes, check if called from here - exit, in any other case :: raise warning and reset env vars if not "%COB_MAIN_DIR%" == "" ( echo. @@ -202,7 +216,7 @@ if not "%COB_MAIN_DIR%" == "" ( goto :cobcver ) else ( echo Warning: batch was called before from "%COB_MAIN_DIR%" - echo resetting COB_CFLAGS, COB_LDFLAGS + echo resetting COB_CFLAGS, COB_LDFLAGS set "COB_CFLAGS=" set "COB_LDLAGS=" ) @@ -226,6 +240,11 @@ set "PATH=%COB_MAIN_DIR%bin;%PATH%" :: Locales set "LOCALEDIR=%COB_MAIN_DIR%locale" +:: Timezone database +if exist "%COB_MAIN_DIR%share\zoneinfo" ( + set "TZDIR=%COB_MAIN_DIR%share\zoneinfo" +) + :: start executable as requested :call_if_needed if not [%1] == [] ( @@ -236,7 +255,7 @@ if not [%1] == [] ( goto :eof ) -:: new cmd to stay open if not started directly from cmd.exe window +:: new cmd to stay open if not started directly from cmd.exe window echo %cmdcmdline% | find /i "%~0" >nul if %errorlevel% equ 0 ( cmd /k "cobc.exe --version && $versinfo_cmds" @@ -288,6 +307,27 @@ _FEOF sed -i 's/$/\r/' "$target_dir/README.txt" +echo && echo removing some unneeded files +rm -rf "$target_dir/bin/auto"* +rm -rf "$target_dir/bin/aclocal"* + +rm -rf "$target_dir/bin/"*perl* +rm -rf "$target_dir/lib/"*perl* + +rm -rf "$target_dir/lib/"*.la + +rm -rf "$target_dir/lib/terminfo"* + +rm -rf "$target_dir/lib/tcl"* +rm -rf "$target_dir/lib/tkl"* +rm -rf "$target_dir/lib/tdbc"* + +rm -rf "$target_dir/lib/cmake"* +rm -rf "$target_dir/lib/pkgconfig"* + +rm -rf "$target_dir/libexec/mingw-get" + + echo && echo duplicating for debug version... cp -rp "$target_dir" "$target_dir"_dbg From af73d889ad61855abc4541d06b5ca567a4aa5f7c Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 10 Dec 2022 16:53:12 +0000 Subject: [PATCH 06/18] build_aux/create_mingw_bindist.sh - follow-up to [r4859] * plain old mingw adjustments * fix in generated files --- build_aux/create_mingw_bindist.sh | 44 ++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 15 deletions(-) diff --git a/build_aux/create_mingw_bindist.sh b/build_aux/create_mingw_bindist.sh index 14abfe2f1..c5816490a 100755 --- a/build_aux/create_mingw_bindist.sh +++ b/build_aux/create_mingw_bindist.sh @@ -90,16 +90,26 @@ popd 1>/dev/null echo && echo copying MinGW files... echo " bin..." +if test -f "$MINGWDIR/mingw32/bin"; then + cp -pr "$MINGWDIR/mingw32/bin" "$target_dir/" +fi cp -pr "$MINGWDIR/bin" "$target_dir/" echo " include..." +if test -f "$MINGWDIR/mingw32/include"; then + cp -pr "$MINGWDIR/mingw32/include" "$target_dir/" +fi cp -pr "$MINGWDIR/include" "$target_dir/" echo " lib..." +if test -f "$MINGWDIR/mingw32/lib"; then + cp -pr "$MINGWDIR/mingw32/lib" "$target_dir/" +fi cp -pr "$MINGWDIR/lib" "$target_dir/" echo " libexec..." cp -pr "$MINGWDIR/libexec" "$target_dir/" echo " share... (locale and friends)" # note: possible copying more of share later cp -pr "$MINGWDIR/share/locale" "$target_dir/" +mkdir -p "$target_dir/share" cp -pr "$MINGWDIR/share/gdb" "$target_dir/share/" cp -pr "$MINGWDIR/share/gcc"* "$target_dir/share/" cp -pr "$MINGWDIR/share/man" "$target_dir/share/" @@ -256,7 +266,7 @@ if not [%1] == [] ( ) :: new cmd to stay open if not started directly from cmd.exe window -echo %cmdcmdline% | find /i "%~0" >nul +echo %cmdcmdline% | %windir%\system32\find.exe /i "%~0" >nul if %errorlevel% equ 0 ( cmd /k "cobc.exe --version && $versinfo_cmds" goto :eof @@ -299,8 +309,8 @@ same source tarball don't have. Important: See BUGS.txt for possible known issues in this distribution! For running GnuCOBOL simply double-click set_env.cmd found next to this file, or, -if already in cmd, call setenv.cmd once. -You can use cobc/cobcrun in the command prompt afterwards. +if already in cmd, call set_env.cmd once. +You can use cobc and cobcrun in the command prompt afterwards. _FEOF } >> "$target_dir/README.txt" @@ -308,24 +318,28 @@ sed -i 's/$/\r/' "$target_dir/README.txt" echo && echo removing some unneeded files -rm -rf "$target_dir/bin/auto"* -rm -rf "$target_dir/bin/aclocal"* +pushd "$target_dir/bin" 1>/dev/null +rm -rf auto* +rm -rf aclocal* -rm -rf "$target_dir/bin/"*perl* -rm -rf "$target_dir/lib/"*perl* +rm -rf *perl* +cd ../lib 1>/dev/null +rm -rf *perl* -rm -rf "$target_dir/lib/"*.la +rm -rf *.la -rm -rf "$target_dir/lib/terminfo"* +rm -rf terminfo* -rm -rf "$target_dir/lib/tcl"* -rm -rf "$target_dir/lib/tkl"* -rm -rf "$target_dir/lib/tdbc"* +rm -rf tcl* +rm -rf tkl* +rm -rf tdbc* -rm -rf "$target_dir/lib/cmake"* -rm -rf "$target_dir/lib/pkgconfig"* +rm -rf cmake* +rm -rf pkgconfig* -rm -rf "$target_dir/libexec/mingw-get" +cd .. 1>/dev/null +rm -rf libexec/mingw-get +popd 1>/dev/null echo && echo duplicating for debug version... From 57b38051fe5b2341dd14d97e34879c8086e37d99 Mon Sep 17 00:00:00 2001 From: nberth Date: Mon, 12 Dec 2022 10:42:22 +0000 Subject: [PATCH 07/18] Implement optional safe partial replacement when source operand is an alphanumeric literal cobc: * cobc.h (struct cb_replace_src, struct cb_replace_list, struct cb_turn_list, cb_turn_list, struct list_error, struct list_replace, struct list_skip, struct list_files), tree.h (enum cb_replace): move internal struct and symbol declarations to tree.h, and adapt some structures for strict partial text replacement * cobc.c (print_replace_text, print_replace_main), pplex.l (set_print_replace_list, ppecho), ppparse.y (ppp_replace_src, ppp_replace_list_add): handle strict partial text replacement, enabled unless dialect option partial-replace-when-literal-src (formerly partial-replacing-with-literal) is "skip" config: * general: rename partial-replacing-with-literal into partial-replace-when-literal-src, with special semantics of "skip" --- cobc/ChangeLog | 19 ++++- cobc/cobc.c | 14 +++- cobc/cobc.h | 75 -------------------- cobc/config.def | 9 +-- cobc/pplex.l | 26 ++++--- cobc/ppparse.y | 67 ++++++++++++++---- cobc/tree.h | 92 +++++++++++++++++++++++- config/ChangeLog | 6 ++ config/acu-strict.conf | 2 +- config/bs2000-strict.conf | 2 +- config/cobol2002.conf | 2 +- config/cobol2014.conf | 2 +- config/cobol85.conf | 2 +- config/default.conf | 2 +- config/gcos-strict.conf | 2 +- config/ibm-strict.conf | 2 +- config/mf-strict.conf | 2 +- config/mvs-strict.conf | 2 +- config/realia-strict.conf | 2 +- config/rm-strict.conf | 2 +- config/xopen.conf | 2 +- tests/testsuite.src/configuration.at | 2 +- tests/testsuite.src/listings.at | 71 +++++++++++++++++++ tests/testsuite.src/syn_copy.at | 100 ++++++++++++++++++++------- 24 files changed, 357 insertions(+), 150 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index c218e21a3..0227a910d 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -14,14 +14,27 @@ * codegen.c (output_param): added handling for prototype name, returning its name as literal -2022-12-05 Nicolas Berthier - - * cobc.c: replace some incorrect '%d' format indicators with '%lu' +2022-12-06 Nicolas Berthier + + * cobc.h (struct cb_replace_src, struct cb_replace_list, struct + cb_turn_list, cb_turn_list, struct list_error, struct list_replace) + (struct list_skip, struct list_files), tree.h (enum cb_replace): move + internal struct and symbol declarations to tree.h, and adapt some + structures for strict partial text replacement + * cobc.c (print_replace_text, print_replace_main), pplex.l + (set_print_replace_list, ppecho), ppparse.y (ppp_replace_src, + ppp_replace_list_add): handle strict partial text replacement, enabled + unless dialect option partial-replace-when-literal-src + (formerly partial-replacing-with-literal) is "skip" 2022-12-06 Simon Sobisch * field.c (validate_redefines): check for target not to have ANY LENGTH +2022-12-05 Nicolas Berthier + + * cobc.c: replace some incorrect '%d' format indicators with '%lu' + 2022-12-03 Simon Sobisch * cobc.c: check SOURCE_DATE_EPOCH once, if set parse via libcob diff --git a/cobc/cobc.c b/cobc/cobc.c index 6db43b7a7..19ea18d03 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -6904,6 +6904,7 @@ print_replace_text (struct list_files *cfile, FILE *fd, int overread = 0; int tokmatch = 0; int subword = 0; + int strictmatch = 0; size_t ttix, ttlen, from_token_len; size_t newlinelen; char lterm[2]; @@ -6933,8 +6934,10 @@ print_replace_text (struct list_files *cfile, FILE *fd, for (int i = 0; i < pline_cnt; i++) { fprintf (stdout, " pline[%2d]: %s\n", i, pline[i]); } - fprintf (stdout, " rep: first = %d, last = %d, lead_trail = %d\n", - rep->firstline, rep->lastline, rep->lead_trail); + fprintf (stdout, + " rep: first = %d, last = %d, lead_trail = %d, strict = %d\n", + rep->firstline, rep->lastline, rep->lead_trail, + rep->strict_partial); fprintf (stdout, " fromlen: %lu\n", strlen(rfp)); fprintf (stdout, " from: '%80.80s'\n", rfp); fprintf (stdout, " tolen: %lu\n", strlen(rep->to)); @@ -7105,15 +7108,20 @@ print_replace_text (struct list_files *cfile, FILE *fd, ttix = 0; if (rep->lead_trail == CB_REPLACE_LEADING) { subword = 1; + strictmatch = rep->strict_partial; } else if (rep->lead_trail == CB_REPLACE_TRAILING) { if (ttlen >= from_token_len) { subword = 1; + strictmatch = rep->strict_partial; ttix = ttlen - from_token_len; ttlen = ttix; } } if (subword) { - tokmatch = !strncasecmp (&ttoken[ttix], ftoken, from_token_len); + /* When strictmatch, length of word must be + strictly greater than matched token: */ + tokmatch = (!strictmatch || ttlen > from_token_len) + && !strncasecmp (&ttoken[ttix], ftoken, from_token_len); } else { tokmatch = !strcasecmp (ttoken, ftoken); } diff --git a/cobc/cobc.h b/cobc/cobc.h index 02b1d33ae..af008f95c 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -125,10 +125,6 @@ enum cb_current_date { }; #endif -/* COPY extended syntax defines */ -#define CB_REPLACE_LEADING 1U -#define CB_REPLACE_TRAILING 2U - /* Stringify macros */ #define CB_STRINGIFY(s) #s #define CB_XSTRINGIFY(s) CB_STRINGIFY(s) @@ -274,17 +270,6 @@ struct cb_text_list { const char *text; }; -/* Generic replace list structure */ -struct cb_replace_list { - int line_num; - struct cb_replace_list *next; /* next pointer */ - struct cb_replace_list *last; - struct cb_replace_list *prev; - const struct cb_text_list *old_text; - const struct cb_text_list *new_text; - unsigned int lead_trail; -}; - /* Structure for extended filenames */ struct local_filename { struct local_filename *next; /* next pointer */ @@ -321,15 +306,6 @@ struct cb_exception { int fatal; /* If recognizing this should abort */ }; -/* >>TURN directive list */ -struct cb_turn_list { - struct cb_turn_list *next; - struct cb_text_list *ec_names; - int line; - int enable; - int with_location; -}; - /* Type of name to check in cobc_check_valid_name */ enum cobc_name_type { FILE_BASE_NAME = 0, @@ -339,50 +315,6 @@ enum cobc_name_type { /* Listing structures and externals */ -/* List of error messages */ -struct list_error { - struct list_error *next; - struct list_error *prev; - int line; /* Line number for error */ - char *file; /* File name */ - char *prefix; /* Error prefix */ - char *msg; /* Error Message text */ -}; - -/* List of REPLACE text blocks */ -struct list_replace { - struct list_replace *next; - int firstline; /* First line for replace */ - int lastline; /* Last line for replace */ - int lead_trail; /* LEADING/TRAILING flag */ - char *from; /* Old (from) text */ - char *to; /* New (to) text */ -}; - -/* List of skipped lines (conditional compilation) */ -struct list_skip { - struct list_skip *next; - int skipline; /* line number of skipped line */ -}; - -/* Listing file control structure */ -struct list_files { - struct list_files *next; - struct list_files *copy_head; /* COPY book list head */ - struct list_files *copy_tail; /* COPY book list tail */ - struct list_error *err_head; /* Error message list head */ - struct list_replace *replace_head; /* REPLACE list head */ - struct list_replace *replace_tail; /* REPLACE list tail */ - struct list_skip *skip_head; /* Skip list head */ - struct list_skip *skip_tail; /* Skip list tail */ - int copy_line; /* Line start for copy book */ - int listing_on; /* Listing flag for this file */ - enum cb_format source_format; /* source format for file */ - const char *name; /* Name of this file */ -}; - -extern struct list_files *cb_current_file; - #if 0 /* ancient OSVS registers that need special runtime handling - low priority */ extern enum cb_current_date current_date; #endif @@ -397,8 +329,6 @@ extern const size_t cb_exception_table_len; #define CB_EXCEPTION_ENABLE(id) cb_exception_table[id].enable #define CB_EXCEPTION_FATAL(id) cb_exception_table[id].fatal -extern struct cb_turn_list *cb_turn_list; - /* undef macros that are only for internal use with def-files */ #undef CB_FLAG @@ -643,11 +573,6 @@ extern int pplex (void); extern int ppparse (void); #endif -extern int ppopen (const char *, struct cb_replace_list *); -extern int ppcopy (const char *, const char *, - struct cb_replace_list *); -extern void pp_set_replace_list (struct cb_replace_list *, - const cob_u32_t); extern unsigned int ppparse_verify (const enum cb_support tag, const char *feature); extern void ppparse_error (const char *); diff --git a/cobc/config.def b/cobc/config.def index eb0d81208..61389e139 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -195,7 +195,7 @@ CB_CONFIG_BOOLEAN (cb_areacheck, "areacheck", " * division, section, paragraph names, level indicators (FD, SD, RD, and CD),\n" " and toplevel numbers (01 and 77) must start in Area A;\n" " * statements must not start in Area A; and\n" - " * separator periods must not be within Area A.")) + " * separator periods must not be within Area A")) /* Support flags */ @@ -206,9 +206,10 @@ CB_CONFIG_SUPPORT (cb_comment_paragraphs, "comment-paragraphs", CB_CONFIG_SUPPORT (cb_control_division, "control-division", _("CONTROL DIVISION")) -CB_CONFIG_SUPPORT (cb_partial_replacing_with_literal, - "partial-replacing-with-literal", - _("partial replacing with literal")) +/* Enables literals as replacement operands. */ +CB_CONFIG_SUPPORT (cb_partial_replace_when_literal_src, "partial-replace-when-literal-src", + _("apply partial replacing with literal source operand even when it replaces with spaces only;\n" + " * \"skip\" prevents such replacements")) CB_CONFIG_SUPPORT (cb_memory_size_clause, "memory-size-clause", _("MEMORY-SIZE clause")) diff --git a/cobc/pplex.l b/cobc/pplex.l index 7b91e2ba6..730d01581 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -1759,16 +1759,18 @@ set_print_replace_list (struct cb_replace_list *list) size_t length; for (r = list; r; r = r->next) { + const struct cb_replace_src *src = r->src; repl = cobc_malloc (sizeof (struct list_replace)); repl->firstline = r->line_num; - repl->lead_trail = r->lead_trail; + repl->lead_trail = src->lead_trail; + repl->strict_partial = src->strict; repl->lastline = cb_source_line; - for (l = r->old_text, length = 0; l; l = l->next) { + for (l = src->text_list, length = 0; l; l = l->next) { length += strlen (l->text); } repl->from = cobc_malloc (length + 2); - for (l = r->old_text; l; l = l->next) { + for (l = src->text_list; l; l = l->next) { strcat (repl->from, l->text); } @@ -2577,12 +2579,12 @@ ppecho_replace (struct cb_replace_list *save_ptr) /* variables after breaking out of the loop BUT */ /* ppparse.y guarantees that we have only one token */ /* and therefore only one iteration of this loop */ - for (lno = r->old_text; lno; lno = lno->next) { + for (lno = r->src->text_list; lno; lno = lno->next) { if (lno->text[0] == ' ' || lno->text[0] == '\n') { continue; } while (queue && (queue->text[0] == ' ' || - queue->text[0] == '\n')) { + queue->text[0] == '\n')) { queue = queue->next; } if (queue == NULL) { @@ -2594,19 +2596,21 @@ ppecho_replace (struct cb_replace_list *save_ptr) } return -1; } - if (r->lead_trail == CB_REPLACE_LEADING) { + if (r->src->lead_trail == CB_REPLACE_LEADING) { /* Check leading text */ size = strlen (lno->text); - if (strncasecmp (lno->text, queue->text, size)) { + if ((r->src->strict && strlen (queue->text) == size) + || strncasecmp (lno->text, queue->text, size)) { /* No match */ break; } save_queue = queue; - } else if (r->lead_trail == CB_REPLACE_TRAILING) { + } else if (r->src->lead_trail == CB_REPLACE_TRAILING) { /* Check trailing text */ size = strlen (lno->text); size2 = strlen (queue->text); - if (size2 < size) { + if (size2 < size + || (r->src->strict && size2 == size)) { /* No match */ break; } @@ -2624,7 +2628,7 @@ ppecho_replace (struct cb_replace_list *save_ptr) } if (lno == NULL) { /* Match */ - if (r->lead_trail == CB_REPLACE_TRAILING + if (r->src->lead_trail == CB_REPLACE_TRAILING && save_queue /* <- silence warnings */) { /* Non-matched part of original text */ fprintf (ppout, "%*.*s", (int)size2, (int)size2, @@ -2639,7 +2643,7 @@ ppecho_replace (struct cb_replace_list *save_ptr) for (lno = r->new_text; lno; lno = lno->next) { ppecho_direct (lno->text); } - if (r->lead_trail == CB_REPLACE_LEADING + if (r->src->lead_trail == CB_REPLACE_LEADING && save_queue /* <- silence warnings */) { /* Non-matched part of original text */ ppecho_direct (save_queue->text + size); diff --git a/cobc/ppparse.y b/cobc/ppparse.y index d89692125..7b143ad48 100644 --- a/cobc/ppparse.y +++ b/cobc/ppparse.y @@ -97,11 +97,13 @@ static char * literal_token (char *t, int allow_spaces) { if (t[0] == '\'' || t[0] == '"') { - (void) ppparse_verify (cb_partial_replacing_with_literal, - _("partial replacing with literal")); + if (cb_partial_replace_when_literal_src != CB_SKIP) + (void) ppparse_verify (cb_partial_replace_when_literal_src, + _("partial replacing with literal")); } else if (allow_spaces && literal_is_space_keyword (t)) { - (void) ppparse_verify (cb_partial_replacing_with_literal, - _("partial replacing with literal")); + if (cb_partial_replace_when_literal_src != CB_SKIP) + (void) ppparse_verify (cb_partial_replace_when_literal_src, + _("partial replacing with literal")); t[0] = '\0'; } else { ppparse_error (_("unexpected COBOL word in partial replacement " @@ -132,19 +134,52 @@ fold_upper (char *name) return name; } +static struct cb_replace_src * +ppp_replace_src (const struct cb_text_list * const text_list, + const unsigned int literal_src) +{ + const unsigned int allow_empty_replacement = + !literal_src || cb_partial_replace_when_literal_src != CB_SKIP; + struct cb_replace_src *s = cobc_plex_malloc (sizeof (struct cb_replace_src)); + /* Note the two next fields are re-assessed in ppp_replace_list_add below */ + s->lead_trail = CB_REPLACE_ALL; + s->strict = allow_empty_replacement ? 0 : 1; + s->text_list = text_list; + return s; +} + static struct cb_replace_list * ppp_replace_list_add (struct cb_replace_list *list, - const struct cb_text_list *old_text, - const struct cb_text_list *new_text, - const unsigned int lead_or_trail) + struct cb_replace_src *src, + const struct cb_text_list *new_text, + const unsigned int lead_or_trail) { struct cb_replace_list *p; p = cobc_plex_malloc (sizeof (struct cb_replace_list)); p->line_num = cb_source_line; - p->old_text = old_text; + src->lead_trail = lead_or_trail; + if (!lead_or_trail) { + /* Strictness flag is irrelevant for non-LEADING nor TRAILING + replacements */ + src->strict = 0; + } else { + /* Use replacement text to decide strictness of partial match */ + const char * c; + int has_space = new_text->next != NULL; + for (c = new_text->text; !has_space && *c; c++) { + has_space = isspace(*c); + } + if (has_space) { + /* Note: as it appears, multi-word or spaces in + replacing is forbidden on GCOS. */ + ppparse_error (_("invalid partial replacing operand")); + return NULL; + } + src->strict = src->strict && *new_text->text == '\0'; + } + p->src = src; p->new_text = new_text; - p->lead_trail = lead_or_trail; if (!list) { p->last = p; return p; @@ -584,6 +619,7 @@ ppparse_clear_vars (const struct cb_define_struct *p) %union { char *s; struct cb_text_list *l; + struct cb_replace_src *p; struct cb_replace_list *r; struct cb_define_struct *ds; unsigned int ui; @@ -719,9 +755,9 @@ ppparse_clear_vars (const struct cb_define_struct *p) %type token_list %type identifier %type subscripts -%type text_src +%type

text_src %type text_dst -%type text_partial_src +%type

text_partial_src %type text_partial_dst %type alnum_list %type alnum_with @@ -1627,11 +1663,11 @@ replacing_list: text_src: EQEQ token_list EQEQ { - $$ = $2; + $$ = ppp_replace_src ($2, 0); } | identifier { - $$ = $1; + $$ = ppp_replace_src ($1, 0); } ; @@ -1653,11 +1689,12 @@ text_dst: text_partial_src: EQEQ TOKEN EQEQ { - $$ = ppp_list_add (NULL, $2); + $$ = ppp_replace_src (ppp_list_add (NULL, $2), 0); } | TOKEN { - $$ = ppp_list_add (NULL, literal_token ($1, 0)); + $$ = ppp_replace_src (ppp_list_add (NULL, literal_token ($1, 0)), + ($1[0] == '\'' || $1[0] == '"')); } ; diff --git a/cobc/tree.h b/cobc/tree.h index 51da2196c..40b59e152 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1590,7 +1590,94 @@ extern void ppparse_clear_vars (const struct cb_define_struct *); extern struct cb_define_struct *ppp_search_lists (const char *name); extern void plex_action_directive (const enum cb_directive_action, - const unsigned int); + const unsigned int); + +/* COPY/REPLACING/REPLACE */ + +/* COPY extended syntax defines */ +enum cb_replace { + CB_REPLACE_ALL = 0, + CB_REPLACE_LEADING = 1, + CB_REPLACE_TRAILING = 2, +}; + +/* Strict/loose source text replacement structure */ +struct cb_replace_src { + const struct cb_text_list *text_list; /* single-cell when strict */ + enum cb_replace lead_trail; + unsigned int strict: 1; +}; + +/* Generic replace list structure */ +struct cb_replace_list { + int line_num; + struct cb_replace_list *next; /* next pointer */ + struct cb_replace_list *last; + struct cb_replace_list *prev; + const struct cb_replace_src *src; + const struct cb_text_list *new_text; +}; + +extern void pp_set_replace_list (struct cb_replace_list *, + const cob_u32_t); + +/* List of error messages */ +struct list_error { + struct list_error *next; + struct list_error *prev; + int line; /* Line number for error */ + char *file; /* File name */ + char *prefix; /* Error prefix */ + char *msg; /* Error Message text */ +}; + +/* List of REPLACE text blocks */ +struct list_replace { + struct list_replace *next; + int firstline; /* First line for replace */ + int lastline; /* Last line for replace */ + enum cb_replace lead_trail; /* LEADING/TRAILING flag */ + int strict_partial; /* Partial repl. strictness flag */ + char *from; /* Old (from) text */ + char *to; /* New (to) text */ +}; + +/* List of skipped lines (conditional compilation) */ +struct list_skip { + struct list_skip *next; + int skipline; /* line number of skipped line */ +}; + +/* Listing file control structure */ +struct list_files { + struct list_files *next; + struct list_files *copy_head; /* COPY book list head */ + struct list_files *copy_tail; /* COPY book list tail */ + struct list_error *err_head; /* Error message list head */ + struct list_replace *replace_head; /* REPLACE list head */ + struct list_replace *replace_tail; /* REPLACE list tail */ + struct list_skip *skip_head; /* Skip list head */ + struct list_skip *skip_tail; /* Skip list tail */ + int copy_line; /* Line start for copy book */ + int listing_on; /* Listing flag for this file */ + enum cb_format source_format; /* source format for file */ + const char *name; /* Name of this file */ +}; + +extern struct list_files *cb_current_file; + +/* Directive-specific */ + +/* >>TURN directive list */ +struct cb_turn_list { + struct cb_turn_list *next; + struct cb_text_list *ec_names; + int line; + int enable; + int with_location; +}; + +extern struct cb_turn_list *cb_turn_list; /* Report */ @@ -2496,6 +2583,9 @@ extern void cobc_xref_set_receiving (const cb_tree); extern unsigned int cb_correct_program_order; /* pplex.l */ +extern int ppopen (const char *, struct cb_replace_list *); +extern int ppcopy (const char *, const char *, + struct cb_replace_list *); extern int cobc_has_areacheck_directive (const char *directive); /* Function defines */ diff --git a/config/ChangeLog b/config/ChangeLog index de0fd42c3..e0a5c2e5d 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,4 +1,10 @@ +2022-12-07 Nicolas Berthier + + * general: rename partial-replacing-with-literal into + partial-replace-when-literal-src, with special semantics of + "skip" + 2022-12-03 Simon Sobisch * runtime.cfg: updated COB_CURRENT_DATE for epoch diff --git a/config/acu-strict.conf b/config/acu-strict.conf index 924283d01..0b32e4854 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -202,7 +202,7 @@ dpc-in-data: xml # verify alter-statement: obsolete comment-paragraphs: obsolete # not verified yet -partial-replacing-with-literal: ok +partial-replace-when-literal-src: ok control-division: unconformable call-overflow: ok data-records-clause: obsolete # not verified yet diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index b39f31cbe..8921936ad 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -201,7 +201,7 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: unconformable control-division: unconformable -partial-replacing-with-literal: unconformable # not verified yet +partial-replace-when-literal-src: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 699fd0fc7..20f8d841b 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -200,7 +200,7 @@ dpc-in-data: xml alter-statement: unconformable comment-paragraphs: unconformable control-division: unconformable -partial-replacing-with-literal: unconformable +partial-replace-when-literal-src: unconformable call-overflow: archaic data-records-clause: unconformable debugging-mode: obsolete diff --git a/config/cobol2014.conf b/config/cobol2014.conf index ec3b388fd..d0b9293ec 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -200,7 +200,7 @@ dpc-in-data: xml alter-statement: unconformable comment-paragraphs: unconformable control-division: unconformable -partial-replacing-with-literal: unconformable +partial-replace-when-literal-src: unconformable call-overflow: archaic data-records-clause: unconformable debugging-mode: unconformable diff --git a/config/cobol85.conf b/config/cobol85.conf index c06f25706..a4e10f424 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -200,7 +200,7 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete control-division: unconformable -partial-replacing-with-literal: unconformable +partial-replace-when-literal-src: unconformable call-overflow: ok data-records-clause: obsolete debugging-mode: ok diff --git a/config/default.conf b/config/default.conf index f4117bf98..d9dbd6dea 100644 --- a/config/default.conf +++ b/config/default.conf @@ -220,7 +220,7 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete control-division: unconformable -partial-replacing-with-literal: obsolete +partial-replace-when-literal-src: obsolete call-overflow: archaic data-records-clause: obsolete debugging-mode: ok diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 6dbea3b85..885d2e5c6 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -199,7 +199,7 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete control-division: ok -partial-replacing-with-literal: ok +partial-replace-when-literal-src: skip # i.e, do not replace if results in spaces only call-overflow: archaic data-records-clause: obsolete debugging-mode: ok diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 5ef6121d6..1852798b5 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -199,7 +199,7 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete control-division: unconformable -partial-replacing-with-literal: unconformable +partial-replace-when-literal-src: unconformable call-overflow: ok data-records-clause: obsolete debugging-mode: ok diff --git a/config/mf-strict.conf b/config/mf-strict.conf index 8340b7c56..253ec18cb 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -202,7 +202,7 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete control-division: unconformable -partial-replacing-with-literal: unconformable +partial-replace-when-literal-src: unconformable call-overflow: ok data-records-clause: obsolete debugging-mode: ok diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index f8cafdcac..ef18b7659 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -198,7 +198,7 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete -partial-replacing-with-literal: unconformable +partial-replace-when-literal-src: unconformable control-division: unconformable call-overflow: ok # not verified yet data-records-clause: obsolete diff --git a/config/realia-strict.conf b/config/realia-strict.conf index 6a7e59357..69045d32e 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -203,7 +203,7 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: ok control-division: unconformable # not verified yet -partial-replacing-with-literal: unconformable # not verified yet +partial-replace-when-literal-src: unconformable # not verified yet call-overflow: ok data-records-clause: ignore debugging-mode: unconformable diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 3aea03962..82cb46283 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -205,7 +205,7 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete control-division: unconformable -partial-replacing-with-literal: unconformable # not verified yet +partial-replace-when-literal-src: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok diff --git a/config/xopen.conf b/config/xopen.conf index 364ca8fc7..c60e14e8d 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -217,7 +217,7 @@ dpc-in-data: xml alter-statement: warning # should not be used ... comment-paragraphs: warning # should not be used ... -partial-replacing-with-literal: unconformable +partial-replace-when-literal-src: unconformable control-division: unconformable call-overflow: ok data-records-clause: warning # should not be used ... diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index 22a0de8ae..7d6eed30f 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -460,7 +460,7 @@ test.conf: missing definitions: no definition of 'areacheck' no definition of 'comment-paragraphs' no definition of 'control-division' - no definition of 'partial-replacing-with-literal' + no definition of 'partial-replace-when-literal-src' no definition of 'memory-size-clause' no definition of 'multiple-file-tape-clause' no definition of 'label-records-clause' diff --git a/tests/testsuite.src/listings.at b/tests/testsuite.src/listings.at index adf0250f7..d9904f9ac 100644 --- a/tests/testsuite.src/listings.at +++ b/tests/testsuite.src/listings.at @@ -221,6 +221,77 @@ AT_CHECK([diff expected.lst prog.lis], [0], [], []) AT_CLEANUP +AT_SETUP([Partial replacement with literals]) +AT_KEYWORDS([listing gcos]) + +AT_CAPTURE_FILE([prog.lst]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 W-DATA. + 3 X PIC X(1) VALUE "X". + 3 XX PIC X(2) VALUE "XX". + 3 Z PIC X(1) VALUE "Z". + 3 ZZ PIC X(2) VALUE "ZZ". + 3 Y PIC X(1) VALUE "Y". + PROCEDURE DIVISION. + REPLACE LEADING "X" BY SPACES + TRAILING "Z" BY SPACES + LEADING "Y" BY "X". + MAIN. + DISPLAY "XX: *" XX "*" + DISPLAY "X: *" X "*" + DISPLAY "ZZ: *" ZZ "*" + DISPLAY "Z: *" Z "*" + DISPLAY "Y: *" Y "*" + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=skip -t prog.lst -tlines=0 prog.cob], [0], [], []) + +AT_DATA([expected.lst], +[GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY + +LINE PG/LN A...B............................................................ + +000001 +000002 IDENTIFICATION DIVISION. +000003 PROGRAM-ID. prog. +000004 DATA DIVISION. +000005 WORKING-STORAGE SECTION. +000006 1 W-DATA. +000007 3 X PIC X(1) VALUE "X". +000008 3 XX PIC X(2) VALUE "XX". +000009 3 Z PIC X(1) VALUE "Z". +000010 3 ZZ PIC X(2) VALUE "ZZ". +000011 3 Y PIC X(1) VALUE "Y". +000012 PROCEDURE DIVISION. +000013 REPLACE LEADING "X" BY SPACES +000014 TRAILING "Z" BY SPACES +000015 LEADING "Y" BY "X". +000016 MAIN. +000017 DISPLAY "XX: *" X "*" +000018 DISPLAY "X: *" X "*" +000019 DISPLAY "ZZ: *" ZZ "*" +000020 DISPLAY "Z: *" Z "*" +000021 DISPLAY "Y: *" X "*" +000022 STOP RUN. + + +0 warnings in compilation group +0 errors in compilation group +]) + +AT_CHECK([$UNIFY_LISTING prog.lst prog.lis once], [0], [], []) +AT_CHECK([diff expected.lst prog.lis], [0], [], []) + +AT_CLEANUP + + + AT_SETUP([COPY replacement with partial match]) AT_KEYWORDS([listing copy]) AT_XFAIL_IF([true]) diff --git a/tests/testsuite.src/syn_copy.at b/tests/testsuite.src/syn_copy.at index 9eb8abed6..f852773ea 100644 --- a/tests/testsuite.src/syn_copy.at +++ b/tests/testsuite.src/syn_copy.at @@ -531,13 +531,19 @@ AT_KEYWORDS([copy gcos]) AT_DATA([copy.inc], [ 01 TEST-VAR PIC X(2) VALUE "OK". 01 NORM-VAR PIC X(2) VALUE "OK". + 01 X PIC X(2) VALUE "OK". ]) AT_DATA([copy2.inc], [ - 01 TEST-FIRST PIC X(2) VALUE "OK". - 01 TEST-SECOND PIC X(2) VALUE "OK". + 01 TEST-FIRST PIC X(2) VALUE "OK". + 01 TEST-SECND PIC X(2) VALUE "OK". + 01 Y PIC X(2) VALUE "OK". ]) +# When `-fpartial-replace-when-literal-src' is "skip", X and +# Y are available: partial replacement with a source literal does not +# apply when the replacement does not lead to a valid word (cf GCOS +# reference manual, pp 537--538, 542). AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. @@ -545,32 +551,54 @@ AT_DATA([prog.cob], [ WORKING-STORAGE SECTION. COPY "copy.inc" REPLACING LEADING "TEST" BY "FIRST" - LEADING "NORM" BY "SECOND". + LEADING "NORM" BY "SECOND" + LEADING "X" BY "". COPY "copy2.inc" REPLACING TRAILING "FIRST" BY "VAR1" - TRAILING "SECOND" BY "VAR2". + TRAILING "SECND" BY "VAR2" + TRAILING "Y" BY "". PROCEDURE DIVISION. - DISPLAY FIRST-VAR NO ADVANCING - END-DISPLAY. - DISPLAY SECOND-VAR NO ADVANCING - END-DISPLAY. - DISPLAY TEST-VAR1 NO ADVANCING - END-DISPLAY. - DISPLAY TEST-VAR2 NO ADVANCING - END-DISPLAY. + DISPLAY FIRST-VAR NO ADVANCING END-DISPLAY. + DISPLAY SECOND-VAR NO ADVANCING END-DISPLAY. + DISPLAY X NO ADVANCING END-DISPLAY. + DISPLAY TEST-VAR1 NO ADVANCING END-DISPLAY. + DISPLAY TEST-VAR2 NO ADVANCING END-DISPLAY. + DISPLAY Y NO ADVANCING END-DISPLAY. STOP RUN. ]) -AT_CHECK([$COMPILE -fpartial-replacing-with-literal=ok prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKOKOKOK]) -AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=error prog.cob], [1], [], +AT_CHECK([$COMPILE -fpartial-replace-when-literal-src=skip -o prog-skip prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog-skip], [0], [OKOKOKOKOKOK]) +AT_CHECK([$COMPILE -fpartial-replace-when-literal-src=ok -o prog prog.cob], [1], [], +[copy.inc:2: error: parentheses must be preceded by a picture symbol +copy.inc:2: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:3: error: parentheses must be preceded by a picture symbol +copy.inc:3: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:4: error: parentheses must be preceded by a picture symbol +copy.inc:4: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:17: error: 'X' cannot be used here +prog.cob:20: error: 'Y' cannot be used here +]) +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=error prog.cob], [1], [], [prog.cob:7: error: partial replacing with literal used prog.cob:7: error: partial replacing with literal used prog.cob:8: error: partial replacing with literal used prog.cob:8: error: partial replacing with literal used -prog.cob:10: error: partial replacing with literal used -prog.cob:10: error: partial replacing with literal used +prog.cob:9: error: partial replacing with literal used +prog.cob:9: error: partial replacing with literal used prog.cob:11: error: partial replacing with literal used prog.cob:11: error: partial replacing with literal used +prog.cob:12: error: partial replacing with literal used +prog.cob:12: error: partial replacing with literal used +prog.cob:13: error: partial replacing with literal used +prog.cob:13: error: partial replacing with literal used +copy.inc:2: error: parentheses must be preceded by a picture symbol +copy.inc:2: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:3: error: parentheses must be preceded by a picture symbol +copy.inc:3: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:4: error: parentheses must be preceded by a picture symbol +copy.inc:4: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:17: error: 'X' cannot be used here +prog.cob:20: error: 'Y' cannot be used here ]) AT_DATA([prog_err.cob], [ @@ -585,11 +613,11 @@ AT_DATA([prog_err.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=ok prog_err.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=skip prog_err.cob], [1], [], [prog_err.cob:7: error: unexpected COBOL word in partial replacement phrase prog_err.cob:8: error: unexpected COBOL word in partial replacement phrase ]) -AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=unconformable prog_err.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=unconformable prog_err.cob], [1], [], [prog_err.cob:7: error: unexpected COBOL word in partial replacement phrase prog_err.cob:7: error: partial replacing with literal does not conform to GnuCOBOL prog_err.cob:8: error: partial replacing with literal does not conform to GnuCOBOL @@ -668,22 +696,46 @@ AT_DATA([prog.cob], [ 01 PREFIX-VAR1 PIC X(2) VALUE "OK". 01 VAR2-SUFFIX PIC X(2) VALUE "OK". PROCEDURE DIVISION. - DISPLAY VAR1 NO ADVANCING. - DISPLAY VAR2 NO ADVANCING. + DISPLAY "VAR1: " VAR1 NO ADVANCING. + DISPLAY "VAR1: " VAR2 NO ADVANCING. STOP RUN. ]) +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=ok prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=skip prog.cob], [0], [], []) + +AT_DATA([prog2.cob], [ + COPY prog REPLACING LEADING "VAR1" BY SPACES. +]) +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=ok prog2.cob], [0]) AT_DATA([prog_err.cob], [ COPY prog REPLACING LEADING SPACES BY "PREFIX-". ]) - -AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=ok prog.cob], [0], [], []) -AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=ok prog_err.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=ok prog_err.cob], [1], [], +[prog_err.cob:2: error: unexpected COBOL word in partial replacement phrase +]) +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=skip prog_err.cob], [1], [], [prog_err.cob:2: error: unexpected COBOL word in partial replacement phrase ]) +# Check that partial replacement rejects spaces in right operand: +AT_DATA([prog_err2.cob], [ + COPY prog REPLACING LEADING "VAR" BY "VAR1 ". +]) +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=ok prog_err2.cob], [1], [], +[prog_err2.cob:2: error: invalid partial replacing operand +]) + +AT_DATA([prog_err3.cob], [ + COPY prog REPLACING LEADING "VAR" BY " VAR1". +]) +AT_CHECK([$COMPILE_ONLY -fpartial-replace-when-literal-src=ok prog_err3.cob], [1], [], +[prog_err3.cob:2: error: invalid partial replacing operand +]) + AT_CLEANUP + AT_SETUP([COPY: Simple Partial match]) AT_KEYWORDS([copy]) From 9aea7ec99a566067456ee12fb73a86ecfd2f0ad2 Mon Sep 17 00:00:00 2001 From: nberth Date: Mon, 12 Dec 2022 10:56:20 +0000 Subject: [PATCH 08/18] Add flag -fdefault-colseq for default collation [feature-requests:#426] cobc: * flag.def, cobc.c (process_command_line): add new default-colseq flag * tree.h, parser.y (cb_deciph_default_colseq_name): new helper function * parser.y (build_default_colseq, setup_default_colseq, setup_program): initialize default collating sequence for programs when the default-colseq flag is not NATIVE --- cobc/ChangeLog | 9 +++++ cobc/cobc.c | 7 ++++ cobc/flag.def | 4 ++ cobc/parser.y | 66 ++++++++++++++++++++++++++++++++- cobc/tree.c | 2 +- cobc/tree.h | 2 + tests/testsuite.src/run_misc.at | 36 ++++++++++++++++++ 7 files changed, 123 insertions(+), 3 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 0227a910d..4727a8566 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,13 @@ +2022-12-09 Nicolas Berthier + + FR 426 Default collation option + * flag.def, cobc.c (process_command_line): add new default-colseq flag + * tree.h, parser.y (cb_deciph_default_colseq_name): new helper function + * parser.y (build_default_colseq, setup_default_colseq, setup_program): + initialize default collating sequence for programs when the + default-colseq flag is not NATIVE + 2022-12-08 Simon Sobisch * typeck.c (items_have_same_data_clauses): fix handling for ANY LENGTH diff --git a/cobc/cobc.c b/cobc/cobc.c index 19ea18d03..b10699fce 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -3596,6 +3596,13 @@ process_command_line (const int argc, char **argv) } break; + case 15: + /* -fdefault-colseq= */ + if (cb_deciph_default_colseq_name (cob_optarg)) { + cobc_err_exit (COBC_INV_PAR, "-fdefault-colseq"); + } + break; + case 4: /* -ffold-copy= : COPY fold case */ if (!cb_strcasecmp (cob_optarg, "UPPER")) { diff --git a/cobc/flag.def b/cobc/flag.def index fa49ca295..2c4f53ea3 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -99,6 +99,10 @@ CB_FLAG_NQ (1, "ebcdic-table", 14, /* cf cconv.h for all available tables */ " * ibm: translation to restricted ASCII as per IBM\n" " * gcos: translation to extended ASCII as per GCOS7")) +CB_FLAG_NQ (1, "default-colseq", 15, + _(" -fdefault-colseq=[ASCII|EBCDIC|NATIVE]\tdefine default collating sequence\n" + " * default: NATIVE")) + /* Binary flags */ /* Flags with suppressed help */ diff --git a/cobc/parser.y b/cobc/parser.y index 1b353697f..50af35a4e 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -272,6 +272,7 @@ static cb_tree xml_encoding; static int with_xml_dec; static int with_attrs; +static cb_tree default_collation; static cb_tree alphanumeric_collation; static cb_tree national_collation; @@ -334,6 +335,64 @@ check_non_area_a (cb_tree stmt) { } } +/* Collating sequences */ + +/* Known collating sequences/alphabets */ +enum { + CB_COLSEQ_NATIVE, + CB_COLSEQ_ASCII, + CB_COLSEQ_EBCDIC, +} cb_default_colseq = CB_COLSEQ_NATIVE; + +/* Decipher character conversion table names */ +int cb_deciph_default_colseq_name (const char * const name) +{ + if (! cb_strcasecmp (name, "ASCII")) { + cb_default_colseq = CB_COLSEQ_ASCII; + } else if (! cb_strcasecmp (name, "EBCDIC")) { + cb_default_colseq = CB_COLSEQ_EBCDIC; + } else if (! cb_strcasecmp (name, "NATIVE")) { + cb_default_colseq = CB_COLSEQ_NATIVE; + } else { + return 1; + } + return 0; +} + +static void +build_default_colseq (const char *alphabet_name, + int alphabet_type, + 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)); + alpha->alphabet_type = alphabet_type; + alpha->alphabet_target = alphabet_target; + default_collation = name; +} + +static void +setup_default_colseq (void) +{ + switch (cb_default_colseq) { + case CB_COLSEQ_NATIVE: + default_collation = NULL; + break; + case CB_COLSEQ_ASCII: + build_default_colseq ("ASCII", + CB_ALPHABET_ASCII, + CB_ALPHABET_ALPHANUMERIC); + break; + case CB_COLSEQ_EBCDIC: + build_default_colseq ("EBCDIC", + CB_ALPHABET_EBCDIC, + CB_ALPHABET_ALPHANUMERIC); + break; + } +} + + /* Statements */ static void @@ -1257,6 +1316,9 @@ setup_program (cb_tree id, cb_tree as_literal, const unsigned char type, const i cb_define (id, CB_TREE (current_program)); } + /* Initalize default COLLATING SEQUENCE */ + setup_default_colseq (); + begin_scope_of_program_name (current_program); return 0; @@ -5534,7 +5596,7 @@ collating_sequence_clause: collating_sequence: _collating SEQUENCE { - alphanumeric_collation = national_collation = NULL; + alphanumeric_collation = national_collation = default_collation; } coll_sequence_values ; @@ -16100,7 +16162,7 @@ _sort_duplicates: _sort_collating: /* empty */ { - alphanumeric_collation = national_collation = NULL; + alphanumeric_collation = national_collation = default_collation; } | collating_sequence ; diff --git a/cobc/tree.c b/cobc/tree.c index 2700c5480..9fcbdc2b8 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -626,7 +626,7 @@ cb_name_1 (char *s, cb_tree x, const int size) size_element = cb_name_1 (buff, p->offset, COB_SMALL_BUFF); if (size_real + size_element + 6 >= size) { /* drop that " (X:Y) [in Z]" */ - return size_real; + return size_real; } if (p->length) { size_refmod = sprintf (s, " (%s:", buff); diff --git a/cobc/tree.h b/cobc/tree.h index 40b59e152..2257d46e1 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2294,6 +2294,8 @@ extern cb_tree cb_debug_sub_2; extern cb_tree cb_debug_sub_3; extern cb_tree cb_debug_contents; +extern int cb_deciph_default_colseq_name (const char *const); + extern struct cb_program *cb_build_program (struct cb_program *, const int); diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 2ba1fa374..23ca756d4 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -3517,6 +3517,42 @@ AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) AT_CLEANUP +AT_SETUP([SORT: table sort with default COLLATING SEQUENCE]) +AT_KEYWORDS([runmisc EBCDIC ASCII default-colseq]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC X(10) VALUE "d4b2e1a3c5". + 01 G REDEFINES Z. + 02 TBL OCCURS 10. + 03 X PIC X. + PROCEDURE DIVISION. + SORT TBL ASCENDING KEY X. + >>IF EXPECT-ORDER = 'ASCII' + IF G NOT = "12345abcde" + >>ELIF EXPECT-ORDER = 'EBCDIC' + IF G NOT = "abcde12345" + >>ELSE *> = 'NATIVE' + IF NOT G = "12345abcde" OR "abcde12345" + >>END-IF + DISPLAY G END-DISPLAY + END-IF. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fdefault-colseq=ascii -DEXPECT-ORDER=ASCII -o ascii prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./ascii], [0], [], []) +AT_CHECK([$COMPILE -fdefault-colseq=ebcdic -DEXPECT-ORDER=EBCDIC -o ebcdic prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./ebcdic], [0], [], []) +AT_CHECK([$COMPILE -fdefault-colseq=native -DEXPECT-ORDER=NATIVE -o native prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./native], [0], [], []) + +AT_CLEANUP + + AT_SETUP([PIC ZZZ-, ZZZ+]) AT_KEYWORDS([runmisc editing]) From cbcb44ae1943093063ae13694bd12fd4cd9ecd88 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 12 Dec 2022 11:06:09 +0000 Subject: [PATCH 09/18] fixed [r4858] broken fileio.c (cob_str_from_fld) --- libcob/fileio.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libcob/fileio.c b/libcob/fileio.c index 83abe5419..f7ee76a50 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -6806,7 +6806,7 @@ cob_str_from_fld (const cob_field *f) } end--; } - s = mptr = cob_fast_malloc (end - data + 1); + s = mptr = cob_fast_malloc (end + 1 - data + 1); if (*end == ' ' || *end == 0) { *s = 0; return s; @@ -6814,9 +6814,9 @@ cob_str_from_fld (const cob_field *f) while (data <= end) { #if 0 /* Quotes in file */ - if (*s == '"') { + if (*data == '"') { quote_switch = !quote_switch; - s++; + data++; continue; } if (!quote_switch @@ -6825,8 +6825,8 @@ cob_str_from_fld (const cob_field *f) break; } #else - if (*s == '"') { - s++; + if (*data == '"') { + data++; continue; } #endif From 6a25f27d06d720c0d09453b0f8b59e5e32fb9fde Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 12 Dec 2022 14:53:44 +0000 Subject: [PATCH 10/18] codegen adjustments * codegen.c (output_initialize): added missing generation of runtime checks for INITIALIZE (again?) * typeck.c (cb_build_move): optimized (=identical) generation for MOVE no matter if runtime checks are enabled or not (speed + identical behavior) --- NEWS | 13 ++--- cobc/ChangeLog | 7 +++ cobc/codegen.c | 12 ++++- cobc/typeck.c | 85 +++++++++++++++++++++++++++++---- tests/testsuite.src/run_misc.at | 40 +++++++++++++--- 5 files changed, 136 insertions(+), 21 deletions(-) diff --git a/NEWS b/NEWS index 77d772e5a..b5b01a58b 100644 --- a/NEWS +++ b/NEWS @@ -340,12 +340,13 @@ NEWS - user visible changes -*- outline -*- INSPECT that use big COBOL fields (multiple KB) CALL data-item, and first time for each CALL ACCEPT DATE/TIME/DAY and datetime related FUNCTIONs + MOVE with enabled runtime checks (only with re-compile) ** execution times for programs that are new generated with -fsource-location (implied with --debug/-fec) are cut down, especially when many "simple" statements or lot of sections/paragraphs are used; also the runtime checks for use of LINKAGE fields and/or subscripts/reference-modification will be - much faster + much faster * New build features @@ -411,10 +412,10 @@ NEWS - user visible changes -*- outline -*- ** JSON GENERATE statement (note: runtime support needs additional library cJSON or JSON-C) - + ** CONTINUE AFTER statement (COBOL 2022) implemented, also handle fractions of seconds in C$SLEEP now - + ** TYPEDEF and SAME AS (COBOL 2002) implemented, including the MicroFocus and RM/COBOL variants @@ -446,7 +447,7 @@ NEWS - user visible changes -*- outline -*- still applied; File name mapping now applies both to COBOL statements and CALLable CBL_ and C$ file routines. - + ** Screen I/O: initial mouse support (for details see runtime.cfg), use of CURSOR clause in SPECIAL-NAMES for positioning on ACCEPT @@ -462,7 +463,7 @@ NEWS - user visible changes -*- outline -*- extensions [as post-rc1-change this may be set to old behavior by defining COB_MULTI_EXTENSION when building GnuCOBOL/cobc] * library names are now tested for environment "COB_COPY_LIB_libname", - allowing the directory to specified externally (also as no-directory + allowing the directory to specified externally (also as no-directory by exporting with empty value) and has a fallback (with a warning) to be effectively ignored (as previous versions did this) @@ -601,7 +602,7 @@ NEWS - user visible changes -*- outline -*- * Too many bug fixes to list here (please check ChangeLogs for full details), includes the following CVEs: - + ** compiler (may be triggered with special crafted source files) CVE-2019-14468, CVE-2019-14486, CVE-2019-14528, CVE-2019-14541, CVE-2019-16396, CVE-2019-16395 diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 4727a8566..35571f9d3 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,11 @@ +2022-12-12 Simon Sobisch + + * codegen.c (output_initialize): added missing generation of runtime checks + for INITIALIZE (again?) + * typeck.c (cb_build_move): optimized (=identical) generation for MOVE no + matter if runtime checks are enabled or not (speed + identical behavior) + 2022-12-09 Nicolas Berthier FR 426 Default collation option diff --git a/cobc/codegen.c b/cobc/codegen.c index 21a165d52..9a73b8abe 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -5595,8 +5595,18 @@ output_initialize (struct cb_initialize *p) const enum cobc_init_type type = deduce_initialize_type (p, f, 1); - if (type == INITIALIZE_NONE) + if (type == INITIALIZE_NONE) { return; + } + + /* output runtime checks */ + if (CB_REFERENCE_P (p->var) + && CB_REFERENCE (p->var)->check) { + /* note: should only be when init_flag is set */ + struct cb_reference *ref = CB_REFERENCE (p->var); + output_stmt (ref->check); + ref->check = NULL; + } /* TODO: if cb_default_byte >= 0 do a huge memset first, then only diff --git a/cobc/typeck.c b/cobc/typeck.c index 52ae17067..d41a92e50 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2493,7 +2493,17 @@ cb_build_identifier (cb_tree x, const int subchk) } } - /* Run-time check for ODO (including all the fields' subordinate items) */ + /* Run-time check for ODO (including all the fields' subordinate items), + FIXME: this should only be done "once" per ODO and statement, but + if the statement is a list it is done multiple times: + 77 XX PIC 99 VALUE 5. + 01 X PIC X OCCURS 0 TO 10 DEPENDING ON XX. + MOVE ZERO TO X(2) X(4) X(6) X(8) X(10) X(1) + --> currently generated for each of the 6 "X" items, as we (need to) + call this function 6 times from parser (target_identifier) + --> either cache field name here (dropping after each statement) + or remove/skip later during codegen + */ if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT) && f->odo_level != 0) { for (p = f; p; p = p->children) { if (CB_VALID_TREE (p->depending) @@ -11741,6 +11751,8 @@ cb_tree cb_build_move (cb_tree src, cb_tree dst) { struct cb_reference *src_ref, *dst_ref, *x; + cb_tree chks = NULL; + cb_tree ret; int move_zero; if (CB_INVALID_TREE(src) @@ -11819,28 +11831,85 @@ cb_build_move (cb_tree src, cb_tree dst) return CB_BUILD_FUNCALL_2 ("cob_move", src, dst); } +#if 1 /* OPTCHK Simon: optimal copy also with runtime checks enabled */ + /* TODO: optimize by resolving subscripts as integers once per statement, + 77 XX PIC 99 VALUE 5. + 01 X PIC X OCCURS 0 TO 10 DEPENDING ON XX. + MOVE ZERO TO X(2) X(4) X(6) X(8) + current version: + cob_check_odo (cob_get_numdisp (b_17, 2), 0, 10, "X", "XX"); + cob_check_subscript (2, cob_get_numdisp (b_17, 2), "X", 1); + *(b_18 + 1) = 48; + cob_check_odo (cob_get_numdisp (b_17, 2), 0, 10, "X", "XX"); + cob_check_subscript (4, cob_get_numdisp (b_17, 2), "X", 1); + *(b_18 + 3) = 48; + cob_check_odo (cob_get_numdisp (b_17, 2), 0, 10, "X", "XX"); + cob_check_subscript (6, cob_get_numdisp (b_17, 2), "X", 1); + *(b_18 + 5) = 48; + cob_check_odo (cob_get_numdisp (b_17, 2), 0, 10, "X", "XX"); + cob_check_subscript (8, cob_get_numdisp (b_17, 2), "X", 1); + *(b_18 + 7) = 48; + much better version (separate issue: the odo-item should + only be checked once, see comment on its addition): + { + const int odo_value = cob_get_numdisp (b_17, 2); + cob_check_odo (, 0, 10, "X", "XX"); + cob_check_subscript (2, odo_value, "X", 1); + *(b_18 + 1) = 48; + cob_check_odo (odo_value, 0, 10, "X", "XX"); + cob_check_subscript (4, odo_value, "X", 1); + *(b_18 + 3) = 48; + cob_check_odo (odo_value, 0, 10, "X", "XX"); + cob_check_subscript (6, odo_value, "X", 1); + *(b_18 + 5) = 48; + cob_check_odo (odo_value, 0, 10, "X", "XX"); + cob_check_subscript (8, odo_value, "X", 1); + *(b_18 + 7) = 48; + } + */ + if (src_ref && src_ref->check) { + chks = src_ref->check; + src_ref->check = NULL; + if (dst_ref && dst_ref->check) { + chks = cb_list_add (chks, dst_ref->check); + dst_ref->check = NULL; + } + } else + if (dst_ref && dst_ref->check) { + chks = dst_ref->check; + dst_ref->check = NULL; + } +#else if (src_ref && src_ref->check) { return CB_BUILD_FUNCALL_2 ("cob_move", src, dst); } if (dst_ref && dst_ref->check) { return CB_BUILD_FUNCALL_2 ("cob_move", src, dst); } +#endif /* Output optimal code */ if (src == cb_zero) { - return cb_build_move_zero (dst); + ret = cb_build_move_zero (dst); } else if (src == cb_space) { - return cb_build_move_space (dst); + ret = cb_build_move_space (dst); } else if (src == cb_high) { - return cb_build_move_high (dst); + ret = cb_build_move_high (dst); } else if (src == cb_low) { - return cb_build_move_low (dst); + ret = cb_build_move_low (dst); } else if (src == cb_quote) { - return cb_build_move_quote (dst); + ret = cb_build_move_quote (dst); } else if (CB_LITERAL_P (src)) { - return cb_build_move_literal (src, dst); + ret = cb_build_move_literal (src, dst); + } else { + ret = cb_build_move_field (src, dst); } - return cb_build_move_field (src, dst); +#if 1 /* OPTCHK Simon: optimal copy also with runtime checks enabled */ + if (chks) { + return cb_list_add (chks, ret); + } +#endif + return ret; } /* TO-DO: Shouldn't this include validate_move()? */ diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 23ca756d4..bca3f1966 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -893,7 +893,7 @@ AT_DATA([prog.cob], [ MOVE ZERO TO X(2) X(4) X(6) X(8) SET ADDRESS OF X-ALL TO ADDRESS OF X(1) IF X-ALL NOT = " 0 0 0 0AA" - DISPLAY X-ALL UPON SYSERR + DISPLAY X-ALL UPON SYSERR. STOP RUN. ]) @@ -911,20 +911,48 @@ AT_DATA([prog2.cob], [ LINKAGE SECTION. 01 X-ALL PIC X(10). PROCEDURE DIVISION. - INITIALIZE X(1) X(3) X(5) X(7) MOVE ZERO TO X(2) X(4) X(6) X(8) + INITIALIZE X(1) X(3) X(5) X(7) SET ADDRESS OF X-ALL TO ADDRESS OF X(1) IF X-ALL NOT = " 0 0 0 0AA" - DISPLAY X-ALL UPON SYSERR + DISPLAY X-ALL UPON SYSERR. STOP RUN. ]) -AT_CHECK([$COMPILE -fno-ec=bound -o baddy prog2.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./baddy], [0], [], []) +AT_CHECK([$COMPILE -fno-ec=bound -o baddy2 prog2.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./baddy2], [0], [], []) AT_CHECK([$COMPILE prog2.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog2], [1], [], -[libcob: prog2.cob:13: error: subscript of 'X' out of bounds: 6 +[libcob: prog2.cob:12: error: subscript of 'X' out of bounds: 6 +note: current maximum subscript for 'X': 5 +]) + +AT_DATA([prog3.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog3. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 XX PIC 99 VALUE 5. + 01 X PIC X OCCURS 0 TO 10 + DEPENDING ON XX VALUE "A". + LINKAGE SECTION. + 01 X-ALL PIC X(10). + PROCEDURE DIVISION. + INITIALIZE X(1) X(3) X(5) X(7) + MOVE ZERO TO X(2) X(4) X(6) X(8) + SET ADDRESS OF X-ALL TO ADDRESS OF X(1) + IF X-ALL NOT = " 0 0 0 0AA" + DISPLAY X-ALL UPON SYSERR. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fno-ec=bound -o baddy3 prog3.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./baddy3], [0], [], []) + +AT_CHECK([$COMPILE prog3.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog3], [1], [], +[libcob: prog3.cob:12: error: subscript of 'X' out of bounds: 7 note: current maximum subscript for 'X': 5 ]) From 20ea24088502e29c7166784bed268c0508a74283 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 12 Dec 2022 21:29:50 +0000 Subject: [PATCH 11/18] fix related to [feature-requests:#193 TYPEDEF]: TYPEDEFs got actual field definitions and storage attached cobc: * codegen.c (output_initial_values): don't do any init for TYPEDEFs, as these are only prototypes and otherwise lead to actual storage (and useless init) * codegen.c (output_display_fields): don't dump TYPEDEFs --- NEWS | 5 +- cobc/ChangeLog | 4 ++ cobc/codegen.c | 9 ++- tests/testsuite.src/syn_misc.at | 116 ++++++++++++++++---------------- 4 files changed, 72 insertions(+), 62 deletions(-) diff --git a/NEWS b/NEWS index b5b01a58b..a6e5b385c 100644 --- a/NEWS +++ b/NEWS @@ -5,7 +5,6 @@ NEWS - user visible changes -*- outline -*- planned: * configure: minor checking to set TIME_T_IS_NON_ARITHMETIC - * changes to CALL handling especially for BY VALUE and stdcall * adjustments for registers and XML PARSE stubs * investigation of code analysis tools and user feedback @@ -297,6 +296,10 @@ NEWS - user visible changes -*- outline -*- this issue and all executed code from the signal handler but the COBOL data dump is now signal and thread safe +** TYPEDEF items got storage and attribute assigned, leading to bigger modules, + longer loading time and longer compile times; if you use those a recompile + is highly suggested + * Listing changes ** the timestamp in the header was changed from ANSI date format like diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 35571f9d3..05c0dec24 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -5,6 +5,10 @@ for INITIALIZE (again?) * typeck.c (cb_build_move): optimized (=identical) generation for MOVE no matter if runtime checks are enabled or not (speed + identical behavior) + * codegen.c (output_initial_values): don't do any init for TYPEDEFs, + as these are only prototypes and otherwise lead to actual storage + (and useless init) + * codegen.c (output_display_fields): don't dump TYPEDEFs 2022-12-09 Nicolas Berthier diff --git a/cobc/codegen.c b/cobc/codegen.c index 9a73b8abe..dfcac3ed2 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -10458,14 +10458,16 @@ output_initial_values (struct cb_field *f) cb_tree x; for (p = f; p; p = p->sister) { - x = cb_build_field_reference (p, NULL); - if (p->flag_item_based) { + if (p->flag_item_based + || p->flag_external + || p->flag_is_typedef) { continue; } /* For special registers */ if (p->flag_no_init && !p->count) { continue; } + x = cb_build_field_reference (p, NULL); output_line ("/* initialize field %s */", p->name); output_stmt (cb_build_initialize (x, cb_true, NULL, 1, 0, 0)); output_newline (); @@ -10647,7 +10649,8 @@ output_display_fields (struct cb_field *f, size_t offset, unsigned int idx) for (; f; f = f->sister) { int has_based_check = 0; /* skip entries we never want to dump */ - if (f->level == 0 && f->file == NULL) { + if ((f->level == 0 && f->file == NULL) + || f->flag_is_typedef) { continue; } /* For special registers */ diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index f5d888385..b6785d00d 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -8827,7 +8827,7 @@ AT_DATA([prog.cob], [ * * --> missing: floating point edited pictures, * those are left to the reader as excercise :-) - * + 77 x36 pic x(36) is typedef. * In the following block, "sync" prevents SIGBUS errors on SOLARIS systems. 01 special-data. 05 r2d2 usage bit pic 111 value b'110'. @@ -8837,7 +8837,7 @@ AT_DATA([prog.cob], [ *> 05 idx usage index sync. *> 05 hnd usage handle sync. 01 alphanumeric-data. - 05 alpnum pic x(36) value "some numb3rs 4 n00bs l1k3 m3". + 05 alpnum usage x36 value "some numb3rs 4 n00bs l1k3 m3". 05 alpha pic a(36) value "thats some text". 05 edit-num1 pic --9.999. 05 edit-num2 pic ++9.999. @@ -8910,42 +8910,42 @@ AT_CHECK([($GREP -A 200 "P_dump:" prog.c | $GREP -B 200 "END OF DUMP") || exit 7 cob_dump_field_ext ( 1, "floating-data", COB_SET_FLD(f0, 12, b_43, &a_47), 0, 0); cob_dump_field_ext ( 5, "dbl", COB_SET_FLD(f0, 8, b_43, &a_37), 0, 0); cob_dump_field_ext ( 5, "flt", COB_SET_FLD(f0, 4, b_43 + 8, &a_39), 0, 0); - cob_dump_field_ext ( 1, "special-data", COB_SET_FLD(f0, 1, b_46, &a_47), 0, 0); - cob_dump_field_ext ( 5, "r2d2", COB_SET_FLD(f0, 1, b_46, &a_41), 0, 0); - cob_dump_field_ext ( 1, "alphanumeric-data", COB_SET_FLD(f0, 101, b_48, &a_47), 0, 0); - cob_dump_field_ext ( 5, "alpnum", COB_SET_FLD(f0, 36, b_48, &a_48), 0, 0); - cob_dump_field_ext ( 5, "alpha", COB_SET_FLD(f0, 36, b_48 + 36, &a_48), 0, 0); - cob_dump_field_ext ( 5, "edit-num1", COB_SET_FLD(f0, 7, b_48 + 72, &a_42), 0, 0); - cob_dump_field_ext ( 5, "edit-num2", COB_SET_FLD(f0, 7, b_48 + 79, &a_43), 0, 0); - cob_dump_field_ext ( 5, "edit-num3", COB_SET_FLD(f0, 7, b_48 + 86, &a_44), 0, 0); - cob_dump_field_ext ( 5, "edit-num4", COB_SET_FLD(f0, 8, b_48 + 93, &a_45), 0, 0); - cob_dump_field_ext ( 1, "national-data", COB_SET_FLD(f0, 116, b_55, &a_47), 0, 0); - cob_dump_field_ext ( 5, "nat", COB_SET_FLD(f0, 72, b_55, &a_49), 0, 0); - cob_dump_field_ext ( 5, "nat-num", COB_SET_FLD(f0, 15, b_55 + 72, &a_50), 0, 0); - cob_dump_field_ext ( 5, "net-num1", COB_SET_FLD(f0, 7, b_55 + 87, &a_42), 0, 0); - cob_dump_field_ext ( 5, "net-num2", COB_SET_FLD(f0, 7, b_55 + 94, &a_43), 0, 0); - cob_dump_field_ext ( 5, "net-num3", COB_SET_FLD(f0, 7, b_55 + 101, &a_44), 0, 0); - cob_dump_field_ext ( 5, "net-num4", COB_SET_FLD(f0, 8, b_55 + 108, &a_45), 0, 0); - cob_dump_field_ext ( 0, "x-idx", COB_SET_FLD(f0, 4, (cob_u8_t *)&b_63, &a_46), 0, 0); + cob_dump_field_ext ( 1, "special-data", COB_SET_FLD(f0, 1, b_47, &a_47), 0, 0); + cob_dump_field_ext ( 5, "r2d2", COB_SET_FLD(f0, 1, b_47, &a_41), 0, 0); + cob_dump_field_ext ( 1, "alphanumeric-data", COB_SET_FLD(f0, 101, b_49, &a_47), 0, 0); + cob_dump_field_ext ( 5, "alpnum", COB_SET_FLD(f0, 36, b_49, &a_48), 0, 0); + cob_dump_field_ext ( 5, "alpha", COB_SET_FLD(f0, 36, b_49 + 36, &a_48), 0, 0); + cob_dump_field_ext ( 5, "edit-num1", COB_SET_FLD(f0, 7, b_49 + 72, &a_42), 0, 0); + cob_dump_field_ext ( 5, "edit-num2", COB_SET_FLD(f0, 7, b_49 + 79, &a_43), 0, 0); + cob_dump_field_ext ( 5, "edit-num3", COB_SET_FLD(f0, 7, b_49 + 86, &a_44), 0, 0); + cob_dump_field_ext ( 5, "edit-num4", COB_SET_FLD(f0, 8, b_49 + 93, &a_45), 0, 0); + cob_dump_field_ext ( 1, "national-data", COB_SET_FLD(f0, 116, b_56, &a_47), 0, 0); + cob_dump_field_ext ( 5, "nat", COB_SET_FLD(f0, 72, b_56, &a_49), 0, 0); + cob_dump_field_ext ( 5, "nat-num", COB_SET_FLD(f0, 15, b_56 + 72, &a_50), 0, 0); + cob_dump_field_ext ( 5, "net-num1", COB_SET_FLD(f0, 7, b_56 + 87, &a_42), 0, 0); + cob_dump_field_ext ( 5, "net-num2", COB_SET_FLD(f0, 7, b_56 + 94, &a_43), 0, 0); + cob_dump_field_ext ( 5, "net-num3", COB_SET_FLD(f0, 7, b_56 + 101, &a_44), 0, 0); + cob_dump_field_ext ( 5, "net-num4", COB_SET_FLD(f0, 8, b_56 + 108, &a_45), 0, 0); + cob_dump_field_ext ( 0, "x-idx", COB_SET_FLD(f0, 4, (cob_u8_t *)&b_64, &a_46), 0, 0); { int i_1; int max_1 = (*(cob_s8_ptr) (b_17 + 63)); if (max_1 > 5) max_1 = 5; for (i_1=0; i_1 < max_1; i_1++) { - cob_dump_field_ext ( 1, "FILLER", COB_SET_FLD(f0, 3, b_62, &a_47), 0, 1, i_1, 3UL); /* OCCURS 2 5 */ - cob_dump_field_ext ( 3, "x-basis", COB_SET_FLD(f0, 3, b_62, &a_47), 0, 1, i_1, 3UL); - cob_dump_field_ext ( 5, "x-a", COB_SET_FLD(f0, 1, b_62, &a_48), 0, 1, i_1, 3UL); - cob_dump_field_ext ( 5, "x-b", COB_SET_FLD(f0, 1, b_62 + 1, &a_48), 0, 1, i_1, 3UL); - cob_dump_field_ext ( 5, "x-c", COB_SET_FLD(f0, 1, b_62 + 2, &a_48), 0, 1, i_1, 3UL); - /* cob_dump_field_ext ( 3, "FILLER", COB_SET_FLD(f0, 3, b_62, &a_48), 0, 1, i_1, 3UL); REDEFINES */ - /* cob_dump_field_ext (88, "sw-x-basis-full", COB_SET_FLD(f0, 3, b_62, &a_48), 0, 1, i_1, 3UL); VALUE (cob_field *)&c_18 */ + cob_dump_field_ext ( 1, "FILLER", COB_SET_FLD(f0, 3, b_63, &a_47), 0, 1, i_1, 3UL); /* OCCURS 2 5 */ + cob_dump_field_ext ( 3, "x-basis", COB_SET_FLD(f0, 3, b_63, &a_47), 0, 1, i_1, 3UL); + cob_dump_field_ext ( 5, "x-a", COB_SET_FLD(f0, 1, b_63, &a_48), 0, 1, i_1, 3UL); + cob_dump_field_ext ( 5, "x-b", COB_SET_FLD(f0, 1, b_63 + 1, &a_48), 0, 1, i_1, 3UL); + cob_dump_field_ext ( 5, "x-c", COB_SET_FLD(f0, 1, b_63 + 2, &a_48), 0, 1, i_1, 3UL); + /* cob_dump_field_ext ( 3, "FILLER", COB_SET_FLD(f0, 3, b_63, &a_48), 0, 1, i_1, 3UL); REDEFINES */ + /* cob_dump_field_ext (88, "sw-x-basis-full", COB_SET_FLD(f0, 3, b_63, &a_48), 0, 1, i_1, 3UL); VALUE (cob_field *)&c_18 */ } } - cob_dump_field_ext ( 1, "x-rms", COB_SET_FLD(f0, 1, b_70, &a_47), 0, 0); - cob_dump_field_ext ( 5, "x-rms-a", COB_SET_FLD(f0, 1, b_70, &a_48), 0, 0); - /* cob_dump_field_ext ( 1, "FILLER", COB_SET_FLD(f0, 1, b_70, &a_48), 0, 0); REDEFINES */ - /* cob_dump_field_ext (88, "sw-x-rms-full", COB_SET_FLD(f0, 1, b_70, &a_48), 0, 0); VALUE (cob_field *)&c_19 OR (cob_field *)&c_20 OR (cob_field *)&c_21 THRU (cob_field *)&c_22 OR (cob_field *)&c_20 OR &cob_all_quote */ + cob_dump_field_ext ( 1, "x-rms", COB_SET_FLD(f0, 1, b_71, &a_47), 0, 0); + cob_dump_field_ext ( 5, "x-rms-a", COB_SET_FLD(f0, 1, b_71, &a_48), 0, 0); + /* cob_dump_field_ext ( 1, "FILLER", COB_SET_FLD(f0, 1, b_71, &a_48), 0, 0); REDEFINES */ + /* cob_dump_field_ext (88, "sw-x-rms-full", COB_SET_FLD(f0, 1, b_71, &a_48), 0, 0); VALUE (cob_field *)&c_19 OR (cob_field *)&c_20 OR (cob_field *)&c_21 THRU (cob_field *)&c_22 OR (cob_field *)&c_20 OR &cob_all_quote */ /* Dump LOCAL-STORAGE SECTION */ cob_dump_output("LOCAL-STORAGE"); @@ -8995,39 +8995,39 @@ AT_CHECK([($GREP -A 200 "P_dump:" prog.c | $GREP -B 200 "END OF DUMP") || exit 7 /* cob_dump_field_ext ( 1, "floating-data", COB_SET_FLD(f0, 12, b_43, &a_47), 0, 0); */ /* cob_dump_field_ext ( 5, "dbl", COB_SET_FLD(f0, 8, b_43, &a_37), 0, 0); */ /* cob_dump_field_ext ( 5, "flt", COB_SET_FLD(f0, 4, b_43 + 8, &a_39), 0, 0); */ - /* cob_dump_field_ext ( 1, "special-data", COB_SET_FLD(f0, 1, b_46, &a_47), 0, 0); */ - /* cob_dump_field_ext ( 5, "r2d2", COB_SET_FLD(f0, 1, b_46, &a_41), 0, 0); */ - /* cob_dump_field_ext ( 1, "alphanumeric-data", COB_SET_FLD(f0, 101, b_48, &a_47), 0, 0); */ - /* cob_dump_field_ext ( 5, "alpnum", COB_SET_FLD(f0, 36, b_48, &a_48), 0, 0); */ - /* cob_dump_field_ext ( 5, "alpha", COB_SET_FLD(f0, 36, b_48 + 36, &a_48), 0, 0); */ - /* cob_dump_field_ext ( 5, "edit-num1", COB_SET_FLD(f0, 7, b_48 + 72, &a_42), 0, 0); */ - /* cob_dump_field_ext ( 5, "edit-num2", COB_SET_FLD(f0, 7, b_48 + 79, &a_43), 0, 0); */ - /* cob_dump_field_ext ( 5, "edit-num3", COB_SET_FLD(f0, 7, b_48 + 86, &a_44), 0, 0); */ - /* cob_dump_field_ext ( 5, "edit-num4", COB_SET_FLD(f0, 8, b_48 + 93, &a_45), 0, 0); */ - /* cob_dump_field_ext ( 1, "national-data", COB_SET_FLD(f0, 116, b_55, &a_47), 0, 0); */ - /* cob_dump_field_ext ( 5, "nat", COB_SET_FLD(f0, 72, b_55, &a_49), 0, 0); */ - /* cob_dump_field_ext ( 5, "nat-num", COB_SET_FLD(f0, 15, b_55 + 72, &a_50), 0, 0); */ - /* cob_dump_field_ext ( 5, "net-num1", COB_SET_FLD(f0, 7, b_55 + 87, &a_42), 0, 0); */ - /* cob_dump_field_ext ( 5, "net-num2", COB_SET_FLD(f0, 7, b_55 + 94, &a_43), 0, 0); */ - /* cob_dump_field_ext ( 5, "net-num3", COB_SET_FLD(f0, 7, b_55 + 101, &a_44), 0, 0); */ - /* cob_dump_field_ext ( 5, "net-num4", COB_SET_FLD(f0, 8, b_55 + 108, &a_45), 0, 0); */ - /* cob_dump_field_ext ( 0, "x-idx", COB_SET_FLD(f0, 4, (cob_u8_t *)&b_63, &a_46), 0, 0); */ + /* cob_dump_field_ext ( 1, "special-data", COB_SET_FLD(f0, 1, b_47, &a_47), 0, 0); */ + /* cob_dump_field_ext ( 5, "r2d2", COB_SET_FLD(f0, 1, b_47, &a_41), 0, 0); */ + /* cob_dump_field_ext ( 1, "alphanumeric-data", COB_SET_FLD(f0, 101, b_49, &a_47), 0, 0); */ + /* cob_dump_field_ext ( 5, "alpnum", COB_SET_FLD(f0, 36, b_49, &a_48), 0, 0); */ + /* cob_dump_field_ext ( 5, "alpha", COB_SET_FLD(f0, 36, b_49 + 36, &a_48), 0, 0); */ + /* cob_dump_field_ext ( 5, "edit-num1", COB_SET_FLD(f0, 7, b_49 + 72, &a_42), 0, 0); */ + /* cob_dump_field_ext ( 5, "edit-num2", COB_SET_FLD(f0, 7, b_49 + 79, &a_43), 0, 0); */ + /* cob_dump_field_ext ( 5, "edit-num3", COB_SET_FLD(f0, 7, b_49 + 86, &a_44), 0, 0); */ + /* cob_dump_field_ext ( 5, "edit-num4", COB_SET_FLD(f0, 8, b_49 + 93, &a_45), 0, 0); */ + /* cob_dump_field_ext ( 1, "national-data", COB_SET_FLD(f0, 116, b_56, &a_47), 0, 0); */ + /* cob_dump_field_ext ( 5, "nat", COB_SET_FLD(f0, 72, b_56, &a_49), 0, 0); */ + /* cob_dump_field_ext ( 5, "nat-num", COB_SET_FLD(f0, 15, b_56 + 72, &a_50), 0, 0); */ + /* cob_dump_field_ext ( 5, "net-num1", COB_SET_FLD(f0, 7, b_56 + 87, &a_42), 0, 0); */ + /* cob_dump_field_ext ( 5, "net-num2", COB_SET_FLD(f0, 7, b_56 + 94, &a_43), 0, 0); */ + /* cob_dump_field_ext ( 5, "net-num3", COB_SET_FLD(f0, 7, b_56 + 101, &a_44), 0, 0); */ + /* cob_dump_field_ext ( 5, "net-num4", COB_SET_FLD(f0, 8, b_56 + 108, &a_45), 0, 0); */ + /* cob_dump_field_ext ( 0, "x-idx", COB_SET_FLD(f0, 4, (cob_u8_t *)&b_64, &a_46), 0, 0); */ { /* int max_1 = (*(cob_s8_ptr) (b_17 + 63)); */ { - /* cob_dump_field_ext ( 1, "FILLER", COB_SET_FLD(f0, 3, b_62, &a_47), 0, 1, i_1, 3UL); OCCURS 2 5 */ - /* cob_dump_field_ext ( 3, "x-basis", COB_SET_FLD(f0, 3, b_62, &a_47), 0, 1, i_1, 3UL); */ - /* cob_dump_field_ext ( 5, "x-a", COB_SET_FLD(f0, 1, b_62, &a_48), 0, 1, i_1, 3UL); */ - /* cob_dump_field_ext ( 5, "x-b", COB_SET_FLD(f0, 1, b_62 + 1, &a_48), 0, 1, i_1, 3UL); */ - /* cob_dump_field_ext ( 5, "x-c", COB_SET_FLD(f0, 1, b_62 + 2, &a_48), 0, 1, i_1, 3UL); */ - /* cob_dump_field_ext ( 3, "FILLER", COB_SET_FLD(f0, 3, b_62, &a_48), 0, 1, i_1, 3UL); REDEFINES */ - /* cob_dump_field_ext (88, "sw-x-basis-full", COB_SET_FLD(f0, 3, b_62, &a_48), 0, 1, i_1, 3UL); VALUE (cob_field *)&c_18 */ + /* cob_dump_field_ext ( 1, "FILLER", COB_SET_FLD(f0, 3, b_63, &a_47), 0, 1, i_1, 3UL); OCCURS 2 5 */ + /* cob_dump_field_ext ( 3, "x-basis", COB_SET_FLD(f0, 3, b_63, &a_47), 0, 1, i_1, 3UL); */ + /* cob_dump_field_ext ( 5, "x-a", COB_SET_FLD(f0, 1, b_63, &a_48), 0, 1, i_1, 3UL); */ + /* cob_dump_field_ext ( 5, "x-b", COB_SET_FLD(f0, 1, b_63 + 1, &a_48), 0, 1, i_1, 3UL); */ + /* cob_dump_field_ext ( 5, "x-c", COB_SET_FLD(f0, 1, b_63 + 2, &a_48), 0, 1, i_1, 3UL); */ + /* cob_dump_field_ext ( 3, "FILLER", COB_SET_FLD(f0, 3, b_63, &a_48), 0, 1, i_1, 3UL); REDEFINES */ + /* cob_dump_field_ext (88, "sw-x-basis-full", COB_SET_FLD(f0, 3, b_63, &a_48), 0, 1, i_1, 3UL); VALUE (cob_field *)&c_18 */ } } - /* cob_dump_field_ext ( 1, "x-rms", COB_SET_FLD(f0, 1, b_70, &a_47), 0, 0); */ - /* cob_dump_field_ext ( 5, "x-rms-a", COB_SET_FLD(f0, 1, b_70, &a_48), 0, 0); */ - /* cob_dump_field_ext ( 1, "FILLER", COB_SET_FLD(f0, 1, b_70, &a_48), 0, 0); REDEFINES */ - /* cob_dump_field_ext (88, "sw-x-rms-full", COB_SET_FLD(f0, 1, b_70, &a_48), 0, 0); VALUE (cob_field *)&c_19 OR (cob_field *)&c_20 OR (cob_field *)&c_21 THRU (cob_field *)&c_22 OR (cob_field *)&c_20 OR &cob_all_quote */ + /* cob_dump_field_ext ( 1, "x-rms", COB_SET_FLD(f0, 1, b_71, &a_47), 0, 0); */ + /* cob_dump_field_ext ( 5, "x-rms-a", COB_SET_FLD(f0, 1, b_71, &a_48), 0, 0); */ + /* cob_dump_field_ext ( 1, "FILLER", COB_SET_FLD(f0, 1, b_71, &a_48), 0, 0); REDEFINES */ + /* cob_dump_field_ext (88, "sw-x-rms-full", COB_SET_FLD(f0, 1, b_71, &a_48), 0, 0); VALUE (cob_field *)&c_19 OR (cob_field *)&c_20 OR (cob_field *)&c_21 THRU (cob_field *)&c_22 OR (cob_field *)&c_20 OR &cob_all_quote */ /* Dump LOCAL-STORAGE SECTION (informational) */ /* cob_dump_output("LOCAL-STORAGE"); */ From aa7564534102a5e7f241d00149b31e14f6c9842d Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 12 Dec 2022 22:12:03 +0000 Subject: [PATCH 12/18] configure now checks for PERL and passes that as default to make test, instead of using hard-wired binary name "perl" configure.ac: * check for and substitute PERL/perl tests: * Makefile.am, cobol85/Makefile.am, cobol85/Makefile.module.in: use PERL via variable, default is substituted from configure additional: build_aux/create_mingw_bindist.sh: don't remove perl as it may be used in the distribution for test coverage via lcov --- ChangeLog | 4 ++++ NEWS | 1 + build_aux/create_mingw_bindist.sh | 6 ++++-- build_windows/README.txt | 4 ++-- tests/Makefile.am | 4 ++-- tests/cobol85/ChangeLog | 5 +++++ tests/cobol85/Makefile.am | 5 +++-- tests/cobol85/Makefile.module.in | 10 ++++++---- tests/cobol85/README | 9 ++++++++- 9 files changed, 35 insertions(+), 13 deletions(-) diff --git a/ChangeLog b/ChangeLog index 8d98e60b6..db3364a9e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ +2022-12-12 Simon Sobisch + + * configure.ac: check for and substitute PERL/perl + 2022-12-02 Simon Sobisch * Makefile.am: tarstamp.h may now be created on base of VCSDATE or diff --git a/NEWS b/NEWS index a6e5b385c..90577272e 100644 --- a/NEWS +++ b/NEWS @@ -357,6 +357,7 @@ NEWS - user visible changes -*- outline -*- ** configure now honors MATH_LIBS ** configure now checks for XCurses and allows --with-curses=xcurses (experimental) +** configure now checks for PERL and passes that as default to make test ** cobc handles SOURCE_DATE_EPOCH now, allowing to override timestamps in generated code and listing files, allowing reproducible builds diff --git a/build_aux/create_mingw_bindist.sh b/build_aux/create_mingw_bindist.sh index c5816490a..14ec89924 100755 --- a/build_aux/create_mingw_bindist.sh +++ b/build_aux/create_mingw_bindist.sh @@ -322,9 +322,11 @@ pushd "$target_dir/bin" 1>/dev/null rm -rf auto* rm -rf aclocal* -rm -rf *perl* +# Note: perl may be used in the distribution for +# test coverage via lcov, so leave in +#rm -rf *perl* cd ../lib 1>/dev/null -rm -rf *perl* +#rm -rf *perl* rm -rf *.la diff --git a/build_windows/README.txt b/build_windows/README.txt index bf19074ea..53ef4d3a0 100644 --- a/build_windows/README.txt +++ b/build_windows/README.txt @@ -57,9 +57,9 @@ How to test the native builds: * currently you will need a GNU/Linux-like environment for running the testsuite (normally MinGW with MSYS, MSYS2 or Cygwin) * if you want to run the NIST testsuite you need a perl binary installed and - in PATH + either as "perl" (.exe/.cmd/.bat) in PATH or specify it via PERL variable * if you've set MAKE_DIST in config.h copy the dist package to the place - cobc --info says (for example to C:\GnuCOBOL_3.1) + cobc --info says (for example to C:\GnuCOBOL_3.x) * start the VS command prompt that matches the version you want to test * do the following commands: set COB_UNIX_LF=YES diff --git a/tests/Makefile.am b/tests/Makefile.am index 13a5c83cc..158f774d3 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -110,8 +110,8 @@ checkmanual: prereq-manual prereq-check prereq-testsuite prereq-manual test: atlocal - @echo testing for perl && perl -v 1>/dev/null \ - || (echo "Error: no working 'perl' in PATH" && false) + @echo testing for perl && $(PERL) -v 1>/dev/null \ + || (echo "Error: could not executed $(PERL)" && false) @cd cobol85 && $(MAKE) $(AM_MAKEFLAGS) test checkall: check test diff --git a/tests/cobol85/ChangeLog b/tests/cobol85/ChangeLog index 07eff0eb7..26ea3dc94 100644 --- a/tests/cobol85/ChangeLog +++ b/tests/cobol85/ChangeLog @@ -1,4 +1,9 @@ +2022-12-12 Simon Sobisch + + * Makefile.am, Makefile.module.in: use PERL via variable, + default is substituted from configure + 2022-10-11 Simon Sobisch * Makefile.module.in: added and adjusted clean targets diff --git a/tests/cobol85/Makefile.am b/tests/cobol85/Makefile.am index c245f50b8..400e2221d 100644 --- a/tests/cobol85/Makefile.am +++ b/tests/cobol85/Makefile.am @@ -144,7 +144,7 @@ test-local-compat: # then remove the rm of the file below summary.log: @echo "Computing total test results..." - @perl "$(srcdir)/summary.pl" $(MODULES) > $@ + @$(PERL) "$(srcdir)/summary.pl" $(MODULES) > $@ diff: @echo "Comparing test results for each module" @@ -228,12 +228,13 @@ $(MODULES_ALL): newcob.val EXEC85$(EXEEXT) $(srcdir)/EXEC85.conf.in Makefile.mod export NEWCOB_VAL=$(abs_srcdir)/newcob.val; \ fi; \ cd $@ && $(PRE_INST_ENV) ../EXEC85$(EXEEXT) - @perl $(srcdir)/expand.pl $@/newcob.tmp $@ + @$(PERL) $(srcdir)/expand.pl $@/newcob.tmp $@ # @$(RM) ./$@/newcob.tmp ./$@/newcob.log ./$@/EXEC85.conf @export CBL_LIST="`ls $@/*.CBL | cut -f2 -d/ | tr '\n' ' '`" && \ $(SED) -e 's/##MODULE##/'"$@"'/' \ -e 's|##COB85DIR##|'$(abs_srcdir)'|' \ -e 's|##DIFF_FLAGS##|'"$(DIFF_FLAGS)"'|' \ + -e 's|##PERL##|'"$(PERL)"'|' \ -e 's|##TESTS##|'"` echo $$CBL_LIST | $(SED) -e 's/\.CBL//g'`"'|' \ -e 's|##TESTS_LOCAL##|'"`echo $$CBL_LIST | $(SED) -e 's/\.CBL/-local/g'`"'|' \ $(srcdir)/Makefile.module.in > $@/Makefile diff --git a/tests/cobol85/Makefile.module.in b/tests/cobol85/Makefile.module.in index 80e83bda7..cc2f35848 100644 --- a/tests/cobol85/Makefile.module.in +++ b/tests/cobol85/Makefile.module.in @@ -25,6 +25,8 @@ TESTS_LOCAL = ##TESTS_LOCAL## RM = rm -rf DIFF_FLAGS = ##DIFF_FLAGS## +PERL = ##PERL## + all: @$(MAKE) test @$(MAKE) diff @@ -54,7 +56,7 @@ test: test-local: @echo @echo "Performing tests for module directory ##MODULE##" - @perl ##COB85DIR##/report.pl + @$(PERL) ##COB85DIR##/report.pl diff: report.txt @echo @@ -67,7 +69,7 @@ test-O: test-O-local: @echo @echo "Performing tests (optimized) for module directory ##MODULE##" - @perl ##COB85DIR##/report.pl -O + @$(PERL) ##COB85DIR##/report.pl -O libs: @if test -d lib; then \ @@ -78,7 +80,7 @@ libs-local: @if test -d lib; then \ echo "" ; \ echo "Compiling libs for module directory ##MODULE##..."; \ - perl ##COB85DIR##/report.pl lib ; \ + $(PERL) ##COB85DIR##/report.pl lib ; \ fi $(TESTS): libs @@ -86,7 +88,7 @@ $(TESTS): libs $(TESTS_LOCAL): libs-local @echo "Running single test `echo $@ | sed -e 's|-.*||g'`" - @perl ##COB85DIR##/report.pl `echo $@ | sed -e 's|-.*||g'` 2>$@.log + @$(PERL) ##COB85DIR##/report.pl `echo $@ | sed -e 's|-.*||g'` 2>$@.log @grep `echo $@ | sed -e 's|-.*||g'` ##COB85DIR##/##MODULE##.txt | diff - $@.log @rm -rf $@.log diff --git a/tests/cobol85/README b/tests/cobol85/README index 4e3cb7625..2e8c66b1f 100644 --- a/tests/cobol85/README +++ b/tests/cobol85/README @@ -3,7 +3,14 @@ How to run the NIST CCVS85 (aka. ANSI85) Test Suite *NOTE* It is expected that WARNING messages appear when running the test. -*NOTE* The language interpreter "perl" is required to run these tests. +*NOTE* The language interpreter "perl" is required to run these tests, +you can use a different named binary or specify its full path as PERL=... +during make. +For cross-compile and win32 builds: ensure that PERL handles the exported +environment in the environment that actually runs the test _and_ either +passes those to the execution environment or that this environment has +those variables (set in the execution environment via pre-inst-env script) +set otherwise. The final command of the the test is a diff between expected results and actual results, i.e. "diff summary.txt summary.log". From 0ecac30799045f54999a61abe9dc36bf39d7b188 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 12 Dec 2022 22:54:26 +0000 Subject: [PATCH 13/18] configure now checks for PERL and passes that as default to make test, instead of using hard-wired binary name "perl" configure.ac: * check for and substitute PERL/perl tests: * Makefile.am, cobol85/Makefile.am, cobol85/Makefile.module.in: use PERL via variable, default is substituted from configure additional: build_aux/create_mingw_bindist.sh: don't remove perl as it may be used in the distribution for test coverage via lcov --- configure.ac | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/configure.ac b/configure.ac index 3125fd1f1..e75e92f91 100644 --- a/configure.ac +++ b/configure.ac @@ -1781,6 +1781,10 @@ fi dnl currently not directly used: AM_ICONV AM_LANGINFO_CODESET +# Check for perl, used for "make test" +#AM_MISSING_PROG(PERL, perl) --> only use for tools that generate something +AC_CHECK_PROG(PERL, perl, perl) + # GnuCOBOL Configuration COB_CONFIG_DIR="$datadir/$PACKAGE_TARNAME/config" From 3ed6cb6a245ecd21282bd200087dadf19e991769 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 13 Dec 2022 08:56:20 +0000 Subject: [PATCH 14/18] follow-up to [r4845] work on resolving date + time speedup and epoch parsing cobc: * cobc.c (set_compile_date_tm): extracted from set_listing_date * cobc.c (set_compile_date): execute set_compile_date_tm on each setting * codegen.c (output_gnucobol_defines): use pre-set compile timestamp instead if re-setting them --- cobc/ChangeLog | 4 ++++ cobc/cobc.c | 34 ++++++++++++++++++++-------------- cobc/codegen.c | 44 +++++++++++++------------------------------- 3 files changed, 37 insertions(+), 45 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 05c0dec24..4242b7164 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -59,6 +59,10 @@ * cobc.c: check SOURCE_DATE_EPOCH once, if set parse via libcob to use as compile timestamp + * cobc.c (set_compile_date_tm): extracted from set_listing_date + * cobc.c (set_compile_date): execute set_compile_date_tm on each setting + * codegen.c (output_gnucobol_defines): use pre-set compile timestamp + instead if re-setting them 2022-12-02 Simon Sobisch diff --git a/cobc/cobc.c b/cobc/cobc.c index b10699fce..8d5334f6b 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -2164,6 +2164,24 @@ cobc_clean_up (const int status) file_list = NULL; } +static void +set_compile_date_tm (void) +{ + current_compile_tm.tm_sec = current_compile_time.second; + current_compile_tm.tm_min = current_compile_time.minute; + current_compile_tm.tm_hour = current_compile_time.hour; + current_compile_tm.tm_mday = current_compile_time.day_of_month; + current_compile_tm.tm_mon = current_compile_time.month - 1; + current_compile_tm.tm_year = current_compile_time.year - 1900; + if (current_compile_time.day_of_week == 7) { + current_compile_tm.tm_wday = 0; + } else { + current_compile_tm.tm_wday = current_compile_time.day_of_week; + } + current_compile_tm.tm_yday = current_compile_time.day_of_year; + current_compile_tm.tm_isdst = current_compile_time.is_daylight_saving_time; +} + static void set_compile_date (void) { @@ -2173,6 +2191,7 @@ set_compile_date (void) sde_todo = 1; if (s && *s) { if (cob_set_date_from_epoch (¤t_compile_time, s) == 0) { + set_compile_date_tm (); return; } cobc_err_msg (_("environment variable '%s' has invalid content"), "SOURCE_DATE_EPOCH"); @@ -2183,6 +2202,7 @@ set_compile_date (void) } } current_compile_time = cob_get_current_date_and_time (); + set_compile_date_tm (); } static void @@ -2192,20 +2212,6 @@ set_listing_date (void) set_compile_date (); } - current_compile_tm.tm_sec = current_compile_time.second; - current_compile_tm.tm_min = current_compile_time.minute; - current_compile_tm.tm_hour = current_compile_time.hour; - current_compile_tm.tm_mday = current_compile_time.day_of_month; - current_compile_tm.tm_mon = current_compile_time.month - 1; - current_compile_tm.tm_year = current_compile_time.year - 1900; - if (current_compile_time.day_of_week == 7) { - current_compile_tm.tm_wday = 0; - } else { - current_compile_tm.tm_wday = current_compile_time.day_of_week; - } - current_compile_tm.tm_yday = current_compile_time.day_of_year; - current_compile_tm.tm_isdst = current_compile_time.is_daylight_saving_time; - #ifdef LISTING_TIMESTAMP_ANSI #define LISTING_TIMESTAMP_FORMAT "%a %b %d %H:%M:%S %Y" /* same format as asctime */ #elif !defined (LISTING_TIMESTAMP_FORMAT) diff --git a/cobc/codegen.c b/cobc/codegen.c index dfcac3ed2..0ba423bb0 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -1798,7 +1798,7 @@ output_standard_includes (struct cb_program *prog) /* GnuCOBOL defines */ static void -output_gnucobol_defines (const char *formatted_date, struct tm *local_time) +output_gnucobol_defines (const char *formatted_date) { int i; @@ -1823,19 +1823,14 @@ output_gnucobol_defines (const char *formatted_date, struct tm *local_time) output_line ("#define COB_PATCH_LEVEL\t\t%d", PATCH_LEVEL); output_line ("#define COB_MODULE_FORMATTED_DATE\t\"%s\"", formatted_date); - if (local_time) { - i = ((local_time->tm_year + 1900) * 10000) + - ((local_time->tm_mon + 1) * 100) + - local_time->tm_mday; - output_line ("#define COB_MODULE_DATE\t\t%d", i); - i = (local_time->tm_hour * 10000) + - (local_time->tm_min * 100) + - local_time->tm_sec; - output_line ("#define COB_MODULE_TIME\t\t%d", i); - } else { - output_line ("#define COB_MODULE_DATE\t\t0"); - output_line ("#define COB_MODULE_TIME\t\t0"); - } + i = ((current_compile_tm.tm_year + 1900) * 10000) + + ((current_compile_tm.tm_mon + 1) * 100) + + current_compile_tm.tm_mday; + output_line ("#define COB_MODULE_DATE\t\t%d", i); + i = (current_compile_tm.tm_hour * 10000) + + (current_compile_tm.tm_min * 100) + + current_compile_tm.tm_sec; + output_line ("#define COB_MODULE_TIME\t\t%d", i); } @@ -13266,12 +13261,6 @@ codegen (struct cb_program *prog, const char *translate_name) void codegen_init (struct cb_program *prog, const char *translate_name) { - struct tm* loctime; - time_t sectime; - - sectime = time (NULL); - loctime = localtime (§ime); - current_program = prog; current_section = NULL; current_paragraph = NULL; @@ -13310,16 +13299,9 @@ codegen_init (struct cb_program *prog, const char *translate_name) string_buffer = cobc_main_malloc ((size_t)COB_MINI_BUFF); } - if (loctime) { - /* Leap seconds ? */ - if (loctime->tm_sec >= 60) { - loctime->tm_sec = 59; - } - strftime (string_buffer, (size_t)COB_MINI_MAX, - "%b %d %Y %H:%M:%S", loctime); - } else { - string_buffer[0] = 0; - } + strftime (string_buffer, (size_t)COB_MINI_MAX, + "%b %d %Y %H:%M:%S", ¤t_compile_tm); + output_target = yyout; output_header (string_buffer, NULL); output_target = cb_storage_file; @@ -13338,7 +13320,7 @@ codegen_init (struct cb_program *prog, const char *translate_name) output_standard_includes (prog); /* string_buffer has formatted date from above */ - output_gnucobol_defines (string_buffer, loctime); + output_gnucobol_defines (string_buffer); output_newline (); output_line ("/* Global variables */"); From 7c384575538f29d4d403e8d05e48c0c94ae30ff2 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 13 Dec 2022 09:44:10 +0000 Subject: [PATCH 15/18] type safety for internal warning option handling in cobc cobc: * cobc.c (cb_warn_opt_val, get_warn_opt_value, set_warn_opt_value), cobc.h: renamed cb_warn_opt_val to warn_opt_val and keep local, provide typed functions to get/set the internal option with the "real" type for improved type checks and internal cobc debugging * cobc.c, error.c, field.c, parser.y, pplex.l, tree.c, typeck,c; adjusted to use new get_warn_opt_value / set_warn_opt_value functions --- cobc/ChangeLog | 9 ++++++ cobc/cobc.c | 88 +++++++++++++++++++++++++++++--------------------- cobc/cobc.h | 4 +-- cobc/error.c | 22 ++++++------- cobc/field.c | 12 +++---- cobc/parser.y | 4 +-- cobc/pplex.l | 2 +- cobc/tree.c | 16 ++++----- cobc/typeck.c | 30 ++++++++--------- 9 files changed, 106 insertions(+), 81 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 4242b7164..c71325023 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,13 @@ +2022-12-13 Simon Sobisch + + * cobc.c (cb_warn_opt_val, get_warn_opt_value, set_warn_opt_value), cobc.h: + renamed cb_warn_opt_val to warn_opt_val and keep local, provide typed + functions to get/set the internal option with the "real" type for improved + type checks and internal cobc debugging + * cobc.c, error.c, field.c, parser.y, pplex.l, tree.c, typeck,c; adjusted + to use new get_warn_opt_value / set_warn_opt_value functions + 2022-12-12 Simon Sobisch * codegen.c (output_initialize): added missing generation of runtime checks diff --git a/cobc/cobc.c b/cobc/cobc.c index 8d5334f6b..942965128 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -329,7 +329,9 @@ int cb_mf_ibm_comp = -1; /* Flag to emit Old style: cob_set_location, cob_trace_section */ int cb_old_trace = 0; -int cb_warn_opt_val[COB_WARNOPT_MAX]; /* note: int as we feed that to getopt */ +/* warning options, internally stored as int as we feed that to getopt_long, + otherwise only used via typed getter/setter */ +int warn_opt_val[COB_WARNOPT_MAX]; /* Local variables */ @@ -648,17 +650,17 @@ static const struct option long_options[] = { {"fnot-register", CB_RQ_ARG, NULL, '%'}, #define CB_WARNDEF(opt,name,doc) \ - {"W" name, CB_NO_ARG, &cb_warn_opt_val[opt], COBC_WARN_ENABLED_EXPL}, \ - {"Wno-" name, CB_NO_ARG, &cb_warn_opt_val[opt], COBC_WARN_DISABLED_EXPL}, + {"W" name, CB_NO_ARG, &warn_opt_val[opt], COBC_WARN_ENABLED_EXPL}, \ + {"Wno-" name, CB_NO_ARG, &warn_opt_val[opt], COBC_WARN_DISABLED_EXPL}, #define CB_ONWARNDEF(opt,name,doc) \ - {"W" name, CB_NO_ARG, &cb_warn_opt_val[opt], COBC_WARN_ENABLED_EXPL}, \ - {"Wno-" name, CB_NO_ARG, &cb_warn_opt_val[opt], COBC_WARN_DISABLED_EXPL}, + {"W" name, CB_NO_ARG, &warn_opt_val[opt], COBC_WARN_ENABLED_EXPL}, \ + {"Wno-" name, CB_NO_ARG, &warn_opt_val[opt], COBC_WARN_DISABLED_EXPL}, #define CB_NOWARNDEF(opt,name,doc) \ - {"W" name, CB_NO_ARG, &cb_warn_opt_val[opt], COBC_WARN_ENABLED_EXPL}, \ - {"Wno-" name, CB_NO_ARG, &cb_warn_opt_val[opt], COBC_WARN_DISABLED_EXPL}, + {"W" name, CB_NO_ARG, &warn_opt_val[opt], COBC_WARN_ENABLED_EXPL}, \ + {"Wno-" name, CB_NO_ARG, &warn_opt_val[opt], COBC_WARN_DISABLED_EXPL}, #define CB_ERRWARNDEF(opt,name,doc) \ - {"W" name, CB_NO_ARG, &cb_warn_opt_val[opt], COBC_WARN_ENABLED_EXPL}, \ - {"Wno-" name, CB_NO_ARG, &cb_warn_opt_val[opt], COBC_WARN_DISABLED_EXPL}, + {"W" name, CB_NO_ARG, &warn_opt_val[opt], COBC_WARN_ENABLED_EXPL}, \ + {"Wno-" name, CB_NO_ARG, &warn_opt_val[opt], COBC_WARN_DISABLED_EXPL}, #include "warning.def" #undef CB_WARNDEF #undef CB_ONWARNDEF @@ -844,6 +846,20 @@ cobc_err_msg (const char *fmt, ...) fflush (stderr); } +/* */ +const enum cb_warn_val +get_warn_opt_value (const enum cb_warn_opt opt) +{ + return (const enum cb_warn_val)warn_opt_val[opt]; +} + +void +set_warn_opt_value (const enum cb_warn_opt opt, const enum cb_warn_val val) +{ + warn_opt_val[opt] = val; +} + + /* Output cobc source/line where an internal error occurs and exit */ /* LCOV_EXCL_START */ void @@ -3693,10 +3709,10 @@ process_command_line (const int argc, char **argv) case 'w': /* -w : Turn off all warnings (disables -Wall/-Wextra if passed later) */ -#define CB_WARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_DISABLED; -#define CB_ONWARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_DISABLED; -#define CB_NOWARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_DISABLED; -#define CB_ERRWARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_DISABLED; +#define CB_WARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_DISABLED); +#define CB_ONWARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_DISABLED); +#define CB_NOWARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_DISABLED); +#define CB_ERRWARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_DISABLED); #include "warning.def" #undef CB_WARNDEF #undef CB_ONWARNDEF @@ -3706,10 +3722,10 @@ process_command_line (const int argc, char **argv) case 'W': /* -Wall : Turn on most warnings */ -#define CB_WARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_ENABLED; +#define CB_WARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_ENABLED); #define CB_ONWARNDEF(opt,name,doc) #define CB_NOWARNDEF(opt,name,doc) -#define CB_ERRWARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_AS_ERROR; +#define CB_ERRWARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_AS_ERROR); #include "warning.def" #undef CB_WARNDEF #undef CB_ONWARNDEF @@ -3719,10 +3735,10 @@ process_command_line (const int argc, char **argv) case 'Y': /* -Wextra : Turn on every warning that is not dialect related */ -#define CB_WARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_ENABLED; +#define CB_WARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_ENABLED); #define CB_ONWARNDEF(opt,name,doc) -#define CB_NOWARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_ENABLED; -#define CB_ERRWARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_AS_ERROR; +#define CB_NOWARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_ENABLED); +#define CB_ERRWARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_AS_ERROR); #include "warning.def" #undef CB_WARNDEF #undef CB_ONWARNDEF @@ -3745,7 +3761,7 @@ process_command_line (const int argc, char **argv) if (cob_optarg) { #define CB_CHECK_WARNING(opt,name) \ if (strcmp (cob_optarg, name) == 0) { \ - cb_warn_opt_val[opt] = COBC_WARN_AS_ERROR; \ + set_warn_opt_value (opt, COBC_WARN_AS_ERROR); \ } else #define CB_WARNDEF(opt,name,doc) CB_CHECK_WARNING(opt, name) #define CB_ONWARNDEF(opt,name,doc) CB_CHECK_WARNING(opt, name) @@ -3772,8 +3788,8 @@ process_command_line (const int argc, char **argv) if (cob_optarg) { #define CB_CHECK_WARNING(opt,name) \ if (strcmp (cob_optarg, name) == 0 \ - && cb_warn_opt_val[opt] == COBC_WARN_AS_ERROR) { \ - cb_warn_opt_val[opt] = COBC_WARN_ENABLED; \ + && get_warn_opt_value (opt) == COBC_WARN_AS_ERROR) { \ + set_warn_opt_value (opt, COBC_WARN_ENABLED); \ } else #define CB_WARNDEF(opt,name,doc) CB_CHECK_WARNING(opt, name) #define CB_ONWARNDEF(opt,name,doc) CB_CHECK_WARNING(opt, name) @@ -3878,8 +3894,8 @@ process_command_line (const int argc, char **argv) cb_missing_statement = CB_WARNING; } /* FIXME - the warning was only raised if not relaxed */ - if (cb_warn_opt_val[(int)cb_warn_ignored_initial_val] != COBC_WARN_ENABLED_EXPL) { - cb_warn_opt_val[(int)cb_warn_ignored_initial_val] = COBC_WARN_DISABLED; + if (get_warn_opt_value (cb_warn_ignored_initial_val) != COBC_WARN_ENABLED_EXPL) { + set_warn_opt_value (cb_warn_ignored_initial_val, COBC_WARN_DISABLED); } } #if 0 /* deactivated as -frelaxed-syntax-checks and other compiler configurations @@ -3896,18 +3912,18 @@ process_command_line (const int argc, char **argv) { /* 3.x compat -Wconstant-expression also sets -Wconstant-numlit-expression */ /* TODO: handle group warnings */ - const enum cb_warn_val detail_warn = cb_warn_opt_val[(int)cb_warn_constant_numlit_expr]; + const enum cb_warn_val detail_warn = get_warn_opt_value ((int)cb_warn_constant_numlit_expr); if (detail_warn != COBC_WARN_DISABLED_EXPL && detail_warn != COBC_WARN_ENABLED_EXPL) { - const enum cb_warn_val group_warn = cb_warn_opt_val[(int)cb_warn_constant_expr]; - cb_warn_opt_val[(int)cb_warn_constant_numlit_expr] = group_warn; + const enum cb_warn_val group_warn = get_warn_opt_value ((int)cb_warn_constant_expr); + set_warn_opt_value ((int)cb_warn_constant_numlit_expr, group_warn); } /* set all explicit warning options to their later checked variants */ #define CB_CHECK_WARNING(opt) \ - if (cb_warn_opt_val[opt] == COBC_WARN_ENABLED_EXPL) { \ - cb_warn_opt_val[opt] = COBC_WARN_ENABLED; \ - } else if (cb_warn_opt_val[opt] == COBC_WARN_DISABLED_EXPL) { \ - cb_warn_opt_val[opt] = COBC_WARN_DISABLED; \ + if (get_warn_opt_value (opt) == COBC_WARN_ENABLED_EXPL) { \ + set_warn_opt_value (opt, COBC_WARN_ENABLED); \ + } else if (get_warn_opt_value (opt) == COBC_WARN_DISABLED_EXPL) { \ + set_warn_opt_value (opt, COBC_WARN_DISABLED); \ } #define CB_WARNDEF(opt,name,doc) CB_CHECK_WARNING(opt) #define CB_ONWARNDEF(opt,name,doc) CB_CHECK_WARNING(opt) @@ -3923,8 +3939,8 @@ process_command_line (const int argc, char **argv) /* Set active warnings to errors, if requested */ if (error_all_warnings) { #define CB_CHECK_WARNING(opt) \ - if (cb_warn_opt_val[opt] == COBC_WARN_ENABLED) { \ - cb_warn_opt_val[opt] = COBC_WARN_AS_ERROR; \ + if (get_warn_opt_value (opt) == COBC_WARN_ENABLED) { \ + set_warn_opt_value (opt, COBC_WARN_AS_ERROR); \ } #define CB_WARNDEF(opt,name,doc) CB_CHECK_WARNING(opt) #define CB_ONWARNDEF(opt,name,doc) CB_CHECK_WARNING(opt) @@ -8614,10 +8630,10 @@ begin_setup_internal_and_compiler_env (void) #endif /* initial values for warning options */ -#define CB_WARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_DISABLED; -#define CB_ONWARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_ENABLED; -#define CB_NOWARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_DISABLED; -#define CB_ERRWARNDEF(opt,name,doc) cb_warn_opt_val[opt] = COBC_WARN_AS_ERROR; +#define CB_WARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_DISABLED); +#define CB_ONWARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_ENABLED); +#define CB_NOWARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_DISABLED); +#define CB_ERRWARNDEF(opt,name,doc) set_warn_opt_value (opt, COBC_WARN_AS_ERROR); #include "warning.def" #undef CB_WARNDEF #undef CB_ONWARNDEF diff --git a/cobc/cobc.h b/cobc/cobc.h index af008f95c..5587d22bb 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -396,8 +396,8 @@ enum cb_warn_val { COBC_WARN_AS_ERROR = 4 }; -extern int cb_warn_opt_val[COB_WARNOPT_MAX]; /* note: int as we feed that to getopt */ - +extern const enum cb_warn_val get_warn_opt_value (const enum cb_warn_opt); +extern void set_warn_opt_value (const enum cb_warn_opt, const enum cb_warn_val); #define CB_OPTIM_DEF(x) x, enum cb_optim { diff --git a/cobc/error.c b/cobc/error.c index 1536e1462..e21662bdf 100644 --- a/cobc/error.c +++ b/cobc/error.c @@ -336,7 +336,7 @@ static char *warning_option_text (const enum cb_warn_opt opt, const enum cb_warn static enum cb_warn_val cb_warning_internal (const enum cb_warn_opt opt, const char *fmt, va_list ap) { - const enum cb_warn_val pref = cb_warn_opt_val[opt]; + const enum cb_warn_val pref = get_warn_opt_value (opt); if (pref == COBC_WARN_DISABLED) { return pref; @@ -395,7 +395,7 @@ static enum cb_warn_val cb_error_internal (const char *fmt, va_list ap) { const enum cb_warn_opt opt = cb_warn_ignored_error; - const enum cb_warn_val pref = cb_warn_opt_val[opt]; + const enum cb_warn_val pref = get_warn_opt_value (opt); enum cb_warn_val ret = pref; cobc_in_repository = 0; @@ -464,7 +464,7 @@ void cb_plex_warning (const enum cb_warn_opt opt, const size_t sline, const char *fmt, ...) { va_list ap; - const enum cb_warn_val pref = cb_warn_opt_val[opt]; + const enum cb_warn_val pref = get_warn_opt_value (opt); if (pref == COBC_WARN_DISABLED) { return; @@ -621,7 +621,7 @@ configuration_error (const char *fname, const int line, static enum cb_warn_val cb_warning_x_internal (const enum cb_warn_opt opt, cb_tree x, const char *fmt, va_list ap) { - const enum cb_warn_val pref = cb_warn_opt_val[opt]; + const enum cb_warn_val pref = get_warn_opt_value (opt); if (pref == COBC_WARN_DISABLED) { return pref; @@ -715,7 +715,7 @@ listprint_restore (void) void cb_note_x (const enum cb_warn_opt opt, cb_tree x, const char *fmt, ...) { - const enum cb_warn_val pref = cb_warn_opt_val[opt]; + const enum cb_warn_val pref = get_warn_opt_value (opt); va_list ap; if (opt != COB_WARNOPT_NONE && pref == COBC_WARN_DISABLED) { @@ -740,7 +740,7 @@ cb_note_x (const enum cb_warn_opt opt, cb_tree x, const char *fmt, ...) void cb_note (const enum cb_warn_opt opt, const int suppress_listing, const char *fmt, ...) { - const enum cb_warn_val pref = cb_warn_opt_val[opt]; + const enum cb_warn_val pref = get_warn_opt_value (opt); va_list ap; if (opt != COB_WARNOPT_NONE && pref == COBC_WARN_DISABLED) { @@ -768,7 +768,7 @@ static enum cb_warn_val cb_error_x_internal (cb_tree x, const char *fmt, va_list ap) { const enum cb_warn_opt opt = cb_warn_ignored_error; - const enum cb_warn_val pref = cb_warn_opt_val[opt]; + const enum cb_warn_val pref = get_warn_opt_value (opt); enum cb_warn_val ret = COBC_WARN_AS_ERROR; if (ignore_error && pref == COBC_WARN_DISABLED) { @@ -951,7 +951,7 @@ redefinition_warning (cb_tree x, cb_tree y) /* early exit if warning disabled */ { const enum cb_warn_opt opt = cb_warn_redefinition; - const enum cb_warn_val pref = cb_warn_opt_val[opt]; + const enum cb_warn_val pref = get_warn_opt_value (opt); if (pref == COBC_WARN_DISABLED) { return COBC_WARN_DISABLED; } @@ -1006,9 +1006,9 @@ undefined_error (cb_tree x) /* raise errors for each word only once and early leave for suppressed warnings */ if (w->error == 1 - || (r->flag_optional && cb_warn_opt_val[opt] == COBC_WARN_DISABLED) - || (ignore_error && cb_warn_opt_val[cb_warn_ignored_error] == COBC_WARN_DISABLED) - || (ignore_error && cb_warn_opt_val[cb_warn_ignored_error] == COBC_WARN_ENABLED && w->error == -1)) { + || (r->flag_optional && get_warn_opt_value (opt) == COBC_WARN_DISABLED) + || (ignore_error && get_warn_opt_value (cb_warn_ignored_error) == COBC_WARN_DISABLED) + || (ignore_error && get_warn_opt_value (cb_warn_ignored_error) == COBC_WARN_ENABLED && w->error == -1)) { return COBC_WARN_DISABLED; } diff --git a/cobc/field.c b/cobc/field.c index ae37e4927..12ef8a527 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -463,7 +463,7 @@ cb_build_field_tree (cb_tree level, cb_tree name, struct cb_field *last_field, } /* Checks for redefinition */ - if (cb_warn_opt_val[cb_warn_redefinition] + if (get_warn_opt_value (cb_warn_redefinition) && r->word->count > 1 && !r->flag_filler_ref) { if (f->level == 01 || f->level == 77) { redefinition_warning (name, NULL); @@ -1725,7 +1725,7 @@ validate_elem_value (struct cb_field * const f) } /* ISO+IEC+1989-2002: 13.16.42.2-10 */ - if (cb_warn_opt_val[cb_warn_ignored_initial_val] != COBC_WARN_DISABLED) { + if (get_warn_opt_value (cb_warn_ignored_initial_val) != COBC_WARN_DISABLED) { const cb_tree x = CB_TREE (f); const struct cb_field *p; for (p = f; p; p = p->parent) { @@ -3002,8 +3002,8 @@ cleanup_field_value (struct cb_field* f, cb_tree *val) case CB_CATEGORY_NUMERIC: if (CB_LITERAL_P (*val)) { const struct cb_literal* lit = CB_LITERAL (*val); - char* p = (char*)lit->data; - char* end = p + lit->size - 1; + char *p = (char*)lit->data; + char *end = p + lit->size - 1; /* note: literal data has no sign or decimal period any more */ if (*end == '0') { while (p < end && *p == '0') p++; @@ -3068,7 +3068,7 @@ validate_field_value_list (cb_tree values, struct cb_field* f) } if (no_relevant_value && !ret) { -#if 0 /* this idea was nice, but we need a pointer for +#if 0 /* this idea was nice, but we need a hint for INITIALIZE BY VALUE, so don't drop the value; otherwise fails "752. run_misc.at:10849: dump feature with NULL address ..." */ /* if deemed that no value is necessary: drop that completely */ @@ -3103,7 +3103,7 @@ validate_field_value (struct cb_field *f) if (!ret_single) { /* possible cleanup for value */ if (cleanup_field_value (f, &x)) { -#if 0 /* this idea was nice, but we need a pointer for +#if 0 /* this idea was nice, but we need a hint for INITIALIZE BY VALUE, so don't drop the value; otherwise fails "752. run_misc.at:10849: dump feature with NULL address ..." */ /* if deemed that no value is necessary: drop that completely */ diff --git a/cobc/parser.y b/cobc/parser.y index 50af35a4e..e01ce5fbb 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -6602,7 +6602,7 @@ code_set_clause: current_file->code_set = al; break; default: - if (cb_warn_opt_val[cb_warn_additional] != COBC_WARN_DISABLED) { + if (get_warn_opt_value (cb_warn_additional) != COBC_WARN_DISABLED) { cb_note_x (cb_warn_additional, $3, _("ignoring CODE-SET '%s'"), cb_name ($3)); } @@ -15100,7 +15100,7 @@ open_option_sequential: /* FIXME: only allow for sequential / line-sequential files */ /* FIXME: only allow with INPUT */ /* FIXME: add actual compiler configuration */ - if (cb_warn_opt_val[cb_warn_obsolete] == COBC_WARN_AS_ERROR) { + if (get_warn_opt_value (cb_warn_obsolete) == COBC_WARN_AS_ERROR) { (void)cb_verify (CB_OBSOLETE, "OPEN REVERSED"); } else { /* FIXME: set file attribute */ diff --git a/cobc/pplex.l b/cobc/pplex.l index 730d01581..d3e860180 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -2080,7 +2080,7 @@ start: line_overflow to first column that leads to "source text too long") */ - if (cb_warn_opt_val[cb_warn_column_overflow] && line_overflow == 0) { + if (get_warn_opt_value (cb_warn_column_overflow) && line_overflow == 0) { for (coln = text_column; coln < n; ++coln) { if (buff[coln] != ' ' && buff[coln] != '\n') { line_overflow = coln; diff --git a/cobc/tree.c b/cobc/tree.c index 9fcbdc2b8..c4213677e 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -5393,7 +5393,7 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal } if (lit_length > refmod_length) { copy_file_line (e, CB_TREE(l), NULL); - if (cb_warn_opt_val[cb_warn_constant_expr] + if (get_warn_opt_value (cb_warn_constant_expr) && !was_prev_warn (e->source_line, 2)) { if (lit_length > f->size) { cb_warning_x (cb_warn_constant_expr, e, @@ -5422,7 +5422,7 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal if (alph_lit) { copy_file_line (e, CB_TREE(l), NULL); - if (cb_warn_opt_val[cb_warn_constant_expr] + if (get_warn_opt_value (cb_warn_constant_expr) && category == CB_CATEGORY_NUMERIC && !was_prev_warn (e->source_line, 3)) { cb_warning_x (cb_warn_constant_expr, e, @@ -5465,7 +5465,7 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal && fscale >= 0 && fscale < scale) { copy_file_line (e, CB_TREE(l), NULL); - if (cb_warn_opt_val[cb_warn_constant_expr] + if (get_warn_opt_value (cb_warn_constant_expr) && !was_prev_warn (e->source_line, 4)) { cb_warning_x (cb_warn_constant_expr, e, _("literal '%s' has more decimals than '%s'"), @@ -5507,7 +5507,7 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal * Then the literal value will never match the field contents */ copy_file_line (e, CB_TREE(l), NULL); - if (cb_warn_opt_val[cb_warn_constant_expr] + if (get_warn_opt_value (cb_warn_constant_expr) && !was_prev_warn (e->source_line, 4)) { cb_warning_x (cb_warn_constant_expr, e, _("literal '%s' has more digits than '%s'"), @@ -5539,7 +5539,7 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal * be dependent on compiler configuration flags; * therefore we don't set cb_true/cb_false here */ - if (cb_warn_opt_val[cb_warn_constant_expr] + if (get_warn_opt_value (cb_warn_constant_expr) && (op == '<' || op == '[' || op == '>' || op == ']')) { copy_file_line (e, CB_TREE(l), NULL); @@ -6204,7 +6204,7 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) if (relop == cb_true) { enum cb_warn_opt warn_opt = get_warnopt_for_constant (x, y); - if (cb_warn_opt_val[warn_opt] && warn_ok) { + if (get_warn_opt_value (warn_opt) && warn_ok) { if (rlit && llit) { if (!was_prev_warn (e->source_line, warn_type)) { cb_warning_x (warn_opt, e, @@ -6223,7 +6223,7 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) } if (relop == cb_false) { enum cb_warn_opt warn_opt = get_warnopt_for_constant (x, y); - if (cb_warn_opt_val[warn_opt] && warn_ok) { + if (get_warn_opt_value (warn_opt) && warn_ok) { if (rlit && llit) { if (!was_prev_warn (e->source_line, 9 + warn_type)) { cb_warning_x (warn_opt, e, @@ -6721,7 +6721,7 @@ warn_if_no_definition_seen_for_prototype (const struct cb_prototype *proto) return; } - if (cb_warn_opt_val[cb_warn_ignored_initial_val] != COBC_WARN_DISABLED) { + if (get_warn_opt_value (cb_warn_ignored_initial_val) != COBC_WARN_DISABLED) { if (strcmp (proto->name, proto->ext_name) == 0) { /* Warn if no definition seen for element with prototype- diff --git a/cobc/typeck.c b/cobc/typeck.c index d41a92e50..1fa792742 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -1614,11 +1614,11 @@ cb_build_generic_register (const char *name, const char *external_definition, } } if (p) { - const enum cb_warn_val backup = cb_warn_opt_val[cb_warn_unfinished]; + const enum cb_warn_val backup = get_warn_opt_value (cb_warn_unfinished); (void)extract_next_word_from_buffer (p, word); - cb_warn_opt_val[cb_warn_unfinished] = COBC_WARN_DISABLED; + set_warn_opt_value (cb_warn_unfinished, COBC_WARN_DISABLED); field->pic = cb_build_picture (word); - cb_warn_opt_val[cb_warn_unfinished] = backup; + set_warn_opt_value (cb_warn_unfinished, backup); if (field->pic->size == 0) { ret = 1; } @@ -1766,14 +1766,14 @@ cb_build_generic_register (const char *name, const char *external_definition, field->flag_invalid = 1; } else if (current_program) { - const enum cb_warn_val backup = cb_warn_opt_val[cb_warn_unfinished]; + const enum cb_warn_val backup = get_warn_opt_value (cb_warn_unfinished); /* note: the necessary tree items like cb_zero won't be available without a program, and therefore full validation is not possible */ field->flag_internal_register = 1; field->flag_no_init = 1; - cb_warn_opt_val[cb_warn_unfinished] = COBC_WARN_DISABLED; + set_warn_opt_value (cb_warn_unfinished, COBC_WARN_DISABLED); cb_validate_field (field); - cb_warn_opt_val[cb_warn_unfinished] = backup; + set_warn_opt_value (cb_warn_unfinished, backup); } if (field->flag_invalid) { @@ -3450,7 +3450,7 @@ cb_check_definition_matches_prototype (struct cb_program *prog) cb_tree l; /* if check is explicit disabled: don't care */ - if (cb_warn_opt_val[cb_warn_repository_checks] == COBC_WARN_DISABLED) { + if (get_warn_opt_value (cb_warn_repository_checks) == COBC_WARN_DISABLED) { return; } @@ -4160,7 +4160,7 @@ cb_validate_program_environment (struct cb_program *prog) } /* Check CLASS clauses for duplicates */ - if (cb_warn_opt_val[cb_warn_additional] != COBC_WARN_DISABLED) { + if (get_warn_opt_value (cb_warn_additional) != COBC_WARN_DISABLED) { for (l = prog->class_name_list; l; l = CB_CHAIN (l)) { check_class_duplicates (CB_VALUE (l)); } @@ -4353,9 +4353,9 @@ validate_record_depending (cb_tree x) { enum cb_support missing_compiler_config; if (!cb_relaxed_syntax_checks - || cb_warn_opt_val[cb_warn_additional] == COBC_WARN_AS_ERROR) { + || get_warn_opt_value (cb_warn_additional) == COBC_WARN_AS_ERROR) { missing_compiler_config = CB_ERROR; - } else if (cb_warn_opt_val[cb_warn_additional] == COBC_WARN_ENABLED) { + } else if (get_warn_opt_value (cb_warn_additional) == COBC_WARN_ENABLED) { missing_compiler_config = CB_WARNING; } else { missing_compiler_config = CB_OK; @@ -5042,7 +5042,7 @@ cb_validate_labels (struct cb_program *prog) label->name); continue; case CB_WARNING: - if (cb_warn_opt_val[cb_warn_dialect] == COBC_WARN_DISABLED) { + if (get_warn_opt_value (cb_warn_dialect) == COBC_WARN_DISABLED) { break; } cb_warning_x (cb_warn_dialect, x, @@ -5095,7 +5095,7 @@ cb_validate_perform_thru_ranges (struct cb_program *prog) { cb_tree l; if (!cb_flag_section_exit_check - && cb_warn_opt_val[cb_warn_suspicious_perform_thru] == COBC_WARN_DISABLED) { + && get_warn_opt_value (cb_warn_suspicious_perform_thru) == COBC_WARN_DISABLED) { return; } for (l = prog->perform_thru_list; l; l = CB_CHAIN (l)) { @@ -5172,7 +5172,7 @@ cb_validate_program_body (struct cb_program *prog) /* Validate entry points */ /* Check dangling LINKAGE items */ - if (cb_warn_opt_val[cb_warn_linkage] != COBC_WARN_DISABLED + if (get_warn_opt_value (cb_warn_linkage) != COBC_WARN_DISABLED && prog->linkage_storage) { if (prog->returning && cb_ref (prog->returning) != cb_error_node) { @@ -6956,7 +6956,7 @@ cb_build_cond (cb_tree x) conditions, with explicit comparision of class alphanumeric (where all edited items go to) and of class numeric; so likely only do this with a new warning only enabled with -Wextra. */ - if (cb_warn_opt_val[cb_warn_strict_typing] != COBC_WARN_DISABLED) { + if (get_warn_opt_value (cb_warn_strict_typing) != COBC_WARN_DISABLED) { if cb_tree_class... cb_warning_x (cb_warn_strict_typing, x, _("alphanumeric value is expected")); } else { @@ -10124,7 +10124,7 @@ move_warning (cb_tree src, cb_tree dst, const unsigned int value_flag, } } else { /* MOVE or SET statement */ - if (cb_warn_opt_val[warning_opt] != COBC_WARN_DISABLED) { + if (get_warn_opt_value (warning_opt) != COBC_WARN_DISABLED) { cb_warning_x (warning_opt, loc, "%s", msg); if (src_flag) { /* note: src_flag is -1 for numeric literals, From 544f280d869955df9cdbb4da70e01f3e914bcd28 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 13 Dec 2022 09:48:42 +0000 Subject: [PATCH 16/18] type safety for internal warning option handling in cobc, missing part in r4869 --- cobc/cobc.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/cobc/cobc.c b/cobc/cobc.c index 942965128..224db39c3 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -3912,11 +3912,11 @@ process_command_line (const int argc, char **argv) { /* 3.x compat -Wconstant-expression also sets -Wconstant-numlit-expression */ /* TODO: handle group warnings */ - const enum cb_warn_val detail_warn = get_warn_opt_value ((int)cb_warn_constant_numlit_expr); + const enum cb_warn_val detail_warn = get_warn_opt_value (cb_warn_constant_numlit_expr); if (detail_warn != COBC_WARN_DISABLED_EXPL && detail_warn != COBC_WARN_ENABLED_EXPL) { - const enum cb_warn_val group_warn = get_warn_opt_value ((int)cb_warn_constant_expr); - set_warn_opt_value ((int)cb_warn_constant_numlit_expr, group_warn); + const enum cb_warn_val group_warn = get_warn_opt_value (cb_warn_constant_expr); + set_warn_opt_value (cb_warn_constant_numlit_expr, group_warn); } /* set all explicit warning options to their later checked variants */ #define CB_CHECK_WARNING(opt) \ From f5607adc77d9af1da5fc2b50f92b898ffad4505a Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 13 Dec 2022 12:00:13 +0000 Subject: [PATCH 17/18] fixing [bugs:#865] originating in [r4588] libcob: * strings.c (inspect_find_data): added missing area check * strings.c (inspect_common_no_replace, inspect_common_replacing, is_marked): minor refactoring for optimization hints --- libcob/ChangeLog | 12 ++++++++++ libcob/strings.c | 36 ++++++++++++++++------------- tests/testsuite.src/run_misc.at | 40 +++++++++++++++++++++++++++++++-- 3 files changed, 71 insertions(+), 17 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index e0d7d114e..c936b5090 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,10 @@ +2022-12-13 Simon Sobisch + + * strings.c (inspect_find_data): added missing area check bug #865 + * strings.c (inspect_common_no_replace, inspect_common_replacing, + is_marked): minor refactoring for optimization hints + 2022-12-08 Simon Sobisch * common.h (cob_module_type): module type as enum instead of defines only @@ -55,6 +61,11 @@ * screenio.c: fixed compiler warnings related to get_crt3_status +2022-11-26 Simon Sobisch + + * call.c, common.c: internal and explicit setting of no-physical-unload + * common.c: adjustments for COB_PHYSICAL_CANCEL + 2022-11-24 Simon Sobisch * intrinsic.c: switching random number generation to GMP, @@ -80,6 +91,7 @@ by checking sign/zero and reduced number of decimal shifting dynamic allocation * move.c (store_common_region): minor optimization + * move.c: 2022-11-04 Simon Sobisch diff --git a/libcob/strings.c b/libcob/strings.c index e2cf3fc54..13f80ba47 100644 --- a/libcob/strings.c +++ b/libcob/strings.c @@ -180,8 +180,12 @@ inspect_find_data (const cob_field *str) const unsigned char *data = str->data; const size_t len = str->size; - unsigned char* const end_p = inspect_end - len + 1; - unsigned char* p = inspect_start; + register unsigned char *p = inspect_start; + unsigned char *const end_p = inspect_end - len + 1; + + if (p > end_p) { + return NULL; + } while (p != end_p) { if (memcmp (p, data, len) == 0) { @@ -210,8 +214,6 @@ set_inspect_mark (const size_t pos, const size_t length) static COB_INLINE COB_A_INLINE int is_marked (size_t pos, size_t length) { - size_t i; - /* no need to check further if there's no mark or no possible overlap ... */ if (inspect_mark[inspect_mark_min] == 0 || inspect_mark_max < pos @@ -225,9 +227,13 @@ is_marked (size_t pos, size_t length) } /* we have a possible overlap - check if that's also for real */ - for (i = 0; i < length; ++i) { - if (inspect_mark[pos + i] != 0) { - return 1; + { + register size_t i; + + for (i = 0; i < length; ++i) { + if (inspect_mark[pos + i] != 0) { + return 1; + } } } return 0; @@ -237,7 +243,7 @@ static void inspect_common_no_replace (cob_field *f1, cob_field *f2, const enum inspect_type type, const size_t pos, const size_t inspect_len) { - size_t i; + register size_t i; int n = 0; if (type == INSPECT_TRAILING) { @@ -245,7 +251,7 @@ inspect_common_no_replace (cob_field *f1, cob_field *f2, size_t first_marker = 0; for (i = i_max; ; --i) { /* Find matching substring */ - if (memcmp (inspect_start + i, f2->data, f2->size) == 0) { + if (memcmp (i + inspect_start, f2->data, f2->size) == 0) { /* when not marked yet: count, mark and skip handled positions */ if (!is_marked (pos + i, f2->size)) { n++; @@ -268,7 +274,7 @@ inspect_common_no_replace (cob_field *f1, cob_field *f2, size_t last_marker = 0; for (i = 0; i < i_max; ++i) { /* Find matching substring */ - if (memcmp (inspect_start + i, f2->data, f2->size) == 0) { + if (memcmp (i + inspect_start, f2->data, f2->size) == 0) { /* when not marked yet: count, skip handled positions and set mark pos */ if (!is_marked (pos + i, f2->size)) { n++; @@ -289,7 +295,7 @@ inspect_common_no_replace (cob_field *f1, cob_field *f2, const size_t i_max = inspect_len - f2->size + 1; for (i = 0; i < i_max; ++i) { /* Find matching substring */ - if (memcmp (inspect_start + i, f2->data, f2->size) == 0) { + if (memcmp (i + inspect_start, f2->data, f2->size) == 0) { const size_t checked_pos = pos + i; /* when not marked yet: count, mark and skip handled positions */ if (!is_marked (checked_pos, f2->size)) { @@ -333,13 +339,13 @@ static void inspect_common_replacing (cob_field *f1, cob_field *f2, const enum inspect_type type, const size_t pos, const size_t inspect_len) { - size_t i; + register size_t i; if (type == INSPECT_TRAILING) { const size_t i_max = inspect_len - f2->size; /* no + 1 here */ for (i = i_max; ; --i) { /* Find matching substring */ - if (memcmp (inspect_start + i, f2->data, f2->size) == 0) { + if (memcmp (i + inspect_start, f2->data, f2->size) == 0) { /* when not marked yet: count, mark and skip handled positions */ if (do_mark (pos + i, f2->size, f1->data)) { i -= f2->size - 1; @@ -355,7 +361,7 @@ inspect_common_replacing (cob_field *f1, cob_field *f2, const size_t i_max = inspect_len - f2->size + 1; for (i = 0; i < i_max; ++i) { /* Find matching substring */ - if (memcmp (inspect_start + i, f2->data, f2->size) == 0) { + if (memcmp (i + inspect_start, f2->data, f2->size) == 0) { /* when not marked yet: count, mark and skip handled positions */ if (do_mark (pos + i, f2->size, f1->data)) { i += f2->size - 1; @@ -370,7 +376,7 @@ inspect_common_replacing (cob_field *f1, cob_field *f2, const size_t i_max = inspect_len - f2->size + 1; for (i = 0; i < i_max; ++i) { /* Find matching substring */ - if (memcmp (inspect_start + i, f2->data, f2->size) == 0) { + if (memcmp (i + inspect_start, f2->data, f2->size) == 0) { /* when not marked yet: count, mark and skip handled positions */ if (do_mark (pos + i, f2->size, f1->data)) { if (type == INSPECT_FIRST) { diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index bca3f1966..edb75f5d9 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -1998,14 +1998,14 @@ AT_DATA([prog.cob], [ INSPECT X TALLYING TAL FOR CHARACTERS BEFORE INITIAL " ". IF TAL NOT = 3 - DISPLAY TAL. + DISPLAY "1: should be 3 but is " TAL. MOVE 0 TO TAL. MOVE " ABC" TO X. INSPECT X TALLYING TAL FOR CHARACTERS BEFORE INITIAL " ". IF TAL NOT = 0 - DISPLAY TAL. + DISPLAY "2: should be 0 but is " TAL. STOP RUN. ]) @@ -2049,6 +2049,42 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP +AT_SETUP([INSPECT TALLYING BEFORE and AFTER]) +AT_KEYWORDS([runmisc]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "ABC ". + 01 TAL PIC 999 VALUE 0. + 01 MSG PIC X(256) VALUE SPACES. + PROCEDURE DIVISION. + MOVE 0 TO TAL. + INSPECT X TALLYING TAL FOR CHARACTERS + BEFORE INITIAL " " + AFTER " ". + IF TAL NOT = 0 + DISPLAY "1: should be 0 but is " TAL. + + *> checking for no match, includes bug #865 + MOVE 0 TO TAL. + INSPECT MSG TALLYING TAL FOR CHARACTERS + AFTER INITIAL "<" + BEFORE INITIAL " Date: Tue, 13 Dec 2022 12:04:26 +0000 Subject: [PATCH 18/18] Makefile.am: adjusted URL_NEWCOB_TAR_GZ as old value (SF download area) uses javascript-forwarding which does not work with command line tools --- tests/cobol85/ChangeLog | 3 +++ tests/cobol85/Makefile.am | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/tests/cobol85/ChangeLog b/tests/cobol85/ChangeLog index 26ea3dc94..058f3ab8e 100644 --- a/tests/cobol85/ChangeLog +++ b/tests/cobol85/ChangeLog @@ -3,6 +3,9 @@ * Makefile.am, Makefile.module.in: use PERL via variable, default is substituted from configure + * Makefile.am: adjusted URL_NEWCOB_TAR_GZ as old value (SF download area) + uses javascript-forwarding which does not work with command line tools + 2022-10-11 Simon Sobisch diff --git a/tests/cobol85/Makefile.am b/tests/cobol85/Makefile.am index 400e2221d..c452047ba 100644 --- a/tests/cobol85/Makefile.am +++ b/tests/cobol85/Makefile.am @@ -40,7 +40,7 @@ SUMMARY = summarynoix.txt endif URL_NEWCOB_Z = https://www.itl.nist.gov/div897/ctg/suites/newcob.val.Z -URL_NEWCOB_TAR_GZ = https://sourceforge.net/projects/gnucobol/files/nist/newcob.val.tar.gz/download +URL_NEWCOB_TAR_GZ = https://gnucobol.sourceforge.io/files/newcob.val.tar.gz EXTRA_DIST = EXEC85.conf.in expand.pl report.pl summary.pl summary.txt \ summarynoix.txt NC.txt SM.txt IC.txt SQ.txt RL.txt IX.txt \