From d86f0e1bc3806966a8dbeb6f832061c2f05dc578 Mon Sep 17 00:00:00 2001 From: chaat Date: Tue, 11 Jul 2023 20:53:26 +0000 Subject: [PATCH 01/21] follow-up to [r5114] check for internal memory bounds with new flag "memory-check" (implied with --debug) use less size for the first test to prevent WIN32 from hanging --- tests/testsuite.src/run_misc.at | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index b2c9c78f3..699d59e0a 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -14145,13 +14145,13 @@ AT_DATA([callee.cob], [ 77 var PIC X. 01 lrec. - 03 lvar PIC X(64). - 03 lvar2 PIC X(64). + 03 lvar PIC X(32). + 03 lvar2 PIC X(32). PROCEDURE DIVISION USING var. * SET ADDRESS OF lrec TO ADDRESS OF var - SET ADDRESS OF lrec DOWN BY 64 + SET ADDRESS OF lrec DOWN BY 32 MOVE SPACES TO lrec GOBACK. ]) From f53df07a096a074f4d1ddbd860bd93670fe60e9e Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 13 Jul 2023 14:43:04 +0000 Subject: [PATCH 02/21] working on the preparsing cobc: * pplex.l: * (cb_ppecho_direct, output_pending_newlines): output only up to 9 empty lines, for more empty lines in the preparsed output file generate a matching #line directive, this saves both space and serves as a workaround for an unclear scanner bug that may happen with huge amounts of empty lines * (switch_to_buffer): don't re-strdup the filename * parser.y (emit_statement): changed from define to inline function * codegen.c: complete output of program's end source location if requested additional: cobc/replace.c: indent --- cobc/ChangeLog | 18 +++++- cobc/codegen.c | 19 +++++- cobc/parser.y | 15 ++--- cobc/pplex.l | 80 ++++++++++++++++++++++--- cobc/replace.c | 157 +++++++++++++++++++++++-------------------------- 5 files changed, 185 insertions(+), 104 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 8fd95b8c6..c0bdd6dac 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,9 +1,20 @@ +2023-07-13 Simon Sobisch + + * pplex.l (cb_ppecho_direct, output_pending_newlines): output only up + to 9 empty lines, for more empty lines in the preparsed output file + generate a matching #line directive, this saves both space and serves + as a workaround for an unclear scanner bug that may happen with huge + amounts of empty lines + * pplex.l (switch_to_buffer): don't re-strdup the filename + * parser.y (emit_statement): changed from define to inline function + * codegen.c: complete output of program's end source location if requested + 2023-07-11 Fabrice Le Fessant * parser.y: fix code generation for OPEN/CLOSE with multiple - filenames, where DECLARATIVES for all arguments were called when - only one argument failed + filenames, where DECLARATIVES for all arguments were called when + only one argument failed 2023-07-10 Simon Sobisch @@ -2278,7 +2289,8 @@ 2020-09-27 Bob Dubner - * codegen.c (output_cobol_info): emit doubled backslashes for source file + * codegen.c (output_cobol_info): emit doubled backslashes for source file, + fixing bug #698 problem with #line directives 2020-09-22 James K. Lowden diff --git a/cobc/codegen.c b/cobc/codegen.c index 61b3ee4b6..af91e1f1e 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -5262,6 +5262,7 @@ output_initialize_to_default (struct cb_field *f, cb_tree x) static void output_c_info (void) { + /* note: output name is already escaped for C string */ output ("#line %d \"%s\"", output_line_number + 1, output_name); output_newline (); } @@ -5271,6 +5272,7 @@ output_cobol_info (cb_tree x) { const char *p = x->source_file; output ("#line %d \"", x->source_line); + /* escape COBOL file name for C string */ while (*p) { if (*p == '\\') { output ("%c",'\\'); @@ -12237,11 +12239,24 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) /* Output source location as code */ if (cb_flag_source_location) { + struct cb_tree_common loc; + + loc.source_file = prog->common.source_file; + loc.source_line = prog->last_source_line; + loc.source_column = 0; output_newline (); - l = CB_TREE (prog); + output_line ("/* Line: %-10d: last source line :%s */", + prog->last_source_line, prog->common.source_file); + if (cb_flag_c_line_directives) { + output_cobol_info (&loc); + } output_line ("module->module_stmt = 0x%08X;", COB_SET_LINE_FILE (prog->last_source_line, - lookup_source (l->source_file))); + lookup_source (prog->common.source_file))); + if (cb_flag_c_line_directives) { + output_c_info (); + output_line ("cob_nop ();"); + } output_newline (); } diff --git a/cobc/parser.y b/cobc/parser.y index cd8854cb4..de7e6d7dd 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -49,13 +49,6 @@ #define YYSTYPE cb_tree #define yyerror(x) cb_error_always ("%s", x) -#define emit_statement(x) \ -do { \ - if (!skip_statements) { \ - CB_ADD_TO_CHAIN (x, current_program->exec_list); \ - } \ -} ONCE_COB - #define push_expr(type, node) \ current_expr = cb_build_list (cb_int (type), node, current_expr) @@ -406,6 +399,14 @@ build_colseq (enum cb_colseq colseq) /* Statements */ +static COB_INLINE COB_A_INLINE void +emit_statement (cb_tree x) +{ + if (!skip_statements) { + CB_ADD_TO_CHAIN (x, current_program->exec_list); + } +} + static void begin_statement_internal (enum cob_statement statement, const unsigned int term, const char *file, const int line) diff --git a/cobc/pplex.l b/cobc/pplex.l index 9c17d36b6..e17ee005f 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -142,6 +142,7 @@ static size_t comment_allowed; static unsigned int plex_skip_input = 0; static unsigned int plex_nest_depth = 0; static int quotation_mark = 0; +static int echo_newline = 0; static int listing_line = 0; static int requires_listing_line; static enum cb_format source_format = CB_FORMAT_AUTO; @@ -171,6 +172,7 @@ static void skip_to_eol (void); static void count_newlines (const char *); static void display_finish (void); static void get_new_listing_file (void); +static void output_pending_newlines (FILE *); static struct cb_text_list *pp_text_list_add (struct cb_text_list *, const char *, const size_t); @@ -225,6 +227,7 @@ MAYBE_AREA_A [ ]?#? ^{MAYBE_AREA_A}[ ]*">>"[ ]?"COBOL-WORDS" { /* 202x+: directive for setting source format */ BEGIN COBOL_WORDS_DIRECTIVE_STATE; + output_pending_newlines (ppout); return COBOL_WORDS_DIRECTIVE; } @@ -232,6 +235,7 @@ MAYBE_AREA_A [ ]?#? /* 2002+: definition of compiler constants display message during compilation */ /* Define here to preempt next debug rule below */ BEGIN DEFINE_DIRECTIVE_STATE; + output_pending_newlines (ppout); return DEFINE_DIRECTIVE; } @@ -239,12 +243,14 @@ MAYBE_AREA_A [ ]?#? /* previous OpenCOBOL/GnuCOBOL 2.x extension, added in COBOL 202x with slightly different syntax: display message during compilation --> needs a dialect option to switch to the appropriate state */ display_msg[0] = 0; + output_pending_newlines (ppout); BEGIN DISPLAY_DIRECTIVE_STATE; } ^{MAYBE_AREA_A}[ ]*">>"[ ]?"REF-MOD-ZERO-LENGTH" { /* 202x: directive to allow zero ref-mod */ BEGIN ON_OFF_DIRECTIVE_STATE; + output_pending_newlines (ppout); return REFMOD_DIRECTIVE; } @@ -269,30 +275,35 @@ MAYBE_AREA_A [ ]?#? ON implied for empty value Note: further checks in ppparse.y, processed in cobc.c */ BEGIN ON_OFF_DIRECTIVE_STATE; + output_pending_newlines (ppout); return LISTING_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*">>"[ ]?"SOURCE" { /* 2002+: directive for setting source format */ BEGIN SOURCE_DIRECTIVE_STATE; + output_pending_newlines (ppout); return SOURCE_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*">>"[ ]?"SET" { /* OpenCOBOL/GnuCOBOL 2.0 extension: MF SET directive in 2002+ style format */ BEGIN SET_DIRECTIVE_STATE; + output_pending_newlines (ppout); return SET_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*">>"[ ]?"TURN" { /* 2002+: directive for (de-)activating exception checks */ BEGIN TURN_DIRECTIVE_STATE; + output_pending_newlines (ppout); return TURN_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*">>"[ ]?"IF" { /* 2002+: conditional compilation */ BEGIN IF_DIRECTIVE_STATE; + output_pending_newlines (ppout); return IF_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*">>"[ ]?"ELIF" | @@ -300,16 +311,19 @@ MAYBE_AREA_A [ ]?#? /* OpenCOBOL extension: conditional compilation combined ELSE IF, 2002+ style format */ BEGIN IF_DIRECTIVE_STATE; + output_pending_newlines (ppout); return ELIF_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*">>"[ ]?"ELSE" { /* 2002+: conditional compilation */ BEGIN ELSE_DIRECTIVE_STATE; + output_pending_newlines (ppout); return ELSE_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*">>"[ ]?"END-IF" { /* 2002+: conditional compilation */ BEGIN ENDIF_DIRECTIVE_STATE; + output_pending_newlines (ppout); return ENDIF_DIRECTIVE; } @@ -317,12 +331,14 @@ MAYBE_AREA_A [ ]?#? /* 2002+: more then 60 seconds per minute (currently always set to off), OFF implied for empty value */ BEGIN ON_OFF_DIRECTIVE_STATE; + output_pending_newlines (ppout); return LEAP_SECOND_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*">>"[ ]?"CALL-CONVENTION" { /* 2002+: convention for CALL/CANCEL */ BEGIN CALL_DIRECTIVE_STATE; + output_pending_newlines (ppout); return CALL_DIRECTIVE; } @@ -361,18 +377,21 @@ MAYBE_AREA_A [ ]?#? /* MF extension: display message during compilation */ display_msg[0] = 0; BEGIN DISPLAY_DIRECTIVE_STATE; + output_pending_newlines (ppout); } ^{MAYBE_AREA_A}[ ]*$[ \t]*"SET" { /* MF extension: SET directive */ /* TODO: check position of the $SET directive */ BEGIN SET_DIRECTIVE_STATE; + output_pending_newlines (ppout); return SET_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*$[ \t]*"IF" { /* MF extension: conditional compilation */ BEGIN IF_DIRECTIVE_STATE; + output_pending_newlines (ppout); return IF_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*$[ \t]*"ELIF" | @@ -380,17 +399,20 @@ MAYBE_AREA_A [ ]?#? /* OpenCOBOL/GnuCOBOL 2.0 extension: conditional compilation combined ELSE IF, MF style format */ BEGIN IF_DIRECTIVE_STATE; + output_pending_newlines (ppout); return ELIF_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*$[ \t]*"ELSE" { /* MF extension: conditional compilation */ BEGIN ELSE_DIRECTIVE_STATE; + output_pending_newlines (ppout); return ELSE_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*$[ \t]*"END" | ^{MAYBE_AREA_A}[ ]*$[ \t]*"END-IF" { /* MF extension: conditional compilation, second undocumented */ BEGIN ENDIF_DIRECTIVE_STATE; + output_pending_newlines (ppout); return ENDIF_DIRECTIVE; } ^{MAYBE_AREA_A}[ ]*$[ \t]*"REGION" | @@ -422,7 +444,7 @@ MAYBE_AREA_A [ ]?#? ^{MAYBE_AREA_A}[ ]*("PROCESS"|"CBL")[ ,;]*[\n] { /* IBM COBOL extension for specifying compiler options */ /* TODO: The CBL (PROCESS) statement must be placed before any - comment lines, IDENTIFICATIO DIVISION, or other + comment lines, IDENTIFICATION DIVISION, or other compiler-directing statements. */ /* empty - so ignored */ skip_to_eol (); @@ -431,7 +453,7 @@ MAYBE_AREA_A [ ]?#? ^{MAYBE_AREA_A}[ ]*("PROCESS"|"CBL")[ ][A-Z0-9() ,;'"=]* { /* IBM COBOL extension for specifying compiler options */ /* TODO: The CBL (PROCESS) statement must be placed before any - comment lines, IDENTIFICATIO DIVISION, or other + comment lines, IDENTIFICATION DIVISION, or other compiler-directing statements. */ char *s = yytext; while (*s == ' ') s++; @@ -484,6 +506,7 @@ MAYBE_AREA_A [ ]?#? ^{MAYBE_AREA_A}.{6}[ ]*"*CONTROL" | ^{MAYBE_AREA_A}.{6}[ ]*"*CBL" { BEGIN CONTROL_STATEMENT_STATE; + output_pending_newlines (ppout); return CONTROL_STATEMENT; } @@ -618,6 +641,7 @@ SUBSTITUTION_SECTION_STATE> if (cb_verify (cb_title_statement, yytext)) { /* handle as listing-directive statement */ BEGIN ALNUM_LITERAL_STATE; + output_pending_newlines (ppout); return TITLE_STATEMENT; } else if (cb_title_statement == CB_SKIP) { /* handle later (normal reserved / user defined word) */ @@ -653,7 +677,7 @@ SUBSTITUTION_SECTION_STATE> } "(" { - inside_bracket++; + inside_bracket++; ppecho (yytext, NULL); } @@ -1133,6 +1157,7 @@ ENDIF_DIRECTIVE_STATE>{ /* Terminate at the end of all input */ if (current_copy_info->next == NULL) { + output_pending_newlines (ppout); /* CHECKME: do we want to drop those? */ /* Check dangling IF/ELSE */ for (; plex_nest_depth > 0; --plex_nest_depth) { cb_source_line = plex_cond_stack[plex_nest_depth].line; @@ -1149,7 +1174,7 @@ ENDIF_DIRECTIVE_STATE>{ newline_count = 0; inside_bracket = 0; comment_allowed = 1; - cb_free_replace (); + cb_free_replace (); copy_stack = NULL; quotation_mark = 0; consecutive_quotation = 0; @@ -1503,12 +1528,33 @@ ppcopy_find_file (char *name, int has_ext) return NULL; } +static COB_INLINE COB_A_INLINE void +output_pending_newlines (FILE *stream) +{ + if (echo_newline > 9) { + /* too much newlines (likely becaue of conditional compilation or + long comment blocks, for example from EXEC SQL preparsers), + so generate source directive from the already adjusted static vars + instead of spitting out possibly hundreds of empty lines */ + fprintf (stream, "\n#line %d \"%s\"\n", cb_source_line, cb_source_file); + echo_newline = 0; + } else { + while (echo_newline > 1) { + fputc ('\n', stream); + echo_newline--; + } + echo_newline = 0; + } +} + int ppcopy (const char *name, const char *lib, struct cb_replace_list *replace_list) { const char *filename = NULL; const int has_ext = (strchr (name, '.') != NULL); + output_pending_newlines (yyout); + if (cb_current_file) { cb_current_file->copy_line = cb_source_line; } @@ -1761,6 +1807,7 @@ plex_clear_vars (void) memset (plex_cond_stack, 0, sizeof(plex_cond_stack)); requires_listing_line = 1; comment_allowed = 1; + echo_newline = 0; } void @@ -1949,6 +1996,8 @@ cb_set_print_replace_list (struct cb_replace_list *list) static void switch_to_buffer (const int line, const char *file, const YY_BUFFER_STATE buffer) { + output_pending_newlines (yyout); + /* Reset file/line */ cb_source_line = line; cb_source_file = cobc_plex_strdup (file); @@ -2028,10 +2077,10 @@ next_word_is_comment_paragraph_name (const char *buff) break; case 8: if (memcmp (p, "SECURITY", len)) return 0; break; - case 12: if ( memcmp (p, "DATE-WRITTEN", len) + case 12: if (memcmp (p, "DATE-WRITTEN", len) && memcmp (p, "INSTALLATION", len)) return 0; break; - case 13: if ( memcmp (p, "DATE-MODIFIED", len) + case 13: if (memcmp (p, "DATE-MODIFIED", len) && memcmp (p, "DATE-COMPILED", len)) return 0; break; default: return 0; @@ -2093,6 +2142,7 @@ start: #endif } if (newline_count < max_size) { + /* FIXME: this doesn't check the buffer size ! */ memset (buff, '\n', newline_count); buff[newline_count] = 0; ipchar = (int)newline_count; @@ -2130,6 +2180,7 @@ start: if (newline_count == 0) { return YY_NULL; } + /* FIXME: this doesn't check the buffer size ! */ memset (buff, '\n', newline_count); buff[newline_count] = 0; ipchar = (int)newline_count; @@ -2279,7 +2330,8 @@ start: ipchar = 0; for (; *bp; bp++) { if (*bp != ' ') { - if ((*bp == '$' && bp[1] != ' ') || (*bp == '>' && bp[1] == '>')) { + if ((*bp == '$' && bp[1] != ' ') + || (*bp == '>' && bp[1] == '>')) { /* Directive */ ipchar = 1; } else if (*bp == '*' && bp[1] == '>') { @@ -2298,6 +2350,7 @@ start: || is_condition_directive_clause (bp))) { /* Directive - pass complete line with NL to ppparse */ if (newline_count) { + /* FIXME: this doesn't check the buffer size ! */ /* Move including NL and NULL byte */ memmove (buff + newline_count, buff, (size_t)n + 1); memset (buff, '\n', newline_count); @@ -2668,9 +2721,18 @@ display_finish (void) unput ('\n'); } -void cb_ppecho_direct (const char *text, const char *token ) +void cb_ppecho_direct (const char *text, const char *token ) { - fputs (text, ppout); + if (text[0] == '\n' && text[1] == 0) { + if (echo_newline == 0) { + /* always keep one trailing \n */ + fputc ('\n', ppout); + } + echo_newline++; + } else { + output_pending_newlines (ppout); + fputs (text, ppout); + } if (cb_listing_file) { check_listing (token != NULL ? token : text, 0); } diff --git a/cobc/replace.c b/cobc/replace.c index 42e44f80a..82f30b48b 100644 --- a/cobc/replace.c +++ b/cobc/replace.c @@ -49,7 +49,7 @@ parsed on the input stream *before* any COPY-REPLACING could have been applied. - The general entry point is `add_text_to_replace(stream, prequeue, + The general entry point is `add_text_to_replace (stream, prequeue, token)`, it adds `token` to `stream`, `prequeue` is 1 if the token should not be treated immediately (because it may be merged with other following tokens if they are of the same kind), 0 @@ -174,9 +174,9 @@ char * string_of_##kind##_list(const struct cb_##kind##_list *list) \ text_list_string[0] = '['; \ \ for(; list != NULL; list = list->next){ \ - size_t len = strlen(list->text); \ + size_t len = strlen (list->text); \ text_list_string[pos++] = '"'; \ - memcpy( text_list_string + pos, list->text, len ); \ + memcpy (text_list_string + pos, list->text, len); \ pos += len; \ text_list_string[pos++] = '"'; \ text_list_string[pos++] = ','; \ @@ -226,7 +226,7 @@ token_list_add (WITH_DEPTH struct cb_token_list *list, const char *text, const char *token) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%stoken_list_add(%s,'%s')\n", + fprintf (stderr, "%stoken_list_add(%s,'%s')\n", DEPTH, string_of_token_list(list), text); #endif struct cb_token_list *p; @@ -259,7 +259,7 @@ const void pop_token (WITH_DEPTH struct cb_replacement_state *repls, const struct cb_token_list *q = repls->token_queue ; repls->token_queue = q->next ; #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%spop_token(%s) -> '%s'\n", + fprintf (stderr, "%spop_token(%s) -> '%s'\n", DEPTH, repls->name, q->text); #endif if (text) *text = q->text ; @@ -271,13 +271,13 @@ void ppecho_switch (WITH_DEPTH struct cb_replacement_state *repls, const char* text, const char* token) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%sppecho_switch(%s, '%s')\n", + fprintf (stderr, "%sppecho_switch(%s, '%s')\n", DEPTH, repls->name, text); #endif switch( repls->ppecho ){ case CB_PPECHO_DIRECT: #ifdef DEBUG_REPLACE - fprintf(stderr, "%s ppecho_direct('%s')\n", DEPTH, text); + fprintf (stderr, "%s ppecho_direct('%s')\n", DEPTH, text); #endif return cb_ppecho_direct (text, token); case CB_PPECHO_REPLACE: @@ -290,7 +290,7 @@ void ppecho_switch_text_list (WITH_DEPTH struct cb_replacement_state *repls, const struct cb_text_list *p) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%sppecho_switch_text_list(%s, %s)\n", + fprintf (stderr, "%sppecho_switch_text_list(%s, %s)\n", DEPTH, repls->name, string_of_text_list(p)); #endif @@ -305,7 +305,7 @@ void ppecho_switch_token_list (WITH_DEPTH struct cb_replacement_state *repls, const struct cb_token_list *p) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%sppecho_switch_token_list(%s, %s)\n", + fprintf (stderr, "%sppecho_switch_token_list(%s, %s)\n", DEPTH, repls->name, string_of_token_list(p)); #endif @@ -335,7 +335,7 @@ int is_leading_or_trailing (WITH_DEPTH int leading, result = 0; } #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, + fprintf (stderr, "%sis_leading_or_trailing(%d, '%s', input='%s', %d) -> %d\n", DEPTH, leading, src_text, text, strict, result); #endif @@ -352,7 +352,7 @@ void ppecho_leading_or_trailing (WITH_DEPTH struct cb_replacement_state *repls, const struct cb_text_list * new_text) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, + fprintf (stderr, "%sppecho_leading_or_trailing(%s, %d, '%s', input='%s', ...)\n", DEPTH, repls->name, leading, src_text, text); #endif @@ -391,7 +391,7 @@ void check_replace (WITH_DEPTH struct cb_replacement_state* repls, const struct cb_replace_list *replace_list) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%scheck_replace(%s, ...)\n", DEPTH, + fprintf (stderr, "%scheck_replace(%s, ...)\n", DEPTH, repls->name); #endif repls->current_list = replace_list; @@ -482,15 +482,15 @@ void check_replace_all (WITH_DEPTH const struct cb_replace_list *replace_list) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%scheck_replace_all(%s,", + fprintf (stderr, "%scheck_replace_all(%s,", DEPTH, repls->name); - fprintf(stderr, "%s new_text = %s,\n", DEPTH, + fprintf (stderr, "%s new_text = %s,\n", DEPTH, string_of_text_list(new_text)); - fprintf(stderr, "%s texts = %s,\n", DEPTH, + fprintf (stderr, "%s texts = %s,\n", DEPTH, string_of_token_list(texts)); - fprintf(stderr, "%s src = %s,\n", DEPTH, + fprintf (stderr, "%s src = %s,\n", DEPTH, string_of_text_list(src)); - fprintf(stderr, "%s)\n", DEPTH); + fprintf (stderr, "%s)\n", DEPTH); #endif if (src==NULL){ @@ -515,7 +515,7 @@ void check_replace_all (WITH_DEPTH * for more texts to be added on the * stream */ #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%s check_replace_all --> PARTIAL MATCH\n", DEPTH); + fprintf (stderr, "%s check_replace_all --> PARTIAL MATCH\n", DEPTH); #endif } else { const char* text = texts->text; @@ -559,7 +559,7 @@ static void check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%scheck_replace_after_match(%s)\n", + fprintf (stderr, "%scheck_replace_after_match(%s)\n", DEPTH, repls->name); #endif repls->current_list = NULL; @@ -580,7 +580,7 @@ static void do_replace (WITH_DEPTH struct cb_replacement_state* repls) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%sdo_replace(%s)\n",DEPTH, repls->name); + fprintf (stderr, "%sdo_replace(%s)\n",DEPTH, repls->name); #endif if (repls->current_list == NULL){ if (repls->replace_list == NULL){ @@ -602,87 +602,78 @@ void do_replace (WITH_DEPTH struct cb_replacement_state* repls) /* Whether a word matches the definition of WORD in pplex.l */ static -int is_word (WITH_DEPTH const char* s){ +int is_word (WITH_DEPTH const char* s) { int i; size_t len = strlen (s); - - for( i = 0; i= '0' && c <= '9' ) - || ( c >= 'A' && c <= 'Z' ) - || ( c >= 'a' && c <= 'z' ) - || ( c >= 128 && c <= 255 ) - ){ - + if (c == '_' + || c == '-' + || ( c >= '0' && c <= '9' ) + || ( c >= 'A' && c <= 'Z' ) + || ( c >= 'a' && c <= 'z' ) + || ( c >= 128 && c <= 255 ) ) { + /* word character, just go on */ } else { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%sis_word('%s') -> 0\n", DEPTH, s); + fprintf (stderr, "%sis_word('%s') -> 0\n", DEPTH, s); #endif return 0; } } #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%sis_word('%s') -> 1\n", DEPTH, s); + fprintf (stderr, "%sis_word('%s') -> 1\n", DEPTH, s); #endif return 1; } static void add_text_to_replace (WITH_DEPTH struct cb_replacement_state *repls, - int prequeue, - const char* text, - const char* token + int prequeue, const char* text, const char* token ) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "%sadd_text_to_replace(%s%s, '%s')\n", DEPTH, + fprintf (stderr, "%sadd_text_to_replace (%s%s, '%s')\n", DEPTH, repls->name, prequeue ? ", PREQUEUE" : "", text); #endif - if( prequeue ){ + if (prequeue) { - if( is_word (MORE_DEPTH text) ) { + if (is_word (MORE_DEPTH text) ) { if( repls->text_prequeue == NULL ){ /* a word should be kept in the prequeue */ repls->text_prequeue = cobc_plex_strdup (text); } else { - /* two following words should be - * merged, and keep waiting in the - * prequeue */ + /* two following words should be merged, + and keep waiting in the prequeue */ repls->text_prequeue = cobc_plex_stradd (repls->text_prequeue, text); } + } else if ( repls->text_prequeue == NULL ){ + /* not a word, and empty prequeue, + just perform replacements */ + add_text_to_replace (MORE_DEPTH repls, 0, text, token); } else { - if( repls->text_prequeue == NULL ){ - /* not a word, and empty prequeue, - * just perform replacements */ - add_text_to_replace(MORE_DEPTH repls, 0, text, token); - } else { - /* not a word, one word in the - * prequeue, flush the word from the - * prequeue and pass the current text - * to the replacements */ - const char* pretext = repls->text_prequeue; - repls->text_prequeue = NULL; - add_text_to_replace(MORE_DEPTH repls, - 0, pretext, NULL); - add_text_to_replace(MORE_DEPTH repls, - 0, text, token); - } + /* not a word, one word in the prequeue, + flush the word from the prequeue and pass the + current text to the replacements */ + const char *pretext = repls->text_prequeue; + repls->text_prequeue = NULL; + add_text_to_replace (MORE_DEPTH repls, 0, pretext, NULL); + add_text_to_replace (MORE_DEPTH repls, 0, text, token); } - } - else { - if( repls->token_queue == NULL && - ( is_space_or_nl (text[0])) ) { + + } else { + + if (repls->token_queue == NULL + && is_space_or_nl (text[0]) ) { ppecho_switch (MORE_DEPTH repls, text, token); } else { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, - "%s add_text_to_replace() -> push_text()\n", + fprintf (stderr, + "%s add_text_to_replace () -> push_text()\n", DEPTH); #endif repls->token_queue = @@ -701,9 +692,9 @@ static void add_text_to_replace (WITH_DEPTH struct cb_replacement_state *repls, static void ppecho_replace (WITH_DEPTH const char *text, const char *token) { #ifdef DEBUG_REPLACE - fprintf(stderr, "%sppecho_replace('%s')\n", DEPTH, text); + fprintf (stderr, "%sppecho_replace('%s')\n", DEPTH, text); #endif - add_text_to_replace(MORE_DEPTH replace_repls, 1, text, token); + add_text_to_replace (MORE_DEPTH replace_repls, 1, text, token); } /* pass a text to the copy-replacing stream (called from ppecho() in @@ -713,14 +704,14 @@ static void ppecho_replace (WITH_DEPTH const char *text, const char *token) void cb_ppecho_copy_replace (const char *text, const char *token) { #ifdef DEBUG_REPLACE - fprintf(stderr, "cb_ppecho_copy_replace('%s')\n", text); + fprintf (stderr, "cb_ppecho_copy_replace('%s')\n", text); #endif - add_text_to_replace(INIT_DEPTH copy_repls, 0, text, token); + add_text_to_replace (INIT_DEPTH copy_repls, 0, text, token); } static -struct cb_replacement_state * create_replacements( enum cb_ppecho ppecho ) +struct cb_replacement_state * create_replacements (enum cb_ppecho ppecho) { struct cb_replacement_state * s; @@ -729,8 +720,8 @@ struct cb_replacement_state * create_replacements( enum cb_ppecho ppecho ) s->text_prequeue = NULL; s->token_queue = NULL; s->replace_list = NULL ; - s->current_list = NULL ; - s->ppecho = ppecho; + s->current_list = NULL ; + s->ppecho = ppecho; #ifdef DEBUG_REPLACE if( ppecho == CB_PPECHO_REPLACE ){ @@ -743,7 +734,7 @@ struct cb_replacement_state * create_replacements( enum cb_ppecho ppecho ) return s; } -static void reset_replacements( struct cb_replacement_state * s ) +static void reset_replacements (struct cb_replacement_state * s) { s->text_prequeue = NULL; s->token_queue = NULL; @@ -763,10 +754,10 @@ void init_replace( void ) } static -void reset_replace( void ) +void reset_replace (void) { - reset_replacements( copy_repls ); - reset_replacements( replace_repls ); + reset_replacements (copy_repls); + reset_replacements (replace_repls); } /* Called by pplex.l at EOF of top file */ @@ -797,18 +788,18 @@ void cb_set_copy_replacing_list (struct cb_replace_list *list) copy_repls->current_list = NULL; copy_repls->replace_list = list ; #ifdef DEBUG_REPLACE - fprintf(stderr, "set_copy_replacing_list(\n"); + fprintf (stderr, "set_copy_replacing_list(\n"); for(;list != NULL; list=list->next){ - fprintf(stderr, " repl = {\n"); - fprintf(stderr, " src = %s\n", + fprintf (stderr, " repl = {\n"); + fprintf (stderr, " src = %s\n", string_of_text_list(list->src->text_list)); - fprintf(stderr, " leading = %d\n", + fprintf (stderr, " leading = %d\n", list->src->lead_trail); - fprintf(stderr, " new_text = %s\n", + fprintf (stderr, " new_text = %s\n", string_of_text_list(list->new_text)); - fprintf(stderr, " };\n"); + fprintf (stderr, " };\n"); } - fprintf(stderr, " )\n"); + fprintf (stderr, " )\n"); #endif } @@ -824,7 +815,7 @@ void cb_set_replace_list (struct cb_replace_list *list, const int is_pushpop) { #ifdef DEBUG_REPLACE_TRACE - fprintf(stderr, "set_replace_list(...)\n"); + fprintf (stderr, "set_replace_list(...)\n"); #endif if (!list) { /* REPLACE [LAST] OFF */ From bbfa460fdfeb44cae6743443317a6e259fc09c89 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 13 Jul 2023 15:08:07 +0000 Subject: [PATCH 03/21] working on the preparsing - follow-up to [r5123] cobc/scanner.l: handle line directive in any state --- cobc/ChangeLog | 1 + cobc/scanner.l | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index c0bdd6dac..6df4da128 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -9,6 +9,7 @@ * pplex.l (switch_to_buffer): don't re-strdup the filename * parser.y (emit_statement): changed from define to inline function * codegen.c: complete output of program's end source location if requested + * scanner.l: handle line directive in any state 2023-07-11 Fabrice Le Fessant diff --git a/cobc/scanner.l b/cobc/scanner.l index 6219ec123..15f3d1871 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -338,7 +338,7 @@ AREA_A "#AREA_A"\n cb_source_line++; } -^"#LINE"[ ]?[0-9]+" ".* { +<*>^"#LINE"[ ]?[0-9]+" ".* { /* Line directive */ char *p1; char *p2; From 469f4f37ab3ffc6b7e390334e2eab013053d8ff3 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 14 Jul 2023 06:56:52 +0000 Subject: [PATCH 04/21] warning adjustment for type mismatch cobc: * warning.def, typeck.c (validate_move), cobc.c (process_command_line): use existing -Wstrict-typing only for "strict" type mismatches, including "same size, different type" and move it to -Wextra; the other mismatches are still raised with -Wall but under the new -Wtyping --- NEWS | 3 ++ cobc/ChangeLog | 22 +++++++++- cobc/cobc.c | 15 ++++++- cobc/typeck.c | 24 +++++++++-- cobc/warning.def | 9 ++-- tests/testsuite.src/data_packed.at | 4 +- tests/testsuite.src/run_fundamental.at | 58 ++++++++++++++------------ 7 files changed, 97 insertions(+), 38 deletions(-) diff --git a/NEWS b/NEWS index 31ffd88bf..0b7539dd0 100644 --- a/NEWS +++ b/NEWS @@ -316,6 +316,9 @@ NEWS - user visible changes -*- outline -*- ** adjustments to warning options: -Wconstant-expression was changed to a group warning and includes the new, previously integrated, -Wconstant-numlit-expression + -Wtyping as a new warning raises only very suspicious MOVEs, + -Wstrict-typing, which will warn as before even for MOVE 1 TO PICX-FLD + is not included in -Wall any more -Wlarger-01-redefines as new warning (enabled by -Wextra) to check for the only larger REDEFINES that is explicit allowed by the COBOL standard -Wno-unsupported -Wunsupported new option to disable or only warn diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 6df4da128..c3dca3359 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -10,6 +10,10 @@ * parser.y (emit_statement): changed from define to inline function * codegen.c: complete output of program's end source location if requested * scanner.l: handle line directive in any state + * warning.def, typeck.c (validate_move), cobc.c (process_command_line): + * use existing -Wstrict-typing only for "strict" type mismatches, including + "same size, different type" and move it to -Wextra; the other mismatches + are still raised with -Wall but under the new -Wtyping 2023-07-11 Fabrice Le Fessant @@ -246,6 +250,15 @@ literal for use with CONTROL phrase * parser.y: adjust a bunch of terminals to match the internal name with leading underscore as optional + * cobc.c: check for duplicate source file and skip with warning + * pplex.l: check for recursive file by resolved file name + +2023-05-19 Simon Sobisch + + * parser.y (usage), field.c (validate_field_1): postpone setting of + field attribute flag_is_pointer from parsing the USAGE clause to final + field validation, fixing group and "child" USAGE, as well as + TYPEDEF + SAME AS with pointer types 2023-05-15 Simon Sobisch @@ -253,6 +266,8 @@ from int to their matching enum * tree.c (cb_build_prototype), parser.y (setup_prototype), tree.h (struct cb_prototype): use matching enum + * tree.c (cb_field), parser.y, reserved.c: added parsing of GROUP-USAGE + * field.c (validate_field_1): handle new attribute group_usage 2023-05-11 Simon Sobisch @@ -317,6 +332,11 @@ * typeck.c (cb_build_move_literal): optimized output for literals to fields with BLANK WHEN ZERO and SIGN LEADING +2023-05-02 Simon Sobisch + + * field.c: inclusion of condition-names (level 88) into field that use a + TYPEDEF defintion + 2023-04-25 Simon Sobisch * codegen.c (output_so_load_version_check): new function to generate @@ -528,8 +548,6 @@ 2023-01-30 Simon Sobisch - * field.c (copy_into_field, copy_into_field_recursive): fix missing set - of flag_is_pointer, fixing TYPEDEF + SAME AS with pointer types * parser.y, reserved.c: add DISPLAY-1 as PENDING, actually pass NATIONAL usage if specified * field.c (compute_size), tree.c (cb_tree_type): handle CB_USAGE_NATIONAL diff --git a/cobc/cobc.c b/cobc/cobc.c index 4bb9768a1..0b95fa89b 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -4118,14 +4118,27 @@ process_command_line (const int argc, char **argv) #endif { + /* TODO: handle group warnings, likely via option in warning.def */ + /* 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 (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 (cb_warn_constant_expr); set_warn_opt_value (cb_warn_constant_numlit_expr, group_warn); } + /* group with different main group: -Wstrict-typing (a -Wextra one) implies -Wtyping, + (a -Wall one), and -Wno-typing implies -Wno-strict-typing */ + const enum cb_warn_val strict_warn = get_warn_opt_value (cb_warn_strict_typing); + if (strict_warn == COBC_WARN_ENABLED_EXPL) { + set_warn_opt_value (cb_warn_typing, COBC_WARN_ENABLED_EXPL); + } else { + const enum cb_warn_val warn_type = get_warn_opt_value (cb_warn_typing); + if (warn_type == COBC_WARN_DISABLED_EXPL) { + set_warn_opt_value (cb_warn_strict_typing, COBC_WARN_DISABLED_EXPL); + } + } + /* set all explicit warning options to their later checked variants */ #define CB_CHECK_WARNING(opt) \ if (get_warn_opt_value (opt) == COBC_WARN_ENABLED_EXPL) { \ diff --git a/cobc/typeck.c b/cobc/typeck.c index 3387f8fec..ee8ab6a59 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -10865,16 +10865,24 @@ validate_move (cb_tree src, cb_tree dst, const unsigned int is_value, int *move_ case CB_CATEGORY_ALPHANUMERIC: case CB_CATEGORY_ALPHANUMERIC_EDITED: if (is_value - || l->scale == 0) { + || l->scale != 0 + || l->size != fdst->size) { goto expect_alphanumeric; } + if (l->size == fdst->size) { + goto expect_alphanumeric_strict; + } goto invalid; case CB_CATEGORY_NATIONAL: case CB_CATEGORY_NATIONAL_EDITED: if (is_value - || l->scale == 0) { + || l->scale != 0 + || l->size != fdst->size) { goto expect_national; } + if (l->size == fdst->size) { + goto expect_national_strict; + } goto non_integer_move; case CB_CATEGORY_NUMERIC_EDITED: case CB_CATEGORY_FLOATING_EDITED: @@ -11594,16 +11602,26 @@ validate_move (cb_tree src, cb_tree dst, const unsigned int is_value, int *move_ return 0; expect_numeric: - move_warning (src, dst, is_value, cb_warn_strict_typing, 0, + move_warning (src, dst, is_value, cb_warn_typing, 0, _("numeric value is expected")); return 0; expect_alphanumeric: + move_warning (src, dst, is_value, cb_warn_typing, 0, + _("alphanumeric value is expected")); + return 0; + +expect_alphanumeric_strict: move_warning (src, dst, is_value, cb_warn_strict_typing, 0, _("alphanumeric value is expected")); return 0; expect_national: + move_warning (src, dst, is_value, cb_warn_typing, 0, + _("national value is expected")); + return 0; + +expect_national_strict: move_warning (src, dst, is_value, cb_warn_strict_typing, 0, _("national value is expected")); return 0; diff --git a/cobc/warning.def b/cobc/warning.def index b4c89e3ba..181053e3a 100644 --- a/cobc/warning.def +++ b/cobc/warning.def @@ -1,5 +1,5 @@ /* - Copyright (C) 2003-2012, 2016-2018, 2020-2022 Free Software Foundation, Inc. + Copyright (C) 2003-2012, 2016-2018, 2020-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch This file is part of GnuCOBOL. @@ -66,8 +66,11 @@ CB_NOWARNDEF (cb_warn_pos_overlap, "possible-overlap", CB_WARNDEF (cb_warn_parentheses, "parentheses", _(" -Wparentheses warn if parentheses are omitted around AND within OR")) -CB_WARNDEF (cb_warn_strict_typing, "strict-typing", - _(" -Wstrict-typing warn strictly about type mismatch")) +CB_NOWARNDEF (cb_warn_strict_typing, "strict-typing", + _(" -Wstrict-typing warn strictly about type mismatch, even when same size")) + +CB_WARNDEF (cb_warn_typing, "typing", + _(" -Wtyping warn about type mismatch")) CB_NOWARNDEF (cb_warn_implicit_define, "implicit-define", _(" -Wimplicit-define warn whenever data items are implicitly defined")) diff --git a/tests/testsuite.src/data_packed.at b/tests/testsuite.src/data_packed.at index d51bbd382..a4d2a20f8 100644 --- a/tests/testsuite.src/data_packed.at +++ b/tests/testsuite.src/data_packed.at @@ -1704,8 +1704,8 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -# CHECKME: -Wno-strict-typing because of MOVE warning -AT_CHECK([$COMPILE -Wno-strict-typing prog.cob], [0], [], []) +# CHECKME: -Wno-typing because of MOVE warning +AT_CHECK([$COMPILE -Wno-typing prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [MOVE 1P17: -100000000000000000 : 2. diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 80c536e66..eef65b5b2 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -528,7 +528,7 @@ AT_CLEANUP AT_SETUP([MOVE integer literal to alphanumeric]) -AT_KEYWORDS([fundamental]) +AT_KEYWORDS([fundamental typing]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -538,16 +538,28 @@ AT_DATA([prog.cob], [ 01 X PIC X(04) VALUE SPACES. PROCEDURE DIVISION. MOVE 0 TO X. - DISPLAY X NO ADVANCING - END-DISPLAY. + DISPLAY X NO ADVANCING END-DISPLAY. + MOVE 1000 TO X. + DISPLAY X NO ADVANCING END-DISPLAY. STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob], [0], [], -[prog.cob:8: warning: alphanumeric value is expected -prog.cob:6: note: 'X' defined here as PIC X(04) +AT_CHECK([$COMPILE_ONLY -fdiagnostics-show-option prog.cob], [0], [], +[prog.cob:8: warning: alphanumeric value is expected [[-Wtyping]] +prog.cob:6: note: 'X' defined here as PIC X(04) [[-Wtyping]] ]) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [0 ]) +AT_CHECK([$COMPILE_ONLY -Wstrict-typing -fdiagnostics-show-option prog.cob], [0], [], +[prog.cob:8: warning: alphanumeric value is expected [[-Wtyping]] +prog.cob:6: note: 'X' defined here as PIC X(04) [[-Wtyping]] +prog.cob:10: warning: alphanumeric value is expected [[-Wstrict-typing]] +prog.cob:6: note: 'X' defined here as PIC X(04) [[-Wstrict-typing]] +]) +AT_CHECK([$COMPILE_ONLY -Wextra -Wno-strict-typing -fdiagnostics-show-option prog.cob], [0], [], +[prog.cob:8: warning: alphanumeric value is expected [[-Wtyping]] +prog.cob:6: note: 'X' defined here as PIC X(04) [[-Wtyping]] +]) +AT_CHECK([$COMPILE -Wextra -Wno-typing -fdiagnostics-show-option prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [0 1000]) AT_CLEANUP @@ -2259,7 +2271,7 @@ AT_CLEANUP AT_SETUP([CANCEL test (1)]) -AT_KEYWORDS([fundamental]) +AT_KEYWORDS([fundamental CALL]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -2286,7 +2298,7 @@ AT_CLEANUP AT_SETUP([CANCEL test (2)]) -AT_KEYWORDS([fundamental]) +AT_KEYWORDS([fundamental CALL]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -2294,10 +2306,8 @@ AT_DATA([prog.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. PROCEDURE DIVISION. - CALL "prog2" - END-CALL. - DISPLAY "NG" NO ADVANCING - END-DISPLAY. + CALL "prog2". + DISPLAY "NG" NO ADVANCING. STOP RUN. ]) @@ -2308,8 +2318,7 @@ AT_DATA([prog2.cob], [ WORKING-STORAGE SECTION. PROCEDURE DIVISION. CANCEL "prog". - DISPLAY "NG" NO ADVANCING - END-DISPLAY. + DISPLAY "NG" NO ADVANCING. STOP RUN. ]) @@ -2326,7 +2335,7 @@ AT_CLEANUP AT_SETUP([CANCEL test (3)]) -AT_KEYWORDS([fundamental]) +AT_KEYWORDS([fundamental CALL]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -2334,16 +2343,12 @@ AT_DATA([prog.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. PROCEDURE DIVISION. - CALL "prog2" - END-CALL. - CALL "prog2" - END-CALL. + CALL "prog2". + CALL "prog2". CANCEL "prog2". - CALL "prog2" - END-CALL. + CALL "prog2". CANCEL "prog2". - DISPLAY "NG" NO ADVANCING - END-DISPLAY. + DISPLAY "NG" NO ADVANCING. STOP RUN. ]) @@ -2354,9 +2359,8 @@ AT_DATA([prog2.cob], [ WORKING-STORAGE SECTION. 77 VAR PIC 9(01) value 1. PROCEDURE DIVISION. - DISPLAY VAR NO ADVANCING - END-DISPLAY. - ADD 1 TO VAR END-ADD. + DISPLAY VAR NO ADVANCING. + ADD 1 TO VAR. GOBACK. ]) From 815b0d86d5bb519f367bd23988bb903e70f08167 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 14 Jul 2023 12:07:35 +0000 Subject: [PATCH 05/21] c89compat for r5125 --- cobc/cobc.c | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/cobc/cobc.c b/cobc/cobc.c index 0b95fa89b..86ab811cd 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -4118,19 +4118,20 @@ process_command_line (const int argc, char **argv) #endif { + enum cb_warn_val check_warn /* TODO: handle group warnings, likely via option in warning.def */ /* 3.x compat -Wconstant-expression also sets -Wconstant-numlit-expression */ - 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) { + check_warn = get_warn_opt_value (cb_warn_constant_numlit_expr); + if (check_warn != COBC_WARN_DISABLED_EXPL + && check_warn != COBC_WARN_ENABLED_EXPL) { 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); } /* group with different main group: -Wstrict-typing (a -Wextra one) implies -Wtyping, (a -Wall one), and -Wno-typing implies -Wno-strict-typing */ - const enum cb_warn_val strict_warn = get_warn_opt_value (cb_warn_strict_typing); - if (strict_warn == COBC_WARN_ENABLED_EXPL) { + check_warn = get_warn_opt_value (cb_warn_strict_typing); + if (check_warn == COBC_WARN_ENABLED_EXPL) { set_warn_opt_value (cb_warn_typing, COBC_WARN_ENABLED_EXPL); } else { const enum cb_warn_val warn_type = get_warn_opt_value (cb_warn_typing); @@ -6580,13 +6581,14 @@ line_has_listing_directive (char *line, const enum cb_format source_format, int token = get_directive_start (line, source_format); - if (token != NULL && - !strncasecmp (token, "LISTING", 7)) { + if (token != NULL + && !strncasecmp (token, "LISTING", 7)) { token += 7; *on_off = 1; token = get_next_nonspace (token); - if (!strncasecmp (token, "OFF", 3)) + if (!strncasecmp (token, "OFF", 3)) { *on_off = 0; + } return 1; } return 0; From 5da07ce2c655792c6e62ff9f57302fc05c76d57c Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 14 Jul 2023 12:30:14 +0000 Subject: [PATCH 06/21] c89compat for r5125 take 2 --- cobc/cobc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cobc/cobc.c b/cobc/cobc.c index 86ab811cd..0867596d3 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -4118,7 +4118,7 @@ process_command_line (const int argc, char **argv) #endif { - enum cb_warn_val check_warn + enum cb_warn_val check_warn; /* TODO: handle group warnings, likely via option in warning.def */ /* 3.x compat -Wconstant-expression also sets -Wconstant-numlit-expression */ From 7513ed581613f2e9c4d6fee5ddb8a54c52a2b411 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 18 Jul 2023 13:43:29 +0000 Subject: [PATCH 07/21] libcob/move.c: fix memory trashing in edge cases; following suggestions from @chaat --- libcob/ChangeLog | 5 + libcob/move.c | 25 +- tests/testsuite.src/data_packed.at | 425 ++++++++++++++++++++++++++--- 3 files changed, 415 insertions(+), 40 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index f8c6b2563..14f231c18 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2023-07-18 Simon Sobisch +after suggestions by Chuck Haatvedt + + * move.c (cob_move_display_to_packed): fix memory trashing in edge cases + 2023-07-10 Simon Sobisch * common.c (cob_check_fence), common.h: new function to check for writing diff --git a/libcob/move.c b/libcob/move.c index f5a714c9d..877d7890d 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -511,23 +511,27 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) /* skip not available positions */ p = data1 + (digits1 - scale1) - (digits2 - scale2); while (p < data1) { - p++; i++; /* note: both p and i are digits */ + p++; i++; /* note: both p and i are about digits */ } /* zero out target, then transfer data */ memset (f2->data, 0, f2->size); { register unsigned char *q = f2->data + i / 2; - const unsigned int i_end = digits2 + 1; - /* FIXME: get rid of that, adjust i_end accordingly and always end at sign byte */ - const unsigned char *f2_end = f2->data + f2->size - 1; - const unsigned char *p_end_calc = data1 + digits1; - const unsigned char *p_end = p_end_calc > f2_end ? f2_end : p_end_calc; + const unsigned int i_end = f2->size; + /* FIXME: get rid of that, adjust i_end to handle both truncation of the source to the right + and zero-fill because of scale differences (zero-fill wa s already done) */ + const unsigned char *p_end = data1 + digits1; if (i % 2 == 1) { *q++ = COB_D2I (*p++); i++; } + + /* note: from this point on the variable "i" represents the target bytes, + not the digits any more (therefore we divide by 2) */ + i = i / 2; + /* note: for performance reasons we write "full bytes" only, this means that for COMP-3 we'll read 1 byte "too much = after" from the DISPLAY data; it is believed that this won't raise a SIGBUS anywhere, but we will need to "clean" @@ -535,12 +539,12 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) /* check for necessary loop (until we not need the p_end check) */ if (i_end - i < (unsigned int)(p_end - p + 1) / 2) { - while (i <= i_end) { + while (i < i_end) { *q = (unsigned char) (*p << 4) /* -> dropping the higher bits = no use in COB_D2I */ + COB_D2I (*(p + 1)); q++; + i++; p += 2; - i += 2; } } else { while (p < p_end) { @@ -558,7 +562,9 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) return; } - p = f2->data + f2->size - 1; /* TODO: ending at the sign byte means we can drop that */ + /* note: for zero-fill like MOVE 2.1 TO C3-9v9999 we only go to the second position and + therefore have to set 'p' to the most-right place in the target field*/ + p = f2->data + f2->size - 1; if (!COB_FIELD_HAVE_SIGN (f2)) { *p |= 0x0F; } else if (sign < 0) { @@ -1149,6 +1155,7 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) /* Put sign or currency symbol at the beginning */ if (sign_symbol || curr_symbol) { if (floating_insertion) { + /* use memrchr here as soon as gnulib is used */ for (dst = end - 1; dst > f2->data; --dst) { if (*dst == ' ') { break; diff --git a/tests/testsuite.src/data_packed.at b/tests/testsuite.src/data_packed.at index a4d2a20f8..24b3694bc 100644 --- a/tests/testsuite.src/data_packed.at +++ b/tests/testsuite.src/data_packed.at @@ -226,35 +226,206 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 X-99 PIC 99 USAGE PACKED-DECIMAL. - 01 X-S99 PIC S99 USAGE PACKED-DECIMAL. - 01 X-999 PIC 999 USAGE PACKED-DECIMAL. - 01 X-S999 PIC S999 USAGE PACKED-DECIMAL. - 01 C-P1234 PIC 9999 VALUE 1234. + 78 FENCE VALUE x'ABBAAB'. + 01 FILLER. + 05 FENCE-1 PIC XXX VALUE FENCE. + 05 X-99 PIC 99 USAGE PACKED-DECIMAL. + 05 FENCE-2 PIC XXX VALUE FENCE. + 05 X-S99 PIC S99 USAGE PACKED-DECIMAL. + 05 FENCE-3 PIC XXX VALUE FENCE. + 05 X-999 PIC 999 USAGE PACKED-DECIMAL. + 05 FENCE-4 PIC XXX VALUE FENCE. + 05 X-S999 PIC S999 USAGE PACKED-DECIMAL. + 05 FENCE-5 PIC XXX VALUE FENCE. + 05 X-CALC PIC S9(09)V9(09) USAGE PACKED-DECIMAL. + 05 FENCE-6 PIC XXX VALUE FENCE. + 01 C-P234 PIC 999 VALUE 234. + 01 C-N234 PIC S999 VALUE -234. + 01 C-P1234 PIC 9999 VALUE 234. 01 C-N1234 PIC S9999 VALUE -1234. 01 B-P1234 USAGE BINARY-LONG VALUE 1234. 01 B-N1234 USAGE BINARY-LONG VALUE -1234. PROCEDURE DIVISION. MOVE C-P1234 TO X-99 DISPLAY X-99. + IF FENCE-1 NOT = FENCE + MOVE FENCE TO FENCE-1 + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + MOVE C-P1234 TO X-S99 DISPLAY X-S99. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + MOVE C-P1234 TO X-999 DISPLAY X-999. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + MOVE C-P1234 TO X-S999 DISPLAY X-S999. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + IF FENCE-5 NOT = FENCE + MOVE FENCE TO FENCE-5 + DISPLAY 'broken FENCE-5' UPON SYSERR. + MOVE C-N1234 TO X-99 DISPLAY X-99. + IF FENCE-1 NOT = FENCE + MOVE FENCE TO FENCE-1 + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + MOVE C-N1234 TO X-S99 DISPLAY X-S99. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + MOVE C-N1234 TO X-999 DISPLAY X-999. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + MOVE C-N1234 TO X-S999 DISPLAY X-S999. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + IF FENCE-5 NOT = FENCE + MOVE FENCE TO FENCE-5 + DISPLAY 'broken FENCE-5' UPON SYSERR. + MOVE B-N1234 TO X-999 DISPLAY X-999. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + MOVE B-N1234 TO X-S999 DISPLAY X-S999. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + IF FENCE-5 NOT = FENCE + MOVE FENCE TO FENCE-5 + DISPLAY 'broken FENCE-5' UPON SYSERR. + + MOVE C-P234 TO X-99 + DISPLAY X-99. + IF FENCE-1 NOT = FENCE + MOVE FENCE TO FENCE-1 + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + + MOVE C-P234 TO X-S99 + DISPLAY X-S99. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + + MOVE C-P234 TO X-999 + DISPLAY X-999. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + + MOVE C-P234 TO X-S999 + DISPLAY X-S999. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + IF FENCE-5 NOT = FENCE + MOVE FENCE TO FENCE-5 + DISPLAY 'broken FENCE-5' UPON SYSERR. + + MOVE C-N234 TO X-99 + DISPLAY X-99. + IF FENCE-1 NOT = FENCE + MOVE FENCE TO FENCE-1 + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + + MOVE C-N234 TO X-S99 + DISPLAY X-S99. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + + MOVE C-N234 TO X-999 + DISPLAY X-999. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + + MOVE C-N234 TO X-S999 + DISPLAY X-S999. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + IF FENCE-5 NOT = FENCE + MOVE FENCE TO FENCE-5 + DISPLAY 'broken FENCE-5' UPON SYSERR. + + MOVE ZERO TO X-CALC + DISPLAY X-CALC. + IF FENCE-5 NOT = FENCE + MOVE FENCE TO FENCE-5 + DISPLAY 'broken FENCE-5' UPON SYSERR. + IF FENCE-6 NOT = FENCE + MOVE FENCE TO FENCE-6 + DISPLAY 'broken FENCE-6' UPON SYSERR. + + MOVE 1 TO X-CALC + DISPLAY X-CALC. + IF FENCE-5 NOT = FENCE + MOVE FENCE TO FENCE-5 + DISPLAY 'broken FENCE-5' UPON SYSERR. + IF FENCE-6 NOT = FENCE + MOVE FENCE TO FENCE-6 + DISPLAY 'broken FENCE-6' UPON SYSERR. + STOP RUN. ]) @@ -270,6 +441,16 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], -234 234 -234 +34 ++34 +234 ++234 +34 +-34 +234 +-234 ++000000000.000000000 ++000000001.000000000 ]) AT_CLEANUP @@ -866,34 +1047,113 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 X PIC 99 USAGE PACKED-DECIMAL VALUE 0. - 01 Y PIC 99 USAGE PACKED-DECIMAL VALUE 9. - 01 Z PIC s9(20) USAGE PACKED-DECIMAL VALUE -55. - 01 X-9 PIC 9 USAGE PACKED-DECIMAL. - 01 X-99 PIC 99 USAGE PACKED-DECIMAL. - 01 X-920 PIC 9(20) USAGE PACKED-DECIMAL. - 01 X-921 PIC 9(21) USAGE PACKED-DECIMAL. + 78 FENCE VALUE x'ABBAAB'. + 01 FILLER. + 05 FENCE-A PIC XXX VALUE FENCE. + 05 X PIC 99 USAGE PACKED-DECIMAL VALUE 0. + 05 FENCE-B PIC XXX VALUE FENCE. + 05 Y PIC 99 USAGE PACKED-DECIMAL VALUE 9. + 05 Z PIC s9(20) USAGE PACKED-DECIMAL VALUE -55. + 01 FILLER. + 05 FENCE-1 PIC XXX VALUE FENCE. + 05 X-9 PIC 9 USAGE COMP-6. + 05 FENCE-2 PIC XXX VALUE FENCE. + 05 X-99 PIC 99 USAGE COMP-6. + 05 FENCE-3 PIC XXX VALUE FENCE. + 05 X-920 PIC 9(20) USAGE COMP-6. + 05 FENCE-4 PIC XXX VALUE FENCE. + 05 X-921 PIC 9(21) USAGE COMP-6. + 05 FENCE-5 PIC XXX VALUE FENCE. 01 B-99 USAGE BINARY-LONG UNSIGNED VALUE 99. 01 B-999 USAGE BINARY-LONG UNSIGNED VALUE 123. PROCEDURE DIVISION. COMPUTE X = 1 IF X <> 1 DISPLAY "01 <" X ">". + IF FENCE-A NOT = FENCE + MOVE FENCE TO FENCE-A + DISPLAY 'broken FENCE-A' UPON SYSERR. + IF FENCE-B NOT = FENCE + MOVE FENCE TO FENCE-B + DISPLAY 'broken FENCE-B' UPON SYSERR. + COMPUTE X = Y IF X <> 9 DISPLAY "09 <" X ">". + IF FENCE-A NOT = FENCE + MOVE FENCE TO FENCE-A + DISPLAY 'broken FENCE-A' UPON SYSERR. + IF FENCE-B NOT = FENCE + MOVE FENCE TO FENCE-B + DISPLAY 'broken FENCE-B' UPON SYSERR. + COMPUTE X = X + Y IF Z < -56 DISPLAY "-55 >= " Z. + IF FENCE-A NOT = FENCE + MOVE FENCE TO FENCE-A + DISPLAY 'broken FENCE-A' UPON SYSERR. + IF FENCE-B NOT = FENCE + MOVE FENCE TO FENCE-B + DISPLAY 'broken FENCE-B' UPON SYSERR. + *> + MOVE B-999 TO X-99 IF X-99 <> 23 DISPLAY 'trunk 123 -> 99: 'X-99. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + MOVE B-999 TO X-9 IF X-9 <> 3 DISPLAY 'trunk 123 -> 9: ' X-9. + IF FENCE-1 NOT = FENCE + MOVE FENCE TO FENCE-1 + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + MOVE B-99 TO X-99 + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + MOVE B-999 TO X-920 + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + MOVE X-99 TO X-921 + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + IF FENCE-5 NOT = FENCE + MOVE FENCE TO FENCE-5 + DISPLAY 'broken FENCE-5' UPON SYSERR. + ADD X-99 X-920 GIVING B-99. IF B-99 <> 222 DISPLAY '!222: ' B-99. IF X-920 > 124 DISPLAY '> 124 ' X-920. IF X-921 < 98 DISPLAY '< 98 ' X-921. + + IF FENCE-1 NOT = FENCE + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + DISPLAY 'broken FENCE-3' UPON SYSERR. + IF FENCE-4 NOT = FENCE + DISPLAY 'broken FENCE-4' UPON SYSERR. + IF FENCE-5 NOT = FENCE + DISPLAY 'broken FENCE-5' UPON SYSERR. + STOP RUN. ]) @@ -1198,24 +1458,78 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 X-9 PIC 9 USAGE COMP-6. - 01 X-99 PIC 99 USAGE COMP-6. - 01 X-920 PIC 9(20) USAGE COMP-6. - 01 X-921 PIC 9(21) USAGE COMP-6. + 78 FENCE VALUE x'ABBAAB'. + 01 FILLER. + 05 FENCE-1 PIC XXX VALUE FENCE. + 05 X-9 PIC 9 USAGE COMP-6. + 05 FENCE-2 PIC XXX VALUE FENCE. + 05 X-99 PIC 99 USAGE COMP-6. + 05 FENCE-3 PIC XXX VALUE FENCE. + 05 X-920 PIC 9(20) USAGE COMP-6. + 05 FENCE-4 PIC XXX VALUE FENCE. + 05 X-921 PIC 9(21) USAGE COMP-6. + 05 FENCE-5 PIC XXX VALUE FENCE. 01 B-99 USAGE BINARY-LONG UNSIGNED VALUE 99. 01 B-999 USAGE BINARY-LONG UNSIGNED VALUE 123. PROCEDURE DIVISION. MOVE B-999 TO X-99 IF X-99 <> 23 DISPLAY 'trunk 123 -> 99: 'X-99. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + MOVE B-999 TO X-9 IF X-9 <> 3 DISPLAY 'trunk 123 -> 9: ' X-9. + IF FENCE-1 NOT = FENCE + MOVE FENCE TO FENCE-1 + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + MOVE B-99 TO X-99 + IF FENCE-2 NOT = FENCE + MOVE FENCE TO FENCE-2 + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + MOVE B-999 TO X-920 + IF FENCE-3 NOT = FENCE + MOVE FENCE TO FENCE-3 + DISPLAY 'broken FENCE-3' UPON SYSERR. + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + MOVE X-99 TO X-921 + IF FENCE-4 NOT = FENCE + MOVE FENCE TO FENCE-4 + DISPLAY 'broken FENCE-4' UPON SYSERR. + IF FENCE-5 NOT = FENCE + MOVE FENCE TO FENCE-5 + DISPLAY 'broken FENCE-5' UPON SYSERR. + ADD X-99 X-920 GIVING B-99. IF B-99 <> 222 DISPLAY '!222: ' B-99. IF X-920 > 124 DISPLAY '> 124 ' X-920. IF X-921 < 98 DISPLAY '< 98 ' X-921. + + IF FENCE-1 NOT = FENCE + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-3 NOT = FENCE + DISPLAY 'broken FENCE-3' UPON SYSERR. + IF FENCE-4 NOT = FENCE + DISPLAY 'broken FENCE-4' UPON SYSERR. + IF FENCE-5 NOT = FENCE + DISPLAY 'broken FENCE-5' UPON SYSERR. + STOP RUN. ]) @@ -1641,13 +1955,19 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 XS. - 05 X-1 PIC 999PPP COMP-3 VALUE 91000. - 05 X-2 PIC 999PPP COMP-3 VALUE 92000. - 05 X-3 PIC X VALUE "$". - 05 X-4 PIC VPPP999 COMP-3 VALUE 0.000128. - 01 D-1 PIC 999PPP COMP-3 VALUE 95000. - 01 D-2 PIC 9999PP COMP-3 VALUE 193000. + 78 FENCE VALUE x'ABBAAB'. + 01 FILLER. + 05 FENCE-A PIC XXX VALUE FENCE. + 05 X-1 PIC 999PPP COMP-6 VALUE 91000. + 05 FENCE-B PIC XXX VALUE FENCE. + 05 X-2 PIC 999PPP COMP-6 VALUE 92000. + 05 FENCE-C PIC XXX VALUE FENCE. + 05 X-4 PIC VPPP999 COMP-6 VALUE 0.000128. + 05 FENCE-D PIC XXX VALUE FENCE. + 01 FENCE-1 PIC XXX VALUE FENCE. + 01 D-1 PIC 999PPP COMP-6 VALUE 95000. + 01 D-2 PIC 9999PP COMP-6 VALUE 193000. + 01 FENCE-2 PIC XXX VALUE FENCE. 01 WRK-DS-LS-1P17-1 PIC S9P(17) SIGN LEADING SEPARATE CHARACTER VALUE -100000000000000000. 01 WRK-AE-3 PIC XBXXX/XXX/XXX/XXX/XXXBXX. @@ -1701,6 +2021,20 @@ AT_DATA([prog.cob], [ MULTIPLY 2 BY X-1 GIVING X-1. IF X-1 NOT = 62000 DISPLAY "* 2 failed: " X-1. + + IF FENCE-1 NOT = FENCE + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-A NOT = FENCE + DISPLAY 'broken FENCE-A' UPON SYSERR. + IF FENCE-B NOT = FENCE + DISPLAY 'broken FENCE-B' UPON SYSERR. + IF FENCE-C NOT = FENCE + DISPLAY 'broken FENCE-C' UPON SYSERR. + IF FENCE-D NOT = FENCE + DISPLAY 'broken FENCE-D' UPON SYSERR. + STOP RUN. ]) @@ -1735,13 +2069,19 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 XS. - 05 X-1 PIC 999PPP COMP-6 VALUE 91000. - 05 X-2 PIC 999PPP COMP-6 VALUE 92000. - 05 X-3 PIC X VALUE "$". - 05 X-4 PIC VPPP999 COMP-6 VALUE 0.000128. - 01 D-1 PIC 999PPP COMP-6 VALUE 95000. - 01 D-2 PIC 9999PP COMP-6 VALUE 193000. + 78 FENCE VALUE x'ABBAAB'. + 01 FILLER. + 05 FENCE-A PIC XXX VALUE FENCE. + 05 X-1 PIC 999PPP COMP-6 VALUE 91000. + 05 FENCE-B PIC XXX VALUE FENCE. + 05 X-2 PIC 999PPP COMP-6 VALUE 92000. + 05 FENCE-C PIC XXX VALUE FENCE. + 05 X-4 PIC VPPP999 COMP-6 VALUE 0.000128. + 05 FENCE-D PIC XXX VALUE FENCE. + 01 FENCE-1 PIC XXX VALUE FENCE. + 01 D-1 PIC 999PPP COMP-6 VALUE 95000. + 01 D-2 PIC 9999PP COMP-6 VALUE 193000. + 01 FENCE-2 PIC XXX VALUE FENCE. PROCEDURE DIVISION. DISPLAY "INIT X-1 : " X-1 " .". DISPLAY "INIT X-2 : " X-2 " .". @@ -1775,6 +2115,20 @@ AT_DATA([prog.cob], [ MULTIPLY 2 BY X-1 GIVING X-1. IF X-1 NOT = 62000 DISPLAY "* 2 failed: " X-1. + + IF FENCE-1 NOT = FENCE + DISPLAY 'broken FENCE-1' UPON SYSERR. + IF FENCE-2 NOT = FENCE + DISPLAY 'broken FENCE-2' UPON SYSERR. + IF FENCE-A NOT = FENCE + DISPLAY 'broken FENCE-A' UPON SYSERR. + IF FENCE-B NOT = FENCE + DISPLAY 'broken FENCE-B' UPON SYSERR. + IF FENCE-C NOT = FENCE + DISPLAY 'broken FENCE-C' UPON SYSERR. + IF FENCE-D NOT = FENCE + DISPLAY 'broken FENCE-D' UPON SYSERR. + STOP RUN. ]) @@ -1806,7 +2160,11 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 77 RESULT PIC 9(03) PACKED-DECIMAL. + 78 FENCE VALUE x'ABBAAB'. + 01 FILLER. + 05 FENCE-A PIC XXX VALUE FENCE. + 05 RESULT PIC 9(03) PACKED-DECIMAL. + 05 FENCE-B PIC XXX VALUE FENCE. PROCEDURE DIVISION. MAIN. * internal arithmetic to DISPLAY @@ -1840,6 +2198,11 @@ AT_DATA([prog.cob], [ IF RESULT NOT = 16 DISPLAY "NOT [+20] 16: " RESULT. + IF FENCE-A NOT = FENCE + DISPLAY 'broken FENCE-A' UPON SYSERR. + IF FENCE-B NOT = FENCE + DISPLAY 'broken FENCE-B' UPON SYSERR. + STOP RUN. ]) From 698ce4c46a82c56ffe6aa2064b7d807bf6e04a5b Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Wed, 19 Jul 2023 21:35:14 +0000 Subject: [PATCH 08/21] adjustments to compile-time checks for reference-modification cobc: * typeck.c (cb_build_identifier): allow ref-mod up to identifier length * typeck.c (cb_build_identifier): new warning for suspicious reference-modification with start or length set to maximum and the other to var * typeck.c (refmod_checks): extracted from (cb_build_identifier) * typeck.c (refmod_checks): prevent condition-names to be reference-modified additional: * typeck.c (cb_build_move_literal): optimize to cb_build_move_num_zero in more cases * parser.y (class_value): improved error messages * tree.c (cb_build_cast): set numeric category for all integer casts * tree.c (cb_build_intrinsic): refactored to get the name in a single place --- NEWS | 7 +- cobc/ChangeLog | 16 ++ cobc/parser.y | 13 +- cobc/pplex.l | 2 +- cobc/replace.c | 23 +- cobc/tree.c | 97 +++++---- cobc/typeck.c | 291 ++++++++++++++++---------- tests/testsuite.src/run_initialize.at | 2 +- tests/testsuite.src/run_misc.at | 6 +- tests/testsuite.src/run_refmod.at | 28 +-- tests/testsuite.src/run_subscripts.at | 2 +- tests/testsuite.src/syn_refmod.at | 64 ++++-- 12 files changed, 336 insertions(+), 215 deletions(-) diff --git a/NEWS b/NEWS index 0b7539dd0..5e7d66c1d 100644 --- a/NEWS +++ b/NEWS @@ -3,7 +3,7 @@ NEWS - user visible changes -*- outline -*- GnuCOBOL 3.2rc1 (20230118) GnuCOBOL 3.2rc2 (20230210) GnuCOBOL 3.2rc3 ASAP - 3.2 final (depending on feedback) around 2023/04/25 + 3.2 final (depending on feedback) end of July 2023 planned for final: * extending testsuite and documentation @@ -300,7 +300,8 @@ NEWS - user visible changes -*- outline -*- of internal memory used during CALL; this can help in finding otherwise hard to diagnose overwrite of memory and as it is only done on CALL has a much smaller footprint than -fec=bounds (as both check different - aspects at different places it is also reasonable to use both) + aspects at different places it is also reasonable to use both); + to disable it use -fmemory-check=none or limit by -fmemory-check=pointer ** the option -g does no longer imply -fno-remove-unreachable; if you want to keep those in you need to explicit specify this @@ -331,6 +332,8 @@ NEWS - user visible changes -*- outline -*- a coding error -Wsuspicious-perform-thru (enabled by default) to check for PERFORM ranges that are likely to create unwanted behaviour + -Wother now warns for suspicious reference-modification which is likely to + create out-of-bounds access at runtime ** new compiler command line option to list the known runtime exception names and fatality `cobc --list-exceptions` diff --git a/cobc/ChangeLog b/cobc/ChangeLog index c3dca3359..762f8c02e 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,19 @@ +2023-07-19 Simon Sobisch + + * typeck.c (refmod_checks): extracted from (cb_build_identifier) + * typeck.c (refmod_checks): prevent condition-names to be reference-modified + * parser.y (class_value): improved error messages + * tree.c (cb_build_cast): set numeric category for all integer casts + +2023-07-15 Simon Sobisch + + * typeck.c (cb_build_identifier): allow ref-mod up to identifier length + * typeck.c (cb_build_identifier): new warning for suspicious reference- + modification with start or length set to maximum and the other to var + * typeck.c (cb_build_move_literal): optimize to cb_build_move_num_zero in + more cases + 2023-07-13 Simon Sobisch * pplex.l (cb_ppecho_direct, output_pending_newlines): output only up @@ -218,6 +233,7 @@ * parser.y, reserved.c: added RIGHTLINE - GC extension matching LEFLINE * parser.y: drop PENDING from OVERLINE and LEFTLINE + * tree.c (cb_build_intrinsic): refactored to get the name in a single place 2023-05-24 Simon Sobisch diff --git a/cobc/parser.y b/cobc/parser.y index de7e6d7dd..69f1565cf 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -4989,12 +4989,12 @@ class_item: } | class_value THRU class_value { - if (CB_TREE_CLASS ($1) != CB_CLASS_NUMERIC && - CB_LITERAL_P ($1) && CB_LITERAL ($1)->size != 1) { + if (CB_TREE_CLASS ($1) != CB_CLASS_NUMERIC + && CB_LITERAL_P ($1) && CB_LITERAL ($1)->size != 1) { cb_error (_("CLASS literal with THRU must have size 1")); } - if (CB_TREE_CLASS ($3) != CB_CLASS_NUMERIC && - CB_LITERAL_P ($3) && CB_LITERAL ($3)->size != 1) { + if (CB_TREE_CLASS ($3) != CB_CLASS_NUMERIC + && CB_LITERAL_P ($3) && CB_LITERAL ($3)->size != 1) { cb_error (_("CLASS literal with THRU must have size 1")); } if (cb_literal_value ($1) <= cb_literal_value ($3)) { @@ -19743,11 +19743,12 @@ class_value: { if (cb_tree_category ($1) == CB_CATEGORY_NUMERIC) { if (CB_LITERAL ($1)->sign || CB_LITERAL ($1)->scale) { - cb_error (_("integer value expected")); + cb_error_x ($1, _("integer value expected")); } else { int n = cb_get_int ($1); + /* FIXME: national class has bigger "number of characters in its character set" */ if (n < 1 || n > 256) { - cb_error (_("invalid CLASS value")); + cb_error_x ($1, _("CLASS value %d outside of range for the used character set"), n); } } } diff --git a/cobc/pplex.l b/cobc/pplex.l index e17ee005f..623b2e5d4 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -2000,7 +2000,7 @@ switch_to_buffer (const int line, const char *file, const YY_BUFFER_STATE buffer /* Reset file/line */ cb_source_line = line; - cb_source_file = cobc_plex_strdup (file); + cb_source_file = file; fprintf (yyout, "#line %d \"%s\"\n", line, file); /* Switch buffer */ yy_switch_to_buffer (buffer); diff --git a/cobc/replace.c b/cobc/replace.c index 82f30b48b..ab04beeb9 100644 --- a/cobc/replace.c +++ b/cobc/replace.c @@ -274,7 +274,7 @@ void ppecho_switch (WITH_DEPTH struct cb_replacement_state *repls, fprintf (stderr, "%sppecho_switch(%s, '%s')\n", DEPTH, repls->name, text); #endif - switch( repls->ppecho ){ + switch (repls->ppecho) { case CB_PPECHO_DIRECT: #ifdef DEBUG_REPLACE fprintf (stderr, "%s ppecho_direct('%s')\n", DEPTH, text); @@ -324,9 +324,9 @@ int is_leading_or_trailing (WITH_DEPTH int leading, const size_t src_len = strlen (src_text); const size_t text_len = strlen(text); int result ; - if( text_len > src_len || ( !strict && text_len == src_len ) ){ + if (text_len > src_len || ( !strict && text_len == src_len )) { int pos = leading ? 0 : text_len - src_len ; - if( strncasecmp (src_text, text+pos, src_len) ){ + if (strncasecmp (src_text, text+pos, src_len)) { result = 0; } else { result = 1; @@ -362,7 +362,7 @@ void ppecho_leading_or_trailing (WITH_DEPTH struct cb_replacement_state *repls, if (!leading && text_len > src_len) { /* For TRAILING, we have to keep only the non-matched - * prefix part of the matching text */ + prefix part of the matching text */ const char* remaining_text = cobc_plex_strsub (text, text_len - src_len); @@ -503,7 +503,7 @@ void check_replace_all (WITH_DEPTH check_replace_after_match (MORE_DEPTH repls); } else { const char* src_text = src->text; - if ( is_space_or_nl(src_text[0]) ){ + if (is_space_or_nl(src_text[0])) { /* skip spaces in replacement */ check_replace_all (MORE_DEPTH repls,new_text,texts, src->next, replace_list); @@ -520,7 +520,7 @@ void check_replace_all (WITH_DEPTH } else { const char* text = texts->text; texts = texts->next; - if ( is_space_or_nl(text[0]) ){ + if (is_space_or_nl(text[0])) { /* skip spaces in texts */ check_replace_all (MORE_DEPTH repls, new_text, @@ -564,7 +564,7 @@ void check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls) #endif repls->current_list = NULL; if (repls->token_queue != NULL){ - if( is_space_or_nl (repls->token_queue->text[0]) ){ + if (is_space_or_nl (repls->token_queue->text[0])) { ppecho_switch (MORE_DEPTH repls, repls->token_queue->text, repls->token_queue->token); @@ -632,6 +632,9 @@ static void add_text_to_replace (WITH_DEPTH struct cb_replacement_state *repls, int prequeue, const char* text, const char* token ) { + /* CHECKME: this function takes >35% of the parsing cpu instructions, + with > 18% for memory allocation - can we reduce especially the + later in cases where REPLACE / REPLACING is not active? */ #ifdef DEBUG_REPLACE_TRACE fprintf (stderr, "%sadd_text_to_replace (%s%s, '%s')\n", DEPTH, repls->name, prequeue ? ", PREQUEUE" : "", text); @@ -640,7 +643,7 @@ static void add_text_to_replace (WITH_DEPTH struct cb_replacement_state *repls, if (is_word (MORE_DEPTH text) ) { - if( repls->text_prequeue == NULL ){ + if (repls->text_prequeue == NULL) { /* a word should be kept in the prequeue */ repls->text_prequeue = cobc_plex_strdup (text); @@ -651,7 +654,7 @@ static void add_text_to_replace (WITH_DEPTH struct cb_replacement_state *repls, cobc_plex_stradd (repls->text_prequeue, text); } - } else if ( repls->text_prequeue == NULL ){ + } else if (repls->text_prequeue == NULL) { /* not a word, and empty prequeue, just perform replacements */ add_text_to_replace (MORE_DEPTH repls, 0, text, token); @@ -724,7 +727,7 @@ struct cb_replacement_state * create_replacements (enum cb_ppecho ppecho) s->ppecho = ppecho; #ifdef DEBUG_REPLACE - if( ppecho == CB_PPECHO_REPLACE ){ + if (ppecho == CB_PPECHO_REPLACE) { s->name = "COPY-REPLACING"; } else { s->name = "REPLACE"; diff --git a/cobc/tree.c b/cobc/tree.c index 3ef441b1a..1720eea56 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -337,11 +337,11 @@ lookup_word (struct cb_reference *p, const char *name) len = COB_MAX_WORDLEN; #endif } - for (i = 0; i < len; ++i) { - word[i] = (cob_u8_t)toupper ((unsigned char)name[i]); + for (i = 0; i < len; ++i) { + word[i] = (cob_u8_t)toupper ((unsigned char)name[i]); + } + word[i] = 0; } - word[i] = 0; - } val = word_hash (word); /* Find an existing word */ @@ -1842,7 +1842,7 @@ cb_get_int (const cb_tree x) int val; if (x == NULL || x == cb_error_node) return 0; - if (CB_INTEGER_P(x)) return CB_INTEGER(x)->val; + if (CB_INTEGER_P (x)) return CB_INTEGER (x)->val; /* LCOV_EXCL_START */ if (!CB_LITERAL_P (x)) { @@ -1935,7 +1935,7 @@ cb_get_long_long (const cb_tree x) if (l->scale < 0) { size = size - l->scale; } - check_lit_length(size, (const char *)l->data + i); + check_lit_length (size, (const char *)l->data + i); /* Check numeric literal length matching requested output type */ if (unlikely (size >= 19U)) { @@ -3610,7 +3610,7 @@ cb_build_picture (const char *str) case 'U': /* this is only a hack and wrong, - adding UTF-8 type woll need a separate + adding UTF-8 type will need a separate PIC, but this will need handling in both the compiler and the runtime, so fake as ALPHANUMERIC for now */ @@ -3620,7 +3620,7 @@ cb_build_picture (const char *str) case 'N': if (!(category & PIC_NATIONAL)) { - category |= PIC_NATIONAL; + category |= PIC_NATIONAL; CB_UNFINISHED ("USAGE NATIONAL"); } x_digits += n * 2; @@ -5411,8 +5411,11 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, f = CB_FIELD (cb_ref (x)); /* ensure the reference was validated as this - also calculates the reference' picture and size */ + also calculates the reference' picture and size */ if (!f->flag_is_verified) { + /* CHECKME: why are several fields not validated + at this point? Note: level 66 are outside of the tree, + but there are others... */ cb_validate_field (f); } if (f->flag_any_length @@ -6445,9 +6448,15 @@ cb_build_cast (const enum cb_cast_type type, const cb_tree val) struct cb_cast *p; enum cb_category category; - if (type == CB_CAST_INTEGER) { + switch (type) { + case CB_CAST_INTEGER: + case CB_CAST_LONG_INT: + case CB_CAST_LENGTH: + case CB_CAST_NEGATIVE_INTEGER: + case CB_CAST_NEGATIVE_LONG_INT: category = CB_CATEGORY_NUMERIC; - } else { + break; + default: category = CB_CATEGORY_UNKNOWN; } p = make_tree (CB_TAG_CAST, category, sizeof (struct cb_cast)); @@ -7000,6 +7009,8 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, struct cb_field *fld; enum cb_category catg; + const char *name = CB_NAME (func); + /* TODO: if all arguments are constants: build a cob_field, then call into libcob to get the value and from there the string representation inserting it here directly (-> numeric/alphanumeric/national constant, @@ -7008,15 +7019,15 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, int numargs = (int)cb_list_length (args); if (unlikely (isuser)) { - if (refmod && CB_LITERAL_P(CB_PAIR_X(refmod)) && - cb_get_int (CB_PAIR_X(refmod)) < 1) { - cb_error_x (func, _("FUNCTION '%s' has invalid reference modification"), CB_NAME(func)); + if (refmod && CB_LITERAL_P (CB_PAIR_X (refmod)) + && cb_get_int (CB_PAIR_X (refmod)) < 1) { + cb_error_x (func, _("FUNCTION '%s' has invalid reference modification"), name); return cb_error_node; } - if (refmod && CB_PAIR_Y(refmod) && - CB_LITERAL_P(CB_PAIR_Y(refmod)) && - cb_get_int (CB_PAIR_Y(refmod)) < 1) { - cb_error_x (func, _("FUNCTION '%s' has invalid reference modification"), CB_NAME(func)); + if (refmod && CB_PAIR_Y (refmod) + && CB_LITERAL_P (CB_PAIR_Y (refmod)) + && cb_get_int (CB_PAIR_Y (refmod)) < 1) { + cb_error_x (func, _("FUNCTION '%s' has invalid reference modification"), name); return cb_error_node; } if (numargs > (int)current_program->max_call_param) { @@ -7025,45 +7036,45 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, return make_intrinsic (func, &userbp, args, cb_int1, refmod, 1); } - cbp = lookup_intrinsic (CB_NAME (func), 1); + cbp = lookup_intrinsic (name, 1); if (!cbp || cbp->active == CB_FEATURE_DISABLED) { - cb_error_x (func, _("FUNCTION '%s' unknown"), CB_NAME (func)); + cb_error_x (func, _("FUNCTION '%s' unknown"), name); return cb_error_node; } if (cbp->active == CB_FEATURE_NOT_IMPLEMENTED) { - cb_error_x (func, _("FUNCTION '%s' is not implemented"), - cbp->name); + cb_error_x (func, _("FUNCTION '%s' is not implemented"), name); return cb_error_node; } if ((cbp->args == -1)) { if (numargs < cbp->min_args) { cb_error_x (func, _("FUNCTION '%s' has wrong number of arguments"), - cbp->name); + name); return cb_error_node; } } else { if (numargs > cbp->args || numargs < cbp->min_args) { cb_error_x (func, _("FUNCTION '%s' has wrong number of arguments"), - cbp->name); + name); return cb_error_node; } } if (refmod) { if (!cbp->refmod) { - cb_error_x (func, _("FUNCTION '%s' cannot have reference modification"), cbp->name); + cb_error_x (func, _("FUNCTION '%s' cannot have reference modification"), name); return cb_error_node; } /* TODO: better check needed, see typeck.c (cb_build_identifier) */ - if (CB_LITERAL_P(CB_PAIR_X(refmod)) && - cb_get_int (CB_PAIR_X(refmod)) < 1) { - cb_error_x (func, _("FUNCTION '%s' has invalid reference modification"), cbp->name); + if (CB_LITERAL_P (CB_PAIR_X (refmod)) + && cb_get_int (CB_PAIR_X (refmod)) < 1) { + cb_error_x (func, _("FUNCTION '%s' has invalid reference modification"), name); return cb_error_node; } - if (CB_PAIR_Y(refmod) && CB_LITERAL_P(CB_PAIR_Y(refmod)) && - cb_get_int (CB_PAIR_Y(refmod)) < 1) { - cb_error_x (func, _("FUNCTION '%s' has invalid reference modification"), cbp->name); + if (CB_PAIR_Y (refmod) + && CB_LITERAL_P (CB_PAIR_Y (refmod)) + && cb_get_int (CB_PAIR_Y (refmod)) < 1) { + cb_error_x (func, _("FUNCTION '%s' has invalid reference modification"), name); return cb_error_node; } } @@ -7158,7 +7169,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, case CB_INTR_TEST_DAY_YYYYDDD: x = CB_VALUE (args); if (cb_tree_category (x) != CB_CATEGORY_NUMERIC) { - cb_error_x (func, _("FUNCTION '%s' has invalid argument"), cbp->name); + cb_error_x (func, _("FUNCTION '%s' has invalid argument"), name); return cb_error_node; } return make_intrinsic (func, cbp, args, NULL, refmod, 0); @@ -7233,13 +7244,13 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, /* TODO: resolve for all (?) values */ x = CB_VALUE (args); if (!CB_REF_OR_FIELD_P (x)) { - cb_error_x (func, _("FUNCTION '%s' has invalid argument"), cbp->name); + cb_error_x (func, _("FUNCTION '%s' has invalid argument"), name); return cb_error_node; } catg = cb_tree_category (x); if (catg != CB_CATEGORY_NUMERIC && catg != CB_CATEGORY_NUMERIC_EDITED) { - cb_error_x (func, _("FUNCTION '%s' has invalid argument"), cbp->name); + cb_error_x (func, _("FUNCTION '%s' has invalid argument"), name); return cb_error_node; } return make_intrinsic (func, cbp, args, NULL, refmod, 0); @@ -7247,7 +7258,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, case CB_INTR_CONTENT_LENGTH: x = CB_VALUE (args); if (cb_tree_category (x) != CB_CATEGORY_DATA_POINTER) { - cb_error_x (func, _("FUNCTION '%s' has invalid argument"), cbp->name); + cb_error_x (func, _("FUNCTION '%s' has invalid argument"), name); return cb_error_node; } return make_intrinsic (func, cbp, args, NULL, NULL, 0); @@ -7255,7 +7266,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, case CB_INTR_CONTENT_OF: x = CB_VALUE (args); if (cb_tree_category (x) != CB_CATEGORY_DATA_POINTER) { - cb_error_x (func, _("FUNCTION '%s' has invalid argument"), cbp->name); + cb_error_x (func, _("FUNCTION '%s' has invalid argument"), name); return cb_error_node; } return make_intrinsic (func, cbp, args, cb_int1, refmod, 0); @@ -7277,7 +7288,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, x = CB_VALUE (args); if (!CB_REF_OR_FIELD_P (x) && !CB_LITERAL_P (x)) { - cb_error_x (func, _ ("FUNCTION '%s' has invalid argument"), cbp->name); + cb_error_x (func, _ ("FUNCTION '%s' has invalid argument"), name); return cb_error_node; } return make_intrinsic (func, cbp, args, NULL, refmod, 0); @@ -7287,12 +7298,12 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, x = CB_VALUE (args); if (!CB_REF_OR_FIELD_P (x) &&!CB_LITERAL_P (x)) { - cb_error_x (func, _ ("FUNCTION '%s' has invalid argument"), cbp->name); + cb_error_x (func, _ ("FUNCTION '%s' has invalid argument"), name); return cb_error_node; } if (!cb_category_is_alpha (x) || cb_field_size(x) % 2 != 0) { - cb_error_x (func, _ ("FUNCTION '%s' has invalid argument"), cbp->name); + cb_error_x (func, _ ("FUNCTION '%s' has invalid argument"), name); return cb_error_node; } return make_intrinsic (func, cbp, args, NULL, refmod, 0); @@ -7329,13 +7340,13 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, case CB_INTR_SUBSTITUTE: case CB_INTR_SUBSTITUTE_CASE: if ((numargs % 2) == 0) { - cb_error_x (func, _("FUNCTION '%s' has wrong number of arguments"), cbp->name); + cb_error_x (func, _("FUNCTION '%s' has wrong number of arguments"), name); return cb_error_node; } /* TODO: follow-up arguments should be of same type */ - if (!cb_category_is_alpha_or_national(CB_VALUE (args))) { - cb_error_x (func, _("FUNCTION '%s' has invalid first argument"), cbp->name); + if (!cb_category_is_alpha_or_national (CB_VALUE (args))) { + cb_error_x (func, _("FUNCTION '%s' has invalid first argument"), name); return cb_error_node; } { @@ -7344,7 +7355,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, } default: - cb_error_x (func, _("FUNCTION '%s' unknown"), CB_NAME (func)); + cb_error_x (func, _("FUNCTION '%s' unknown"), name); return cb_error_node; } } diff --git a/cobc/typeck.c b/cobc/typeck.c index ee8ab6a59..624afc845 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2383,23 +2383,149 @@ cb_build_name_reference (struct cb_field *f1, struct cb_field *f2) return cb_build_reference (full_name); } +/* Reference modification checks */ +static void +refmod_checks (cb_tree x, struct cb_field *f, struct cb_reference *r) +{ + const char *name = r->word->name; + const int adjusted_at_runtime = -1; + int offset; + int length; + int pseudosize; + + if (f->level == 88) { + if (r->offset) { +#if 0 /* FIXME: we have to overlapping msgids - change to only use one in all of cobc */ + cb_error_x (x, _("%s may not be reference modified"), name); +#endif + cb_error_x (x, _("'%s' cannot be reference modified"), name); + r->offset = r->length = NULL; + } + return; + } + + if (!r->offset) { + /* no more checks needed */ + return; + } + + if (f->flag_any_length) { + pseudosize = 0 - f->size; + } else { + if (f->usage == CB_USAGE_NATIONAL) { + pseudosize = f->size / 2; + } else if (f->pic && f->pic->orig && f->pic->orig[0] == 'U') { + /* real "amount of codepoints" only possible to check at runtime */ + pseudosize = f->size / 4; + } else { + /* note: child elements under UNBOUNDED are not included! */ + pseudosize = f->size; + } + if (cb_field_has_unbounded (f)) { + pseudosize *= -1; + } + } + + /* Compile-time check */ + if (!r->length) { + length = 0; + } else + if (CB_LITERAL_P (r->length)) { + length = cb_get_int (r->length); + /* FIXME: needs to be supported for zero length literals */ + if (length < 1) { + cb_error_x (x, _("length of '%s' out of bounds: %d"), + name, length); + return; + } + if (pseudosize > 0 && pseudosize < length) { + cb_error_x (x, _("length of '%s' out of bounds: %d"), + name, length); + return; + } + } else { + length = adjusted_at_runtime; + } + + if (CB_LITERAL_P (r->offset)) { + offset = cb_get_int (r->offset); + if (offset < 1) { + cb_error_x (x, _("offset of '%s' out of bounds: %d"), name, offset); + return; + } + if (length == adjusted_at_runtime && offset == pseudosize) { + cb_warning_x (cb_warn_filler, x, + _("suspicious reference-modification: always using max. position")); + } else + if (pseudosize > 0) { + if (offset > pseudosize) { + cb_error_x (x, _("offset of '%s' out of bounds: %d"), name, offset); + return; + } + if (length > 0 && length > pseudosize - offset + 1) { + cb_error_x (x, _("length of '%s' out of bounds: %d"), + name, length); + return; + } + } + } else { + offset = adjusted_at_runtime; + if (length == pseudosize) { + cb_warning_x (cb_warn_filler, x, + _("suspicious reference-modification: always using max. length")); + } + } + + /* Run-time check */ + if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_REF_MOD)) { + if (f->flag_any_length + || offset == adjusted_at_runtime + || length == adjusted_at_runtime) { + cb_tree e1; + if (cb_ref_mod_zero_length == 2) { + /* allow everything but negative/zero */ + e1 = CB_BUILD_FUNCALL_3 ("cob_check_ref_mod_minimal", + CB_BUILD_STRING0 (f->name), + cb_build_cast_int (r->offset), + r->length ? + cb_build_cast_int (r->length) : + cb_int1); + optimize_defs[COB_CHK_REFMOD_MIN] = 1; + } else { + /* check upper + size + lower as requested */ + e1 = CB_BUILD_FUNCALL_6 ("cob_check_ref_mod_detailed", + CB_BUILD_STRING0 (f->name), + cb_int1, /* abend */ + cb_int (cb_ref_mod_zero_length), + f->flag_any_length ? + CB_BUILD_CAST_LENGTH (CB_TREE(f)) /* known via field.size */ : + pseudosize < 0 ? + CB_BUILD_CAST_LENGTH (x) /* needs to be runtime-calculated */ : + cb_int (pseudosize), + cb_build_cast_int (r->offset), + r->length ? + cb_build_cast_int (r->length) : + cb_int1); + optimize_defs[COB_CHK_REFMOD] = 1; + } + r->check = cb_list_add (r->check, e1); + } + } +} + cb_tree cb_build_identifier (cb_tree x, const int subchk) { struct cb_reference *r; - struct cb_field *f; - struct cb_field *p; + struct cb_field *f; + struct cb_field *p; const char *name; cb_tree v; - cb_tree e1; cb_tree l; cb_tree sub; - int offset; - int length; int n; int numsubs; int refsubs; - int pseudosize; if (x == cb_error_node) { return cb_error_node; @@ -2453,7 +2579,7 @@ cb_build_identifier (cb_tree x, const int subchk) "cob_check_linkage", cb_build_address (cb_build_field_reference (p, NULL)), CB_BUILD_STRING0 ( - CB_REFERENCE(cb_build_name_reference (p, f))->word->name), + CB_REFERENCE (cb_build_name_reference (p, f))->word->name), cb_int1); optimize_defs[COB_CHK_LINKAGE] = 1; } else @@ -2492,7 +2618,7 @@ cb_build_identifier (cb_tree x, const int subchk) } else { numsubs = f->indexes; } - if (likely(!r->flag_all)) { + if (likely (!r->flag_all)) { if (refsubs != numsubs) { if (refsubs > numsubs) { goto refsubserr; @@ -2501,8 +2627,8 @@ cb_build_identifier (cb_tree x, const int subchk) goto refsubserr; } else { cb_warning_x (COBC_WARN_FILLER, x, - _("subscript missing for '%s' - defaulting to 1"), - name); + _("subscript missing for '%s' - defaulting to 1"), + name); for (; refsubs < numsubs; ++refsubs) { CB_ADD_TO_CHAIN (cb_one, r->subs); } @@ -2534,6 +2660,7 @@ cb_build_identifier (cb_tree x, const int subchk) access to PIC L field (p->parent == f). */ && (!p->parent || p->parent == f || !p->parent->flag_picture_l) && !p->flag_unbounded) { + cb_tree e1; e1 = CB_BUILD_FUNCALL_5 ("cob_check_odo", cb_build_cast_int (p->depending), cb_int (p->occurs_min), @@ -2547,7 +2674,7 @@ cb_build_identifier (cb_tree x, const int subchk) } /* Subscript check along with setting of table offset */ - if (r->subs &&! cb_validate_list (r->subs)) { + if (r->subs && !cb_validate_list (r->subs)) { l = r->subs; for (p = f; p && l; p = p->parent) { if (!p->flag_occurs) { @@ -2574,6 +2701,7 @@ cb_build_identifier (cb_tree x, const int subchk) if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) { if (cb_subscript_check != CB_SUB_CHECK_MAX && p->depending && p->depending != cb_error_node) { + cb_tree e1; e1 = CB_BUILD_FUNCALL_4 ("cob_check_subscript", cb_build_cast_int (sub), cb_build_cast_int (p->depending), @@ -2581,16 +2709,16 @@ cb_build_identifier (cb_tree x, const int subchk) cb_int1); optimize_defs[COB_CHK_SUBSCRIPT] = 1; r->check = cb_list_add (r->check, e1); - } else { - if (!CB_LITERAL_P (sub)) { - e1 = CB_BUILD_FUNCALL_4 ("cob_check_subscript", - cb_build_cast_int (sub), - cb_int (p->occurs_max), - CB_BUILD_STRING0 (name), - cb_int0); - optimize_defs[COB_CHK_SUBSCRIPT] = 1; - r->check = cb_list_add (r->check, e1); - } + } else + if (!CB_LITERAL_P (sub)) { + cb_tree e1; + e1 = CB_BUILD_FUNCALL_4 ("cob_check_subscript", + cb_build_cast_int (sub), + cb_int (p->occurs_max), + CB_BUILD_STRING0 (name), + cb_int0); + optimize_defs[COB_CHK_SUBSCRIPT] = 1; + r->check = cb_list_add (r->check, e1); } } } @@ -2603,92 +2731,7 @@ cb_build_identifier (cb_tree x, const int subchk) r->subs = cb_list_reverse (r->subs); } - /* Reference modification check */ - if (f->flag_any_length) { - pseudosize = 0 - f->size; - } else { - if (f->usage == CB_USAGE_NATIONAL) { - pseudosize = f->size / 2; - } else if (f->pic && f->pic->orig && f->pic->orig[0] == 'U') { - pseudosize = f->size / 4; - } else { - /* note: child elements under UNBOUNDED are not included! */ - pseudosize = f->size; - } - if (cb_field_has_unbounded (f)) { - pseudosize *= -1; - } - } - if (r->offset) { - /* Compile-time check */ - if (CB_LITERAL_P (r->offset)) { - offset = cb_get_int (r->offset); - if (pseudosize < 0) { - if (offset < 1) { - cb_error_x (x, _("offset of '%s' out of bounds: %d"), name, offset); - } else if (r->length && CB_LITERAL_P (r->length)) { - length = cb_get_int (r->length); - /* FIXME: needs to be supported for zero length literals */ - if (length < 1) { - cb_error_x (x, _("length of '%s' out of bounds: %d"), - name, length); - } - } - } else { - if (offset < 1 || offset > pseudosize) { - cb_error_x (x, _("offset of '%s' out of bounds: %d"), name, offset); - } else if (r->length && CB_LITERAL_P (r->length)) { - length = cb_get_int (r->length); - /* FIXME: needs to be supported for zero length literals */ - if (length < 1 || length > pseudosize - offset + 1) { - cb_error_x (x, _("length of '%s' out of bounds: %d"), - name, length); - } - } - } - } else if (r->length && CB_LITERAL_P (r->length)) { - length = cb_get_int (r->length); - /* FIXME: needs to be supported for zero length literals */ - if (length < 1 || (pseudosize > 0 && pseudosize <= length)) { - cb_error_x (x, _("length of '%s' out of bounds: %d"), - name, length); - } - } - - /* Run-time check */ - if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_REF_MOD)) { - if (f->flag_any_length || !CB_LITERAL_P (r->offset) || - (r->length && !CB_LITERAL_P (r->length))) { - /* allow everything but negative/zero */ - if (cb_ref_mod_zero_length == 2) { - e1 = CB_BUILD_FUNCALL_3 ("cob_check_ref_mod_minimal", - CB_BUILD_STRING0 (f->name), - cb_build_cast_int (r->offset), - r->length ? - cb_build_cast_int (r->length) : - cb_int1); - optimize_defs[COB_CHK_REFMOD_MIN] = 1; - } else { - /* check upper + size + lower as requested */ - e1 = CB_BUILD_FUNCALL_6 ("cob_check_ref_mod_detailed", - CB_BUILD_STRING0 (f->name), - cb_int1, /* abend */ - cb_int (cb_ref_mod_zero_length), - f->flag_any_length ? - CB_BUILD_CAST_LENGTH (v) /* known via field.size */ : - pseudosize < 0 ? - CB_BUILD_CAST_LENGTH (x) /* needs to be runtime-calculated */ : - cb_int (pseudosize), - cb_build_cast_int (r->offset), - r->length ? - cb_build_cast_int (r->length) : - cb_int1); - optimize_defs[COB_CHK_REFMOD] = 1; - } - r->check = cb_list_add (r->check, e1); - } - } - } + refmod_checks (x, f, r); if (f->storage == CB_STORAGE_CONSTANT) { return f->values; @@ -2706,8 +2749,7 @@ cb_build_identifier (cb_tree x, const int subchk) cb_error_x (x, _("'%s' requires one subscript"), name); break; default: - cb_error_x (x, _("'%s' requires %d subscripts"), - name, f->indexes); + cb_error_x (x, _("'%s' requires %d subscripts"), name, f->indexes); break; } return cb_error_node; @@ -2737,8 +2779,7 @@ cb_build_length_1 (cb_tree x) size = cb_build_binary_op (size, '*', f->depending); } } else if (f->occurs_max > 1) { - size = cb_build_binary_op (size, '*', - cb_int (f->occurs_max)); + size = cb_build_binary_op (size, '*', cb_int (f->occurs_max)); } e = e ? cb_build_binary_op (e, '+', size) : size; } @@ -4778,7 +4819,7 @@ cb_validate_program_data (struct cb_program *prog) } else if (cb_ref (q->depending) != cb_error_node) { cb_tree dep_x = q->depending; if (cb_tree_category (dep_x) != CB_CATEGORY_NUMERIC) { - cb_error_x (dep_x, _ ("'%s' is not numeric"), cb_name (dep_x)); + cb_error_x (dep_x, _("'%s' is not numeric"), cb_name (dep_x)); q->depending = cb_error_node; } else { depfld = CB_FIELD_PTR (q->depending); @@ -12190,15 +12231,34 @@ cb_build_move_literal (cb_tree src, cb_tree dst) return CB_BUILD_FUNCALL_2 ("cob_move", src, dst); } - if ((f->usage == CB_USAGE_PACKED || f->usage == CB_USAGE_COMP_6) + if ((f->usage == CB_USAGE_PACKED + || f->usage == CB_USAGE_COMP_6) && cb_fits_int (src)) { + /* early check for unsigned zero or non-signed field */ + if (l->sign == 0 + || !f->pic->have_sign) { + int i; + for (i = 0; i < l->size; i++) { + if (l->data[i] != '0') { + break; + } + } + if (i == l->size) { + return cb_build_move_num_zero (dst); + } + } + + /* postpone PPPs and non-integer settings to runtime */ if (f->pic->scale < 0) { + /* TODO: handle this case here */ return CB_BUILD_FUNCALL_2 ("cob_move", src, dst); } n = f->pic->scale - l->scale; if ((l->size + n) > 9) { return CB_BUILD_FUNCALL_2 ("cob_move", src, dst); } + + /* get value, then store as integer */ val = cb_get_int (src); for (; n > 0; n--) { val *= 10; @@ -12206,7 +12266,10 @@ cb_build_move_literal (cb_tree src, cb_tree dst) for (; n < 0; n++) { val /= 10; } - if (val == 0) { + if (val == 0 + && (l->sign == 0 + || !f->pic->have_sign)) { + /* shortcut if the (trimmed) value is zero */ return cb_build_move_num_zero (dst); } if (val < 0 && !f->pic->have_sign) { diff --git a/tests/testsuite.src/run_initialize.at b/tests/testsuite.src/run_initialize.at index d2262b375..4edc8a775 100644 --- a/tests/testsuite.src/run_initialize.at +++ b/tests/testsuite.src/run_initialize.at @@ -557,7 +557,7 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP -AT_SETUP([INITIALIZE with reference modification]) +AT_SETUP([INITIALIZE with reference-modification]) AT_KEYWORDS([initialize]) AT_DATA([prog.cob], [ diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 699d59e0a..bdfc0b16d 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -1035,7 +1035,7 @@ AT_CLEANUP ## Expressions -AT_SETUP([Class check with reference modification]) +AT_SETUP([Class check with reference-modification]) AT_KEYWORDS([runmisc]) AT_DATA([prog.cob], [ @@ -10505,8 +10505,6 @@ AT_DATA([sub2.cob], [ END PROGRAM sub2. ]) -AT_CAPTURE_FILE([tstdump.dump]) - AT_CHECK([$COMPILE_MODULE -fdump=ALL prog.cob sub2.cob], [0], [], []) AT_CHECK([COB_DUMP_FILE=NONE \ @@ -10518,6 +10516,8 @@ X is 000005441 libcob: cpyabrt:4: warning: implicit CLOSE of FLATFILE ('RELFIX') ]) +AT_CAPTURE_FILE([tstdump.dump]) + AT_CHECK([COB_DUMP_FILE=tstdump.dump \ $COBCRUN prog], [1], [X is 000000001 diff --git a/tests/testsuite.src/run_refmod.at b/tests/testsuite.src/run_refmod.at index 48baf65ac..74f599ebe 100644 --- a/tests/testsuite.src/run_refmod.at +++ b/tests/testsuite.src/run_refmod.at @@ -1,4 +1,4 @@ -## Copyright (C) 2003-2012, 2014-2015, 2017-2020 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2014-2015, 2017-2020, 2013 Free Software Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart ## ## This file is part of GnuCOBOL. @@ -22,7 +22,7 @@ ## 8.4.2.3.3 General rules -AT_SETUP([Static reference modification]) +AT_SETUP([Static reference-modification]) AT_KEYWORDS([refmod]) AT_DATA([prog.cob], [ @@ -54,7 +54,7 @@ d:d AT_CLEANUP -AT_SETUP([Dynamic reference modification]) +AT_SETUP([Dynamic reference-modification]) AT_KEYWORDS([refmod]) AT_DATA([prog.cob], [ @@ -334,11 +334,11 @@ AT_DATA([prog.cob], [ . ]) -AT_CHECK([$COMPILE -fno-ec=BOUND-REF-MOD prog.cob], [0], [], []) +AT_CHECK([$COMPILE -w -fno-ec=BOUND-REF-MOD prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [cd.], []) -AT_CHECK([$COMPILE -fno-ec=BOUND prog.cob -o progb], [0], [], []) +AT_CHECK([$COMPILE -w -fno-ec=BOUND prog.cob -o progb], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./progb], [0], [cd.], []) -AT_CHECK([$COMPILE prog.cob -o progc], [0], [], []) +AT_CHECK([$COMPILE -w prog.cob -o progc], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./progc], [1], [], [libcob: prog.cob:13: error: length of 'y' out of bounds: 2, starting at: 3, maximum: 3 ]) @@ -371,13 +371,13 @@ AT_DATA([prog2.cob], [ . ]) -AT_CHECK([$COMPILE -fno-ec=BOUND-REF-MOD prog2.cob], [0], [], []) +AT_CHECK([$COMPILE -w -fno-ec=BOUND-REF-MOD prog2.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [.ab.], []) -AT_CHECK([$COMPILE -o prog2b prog2.cob], [0], [], []) +AT_CHECK([$COMPILE -w -o prog2b prog2.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog2b], [1], [.], [libcob: prog2.cob:20: error: length of 'y' out of bounds: 2, maximum: 1 ]) -AT_CHECK([$COMPILE -fno-ref-mod-zero-length -o prog2c prog2.cob], [0], [], []) +AT_CHECK([$COMPILE -w -fno-ref-mod-zero-length -o prog2c prog2.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog2c], [1], [], [libcob: prog2.cob:13: error: length of 'y' out of bounds: 0 ]) @@ -410,7 +410,7 @@ AT_DATA([prog.cob], [ GOBACK. ]) -AT_CHECK([$COBC -x -debug -std=mf prog.cob], [0], [], []) +AT_CHECK([$COBC -w -x -debug -std=mf prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ !], []) AT_DATA([prog1.cob], [ @@ -432,7 +432,7 @@ AT_DATA([prog1.cob], [ GOBACK. ]) -AT_CHECK([$COBC -x -std=mf prog1.cob], [0], [], []) +AT_CHECK([$COBC -w -x -std=mf prog1.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog1], [1], [ !], [libcob: prog1.cob:16: error: length of 'y' out of bounds: 0 ]) @@ -458,12 +458,12 @@ AT_DATA([prog2.cob], [ GOBACK. ]) -AT_CHECK([$COBC -x -std=mf -DTEST-ZERO-LEN-REF-MOD prog2.cob], [0], [], []) +AT_CHECK([$COBC -w -x -std=mf -DTEST-ZERO-LEN-REF-MOD prog2.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog2], [1], [], [libcob: prog2.cob:16: error: length of 'y' out of bounds: 0 ]) -AT_CHECK([$COBC -x -std=mf -o prog2b prog2.cob], [0], [], []) +AT_CHECK([$COBC -w -x -std=mf -o prog2b prog2.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog2b], [1], [], [libcob: prog2.cob:18: error: length of 'y' out of bounds: 2, maximum: 1 ]) @@ -487,7 +487,7 @@ AT_DATA([prog3.cob], [ GOBACK. ]) -AT_CHECK([$COBC -x -std=mf prog3.cob], [0], [], []) +AT_CHECK([$COBC -w -x -std=mf prog3.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog3], [1], [], [libcob: prog3.cob:16: error: length of 'y' out of bounds: 2, maximum: 1 ]) diff --git a/tests/testsuite.src/run_subscripts.at b/tests/testsuite.src/run_subscripts.at index 3782e6ef7..29bb38c7a 100644 --- a/tests/testsuite.src/run_subscripts.at +++ b/tests/testsuite.src/run_subscripts.at @@ -239,7 +239,7 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP -AT_SETUP([length of ODO w/- reference modification]) +AT_SETUP([length of ODO w/- reference-modification]) AT_KEYWORDS([runsubscripts subscripts]) AT_DATA([prog.cob], [ diff --git a/tests/testsuite.src/syn_refmod.at b/tests/testsuite.src/syn_refmod.at index 04005e51a..5f75aab5f 100644 --- a/tests/testsuite.src/syn_refmod.at +++ b/tests/testsuite.src/syn_refmod.at @@ -23,7 +23,7 @@ ## 8.4.2.3.3 General rules -AT_SETUP([valid reference modification]) +AT_SETUP([valid reference-modification]) AT_KEYWORDS([refmod]) AT_DATA([prog.cob], [ @@ -32,19 +32,46 @@ AT_DATA([prog.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. 01 X PIC X(4) VALUE "abcd". + 77 VAR PIC 9 VALUE 1. PROCEDURE DIVISION. - DISPLAY X(1:1) ":" X(1:2) ":" X(1:3) ":" X(1:4) ":" X(1:) - END-DISPLAY. - DISPLAY X(2:1) ":" X(2:2) ":" X(2:3) ":" X(2:) - END-DISPLAY. - DISPLAY X(3:1) ":" X(3:2) ":" X(3:) - END-DISPLAY. - DISPLAY X(4:1) ":" X(4:) - END-DISPLAY. + DISPLAY X(1:1) ":" X(1:2) ":" X(1:3) ":" X(1:4) ":" X(1:). + DISPLAY X(2:1) ":" X(2:2) ":" X(2:3) ":" X(2:). + DISPLAY X(3:1) ":" X(3:2) ":" X(3:). + DISPLAY X(4:1) ":" X(4:). + DISPLAY X(1:4) + DISPLAY X(VAR:4) + DISPLAY X(4:) + DISPLAY X(4:VAR) STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COMPILE -fdiagnostics-show-option prog.cob], [0], [], +[prog.cob:14: warning: suspicious reference-modification: always using max. length [[-Wothers]] +prog.cob:16: warning: suspicious reference-modification: always using max. position [[-Wothers]] +]) + +AT_CLEANUP + +AT_SETUP([invalid reference-modification]) +AT_KEYWORDS([refmod condition-name]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "abcd". + 88 X-AB VALUE "AB". + PROCEDURE DIVISION. + DISPLAY X-AB(1:1). + *> TODO: more to add + GOBACK. +]) + +AT_CHECK([$COMPILE prog.cob], [1], [], +[prog.cob:9: error: 'X-AB' cannot be reference modified +prog.cob:9: error: condition-name not allowed here: 'X-AB' +]) AT_CLEANUP @@ -96,6 +123,8 @@ AT_CLEANUP AT_SETUP([constant-folding out of bounds]) AT_KEYWORDS([refmod expression]) +# note: actually checking out of bounds in general, too + AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. @@ -106,13 +135,9 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION. IF VAR-LEN < 4 DISPLAY X(4 - VAR-LEN:1) - END-DISPLAY DISPLAY X(1: 4 - VAR-LEN) - END-DISPLAY DISPLAY X(9 - VAR-LEN:1) - END-DISPLAY DISPLAY X(1:9 - VAR-LEN) - END-DISPLAY *> special test... INSPECT X CONVERTING "DEF" TO X (1:0 + VAR-LEN) END-IF @@ -121,13 +146,12 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY -fdiagnostics-show-option -Wno-constant-numlit-expression prog.cob], [0], [], [prog.cob:10: warning: offset of 'X' out of bounds: 0 [[-Wignored-error]] -prog.cob:12: warning: length of 'X' out of bounds: 0 [[-Wignored-error]] -prog.cob:14: warning: offset of 'X' out of bounds: 5 [[-Wignored-error]] -prog.cob:16: warning: length of 'X' out of bounds: 5 [[-Wignored-error]] -prog.cob:19: warning: CONVERTING operands differ in size [[-Wignored-error]] +prog.cob:11: warning: length of 'X' out of bounds: 0 [[-Wignored-error]] +prog.cob:12: warning: offset of 'X' out of bounds: 5 [[-Wignored-error]] +prog.cob:13: warning: length of 'X' out of bounds: 5 [[-Wignored-error]] +prog.cob:15: warning: CONVERTING operands differ in size [[-Wignored-error]] ]) -AT_CHECK([$COMPILE_ONLY -Wno-constant-numlit-expression -fno-constant-folding prog.cob], -[0], [], []) +AT_CHECK([$COMPILE_ONLY -Wno-constant-numlit-expression -fno-constant-folding prog.cob], [0], [], []) AT_CLEANUP From 0937903ab05a6c251502accb0c5f2f39ae98a247 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 20 Jul 2023 21:54:07 +0000 Subject: [PATCH 09/21] improved handling for TYPEDEF / SAME AS and symbol-listing/Xref * field.c (copy_validation): new function * field.c (copy_into_field_recursive, copy_into_field): * handling more field attributes * don't re-build picture * handling validation * cobc.c (print_fields): leave a hint to field being TYPEDEF * cobc.c (xref_fields): dont output references for TYPEDEF sub items --- cobc/ChangeLog | 9 +++ cobc/cobc.c | 22 +++++- cobc/field.c | 69 +++++++++++++++-- tests/testsuite.src/syn_definition.at | 105 +++++++++++++++++++------- 4 files changed, 169 insertions(+), 36 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 762f8c02e..46abe4ec2 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,11 @@ +2023-07-20 Simon Sobisch + + * field.c (copy_validation): new function + * field.c (copy_validation, copy_into_field): handling validation + * cobc.c (print_fields): leave a hint to field being TYPEDEF + * cobc.c (xref_fields): dont output references for TYPEDEF sub items + 2023-07-19 Simon Sobisch * typeck.c (refmod_checks): extracted from (cb_build_identifier) @@ -223,6 +230,8 @@ 2023-05-30 Simon Sobisch * typeck.y (is_subordinate_to): start with parent, not field + * field.c (copy_into_field_recursive, copy_into_field): handling more + field attributes, don't re-build picture 2023-05-28 Simon Sobisch diff --git a/cobc/cobc.c b/cobc/cobc.c index 0867596d3..52b47f684 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -719,7 +719,7 @@ static void print_program_header (void); static void print_program_data (const char *); static void print_program_trailer (void); static void print_program_listing (void); -static void print_with_overflow (char *, char *); +static void print_with_overflow (const char *, char *); static int process (const char *); /* cobc functions */ @@ -5687,6 +5687,7 @@ print_88_values (struct cb_field *field) " %-14.14s %02d %s", "CONDITIONAL", f->level, f->name); print_program_data (print_data); + /* CHECKME: Would it be useful or noise to print 88er values here? */ } } @@ -5747,7 +5748,14 @@ print_fields (struct cb_field *top, int *found) pd_off = sprintf (print_data, "%05d ", top->size); } - pd_off += sprintf (print_data + pd_off, "%-14.14s %02d ", type, top->level); + if (top->flag_is_typedef) { + /* at least leave a hint on the TYPEDEF in symbol listing, + note: for "ALPHANUMERIC" we have only 2 positions left, so "T " */ + pd_off += sprintf (print_data + pd_off, "T %-12.12s ", type); + } else { + pd_off += sprintf (print_data + pd_off, "%-14.14s ", type); + } + pd_off += sprintf (print_data + pd_off, "%02d ", top->level); name_or_filler = check_filler_name (top); if (got_picture) { @@ -6064,6 +6072,12 @@ xref_fields (struct cb_field *top) xref_print (&top->xref, XREF_FIELD, NULL); } + /* enough, if we are a typedef, as its contents are only + referenced through fields using this type */ + if (top->flag_is_typedef) { + continue; + } + /* print xref for all assigned 88 validation entries */ if (top->validation) { xref_88_values (top); @@ -6308,7 +6322,7 @@ print_program_trailer (void) cmd_line[pd_off - 1] = 0; force_new_page_for_next_line (); print_program_data (_("command line:")); - print_with_overflow ((char *)" ", cmd_line); + print_with_overflow (" ", cmd_line); print_break = 0; } else { print_program_data (""); @@ -6749,7 +6763,7 @@ print_free_line (const int line_num, char pch, char *line) } static void -print_with_overflow (char *prefix, char *content) +print_with_overflow (const char *prefix, char *content) { const unsigned int max_chars_on_line = cb_listing_wide ? 120 : 80; int offset; diff --git a/cobc/field.c b/cobc/field.c index dc12c8577..8b9e4ce3e 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -701,6 +701,33 @@ copy_duplicated_field_into_field (struct cb_field *field, struct cb_field *targe copy_into_field_recursive (field, CB_FIELD (x), outer_indexes); } +static void +copy_validation (struct cb_field *source, struct cb_field *target) +{ + struct cb_field *val, *last_val; +#if 0 /* in case we want to allow combining condition-names of typedef and field */ + for (last_val = target->validation; last_val; last_val = last_val->sister) { + /* get to the last validation entry*/ + if (!last_val->sister) { + break; + } + } +#else + if (target->validation) { + (void) cb_syntax_check_x (CB_TREE (target->validation), _("duplicate %s"), "level 88"); + } +#endif + for (val = source->validation; val; val = val->sister) { + /* create content-name and link into the reference list */ + cb_tree x = cb_build_field_tree (88, cb_build_reference (val->name), + target, target->storage, target->file, 0); + last_val = CB_FIELD (x); + /* directly assign the typef's value + false (no need for copy) */ + last_val->values = val->values; + last_val->false_88 = val->false_88; + } +} + static void copy_children (struct cb_field *child, struct cb_field *target, const int level, const int outer_indexes, const enum cb_storage storage) @@ -800,10 +827,12 @@ copy_into_field_recursive (struct cb_field *source, struct cb_field *target, field_attribute_override (flag_sign_leading); field_attribute_override (flag_sign_separate); field_attribute_override (flag_synchronized); - field_attribute_override (flag_item_based); + field_attribute_override (flag_sync_right); + field_attribute_override (flag_sync_left); field_attribute_override (flag_any_length); field_attribute_override (flag_any_numeric); field_attribute_override (flag_invalid); + field_attribute_override (flag_item_based); field_attribute_override (flag_is_pointer); /* Note: attributes must be handled both here and in copy_into_field */ @@ -814,10 +843,18 @@ copy_into_field_recursive (struct cb_field *source, struct cb_field *target, target->redefines = cb_resolve_redefines (target, ref); } + /* copy all level 88 */ + if (source->validation) { + copy_validation (source, target); + } + if (source->children) { copy_children (source->children, target, target->level, outer_indexes, target->storage); } else if (source->pic){ - target->pic = cb_build_picture (source->pic->orig); + /* take over internal PICTURE representation as-is, no use in re-building + that from scratch and handle calculated ->pic special */ + target->pic = cobc_parse_malloc (sizeof (struct cb_picture)); + memcpy (target->pic, source->pic, sizeof (struct cb_picture)); } if (source->sister) { @@ -846,7 +883,8 @@ copy_into_field (struct cb_field *source, struct cb_field *target) #endif /* note: EXTERNAL is always applied from the typedef (if level 1/77), - but may be specified on the field */ + but may be specified on the field; + note: MF has different syntax rules and _only_ allows it on the field */ if (target->level == 1 || target->level == 77) { field_attribute_copy (flag_external); if (target->flag_external @@ -859,6 +897,11 @@ copy_into_field (struct cb_field *source, struct cb_field *target) } } target->usage = source->usage; + target->common.category = source->common.category; + + /* Note: The attributes GLOBAL and SELECT WHEN are never included; + SAME AS does not include EXTERNAL, but the TYPEDEF */ + if (source->values) { if (target->values) { duplicate_clause_message (target->values, "VALUE"); @@ -871,19 +914,32 @@ copy_into_field (struct cb_field *source, struct cb_field *target) field_attribute_copy (flag_sign_clause); field_attribute_copy (flag_sign_leading); field_attribute_copy (flag_sign_separate); - field_attribute_copy (flag_synchronized); - field_attribute_copy (flag_item_based); + if (source->flag_synchronized + && !target->flag_synchronized) { + target->flag_synchronized = source->flag_synchronized; + target->flag_sync_right = source->flag_sync_right; + target->flag_sync_left = source->flag_sync_left; + } field_attribute_override (flag_any_length); field_attribute_override (flag_any_numeric); field_attribute_override (flag_invalid); + field_attribute_copy (flag_item_based); field_attribute_override (flag_is_pointer); /* Note: attributes must be handled both here and in copy_into_field_recursive */ + /* copy all level 88 */ + if (source->validation) { + copy_validation (source, target); + } + if (unlikely (!target->like_modifier)) { if (source->children) { copy_children (source->children, target, target->level, target->indexes, target->storage); } else if (source->pic) { - target->pic = cb_build_picture (source->pic->orig); + /* take over internal PICTURE representation as-is, no use in re-building + that from scratch and in handling calculated ->pic special */ + target->pic = cobc_parse_malloc (sizeof (struct cb_picture)); + memcpy (target->pic, source->pic, sizeof (struct cb_picture)); } } else { struct cb_picture *new_pic = NULL; @@ -954,6 +1010,7 @@ copy_into_field (struct cb_field *source, struct cb_field *target) if (new_pic) { target->pic = new_pic; } else if (target->pic) { + /* CHECKME: is there any use in re-building the PIC? */ target->pic = cb_build_picture (target->pic->orig); } } diff --git a/tests/testsuite.src/syn_definition.at b/tests/testsuite.src/syn_definition.at index 181f11e0f..19e179962 100644 --- a/tests/testsuite.src/syn_definition.at +++ b/tests/testsuite.src/syn_definition.at @@ -2217,7 +2217,7 @@ AT_CLEANUP AT_SETUP([TYPEDEF clause]) -AT_KEYWORDS([definition EXTERNAL GLOBAL TYPE USAGE listing symbols]) +AT_KEYWORDS([definition EXTERNAL GLOBAL TYPE USAGE listing symbols xref]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -2246,7 +2246,9 @@ AT_DATA([prog.cob], [ 49 MT3 USAGE MESSAGE-TEXT-2T. 49 MT3-REN REDEFINES MT3 USAGE MESSAGE-TEXT-2T. - 77 CALCULUS PIC S9(15)V9(03) IS TYPEDEF. + 01 CALCULUS PIC S9(15)V9(03) IS TYPEDEF. + 88 NO-DETAIL VALUE ZERO. + 88 MIN-DETAIL VALUE 0.001. 01 USER-TYPE IS TYPEDEF. 02 AMOUNT USAGE CALCULUS. 02 FILLER OCCURS 100. @@ -2254,6 +2256,7 @@ AT_DATA([prog.cob], [ 01 USER-VAR USAGE USER-TYPE. 01 PROC USAGE PROGRAM-POINTER IS TYPEDEF. + 88 PROC-UNSET VALUE NULL. 77 MY-PROC USAGE PROC VALUE NULL. PROCEDURE DIVISION. @@ -2362,10 +2365,10 @@ prog.cob:21: error: USAGE type-name does not conform to COBOL 2002 prog.cob:23: error: USAGE type-name does not conform to COBOL 2002 prog.cob:25: error: USAGE type-name does not conform to COBOL 2002 prog.cob:26: error: USAGE type-name does not conform to COBOL 2002 -prog.cob:30: error: USAGE type-name does not conform to COBOL 2002 prog.cob:32: error: USAGE type-name does not conform to COBOL 2002 -prog.cob:33: error: USAGE type-name does not conform to COBOL 2002 -prog.cob:36: error: USAGE type-name does not conform to COBOL 2002 +prog.cob:34: error: USAGE type-name does not conform to COBOL 2002 +prog.cob:35: error: USAGE type-name does not conform to COBOL 2002 +prog.cob:39: error: USAGE type-name does not conform to COBOL 2002 ]) AT_CHECK([$COMPILE_ONLY -std=mf-strict prog.cob], [0], [], []) AT_CHECK([$COMPILE_ONLY progstd.cob], [0], [], []) @@ -2395,33 +2398,77 @@ badprog.cob:11: error: illegal combination of TYPE TO with other clauses badprog.cob:12: error: elementary item expected ]) +# FIXME: mises NO-DETAIL above MIN-DETAIL (likely bug in copying in field.c) + +AT_CHECK([$COMPILE_LISTING0 -t - -Xref -fno-tsource -fno-tmessages prog.cob], +[0], +[GnuCOBOL V.R.P prog.cob + +NAME DEFINED REFERENCES + +AUSGABE-FILE-NAME-T 6 13 17 x2 +SOME-VERY-LONG-TYPEDEF-NAME 7 10 21 x2 +AUSGABE-FILE-NAME-2T 8 16 23 x2 +MESSAGE-TEXT-2T 12 19 25 26 x3 +MESSAGE-TEXT-2 19 42 x1 +AUSGABE-FILE-NAME 21 42 x1 +AUSGABE-FILE-NAME-2 21 referenced by parent +DETAIL-NO 21 referenced by parent +OUTPUT-NAME 21 45 x1 +Z-MESSAGE-T2 23 43 x1 +DETAIL-NO 24 43 x1 +Z-MESSAGE-T3 24 referenced by child +MT3 25 44 x1 +AUSGABE-FILE-NAME 26 44 x1 +AUSGABE-FILE-NAME-2 26 referenced by parent +DETAIL-NO 26 referenced by parent +MT3-REN 26 not referenced +AUSGABE-FILE-NAME 28 not referenced +AUSGABE-FILE-NAME-2 28 not referenced +DETAIL-NO 28 not referenced +CALCULUS 28 32 34 x2 +USER-TYPE 31 35 x1 +USER-VAR 35 referenced by child +AMOUNT 37 *46 47 x2 +MIN-DETAIL 37 not referenced +GRP-AMOUNT 37 *47 x1 +MIN-DETAIL 37 not referenced +PROC 37 39 x1 +MY-PROC 39 48 *49 x2 +PROC-UNSET 41 not referenced + + +LABEL DEFINED REFERENCES + +E prog 42 + +], []) + AT_CAPTURE_FILE([symbols.lst]) -AT_CHECK([$COMPILE_ONLY -std=mf-strict -t symbols.lst -tsymbols -fno-tsource -fno-tmessages -tlines=0 prog.cob], +AT_CHECK([$COMPILE_LISTING0 -t symbols.lst -tsymbols -fno-tsource -fno-tmessages prog.cob], [0], [], []) -AT_CHECK([$UNIFY_LISTING symbols.lst symbols.lis once], [0], [], []) - AT_CHECK([test "$COB_HAS_64_BIT_POINTER" = "yes"], [0], [], [], [ # Previous test "failed" --> 32 bit AT_DATA([prog-32.lst], -[GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY +[GnuCOBOL V.R.P prog.cob SIZE TYPE LVL NAME PICTURE WORKING-STORAGE SECTION -00050 ALPHANUMERIC 01 AUSGABE-FILE-NAME-T X(50) +00050 T ALPHANUMERIC 01 AUSGABE-FILE-NAME-T X(50) -00004 NUMERIC 01 SOME-VERY-LONG-TYPEDEF-NAME 9999 +00004 T NUMERIC 01 SOME-VERY-LONG-TYPEDEF-NAME 9999 -00008 GROUP 01 AUSGABE-FILE-NAME-2T +00008 T GROUP 01 AUSGABE-FILE-NAME-2T 00004 NUMERIC 05 FILLER 9999 00004 NUMERIC 05 DETAIL-NO SOME-VERY-LONG-TYPEDE... -00108 GROUP 01 MESSAGE-TEXT-2T +00108 T GROUP 01 MESSAGE-TEXT-2T 00050 ALPHANUMERIC 02 AUSGABE-FILE-NAME AUSGABE-FILE-NAME-T 00004 GROUP 02 FILLER, REDEFINES AUSGABE-FILE-NAME 00004 NUMERIC 05 FILLER 9999 @@ -2438,44 +2485,47 @@ SIZE TYPE LVL NAME PICTURE 00108 GROUP 49 MT3 MESSAGE-TEXT-2T 00108 GROUP 49 MT3-REN MESSAGE-TEXT-2T, REDEFINES MT3 -00018 NUMERIC 77 CALCULUS S9(15)V9(03) +00018 T NUMERIC 01 CALCULUS S9(15)V9(03) + CONDITIONAL 88 NO-DETAIL + CONDITIONAL 88 MIN-DETAIL -01818 GROUP 01 USER-TYPE +01818 T GROUP 01 USER-TYPE 00018 NUMERIC 02 AMOUNT CALCULUS 01800 GROUP 02 FILLER OCCURS 100 00018 NUMERIC 05 GRP-AMOUNT CALCULUS 01818 GROUP 01 USER-VAR USER-TYPE -00004 POINTER 01 PROC PROGRAM-POINTER +00004 T POINTER 01 PROC PROGRAM-POINTER + CONDITIONAL 88 PROC-UNSET 00004 POINTER 77 MY-PROC PROC ]) -AT_CHECK([diff prog-32.lst symbols.lis], [0], [], []) +AT_CHECK([diff prog-32.lst symbols.lst], [0], [], []) ] , [ # Previous test "passed" --> 64 bit AT_DATA([prog-64.lst], -[GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY +[GnuCOBOL V.R.P prog.cob SIZE TYPE LVL NAME PICTURE WORKING-STORAGE SECTION -00050 ALPHANUMERIC 01 AUSGABE-FILE-NAME-T X(50) +00050 T ALPHANUMERIC 01 AUSGABE-FILE-NAME-T X(50) -00004 NUMERIC 01 SOME-VERY-LONG-TYPEDEF-NAME 9999 +00004 T NUMERIC 01 SOME-VERY-LONG-TYPEDEF-NAME 9999 -00008 GROUP 01 AUSGABE-FILE-NAME-2T +00008 T GROUP 01 AUSGABE-FILE-NAME-2T 00004 NUMERIC 05 FILLER 9999 00004 NUMERIC 05 DETAIL-NO SOME-VERY-LONG-TYPEDE... -00108 GROUP 01 MESSAGE-TEXT-2T +00108 T GROUP 01 MESSAGE-TEXT-2T 00050 ALPHANUMERIC 02 AUSGABE-FILE-NAME AUSGABE-FILE-NAME-T 00004 GROUP 02 FILLER, REDEFINES AUSGABE-FILE-NAME 00004 NUMERIC 05 FILLER 9999 @@ -2492,23 +2542,26 @@ SIZE TYPE LVL NAME PICTURE 00108 GROUP 49 MT3 MESSAGE-TEXT-2T 00108 GROUP 49 MT3-REN MESSAGE-TEXT-2T, REDEFINES MT3 -00018 NUMERIC 77 CALCULUS S9(15)V9(03) +00018 T NUMERIC 01 CALCULUS S9(15)V9(03) + CONDITIONAL 88 NO-DETAIL + CONDITIONAL 88 MIN-DETAIL -01818 GROUP 01 USER-TYPE +01818 T GROUP 01 USER-TYPE 00018 NUMERIC 02 AMOUNT CALCULUS 01800 GROUP 02 FILLER OCCURS 100 00018 NUMERIC 05 GRP-AMOUNT CALCULUS 01818 GROUP 01 USER-VAR USER-TYPE -00008 POINTER 01 PROC PROGRAM-POINTER +00008 T POINTER 01 PROC PROGRAM-POINTER + CONDITIONAL 88 PROC-UNSET 00008 POINTER 77 MY-PROC PROC ]) -AT_CHECK([diff prog-64.lst symbols.lis], [0], [], []) +AT_CHECK([diff prog-64.lst symbols.lst], [0], [], []) ]) From 8c8b74898459424db57ab240ebb7e32ab2282cd2 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 21 Jul 2023 11:44:22 +0000 Subject: [PATCH 10/21] fixed generated ec-bound-refmod check for UNBOUNDED items * typeck.c (refmod_checks): fixed bad max-size and missing check for literals --- cobc/ChangeLog | 4 ++ cobc/typeck.c | 6 +-- tests/testsuite.src/run_extensions.at | 59 ++++++++++++++++++++------- 3 files changed, 51 insertions(+), 18 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 46abe4ec2..cb36bfce2 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,8 @@ +2023-07-21 Simon Sobisch + + * typeck.c (refmod_checks): fixed ec-bound-refmod checks for UNBOUNDED + 2023-07-20 Simon Sobisch * field.c (copy_validation): new function diff --git a/cobc/typeck.c b/cobc/typeck.c index 624afc845..18b814cf6 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2387,7 +2387,7 @@ cb_build_name_reference (struct cb_field *f1, struct cb_field *f2) static void refmod_checks (cb_tree x, struct cb_field *f, struct cb_reference *r) { - const char *name = r->word->name; + const char *name = r->word->name; const int adjusted_at_runtime = -1; int offset; int length; @@ -2478,7 +2478,7 @@ refmod_checks (cb_tree x, struct cb_field *f, struct cb_reference *r) /* Run-time check */ if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_REF_MOD)) { - if (f->flag_any_length + if (pseudosize < 0 /* UNBOUNDED or ANY LENGTH */ || offset == adjusted_at_runtime || length == adjusted_at_runtime) { cb_tree e1; @@ -2500,7 +2500,7 @@ refmod_checks (cb_tree x, struct cb_field *f, struct cb_reference *r) f->flag_any_length ? CB_BUILD_CAST_LENGTH (CB_TREE(f)) /* known via field.size */ : pseudosize < 0 ? - CB_BUILD_CAST_LENGTH (x) /* needs to be runtime-calculated */ : + CB_BUILD_CAST_LENGTH (cb_build_field_reference (f, NULL)) /* needs to be runtime-calculated */ : cb_int (pseudosize), cb_build_cast_int (r->offset), r->length ? diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index 8a711fe4d..5ef93148b 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -1046,7 +1046,7 @@ AT_CLEANUP AT_SETUP([INITIALIZE OCCURS UNBOUNDED]) -AT_KEYWORDS([extensions runsubscripts subscripts refmod]) +AT_KEYWORDS([extensions runsubscripts subscripts refmod exceptions]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -1073,9 +1073,7 @@ AT_DATA([prog.cob], [ SET ADDRESS OF a-table TO p INITIALIZE prefix ALL TO VALUE IF FUNCTION LENGTH (a-table) NOT = 372 - DISPLAY 'WRONG LENGTH table: ' FUNCTION LENGTH (a-table) - END-DISPLAY - END-IF + DISPLAY 'WRONG LENGTH table: ' FUNCTION LENGTH (a-table). ALLOCATE FUNCTION LENGTH (a-table) CHARACTERS RETURNING p2 SET ADDRESS OF a-table TO p2 @@ -1085,36 +1083,67 @@ AT_DATA([prog.cob], [ IF LENGTH OF a-table NOT = 372 MOVE LENGTH OF a-table TO dlen - DISPLAY "BAD SIZE: " dlen - END-DISPLAY + DISPLAY "BAD SIZE: " dlen. INITIALIZE table-data (1:FUNCTION LENGTH(rows(1)) * n) ALL TO VALUE IF col2(1) NOT = "BC" - DISPLAY "col2(1) wrong: " col2(1) - END-DISPLAY - END-IF + DISPLAY "col2(1) wrong: " col2(1). IF rows(2) NOT = "DEA" - DISPLAY "rows(2) wrong: " rows(2) - END-DISPLAY - END-IF + DISPLAY "rows(2) wrong: " rows(2). - *> check if ref-mod also works as expected + *> check if ref-mod also works as expected + MOVE 2 TO n MOVE ALL ZEROES TO a-table (1: (LENGTH OF a-table)) + MOVE 7 TO n + IF rows(2) NOT = "000" + DISPLAY "rows(2) after ref-mod MOVE wrong: " rows(2). + IF rows(3) NOT = "BCD" + DISPLAY "rows(3) after ref-mod MOVE wrong: " rows(3). + MOVE ALL '9' TO rows (5) rows (7) *> Test - should only initialize up to current size, not max: + MOVE 4 TO n INITIALIZE table-data TO DEFAULT + MOVE 7 TO n + IF rows(2) NOT = SPACES OR + rows(4) NOT = SPACES + DISPLAY "rows(2/4) after init default wrong: " + rows(2) rows(4). + IF rows(5) NOT = "999" + DISPLAY "rows(5) after init default wrong: " rows(5). + + MOVE 6 TO n INITIALIZE table-data ALL TO VALUE + MOVE 9 TO n + IF rows(5) NOT = "CDE" + DISPLAY "rows(5) after init value wrong: " rows(5). + IF rows(7) NOT = "999" + DISPLAY "rows(7) after init value wrong: " rows(7). + + IF a-table (20:10) NOT = "BC999BCDEA" + DISPLAY "a-table / ref-mod wrong: " a-table (20:10). + move 10 to n + IF a-table (20:n) NOT = "BC999BCDEA" + DISPLAY "a-table / ref-mod length wrong: " a-table (20:n). + move 20 to n + IF a-table (n:10) NOT = "BC999BCDEA" + DISPLAY "a-table / ref-mod offset wrong: " a-table (n:10). *> Test - FUNCTION LENGTH(table-data) must be resolved at run-time - INITIALIZE table-data (1:FUNCTION LENGTH(table-data)) + MOVE 8 TO n + INITIALIZE table-data (1:FUNCTION LENGTH(table-data)) ALL TO VALUE . + + DISPLAY a-table (20:10). *> expect runtime error ]) AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], +[libcob: prog.cob:89: error: length of 'a-table' out of bounds: 10, starting at: 20, maximum: 27 +]) AT_CLEANUP From e864997086592422ad4521345a8c3ad7f7c3705f Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 21 Jul 2023 18:30:30 +0000 Subject: [PATCH 11/21] fix calculation of UNBOUNDED max OCCURS, added with [r5065] cobc/field.c (compute_size): take fields before the UNBOUNDED field into account when calculating its maximum elements additional in cobc/parser.y (validated_field_reference): extracted from (identifier_field) and used in all places with the exact same code --- cobc/ChangeLog | 4 + cobc/field.c | 44 +++++++-- cobc/parser.y | 46 ++++----- cobc/typeck.c | 2 + tests/testsuite.src/run_extensions.at | 4 +- tests/testsuite.src/syn_occurs.at | 132 ++++++++++++++++++++++++++ 6 files changed, 196 insertions(+), 36 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index cb36bfce2..997a74fb7 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -2,6 +2,10 @@ 2023-07-21 Simon Sobisch * typeck.c (refmod_checks): fixed ec-bound-refmod checks for UNBOUNDED + * field.c (compute_size): take fields before the UNBOUNDED field into + account when calculating its maximum elements + * parser.y (validated_field_reference): extracted from (identifier_field) + and used in all places with the exact same code 2023-07-20 Simon Sobisch diff --git a/cobc/field.c b/cobc/field.c index 8b9e4ce3e..ce8115246 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -2867,15 +2867,41 @@ compute_size (struct cb_field *f) } else { c->offset = f->offset + (int) size_check; compute_size (c); - if (c->flag_unbounded) { - const int max_odo_value = get_max_int_val (CB_FIELD_PTR (c->depending)); - unbounded_items++; - /* computed MAX */ - c->occurs_max = (COB_MAX_UNBOUNDED_SIZE / c->size / unbounded_parts) - 1; - /* maximum from ODO field */ - if (max_odo_value != 0 - && max_odo_value < c->occurs_max) { - c->occurs_max = max_odo_value; + if (c->flag_unbounded && CB_VALID_TREE (c->depending)) { + cb_tree dep = cb_ref (c->depending); + if (CB_FIELD_P (dep)) { + const int max_odo_value = get_max_int_val (CB_FIELD (dep)); + unbounded_items++; + /* computed MAX */ + { + /* size above the field [there is no sister for UNBOUNDED]*/ + cob_s64_t size_above = 0; + struct cb_field *curr_fld = c; + struct cb_field *p_fld = f; + while (p_fld) { + struct cb_field *p_fld_c; + for (p_fld_c = p_fld->children; p_fld_c != curr_fld; p_fld_c = p_fld_c->sister) { + if (p_fld_c->size == 0) { + compute_size (p_fld_c); + } + size_above += p_fld_c->size; + } + curr_fld = p_fld; + p_fld = p_fld->parent; + } + /* calculated size */ + c->occurs_max = ( (COB_MAX_UNBOUNDED_SIZE - size_above) + / (c->size * unbounded_parts) + ) - 1; + /* maximum possible in ODO field */ + if (max_odo_value != 0 + && max_odo_value < c->occurs_max) { + c->occurs_max = max_odo_value; + } + } + + } else { + c->depending = cb_error_node; } } size_check += (cob_s64_t)c->size * c->occurs_max; diff --git a/cobc/parser.y b/cobc/parser.y index 69f1565cf..623d8d323 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -2300,6 +2300,23 @@ error_if_not_usage_display_or_nonnumeric_lit (cb_tree x) } } +/* guarantees a reference to a validated field-reference (or cb_error_node) */ +static cb_tree +validated_field_reference (cb_tree fld_ref) +{ + cb_tree ref = NULL; + if (CB_REFERENCE_P (fld_ref)) { + ref = cb_ref (fld_ref); + if (CB_FIELD_P (ref)) { + return fld_ref; + } + } + if (ref != cb_error_node) { + cb_error_x (fld_ref, _ ("'%s' is not a field"), cb_name (fld_ref)); + } + return cb_error_node; +} + static void check_validate_item (cb_tree x) { @@ -19386,19 +19403,7 @@ identifier_or_file_name: identifier_field: identifier_1 { - cb_tree x = NULL; - if (CB_REFERENCE_P ($1)) { - x = cb_ref ($1); - } - - if (x && CB_FIELD_P (x)) { - $$ = $1; - } else { - if (x != cb_error_node) { - cb_error_x ($1, _("'%s' is not a field"), cb_name ($1)); - } - $$ = cb_error_node; - } + $$ = validated_field_reference ($1); } ; @@ -19407,10 +19412,7 @@ identifier_field: type_name: WORD { - cb_tree x = NULL; - if (CB_REFERENCE_P ($1)) { - x = cb_ref ($1); - } + cb_tree x = CB_REFERENCE_P ($1) ? cb_ref ($1) : NULL; if (x && CB_FIELD_P (x) && CB_FIELD (x)->flag_is_typedef) { $$ = $1; @@ -19426,16 +19428,10 @@ type_name: identifier: identifier_1 { - cb_tree x = NULL; - if (CB_REFERENCE_P ($1)) { - x = cb_ref ($1); - } - if (x && CB_FIELD_P (x)) { + cb_tree x = validated_field_reference ($1); + if (x != cb_error_node) { $$ = cb_build_identifier ($1, 0); } else { - if (x != cb_error_node) { - cb_error_x ($1, _("'%s' is not a field"), cb_name ($1)); - } $$ = cb_error_node; } } diff --git a/cobc/typeck.c b/cobc/typeck.c index 18b814cf6..2ae8fcc7f 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -4802,6 +4802,8 @@ cb_validate_program_data (struct cb_program *prog) /* Resolve all references so far */ for (l = cb_list_reverse (prog->reference_list); l; l = CB_CHAIN (l)) { cb_ref (CB_VALUE (l)); + /* TODO: move allocation of prog->reference_list outside of parse_mem + and free it here directly */ } /* Check ODO items */ diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index 5ef93148b..fce021b3a 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -1046,7 +1046,7 @@ AT_CLEANUP AT_SETUP([INITIALIZE OCCURS UNBOUNDED]) -AT_KEYWORDS([extensions runsubscripts subscripts refmod exceptions]) +AT_KEYWORDS([extensions runsubscripts subscripts refmod exceptions ibm]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -1149,7 +1149,7 @@ AT_CLEANUP AT_SETUP([INITIALIZE OCCURS ODOSLIDE]) -AT_KEYWORDS([extensions runsubscripts subscripts]) +AT_KEYWORDS([extensions runsubscripts subscripts ibm]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at index afa8fb327..da160344a 100644 --- a/tests/testsuite.src/syn_occurs.at +++ b/tests/testsuite.src/syn_occurs.at @@ -194,6 +194,24 @@ AT_DATA([prog4.cob], [ 77 I PIC X. ]) +AT_DATA([prog5.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G-1. + 05 G-1-F1 PIC X(002). + 05 G-2. + 07 G-3 + OCCURS 1 TO 99999 + DEPENDING ON G-3-ELEMENTS + ASCENDING KEY IS G-4-KEY + INDEXED BY IND. + 10 G-4. + 15 N PIC 9(001). + * +]) + AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:7: error: 'G-2' cannot have an OCCURS clause due to 'X' ]) @@ -219,6 +237,120 @@ AT_CHECK([$COMPILE_ONLY -fcomplex-odo prog4.cob], [1], [], [prog4.cob:8: error: 'I' is not numeric ]) +AT_CHECK([$COMPILE_ONLY prog5.cob], [1], [], +[prog5.cob:11: error: 'G-3-ELEMENTS' is not defined +prog5.cob:12: error: 'G-4-KEY IN G-2 IN G-1' is not defined +]) + +AT_CLEANUP + + +AT_SETUP([OCCURS UNBOUNDED]) +#AT_KEYWORDS([ibm]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + LINKAGE SECTION. + 01 G-1. + 07 G-2-ELEMENTS PIC 9(08). + 07 G-2 + OCCURS UNBOUNDED + DEPENDING ON G-2-ELEMENTS. + 10 X PIC X. + PROCEDURE DIVISION USING G-1. + DISPLAY G-1. + GOBACK. +]) + +AT_DATA([prog2.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + LINKAGE SECTION. + 01 G-1. + 05 G-1-F1 PIC X(22). + 05 G-1-F2 PIC X(12). + 05 G-2. + 07 G-3-ELEMENTS PIC 9(08). + 07 G-3 + OCCURS UNBOUNDED + DEPENDING ON G-3-ELEMENTS. + 10 G-4. + 15 X PIC 9(22). + PROCEDURE DIVISION USING G-1. + DISPLAY G-1. + GOBACK. +]) + +AT_DATA([bad.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G-1. + 07 G-2-ELEMENTS PIC 9(08). + 07 G-2 + OCCURS UNBOUNDED + DEPENDING ON G-2-ELEMENTS. + 10 X PIC X. +]) + +AT_DATA([bad2.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G-1. + 05 G-1-F1 PIC X(22). + 05 G-2. + 07 G-3-ELEMENTS PIC 9(08). + 07 G-3 + OCCURS UNBOUNDED. + 10 G-4. + 15 X PIC 9(22). +]) + +AT_DATA([bad3.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G-1. + 05 G-1-F1 PIC X(22). + 05 G-1-F2 PIC X(12). + 05 G-2. + 07 G-3 + OCCURS UNBOUNDED + DEPENDING ON G-3-ELEMENTS. + 10 G-4. + 15 X PIC 9(22). +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -std=ibm-strict prog.cob], [0], [], []) + +# TODO: opt to a different path, if UNBOUNDED is not reserved +AT_CHECK([$COMPILE_ONLY -std=cobol2014 prog.cob], [1], [], +[prog.cob:9: error: syntax error, unexpected Identifier, expecting UNBOUNDED +]) + +AT_CHECK([$COMPILE_ONLY prog2.cob], [0], [], []) + +AT_CHECK([$COMPILE_ONLY bad.cob], [1], [], +[bad.cob:8: error: 'G-2' is not in LINKAGE SECTION +]) + +AT_CHECK([$COMPILE_ONLY bad2.cob], [1], [], +[bad2.cob:11: error: syntax error, unexpected ., expecting DEPENDING +]) + +AT_CHECK([$COMPILE_ONLY bad3.cob], [1], [], +[bad3.cob:10: error: 'G-3' is not in LINKAGE SECTION +bad3.cob:12: error: 'G-3-ELEMENTS' is not defined +]) + AT_CLEANUP From b6c64c13e2185137ec2745c7d7707505e214ea72 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 21 Jul 2023 19:04:09 +0000 Subject: [PATCH 12/21] fix calculation of UNBOUNDED max OCCURS, added with [r5065] cobc/field.c (compute_size): take fields before the UNBOUNDED field into account when calculating its maximum elements additional in cobc/parser.y (validated_field_reference): extracted from (identifier_field) and used in all places with the exact same code --- libcob/ChangeLog | 5 +++++ libcob/common.c | 23 ++++++++++++----------- 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 14f231c18..5b1b60d90 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2023-07-21 Simon Sobisch + + * common.c (get_config_val): fixed output of "not set" for enum values + * common.c (create_dumpfile): more details if dump could not be created + 2023-07-18 Simon Sobisch after suggestions by Chuck Haatvedt diff --git a/libcob/common.c b/libcob/common.c index fa96bd17d..a70cbe336 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -1066,7 +1066,9 @@ create_dumpfile (void) ret = system (cmd); if (ret) { - fprintf (stderr, "\nlibcob: requested coredump creation failed with status %d\n", ret); + fprintf (stderr, "\nlibcob: "); + fprintf (stderr, _("requested coredump creation failed with status %d"), ret); + fprintf (stderr, "\n\t%s\t%s\n", _("executing:"), (char *)cmd); } return ret; } @@ -2792,7 +2794,7 @@ cob_trace_print (char *val) /* note: only executed after cob_trace_prep (), so call to cob_get_source_line () already done */ - for (i=0; cobsetptr->cob_trace_format[i] != 0; i++) { + for (i = 0; cobsetptr->cob_trace_format[i] != 0; i++) { if (cobsetptr->cob_trace_format[i] == '%') { i++; switch (cobsetptr->cob_trace_format[i]) { @@ -4152,16 +4154,13 @@ cob_check_fence (const char *fence_pre, const char *fence_post, { if (memcmp (fence_pre, "\xFF\xFE\xFD\xFC\xFB\xFA\xFF", 8) || memcmp (fence_post, "\xFA\xFB\xFC\xFD\xFE\xFF\xFA", 8)) { - /* LCOV_EXCL_START */ if (name) { - /* note: reserved, currently not generated in libcob */ cob_runtime_error (_("memory violation detected for '%s' after %s"), name, cob_statement_name[stmt]); } else { cob_runtime_error (_("memory violation detected after %s"), cob_statement_name[stmt]); } - /* LCOV_EXCL_STOP */ cob_hard_failure (); } } @@ -8154,10 +8153,12 @@ get_config_val (char *value, int pos, char *orgvalue) && strcmp (value, gc_conf[pos].default_val) != 0) { strcpy (orgvalue, value); } - strcpy (value, gc_conf[pos].enums[i].match); - if (strcmp (value, "not set") != 0) { + /* insert either value or translated "not set" */ + if (strcmp (gc_conf[pos].enums[i].match, "not set") == 0) { snprintf (value, COB_MEDIUM_MAX, _("not set")); value[COB_MEDIUM_MAX] = 0; /* fix warning */ + } else { + strcpy (value, gc_conf[pos].enums[i].match); } break; } @@ -8191,11 +8192,11 @@ cb_lookup_config (char *keyword) int i; for (i = 0; i < NUM_CONFIG; i++) { /* Set value from config file */ if (gc_conf[i].conf_name - && strcasecmp (keyword, gc_conf[i].conf_name) == 0) { /* Look for config file name */ + && strcasecmp (keyword, gc_conf[i].conf_name) == 0) { /* Look for config file name */ break; } if (gc_conf[i].env_name - && strcasecmp (keyword, gc_conf[i].env_name) == 0) { /* Catch using env var name */ + && strcasecmp (keyword, gc_conf[i].env_name) == 0) { /* Catch using env var name */ break; } } @@ -8212,10 +8213,10 @@ cb_config_entry (char *buf, int line) cob_source_line = line; - for (j= (int)strlen (buf); buf[j-1] == '\r' || buf[j-1] == '\n'; ) /* Remove CR LF */ + for (j = (int)strlen (buf); buf[j-1] == '\r' || buf[j-1] == '\n'; ) /* Remove CR LF */ buf[--j] = 0; - for (i = 0; isspace ((unsigned char)buf[i]); i++); + for (i = 0; isspace ((unsigned char)buf[i]); i++); /* drop leading spaces */ for (j = 0; buf[i] != 0 && buf[i] != ':' && !isspace ((unsigned char)buf[i]) && buf[i] != '=' && buf[i] != '#'; ) keyword[j++] = buf[i++]; From dae830c42efccc1cc33ae1a1d35e7b3a8553d703 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 22 Jul 2023 13:59:44 +0000 Subject: [PATCH 13/21] increase field size for LINKAGE SECTION items to INT_MAX - 1 libcob/coblocal.h (COB_MAX_FIELD_SIZE_LINKAGE): new definition cobc/field.c (compute_size): inspect field storage to check for the appropriate field size limit additional in cobc/field.c (create_implicit_picture): * don't imply a size if the source for VALUE is an intrinsic function or compile-time constant * don't stop on errors but still create an implied PIC to allow more checks later --- NEWS | 8 ++- cobc/ChangeLog | 12 +++- cobc/field.c | 106 ++++++++++++++++++++---------- libcob/ChangeLog | 4 ++ libcob/coblocal.h | 1 + tests/testsuite.src/syn_screen.at | 1 + 6 files changed, 96 insertions(+), 36 deletions(-) diff --git a/NEWS b/NEWS index 5e7d66c1d..cc4986ed7 100644 --- a/NEWS +++ b/NEWS @@ -424,8 +424,12 @@ NEWS - user visible changes -*- outline -*- * More notable changes -** in 64-bit environments, the maximum field size was increased from - 268435456 bytes (999999998 bytes for OCCURS UNBOUNDED) to 2 GB +** in general, the maximum field size in LINKAGE SECTION was increased from + 268435456 bytes (999999998 bytes for OCCURS UNBOUNDED) to the system + specific INT_MAX - 1, which is commonly 2 GB + +** in 64-bit environments, the maximum field size outside of LINKAGE SECTION + was increased from 268435456 bytes to 2 GB ** numeric DISPLAY can store and may contain a positive zero after arithmetic, PACKED-DECIMAL may contain negative zero (x'0D') after arithmetic; as before diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 997a74fb7..4196e37b9 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,9 +1,15 @@ +2023-07-22 Simon Sobisch + + * field.c (compute_size): inspect field storage to check for + the appropriate field size limit + 2023-07-21 Simon Sobisch * typeck.c (refmod_checks): fixed ec-bound-refmod checks for UNBOUNDED * field.c (compute_size): take fields before the UNBOUNDED field into - account when calculating its maximum elements + account when calculating its maximum elements; + fix compiler crash if DEPENDING field does not exist * parser.y (validated_field_reference): extracted from (identifier_field) and used in all places with the exact same code @@ -251,6 +257,10 @@ * parser.y, reserved.c: added RIGHTLINE - GC extension matching LEFLINE * parser.y: drop PENDING from OVERLINE and LEFTLINE * tree.c (cb_build_intrinsic): refactored to get the name in a single place + * field.c (create_implicit_picture): don't imply a size if the source for + VALUE is an intrinsic function or compile-time constant + * field.c (create_implicit_picture): don't stop on errors but still create + an implied PIC to allow more checks later 2023-05-24 Simon Sobisch diff --git a/cobc/field.c b/cobc/field.c index ce8115246..78974ee60 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -37,10 +37,13 @@ #include "../libcob/coblocal.h" /* sanity checks */ -#if COB_MAX_FIELD_SIZE > INT_MAX +#if COB_MAX_FIELD_SIZE >= INT_MAX #error COB_MAX_FIELD_SIZE is too big, must be less than INT_MAX #endif -#if COB_MAX_UNBOUNDED_SIZE > INT_MAX +#if COB_MAX_FIELD_SIZE_LINKAGE >= INT_MAX +#error COB_MAX_FIELD_SIZE_LINKAGE is too big, must be less than INT_MAX +#endif +#if COB_MAX_UNBOUNDED_SIZE >= INT_MAX #error COB_MAX_UNBOUNDED_SIZE is too big, must be less than INT_MAX #endif @@ -1113,13 +1116,17 @@ create_implicit_picture (struct cb_field *f) cb_tree impl_tree = f->screen_from ? f->screen_from : f->screen_to ? f->screen_to : NULL; if (impl_tree) { if (impl_tree == cb_error_node) { - return 1; + size_implied = 1; /* go on to allow further checks */ } if (CB_INTRINSIC_P (impl_tree) || CB_CONST_P (impl_tree)) { size_implied = FIELD_SIZE_UNKNOWN; } else { - size_implied = cb_field_size (impl_tree); - is_numeric = CB_TREE_CATEGORY (impl_tree) == CB_CATEGORY_NUMERIC; + if (CB_INTRINSIC_P (impl_tree) || CB_CONST_P (impl_tree)) { + size_implied = FIELD_SIZE_UNKNOWN; + } else { + size_implied = cb_field_size (impl_tree); + is_numeric = CB_TREE_CATEGORY (impl_tree) == CB_CATEGORY_NUMERIC; + } } } else if (first_value) { /* done later*/ @@ -1132,7 +1139,7 @@ create_implicit_picture (struct cb_field *f) if (size_implied == FIELD_SIZE_UNKNOWN) { cb_error_x (x, _("PICTURE clause required for '%s'"), cb_name (x)); - return 1; + size_implied = 1; /* go on to allow further checks */ } if (is_numeric) { @@ -1141,6 +1148,9 @@ create_implicit_picture (struct cb_field *f) sprintf (pic, "X(%d)", size_implied); } f->pic = cb_build_picture (pic); + if (f->size < size_implied) { + f->size = size_implied; + } return 0; } @@ -1153,10 +1163,12 @@ create_implicit_picture (struct cb_field *f) sprintf (pic, "X(%d)", size_implied); } else if (f->report_source) { size_implied = 1; - if (CB_LITERAL_P (f->report_source)) + if (CB_LITERAL_P (f->report_source)) { size_implied = (int)CB_LITERAL(f->report_source)->size; - else if (CB_FIELD_P (f->report_source)) + } else if (CB_FIELD_P (f->report_source)) { + /* CHECKME: A source of type BINARY may need a different size */ size_implied = (int)CB_FIELD(f->report_source)->size; + } sprintf (pic, "X(%d)", size_implied); } else { /* CHECKME: Where do we want to generate a not-field in the C code? @@ -1166,8 +1178,9 @@ create_implicit_picture (struct cb_field *f) strcpy (pic, "X"); } f->pic = cb_build_picture (pic); - if (f->size < size_implied) + if (f->size < size_implied) { f->size = size_implied; + } return 0; } @@ -1191,8 +1204,10 @@ create_implicit_picture (struct cb_field *f) } if (lp->size < 10) { f->usage = CB_USAGE_COMP_5; + f->size = lp->size; /* CHECKME: that seems wrong */ } else { f->usage = CB_USAGE_DISPLAY; + f->size = lp->size; } f->pic = cb_build_picture (pic); f->pic->category = CB_CATEGORY_NUMERIC; @@ -1201,6 +1216,7 @@ create_implicit_picture (struct cb_field *f) f->pic = cb_build_picture (pic); f->pic->category = CB_CATEGORY_ALPHANUMERIC; f->usage = CB_USAGE_DISPLAY; + f->size = lp->size; } return 0; } @@ -1225,9 +1241,10 @@ create_implicit_picture (struct cb_field *f) } } - /* Checkme: should we raise an error for !cb_relaxed_syntax_checks? */ + /* CHECKME: should we raise an error for !cb_relaxed_syntax_checks? */ if (!ret) { - cb_warning_x (cb_warn_additional, x, _("defining implicit picture size %d for '%s'"), + cb_warning_x (cb_warn_additional, x, + _("defining implicit picture size %d for '%s'"), size_implied, cb_name (x)); } if (is_numeric) { @@ -1238,6 +1255,9 @@ create_implicit_picture (struct cb_field *f) f->pic = cb_build_picture (pic); f->pic->category = CB_CATEGORY_ALPHANUMERIC; f->usage = CB_USAGE_DISPLAY; + if (f->size < size_implied) { + f->size = size_implied; + } return ret; } @@ -1263,6 +1283,7 @@ validate_any_length_item (struct cb_field *f) cb_error_x (x, _("'%s' ANY LENGTH has invalid definition"), cb_name (x)); return 1; } + if (!f->pic) { const char *pic = f->flag_any_numeric ? "9" : "X"; f->pic = cb_build_picture (pic); @@ -1418,22 +1439,24 @@ validate_group (struct cb_field *f) group_error (x, "PICTURE"); } if (f->flag_justified) { - if (!f->flag_picture_l) + if (!f->flag_picture_l) { group_error (x, "JUSTIFIED RIGHT"); - else + } else { cb_error_x (x, _("'%s' cannot have JUSTIFIED RIGHT clause"), cb_name (x)); + } } if (f->flag_blank_zero) { - if (!f->flag_picture_l) + if (!f->flag_picture_l) { group_error (x, "BLANK WHEN ZERO"); - else + } else { cb_error_x (x, _("'%s' cannot have BLANK WHEN ZERO clause"), cb_name (x)); + } } - if (f->storage == CB_STORAGE_SCREEN && - (f->screen_from || f->screen_to || f->values || f->pic)) { + if (f->storage == CB_STORAGE_SCREEN + && (f->screen_from || f->screen_to || f->values || f->pic)) { cb_error_x (x, _("SCREEN group item '%s' has invalid clause"), cb_name (x)); ret = 1; @@ -1677,11 +1700,11 @@ validate_justified_right (const struct cb_field * const f) /* TODO: Error if no PIC? */ if (f->flag_justified - && f->pic - && f->pic->category != CB_CATEGORY_ALPHABETIC - && f->pic->category != CB_CATEGORY_ALPHANUMERIC - && f->pic->category != CB_CATEGORY_BOOLEAN - && f->pic->category != CB_CATEGORY_NATIONAL) { + && f->pic + && f->pic->category != CB_CATEGORY_ALPHABETIC + && f->pic->category != CB_CATEGORY_ALPHANUMERIC + && f->pic->category != CB_CATEGORY_BOOLEAN + && f->pic->category != CB_CATEGORY_NATIONAL) { cb_error_x (x, _("'%s' cannot have JUSTIFIED RIGHT clause"), cb_name (x)); } } @@ -2187,7 +2210,7 @@ validate_elementary_item (struct cb_field *f) validate_elem_screen (f); } - /* Validate PICTURE */ + /* Validate PICTURE (adjusts the field if an implicit PIC is created) */ ret |= validate_pic (f); /* TODO: This is not validation and should be elsewhere. */ @@ -2798,12 +2821,24 @@ get_max_int_val (struct cb_field *f) static int compute_size (struct cb_field *f) { + const int max_size = f->storage == CB_STORAGE_LINKAGE + ? COB_MAX_FIELD_SIZE_LINKAGE + : COB_MAX_FIELD_SIZE; + if (f->level == 66) { /* RENAMES */ if (f->rename_thru) { f->size = f->rename_thru->offset + f->rename_thru->size - f->redefines->offset; } else if (f->redefines) { +#if 0 /* FIXME: redefine loop, possibly also below */ + if (f->redefines->size == 0) { + f->size = compute_size (f->redefines); + } else { + f->size = f->redefines->size; + } +#else f->size = f->redefines->size; +#endif } else { f->size = 1; /* error case: invalid REDEFINES */ } @@ -2811,7 +2846,7 @@ compute_size (struct cb_field *f) } /* early exit if we're already calculated as "too big" */ - if (f->size == COB_MAX_FIELD_SIZE + 1) { + if (f->size == max_size + 1) { return f->size; } @@ -3005,11 +3040,11 @@ compute_size (struct cb_field *f) } goto unbounded_again; } - } else if (size_check > COB_MAX_FIELD_SIZE) { + } else if (size_check > max_size) { cb_error_x (CB_TREE (f), _("'%s' cannot be larger than %d bytes"), - f->name, COB_MAX_FIELD_SIZE); - size_check = COB_MAX_FIELD_SIZE + 1; + f->name, max_size); + size_check = max_size + 1; } if (size_check <= INT_MAX) { f->size = (int) size_check; @@ -3063,14 +3098,19 @@ compute_size (struct cb_field *f) compute_binary_size (f, size); break; case CB_USAGE_ERROR: - /* Fall-through */ - case CB_USAGE_DISPLAY: if (f->pic == NULL) { /* should only happen for fields where we already raised - an error and could not create an implied PICTURE eitehr */ + an error and could not create an implied PICTURE either */ f->size = 1; break; } + /* Fall-through */ + case CB_USAGE_DISPLAY: +#if 0 /* should be always available here */ + if (f->pic == NULL) { + break; + } +#endif /* boolean items without USAGE BIT */ if (f->pic->category == CB_CATEGORY_BOOLEAN) { f->size = f->pic->size / 8; @@ -3084,11 +3124,11 @@ compute_size (struct cb_field *f) f->size++; } /* note: size check for single items > INT_MAX done in tree.c */ - if (f->size > COB_MAX_FIELD_SIZE) { + if (f->size > max_size) { cb_error_x (CB_TREE (f), _("'%s' cannot be larger than %d bytes"), - f->name, COB_MAX_FIELD_SIZE); - f->size = COB_MAX_FIELD_SIZE + 1; + f->name, max_size); + f->size = max_size + 1; } break; case CB_USAGE_NATIONAL: diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 5b1b60d90..8a06cf01e 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,8 @@ +2023-07-22 Simon Sobisch + + * coblocal.h (COB_MAX_FIELD_SIZE_LINKAGE): new definition + 2023-07-21 Simon Sobisch * common.c (get_config_val): fixed output of "not set" for enum values diff --git a/libcob/coblocal.h b/libcob/coblocal.h index 15f4f44da..835f972fe 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -416,6 +416,7 @@ struct config_tbl { #else #define COB_MAX_FIELD_SIZE 2147483646 #endif +#define COB_MAX_FIELD_SIZE_LINKAGE (INT_MAX - 1) /* Maximum bytes in an unbounded table entry (IBM: old 999999998, current 999999999) */ diff --git a/tests/testsuite.src/syn_screen.at b/tests/testsuite.src/syn_screen.at index 44e057355..627f5ca55 100644 --- a/tests/testsuite.src/syn_screen.at +++ b/tests/testsuite.src/syn_screen.at @@ -855,6 +855,7 @@ AT_CHECK([$COMPILE_ONLY -fnot-reserved=MESSAGE prog.cob], [1], [], prog.cob:11: warning: 'from-constant-with-size' has FROM, TO or USING without PIC; PIC will be implied prog.cob:12: warning: 'from-constant-without-pic' has FROM, TO or USING without PIC; PIC will be implied prog.cob:12: error: PICTURE clause required for 'from-constant-without-pic' +prog.cob:13: error: PICTURE clause required for 'FILLER' prog.cob:13: warning: 'FILLER' has FROM, TO or USING without PIC; PIC will be implied prog.cob:14: warning: 'from-func-without-pic' has FROM, TO or USING without PIC; PIC will be implied prog.cob:14: error: PICTURE clause required for 'from-func-without-pic' From 978c12e2399f4c5207f8a12c53cd9bccf828923f Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 22 Jul 2023 14:16:16 +0000 Subject: [PATCH 14/21] testcase expectation fix * don't imply a size if the source for VALUE is an intrinsic function or compile-time constant * don't stop on errors but still create an implied PIC to allow more checks later --- tests/testsuite.src/syn_screen.at | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testsuite.src/syn_screen.at b/tests/testsuite.src/syn_screen.at index 627f5ca55..bc4153e72 100644 --- a/tests/testsuite.src/syn_screen.at +++ b/tests/testsuite.src/syn_screen.at @@ -855,8 +855,8 @@ AT_CHECK([$COMPILE_ONLY -fnot-reserved=MESSAGE prog.cob], [1], [], prog.cob:11: warning: 'from-constant-with-size' has FROM, TO or USING without PIC; PIC will be implied prog.cob:12: warning: 'from-constant-without-pic' has FROM, TO or USING without PIC; PIC will be implied prog.cob:12: error: PICTURE clause required for 'from-constant-without-pic' -prog.cob:13: error: PICTURE clause required for 'FILLER' prog.cob:13: warning: 'FILLER' has FROM, TO or USING without PIC; PIC will be implied +prog.cob:13: error: PICTURE clause required for 'FILLER' prog.cob:14: warning: 'from-func-without-pic' has FROM, TO or USING without PIC; PIC will be implied prog.cob:14: error: PICTURE clause required for 'from-func-without-pic' ]) From bb5c95bf3c47928870bedd142e5b467922b45b76 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 22 Jul 2023 15:01:52 +0000 Subject: [PATCH 15/21] adjustment to [r5065] handling of UNBOUNDED children cobc: * tree.h (cb_field): new flag_above_unbounded * tree.c (cb_field_has_unbounded), tree.h: removed; use flag_above_unbounded in callers (typeck.c, cobc.c) instead * parser.y (occurs_clause): set flag_above_unbounded in parents --- cobc/ChangeLog | 4 ++++ cobc/cobc.c | 2 +- cobc/parser.y | 19 ++++++++++--------- cobc/tree.h | 4 ++-- cobc/typeck.c | 2 +- 5 files changed, 18 insertions(+), 13 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 4196e37b9..38c51bf2c 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -3,6 +3,10 @@ * field.c (compute_size): inspect field storage to check for the appropriate field size limit + * tree.h (cb_field): new flag_above_unbounded + * tree.c (cb_field_has_unbounded), tree.h: removed; use + flag_above_unbounded in callers (typeck.c, cobc.c) instead + * parser.y (occurs_clause): set flag_above_unbounded in parents 2023-07-21 Simon Sobisch diff --git a/cobc/cobc.c b/cobc/cobc.c index 52b47f684..b3a52303c 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -5740,7 +5740,7 @@ print_fields (struct cb_field *top, int *found) got_picture = set_picture (top, picture, picture_len); } - if (top->flag_any_length || cb_field_has_unbounded (top)) { + if (top->flag_any_length || top->flag_above_unbounded) { pd_off = sprintf (print_data, "????? "); } else if (top->flag_occurs && !got_picture) { pd_off = sprintf (print_data, "%05d ", top->size * top->occurs_max); diff --git a/cobc/parser.y b/cobc/parser.y index 623d8d323..aa9dcdbc5 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -774,9 +774,16 @@ setup_occurs (void) } if (current_field->flag_unbounded) { - if (current_field->storage != CB_STORAGE_LINKAGE) { - cb_error_x (CB_TREE(current_field), _("'%s' is not in LINKAGE SECTION"), - cb_name (CB_TREE(current_field))); + if (current_field->storage == CB_STORAGE_LINKAGE) { + struct cb_field *p = current_field; + while (p) { + p->flag_above_unbounded = 1; + p = p->parent; + } + } else { + cb_tree x = CB_TREE (current_field); + cb_error_x (x, _("'%s' is not in LINKAGE SECTION"), cb_name (x)); + current_field->flag_above_unbounded = 1; } } @@ -8375,12 +8382,6 @@ occurs_clause: DEPENDING _on reference _occurs_keys_and_indexed { current_field->flag_unbounded = 1; -#if 0 /* Why should we do this? If this is relevant then it likely needs to be done - either to the field founder or to the complete list of parents up to it. */ - if (current_field->parent) { - current_field->parent->flag_unbounded = 1; - } -#endif current_field->depending = $7; /* most of the field attributes are set when parsing the phrases */; setup_occurs (); diff --git a/cobc/tree.h b/cobc/tree.h index 3649e42ae..5fb72a3fb 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -981,7 +981,7 @@ struct cb_field { unsigned int flag_any_numeric : 1; /* Is ANY NUMERIC */ unsigned int flag_is_returning : 1; /* Is RETURNING item */ unsigned int flag_unbounded : 1; /* OCCURS UNBOUNDED */ - unsigned int flag_comp_1 : 1; /* Is USAGE COMP-1 */ + unsigned int flag_above_unbounded : 1; /* either OCCURS UNBOUNDED field or parent of it */ unsigned int flag_volatile : 1; /* VOLATILE */ unsigned int flag_constant : 1; /* Is 01 AS CONSTANT */ unsigned int flag_internal_constant : 1; /* Is an internally generated CONSTANT */ @@ -993,6 +993,7 @@ struct cb_field { unsigned int flag_internal_register : 1; /* Is an internally generated register */ unsigned int flag_is_typedef : 1; /* TYPEDEF */ unsigned int flag_picture_l : 1; /* Is USAGE PICTURE L */ + unsigned int flag_comp_1 : 1; /* Is USAGE COMP-1 */ }; #define CB_FIELD(x) (CB_TREE_CAST (CB_TAG_FIELD, struct cb_field, x)) @@ -2041,7 +2042,6 @@ extern int cb_tree_type (const cb_tree, const struct cb_field *); extern int cb_category_is_alpha (cb_tree); extern int cb_category_is_national (cb_tree); -extern int cb_field_has_unbounded (struct cb_field *); extern int cb_fits_int (const cb_tree); extern int cb_fits_long_long (const cb_tree); extern int cb_get_int (const cb_tree); diff --git a/cobc/typeck.c b/cobc/typeck.c index 2ae8fcc7f..f28fd8beb 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2421,7 +2421,7 @@ refmod_checks (cb_tree x, struct cb_field *f, struct cb_reference *r) /* note: child elements under UNBOUNDED are not included! */ pseudosize = f->size; } - if (cb_field_has_unbounded (f)) { + if (f->flag_above_unbounded) { pseudosize *= -1; } } From cd19b5fc0f89758ea2828eb43109b4ca2df98e36 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 24 Jul 2023 08:40:45 +0000 Subject: [PATCH 16/21] codegen fixes related to ENTRY statement cobc: * parser.y (entry_statement): don't check parameter address directly on ENTRY, because it just assigns it * codegen.c (output_internal_function, output_entry_function): * moved setting of non-passed parameters to NULL to entry function as we only have ordinal CALL numbers available there * set BY VALUE parameters to zero instead of NULL * codegen.c (output_field_no_target): extracted to reduce code duplication --- NEWS | 7 +- cobc/codegen.c | 111 ++++++++++++++------------ cobc/parser.y | 1 + cobc/tree.c | 24 ++---- tests/testsuite.src/run_extensions.at | 17 ++-- 5 files changed, 81 insertions(+), 79 deletions(-) diff --git a/NEWS b/NEWS index cc4986ed7..1adc3eda3 100644 --- a/NEWS +++ b/NEWS @@ -2,8 +2,7 @@ NEWS - user visible changes -*- outline -*- GnuCOBOL 3.2rc1 (20230118) GnuCOBOL 3.2rc2 (20230210) - GnuCOBOL 3.2rc3 ASAP - 3.2 final (depending on feedback) end of July 2023 + GnuCOBOL 3.2 to be done end of July 2023 planned for final: * extending testsuite and documentation @@ -541,9 +540,11 @@ NEWS - user visible changes -*- outline -*- WHEN (the standard explicit requests a one-time evaluation of the subjects, then comparing the value); to work around possible issues move more complex subjects like variables with subscripts and reference-modification, as well - as calculated subjects and function calls to a temporary variabe and use + as calculated subjects and function calls to a temporary variable and use this as subject for the EVALUATE +For more known issues see the bug tracker. + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GnuCOBOL 3.1.2 released (20201223) diff --git a/cobc/codegen.c b/cobc/codegen.c index af91e1f1e..4879b8473 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -293,6 +293,7 @@ static void output_integer (cb_tree); static void output_index (cb_tree); static void output_func_1 (const char *, cb_tree); static void output_param (cb_tree, int); +static void output_field_no_target (cb_tree); static void output_funcall (cb_tree); static void output_report_summed_field (struct cb_field *); @@ -2768,7 +2769,6 @@ cb_lookup_literal (cb_tree x, int make_decimal) { struct cb_literal *literal; struct literal_list *l; - FILE *savetarget; literal = CB_LITERAL (x); /* Search literal cache */ @@ -2788,11 +2788,7 @@ cb_lookup_literal (cb_tree x, int make_decimal) } /* Output new literal */ - savetarget = output_target; - output_target = NULL; - output_field (x); - - output_target = savetarget; + output_field_no_target (x); /* Cache it */ l = cobc_parse_malloc (sizeof (struct literal_list)); @@ -3489,9 +3485,7 @@ create_field (struct cb_field *f, cb_tree x) { if (!f->flag_field) { struct field_list* fl; - FILE* savetarget = output_target; - output_target = NULL; - output_field (x); + output_field_no_target (x); fl = cobc_parse_malloc (sizeof (struct field_list)); fl->x = x; @@ -3508,10 +3502,18 @@ create_field (struct cb_field *f, cb_tree x) } f->flag_field = 1; - output_target = savetarget; } } +static void +output_field_no_target (cb_tree x) +{ + FILE *savetarget = output_target; + output_target = NULL; + output_field (x); + output_target = savetarget; +} + static void output_param (cb_tree x, int id) { @@ -11502,7 +11504,6 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) struct call_list *clp; struct base_list *bl; struct literal_list *m; - FILE *savetarget; const char *s; char key_ptr[64]; cob_u32_t inc, i; @@ -12053,26 +12054,12 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_newline (); #endif - if (prog->num_proc_params) { - if (!cb_sticky_linkage && !prog->flag_chained + if (prog->num_proc_params + && !cb_sticky_linkage && !prog->flag_chained #if 0 /* RXWRXW USERFUNC */ - && prog->prog_type != COB_MODULE_TYPE_FUNCTION + && prog->prog_type != COB_MODULE_TYPE_FUNCTION #endif ) { - output_line ("/* Set not passed parameter pointers to NULL */"); - output_line ("switch (cob_call_params) {"); - inc = 0; - for (l = parameter_list; l; l = CB_CHAIN (l)) { - output_line ("case %u:", inc++); - output_line ("\t%s%d = NULL;", - CB_PREFIX_BASE, cb_code_field (CB_VALUE (l))->id); - output_line ("/* Fall through */"); - } - output_line ("default:"); - output_line ("\tbreak; "); - output_line ("}"); - output_newline (); - } output_line ("/* Store last parameters for possible later lookup */"); output_local ("/* Last USING parameters for possible later lookup */\n"); for (l = parameter_list; l; l = CB_CHAIN (l)) { @@ -12099,12 +12086,17 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) seen = 1; output_line ("/* Initialize ANY LENGTH parameters */"); } - /* Force field cache */ - savetarget = output_target; - output_target = NULL; - output_param (CB_VALUE (l), inc); - output_target = savetarget; + { + /* Force field cache */ + FILE *savetarget = output_target; + output_target = NULL; + output_param (CB_VALUE (l), inc); + output_target = savetarget; + } + /* FIXME: the ordinal positions are _only_ correct in the entry point + functions, see bug #902 (an ENTRY may only specify the ANY LENGTH + parameter or even swap the order */ output_line ("if (cob_call_params > %u && " "module->next && " "module->next->cob_procedure_params[%u])", @@ -13050,8 +13042,6 @@ output_entry_function (struct cb_program *prog, cb_tree entry, struct cb_field *f; struct cb_field *f1; struct cb_field *f2; - const char *s; - const char *s2; const char *s_prefix; const char *s_type[MAX_CALL_FIELD_PARAMS]; cob_u32_t parmnum; @@ -13147,11 +13137,8 @@ output_entry_function (struct cb_program *prog, cb_tree entry, /* For calling into a module, cob_call_params may not be known */ if (using_list) { - parmnum = 0; - for (l = using_list; l; l = CB_CHAIN (l)) { - parmnum++; - } if (entry_convention & CB_CONV_COBOL) { + unsigned int inc = 0; output_line("/* Get current number of call parameters,"); output_line(" if the parameter count is unknown, set it to all */"); if (cb_flag_implicit_init) { @@ -13160,12 +13147,32 @@ output_entry_function (struct cb_program *prog, cb_tree entry, output_line ("if (cob_get_global_ptr ()->cob_current_module) {"); } output_line ("\tcob_call_params = cob_get_global_ptr ()->cob_call_params;"); + if (!cb_sticky_linkage && !prog->flag_chained +#if 0 /* RXWRXW USERFUNC */ + && prog->prog_type != COB_MODULE_TYPE_FUNCTION +#endif + ) { + output_line ("/* Set not passed parameter pointers to NULL */"); + output_line ("switch (cob_call_params) {"); + for (l = using_list; l; l = CB_CHAIN (l)) { + output_line ("case %u:", inc++); + output_line ("\t%s%d = %s;", + CB_PREFIX_BASE, cb_code_field (CB_VALUE (l))->id, + (CB_PURPOSE_INT (l) == CB_CALL_BY_VALUE) + ? "0" : "NULL"); + output_line ("/* Fall through */"); + } + output_line ("default:"); + output_line ("\tbreak; "); + output_line ("}"); + output_newline (); + } output_line ("} else {"); - output_line ("\tcob_call_params = %d;", parmnum); + output_line ("\tcob_call_params = %u;", cb_list_length (using_list)); output_line ("};"); } else { output_line ("/* Set current number of call parameters to max */"); - output_line (" cob_call_params = %d;", parmnum); + output_line (" cob_call_params = %u;", cb_list_length (using_list)); } output_newline(); } @@ -13179,20 +13186,20 @@ output_entry_function (struct cb_program *prog, cb_tree entry, /* Sticky linkage parameters */ if (cb_sticky_linkage && using_list) { for (l = using_list, parmnum = 0; l; l = CB_CHAIN (l), parmnum++) { - f = cb_code_field (CB_VALUE (l)); + cb_tree f_tree = CB_VALUE (l); + f = cb_code_field (f_tree); sticky_ids[parmnum] = f->id; if (CB_PURPOSE_INT (l) == CB_CALL_BY_VALUE) { - s = try_get_by_value_parameter_type (f->usage, l); - if (f->usage == CB_USAGE_FP_BIN128 - || f->usage == CB_USAGE_FP_DEC128) { - s2 = "{{0, 0}}"; - } else { - s2 = "0"; - } - + const char *s = try_get_by_value_parameter_type (f->usage, l); if (s) { - output_line ("static %s\tcob_parm_l_%d = %s;", - s, f->id, s2); + output_line ("static %s\tcob_parm_l_%d = %s;" + "\t/* sticky linkage for %s */", + s, f->id, + (f->usage == CB_USAGE_FP_BIN128 + || f->usage == CB_USAGE_FP_DEC128) + ? "{{0, 0}}" : "0", + cb_name (f_tree) + ); sticky_nonp[parmnum] = 1; } } diff --git a/cobc/parser.y b/cobc/parser.y index aa9dcdbc5..d304ace1c 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -13880,6 +13880,7 @@ entry_statement: { check_unreached = 0; begin_statement (STMT_ENTRY, 0); + current_statement->flag_no_based = 1; } entry_body | entry diff --git a/cobc/tree.c b/cobc/tree.c index 1720eea56..8aed921ad 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -1612,17 +1612,6 @@ cb_tree_type (const cb_tree x, const struct cb_field *f) #endif } -/* check if field or any of the child elements has UNBOUNDED */ -int -cb_field_has_unbounded (struct cb_field *f) -{ - if (f->flag_unbounded) { - return 1; - } - f = cb_field_variable_size (f); - return (f && f->flag_unbounded); -} - int cb_fits_int (const cb_tree x) { @@ -2107,14 +2096,11 @@ cb_list_reverse (cb_tree l) unsigned int cb_list_length (cb_tree l) { - unsigned int n; - - if (l == cb_error_node) { - return 0; - } - n = 0; - for (; l; l = CB_CHAIN (l)) { - n++; + unsigned int n = 0; + if (l != cb_error_node) { + for (; l; l = CB_CHAIN (l)) { + n++; + } } return n; } diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index fce021b3a..12fd22133 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -2575,7 +2575,7 @@ AT_CLEANUP # ENTRY AT_SETUP([ENTRY]) -AT_KEYWORDS([extensions]) +AT_KEYWORDS([extensions exceptions ibm]) AT_DATA([caller.cob], [ IDENTIFICATION DIVISION. @@ -2583,7 +2583,7 @@ AT_DATA([caller.cob], [ PROCEDURE DIVISION. CALL "hello" USING "COBOL" END-CALL. - CALL "bye" USING "COBOL" + CALL "bye" USING "COBOL-ENTRY" END-CALL. STOP RUN. ]) @@ -2597,9 +2597,11 @@ AT_DATA([hello.cob], [ 01 MSG-BYE PIC X(5) VALUE "Bye, ". LINKAGE SECTION. 01 X PIC X(5). - 01 Y PIC X(5). + 01 Y PIC X(11). PROCEDURE DIVISION USING X. DISPLAY MSG-HELLO X "!". + * verifies that this does not generate an exception + ENTRY "unused" USING Y. EXIT PROGRAM. ENTRY "bye" USING Y. @@ -2608,11 +2610,16 @@ AT_DATA([hello.cob], [ ]) AT_CHECK([$COMPILE caller.cob], [0], [], []) -# TODO: Doesn't work without sticky-linkage which is likely a bug! +AT_CHECK([$COMPILE_MODULE -fentry-statement=ok hello.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./caller], [0], +[Hello, COBOL! +Bye, COBOL-ENTRY! +]) +# no difference expected with sticky linkage (but other codegen) AT_CHECK([$COMPILE_MODULE -fentry-statement=ok -fsticky-linkage hello.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [Hello, COBOL! -Bye, COBOL! +Bye, COBOL-ENTRY! ]) AT_CLEANUP From 97abd9b502a28dc0c926fc4a1ac1787a204713d8 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 24 Jul 2023 09:46:21 +0000 Subject: [PATCH 17/21] follow-up to [r5114] check for internal memory bounds with new flag "memory-check" (implied with --debug) cobc/typeck.c (cb_emit_call): fixed skipping memory-fence generation for EXTERNAL/BASED sub-fields --- cobc/ChangeLog | 12 ++++++++++ cobc/typeck.c | 9 ++++---- tests/testsuite.src/run_misc.at | 39 ++++++++++++++++++++++++--------- 3 files changed, 46 insertions(+), 14 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 38c51bf2c..bcda32f14 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,16 @@ +2023-07-24 Simon Sobisch + + * parser.y (entry_statement): don't check parameter address + directly on ENTRY, because it just assigns it + * codegen.c (output_internal_function, output_entry_function): moved + setting of non-passed parameters to NULL to entry function as we only + have ordinal CALL numbers available there; set BY VALUE parameters to + zero instead of NULL + * codegen.c (output_field_no_target): extracted to reduce code duplication + * typeck.c (cb_emit_call): fixed skipping memory-fence generation for + EXTERNAL/BASED sub-fields + 2023-07-22 Simon Sobisch * field.c (compute_size): inspect field storage to check for diff --git a/cobc/typeck.c b/cobc/typeck.c index f28fd8beb..21e8a245f 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -8840,14 +8840,15 @@ cb_emit_call (cb_tree prog, cb_tree par_using, cb_tree returning, } if ((cb_flag_memory_check & CB_MEMCHK_USING) && f->storage != CB_STORAGE_LINKAGE - && f->storage != CB_STORAGE_LOCAL - && !f->flag_external - && !f->flag_item_based) { + && f->storage != CB_STORAGE_LOCAL) { f = cb_field_founder (f); if (f->redefines) { f = f->redefines; } - f->flag_used_in_call = 1; + if (!f->flag_external + && !f->flag_item_based) { + f->flag_used_in_call = 1; + } } check_list = cb_list_add (check_list, x); } else if (f->flag_any_length) { diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index bdfc0b16d..de3b7a6a5 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -14100,7 +14100,7 @@ AT_CLEANUP AT_SETUP([runtime check: write to internal storage (1)]) -AT_KEYWORDS([runmisc CALL bounds]) +AT_KEYWORDS([runmisc CALL bounds exceptions]) # note: this check is likely unportable and therefore will likely be adjusted/skipped, # mainly because the memory layout of consecutive variables is not guaranteed; @@ -14114,12 +14114,24 @@ AT_DATA([caller.cob], [ WORKING-STORAGE SECTION. 01 var PIC X. - - 01 varg PIC X GLOBAL. - 01 vare PIC X EXTERNAL. - 01 varb PIC X BASED. + 01 vars. + 03 filler PIC X. + 03 vars-field PIC X. + + 01 varg GLOBAL. + 03 filler PIC X. + 03 varg-field PIC X. + 01 vare EXTERNAL. + 03 filler PIC X. + 03 vare-field PIC X. + 01 varb BASED. + 03 filler PIC X. + 03 varb-field PIC X. LINKAGE SECTION. 01 varl PIC X. + 01 varls. + 03 filler PIC X. + 03 varls-field PIC X. PROCEDURE DIVISION. * @@ -14128,10 +14140,17 @@ AT_DATA([caller.cob], [ CALL "callee" USING var * the following are mostly in to co-test the codegen + CALL "callee" USING vars CALL "callee" USING varg CALL "callee" USING vare CALL "callee" USING varb CALL "callee" USING varl + CALL "callee" USING varls + CALL "callee" USING vars-field + CALL "callee" USING varg-field + CALL "callee" USING vare-field + CALL "callee" USING varb-field + CALL "callee" USING varls-field GOBACK. ]) @@ -14159,29 +14178,29 @@ AT_DATA([callee.cob], [ AT_CHECK([$COMPILE -fno-ec=program-arg-mismatch -fmemory-check=pointer caller.cob], [0], [], []) AT_CHECK([$COMPILE_MODULE -fno-ec=program-arg-mismatch callee.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./caller], [1], [], -[libcob: caller.cob:18: error: memory violation detected after CALL +[libcob: caller.cob:30: error: memory violation detected after CALL ]) AT_CHECK([$COMPILE -fno-ec=program-arg-mismatch -fmemory-check=using caller.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./caller], [1], [], -[libcob: caller.cob:18: error: memory violation detected for 'var' after CALL +[libcob: caller.cob:30: error: memory violation detected for 'var' after CALL ]) AT_CHECK([$COMPILE -fno-ec=program-arg-mismatch -fmemory-check caller.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./caller], [1], [], -[libcob: caller.cob:18: error: memory violation detected for 'var' after CALL +[libcob: caller.cob:30: error: memory violation detected for 'var' after CALL ]) AT_CHECK([$COMPILE -fno-ec=program-arg-mismatch -fmemory-check=all caller.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./caller], [1], [], -[libcob: caller.cob:18: error: memory violation detected for 'var' after CALL +[libcob: caller.cob:30: error: memory violation detected for 'var' after CALL ]) AT_CLEANUP AT_SETUP([runtime check: write to internal storage (2)]) -AT_KEYWORDS([runmisc CALL bounds]) +AT_KEYWORDS([runmisc CALL bounds exceptions]) # PROG A (WS 16 bytes) has its WS overwritten and calls PROG B # because of the write outside of WS the internal storage is broken From 25593eff0d5bc6ec91d75dd6b076c4ccb8018f43 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 24 Jul 2023 10:32:48 +0000 Subject: [PATCH 18/21] minor fileio adjustments libcob/fileio.c: * only check -1 as invalid fd * return fileio status for invalid file state in CBL_ routines, instead of fixed -1 / 35 * adjusted setting of SORT-RETURN register --- libcob/ChangeLog | 7 +++++- libcob/fileio.c | 62 ++++++++++++++++++++++++++++-------------------- 2 files changed, 42 insertions(+), 27 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 8a06cf01e..568fce63b 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2023-07-24 Simon Sobisch + + * fileio.c: only check -1 as invalid fd; return fileio status for + invalid file state in CBL_ routines, instead of fixed -1 / 35 + 2023-07-22 Simon Sobisch * coblocal.h (COB_MAX_FIELD_SIZE_LINKAGE): new definition @@ -80,7 +85,7 @@ after suggestions by Chuck Haatvedt otherwise it is lost on first CLOSE * fileio.c: disable setting of record min/max size outside of OPEN, disable setting of record size in some places - + * fileio.c: adjusted setting of SORT-RETURN register 2023-06-01 Simon Sobisch diff --git a/libcob/fileio.c b/libcob/fileio.c index 18bb06227..00878decb 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -1666,8 +1666,10 @@ cob_fd_file_open (cob_file *f, char *filename, /* LCOV_EXCL_STOP */ } - errno = 0; fd = open (filename, fdmode, fperms); + if (fd != -1) { + errno = 0; + } switch (errno) { case 0: @@ -7060,9 +7062,10 @@ open_cbl_file (unsigned char *file_name, unsigned char *file_access, cob_chk_file_mapping (); fd = open (file_open_name, flag, COB_FILE_MODE); - if (fd < 0) { + if (fd == -1) { + int ret = errno_cob_sts (COB_STATUS_35_NOT_EXISTS); memset (file_handle, -1, (size_t)4); - return 35; + return ret; } memcpy (file_handle, &fd, (size_t)4); return 0; @@ -7304,8 +7307,8 @@ cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) flag |= O_RDONLY; fd1 = open (file_open_name, flag, 0); - if (fd1 < 0) { - return -1; + if (fd1 == -1) { + return errno_cob_sts (COB_STATUS_35_NOT_EXISTS); } { @@ -7319,9 +7322,10 @@ cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) flag &= ~O_RDONLY; flag |= O_CREAT | O_TRUNC | O_WRONLY; fd2 = open (file_open_name, flag, COB_FILE_MODE); - if (fd2 < 0) { + if (fd2 == -1) { + int ret = errno_cob_sts (COB_STATUS_35_NOT_EXISTS); close (fd1); - return -1; + return ret; } ret = 0; @@ -7844,7 +7848,7 @@ cob_create_tmpfile (const char *ext) #else fd = open (filename, O_CREAT | O_TRUNC | O_RDWR | O_BINARY, COB_FILE_MODE); #endif - if (fd < 0) { + if (fd == -1) { cob_free (filename); return NULL; } @@ -8327,6 +8331,11 @@ cob_file_sort_using_extfh (cob_file *sort_file, cob_file *data_file, if (data_file->file_status[0] == '4') { cob_set_exception (COB_EC_SORT_MERGE_FILE_OPEN); } + if (hp->sort_return) { + *(int *)(hp->sort_return) = 16; /* TODO: recheck with MF */ + } else { + /* IBM doc: if not used then a runtime message is displayed */ + } return; } for (;;) { @@ -8386,6 +8395,9 @@ cob_file_sort_giving_internal (cob_file *sort_file, const size_t giving_cnt, if (using_file->file_status[0] == '4') { cob_set_exception (COB_EC_SORT_MERGE_FILE_OPEN); } + if (!hp->sort_return) { + /* IBM doc: if not used then a runtime message is displayed */ + } opt[i] = -1; } } @@ -8430,6 +8442,9 @@ cob_file_sort_giving_internal (cob_file *sort_file, const size_t giving_cnt, if (using_file->file_status[0] == '3') { int j; opt[i] = -2; + if (!hp->sort_return) { + /* IBM doc: if not used then a runtime message is displayed */ + } /* early exit if no GIVING file left */ for (j = 0; j < giving_cnt; ++j) { if (opt[i] >= 0) { @@ -8466,6 +8481,16 @@ cob_file_sort_giving_internal (cob_file *sort_file, const size_t giving_cnt, if (callfh) { cob_free (callfh); } + + /* if any error happened with the GIVING files update SORT-RETURN */ + if (hp->sort_return) { + for (i = 0; i < giving_cnt; ++i) { + if (opt[i] < 0) { + *(int *)(hp->sort_return) = 16; + break; + } + } + } } /* SORT: WRITE all records from 'sort_file' to all passed USING files */ @@ -8549,8 +8574,6 @@ cob_file_release (cob_file *f) } if (hp->sort_return) { *(int *)(hp->sort_return) = 16; - } else { - /* IBM doc: if not used then a runtime message is displayed */ } save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR); } else { @@ -8576,8 +8599,6 @@ cob_file_return (cob_file *f) } if (hp->sort_return) { *(int *)(hp->sort_return) = 16; - } else { - /* IBM doc: if not used then a runtime message is displayed */ } save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR); } else { @@ -9038,23 +9059,12 @@ update_fcd_to_file (FCD3* fcd, cob_file *f, cob_field *fnstatus, int wasOpen) if (wasOpen >= 0) { const int status_code_1 = isdigit(fcd->fileStatus[0]) ? COB_D2I (fcd->fileStatus[0]) : 9; - if (status_code_1 == 0) { + if (status_code_1 != 0 + || cob_last_exception_is (COB_EC_I_O_EOP)) { /* EOP is non-fatal therefore 00 status but needs exception; - note that this global variable is only set if GnuCOBOL is used + note that the global exception is only set if GnuCOBOL is used as EXTFH, in every other case we currently can't set EOP; also note that fcd->lineCount is never read/set */ - if (eop_status == 0) { - cobglobptr->cob_exception_code = 0; - } else { -#if 0 /* correct thing to do, but then also needs to have codegen adjusted - --> module-incompatibility --> 4.x */ - cob_set_exception (eop_status); -#else - cob_set_exception (COB_EC_I_O_EOP); -#endif - eop_status = 0; - } - } else { cob_set_exception (status_exception[status_code_1]); } if (f->file_status) { From 12313877989cde508eb443f911927014566f3574 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 24 Jul 2023 11:00:27 +0000 Subject: [PATCH 19/21] runtime warnings with more details if loading of modules / entry points does not work libcob/call.c: * (cache_preload): runtime warning if preloading from existing path does not work * (cob_try_preload): runtime warning if preloading of requested module does not w * (cob_resolve_internal): runtime warning if loading module from existing path or resolving requested entry point does not workork --- libcob/ChangeLog | 8 +++++++ libcob/call.c | 32 ++++++++++++++++++++------ tests/testsuite.src/run_fundamental.at | 5 +++- tests/testsuite.src/used_binaries.at | 3 ++- 4 files changed, 39 insertions(+), 9 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 568fce63b..d1f073635 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -3,6 +3,14 @@ * fileio.c: only check -1 as invalid fd; return fileio status for invalid file state in CBL_ routines, instead of fixed -1 / 35 + * call.c (cache_preload, cob_resolve_internal): runtime warning if + (pre)loading from existing path does not work + * (cache_preload): runtime warning if preloading from existing path + does not work + * call.c (cob_try_preload): runtime warning if preloading of + requested module does not work + * (cob_resolve_internal): runtime warning if loading module from + existing path or resolving requested entry point does not work 2023-07-22 Simon Sobisch diff --git a/libcob/call.c b/libcob/call.c index afbfe9773..67833b669 100644 --- a/libcob/call.c +++ b/libcob/call.c @@ -46,6 +46,10 @@ FILE *fmemopen (void *buf, size_t size, const char *mode); #include +/* include internal and external libcob definitions, forcing exports */ +#define COB_LIB_EXPIMP +#include "coblocal.h" + /* NOTE - The following variable should be uncommented when it is known that dlopen(NULL) is borked. This is known to be true for some PA-RISC HP-UX 11.11 systems. @@ -86,12 +90,12 @@ lt_dlsym (HMODULE hmod, const char *p) #define lt_dlexit() #define lt_dlhandle HMODULE -#if 0 /* RXWRXW - dlerror */ +#if 1 /* RXWRXW - dlerror */ static char errbuf[64]; static char * lt_dlerror (void) { - sprintf(errbuf, _("LoadLibrary/GetProcAddress error %d"), (int)GetLastError()); + sprintf (errbuf, _("LoadLibrary/GetProcAddress error %d"), (int)GetLastError()); return errbuf; } #endif @@ -114,10 +118,6 @@ lt_dlerror (void) #endif -/* include internal and external libcob definitions, forcing exports */ -#define COB_LIB_EXPIMP -#include "coblocal.h" - #define COB_MAX_COBCALL_PARMS 16 #define CALL_BUFF_SIZE 256U #define CALL_BUFF_MAX (CALL_BUFF_SIZE - 1U) @@ -616,11 +616,14 @@ cache_preload (const char *path) } if (access (path, R_OK) != 0) { + /* note: not reasonable to warn here as we test for multiple paths that way */ return 0; } libhandle = lt_dlopen (path); if (!libhandle) { + cob_runtime_warning ( + _("preloading from existing path '%s' failed; %s"), path, lt_dlerror()); return 0; } @@ -921,6 +924,7 @@ cob_resolve_internal (const char *name, const char *dirent, set_resolve_error (module_type); return NULL; } + lt_dlerror (); /* clear last error conditions */ handle = lt_dlopen (call_filename_buff); if (handle != NULL) { /* Candidate for future calls */ @@ -936,6 +940,10 @@ cob_resolve_internal (const char *name, const char *dirent, snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX, "entry point '%s' not found", (const char *)s); set_resolve_error (module_type); + /* lt_dlerror will now give either the message from lt_dlopen or lt_dlym */ + cob_runtime_warning ( + _("loading from existing path '%s' failed; %s"), + call_filename_buff, lt_dlerror ()); return NULL; } for (i = 0; i < resolve_size; ++i) { @@ -949,6 +957,7 @@ cob_resolve_internal (const char *name, const char *dirent, } call_filename_buff[COB_NORMAL_MAX] = 0; if (access (call_filename_buff, R_OK) == 0) { + lt_dlerror (); /* clear last error conditions */ handle = lt_dlopen (call_filename_buff); if (handle != NULL) { /* Candidate for future calls */ @@ -964,6 +973,10 @@ cob_resolve_internal (const char *name, const char *dirent, snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX, "entry point '%s' not found", (const char *)s); set_resolve_error (module_type); + /* lt_dlerror will now give either the message from lt_dlopen or lt_dlym */ + cob_runtime_warning ( + _("loading from existing path '%s' failed; %s"), + call_filename_buff, lt_dlerror ()); return NULL; } } @@ -1589,7 +1602,12 @@ size_t cob_try_preload (const char* module_name) } } /* If not found, try just using the name as-is */ - return cache_preload (module_name); + ret = cache_preload (module_name); + + if (ret == 0) { + cob_runtime_warning (_("preloading of '%s' failed"), module_name); + } + return ret; #endif } diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index eef65b5b2..a88b6cf61 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -1556,8 +1556,11 @@ some (void) AT_CHECK([$COMPILE prog.cob], [0], [], []) AT_CHECK([$COMPILE_MODULE module.c], [0], [], []) +# CHECKME: the waning itself is likely system specific, +# in this case re-adjust to only check for a warning AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], -[libcob: prog.cob:6: error: entry point 'module' not found +[libcob: prog.cob:6: warning: loading from existing path './module.so' failed; ./module.so: undefined symbol: module +libcob: prog.cob:6: error: entry point 'module' not found ]) AT_CLEANUP diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index bce82d2c7..03e6549d1 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -786,7 +786,8 @@ AT_CHECK([$COBCRUN ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL], [1], [], # it would be allowed for preloading # this was previously checked in cobcrun, now only done in the runtime AT_CHECK([$COBCRUN -q -M ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL noprog], [1], [], -[libcob: error: module 'noprog' not found +[libcob: warning: preloading of 'ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL' failed +libcob: error: module 'noprog' not found ]) AT_CLEANUP From b9f608555808e333aef56ee3b31389aae5074392 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 24 Jul 2023 12:45:49 +0000 Subject: [PATCH 20/21] configure warnings * configure.ac: fix for resolving COBCRUN_NAME bin/cob-config.in: * prevent warning that datadir is used, but datarootdir isn't * allow abbreviated commands (blatantly copied from configure script) --- ChangeLog | 4 ++++ bin/ChangeLog | 11 ++++++++--- bin/cob-config.in | 43 ++++++++++++++++++++++++++++--------------- configure.ac | 12 ++++++++++-- 4 files changed, 50 insertions(+), 20 deletions(-) diff --git a/ChangeLog b/ChangeLog index e37ef7a85..5bc9f0254 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ +2023-07-24 Simon Sobisch + + * configure.ac: fix for resolving COBCRUN_NAME + 2023-05-25 Chuck Haatvedt * configure.ac: added test for HAVE_RESIZE_TERM function diff --git a/bin/ChangeLog b/bin/ChangeLog index f9d3271e4..acf8a135a 100644 --- a/bin/ChangeLog +++ b/bin/ChangeLog @@ -1,8 +1,13 @@ +2023-07-24 Simon Sobisch + + * cob-config.in: prevent warning to use datadir, but not datarootdir; + allow abbreviated commands (blatantly copied from configure script) + 2023-07-01 Fabrice Le Fessant - * cob-config: echo in same order as arguments. Add missing - arguments (--bindir,--libdir,--datadir,--mandir,--includedir) + * cob-config.in: echo in same order as arguments; add missing + arguments (--bindir,--libdir,--datadir,--mandir,--includedir) 2022-10-18 Simon Sobisch @@ -282,7 +287,7 @@ then you can switch easily. -Copyright 2004-2008,2010,2012,2014-2022 Free Software Foundation, Inc. +Copyright 2004-2008,2010,2012,2014-2023 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/bin/cob-config.in b/bin/cob-config.in index 03931f313..7be779bba 100644 --- a/bin/cob-config.in +++ b/bin/cob-config.in @@ -2,8 +2,8 @@ # # cob-config # -# Copyright (C) 2003-2012, 2020 Free Software Foundation, Inc. -# Written by Keisuke Nishida, Roger While +# Copyright (C) 2003-2012, 2020, 2023 Free Software Foundation, Inc. +# Written by Keisuke Nishida, Roger While, Simon Sobisch, Fabrice Le Fessant # # This file is part of GnuCOBOL. # @@ -27,6 +27,7 @@ exec_prefix_set=no libdir=@libdir@ includedir=@includedir@ bindir=@bindir@ +datarootdir=@datarootdir@ datadir=@datadir@ includedir=@includedir@ mandir=@mandir@ @@ -43,6 +44,8 @@ usage() cat < Date: Mon, 24 Jul 2023 13:03:45 +0000 Subject: [PATCH 21/21] fix C compiler warnings in cobc error.c: missing default leads to undefined value [r5074] replace.c: return of "const void" [r5109] --- cobc/error.c | 5 ++++- cobc/replace.c | 14 ++++++-------- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/cobc/error.c b/cobc/error.c index 61421b95d..203b67094 100644 --- a/cobc/error.c +++ b/cobc/error.c @@ -136,11 +136,14 @@ print_error (const char *file, int line, enum cb_error_kind kind, { const char *prefix; - switch( kind ){ + switch (kind) { case CB_KIND_ERROR: prefix = _("error: "); break; case CB_KIND_WARNING: prefix = _("warning: "); break; case CB_KIND_NOTE: prefix = _("note: "); break; case CB_KIND_GENERAL: prefix = ""; break; + default: + cobc_err_msg ("call to print_error with unexpected error kind"); + cobc_abort_terminate (1); } if (!file) { diff --git a/cobc/replace.c b/cobc/replace.c index ab04beeb9..49e28619e 100644 --- a/cobc/replace.c +++ b/cobc/replace.c @@ -244,26 +244,24 @@ token_list_add (WITH_DEPTH struct cb_token_list *list, return p; } else { struct cb_token_list *cursor = list; - for(;cursor->next != NULL; cursor = cursor->next); + for (; cursor->next != NULL; cursor = cursor->next); cursor->next = p; return list; } } - - static -const void pop_token (WITH_DEPTH struct cb_replacement_state *repls, +void pop_token (WITH_DEPTH struct cb_replacement_state *repls, const char **text, const char **token) { - const struct cb_token_list *q = repls->token_queue ; + const struct cb_token_list *q = repls->token_queue; repls->token_queue = q->next ; #ifdef DEBUG_REPLACE_TRACE fprintf (stderr, "%spop_token(%s) -> '%s'\n", DEPTH, repls->name, q->text); #endif - if (text) *text = q->text ; - if (token) *token = q->token ; + if (text) *text = q->text; + if (token) *token = q->token; } static @@ -417,7 +415,7 @@ void check_replace (WITH_DEPTH struct cb_replacement_state* repls, replace_list = replace_list->next; if (src->lead_trail == CB_REPLACE_LEADING - || src->lead_trail == CB_REPLACE_TRAILING){ + || src->lead_trail == CB_REPLACE_TRAILING){ /* LEADING and TRAILING replacements are * different: they match only on one text, so * we just need one test to decide if it is a