diff --git a/ChangeLog b/ChangeLog index e84d909e8..0a410a533 100644 --- a/ChangeLog +++ b/ChangeLog @@ -60,6 +60,10 @@ * configure.ac: check for PDC_free_memory_allocations +2022-07-06 Nicolas Berthier + + * configure.ac: Check for __attribute__((pure)) + 2022-06-21 Simon Sobisch * configure.ac: always build INDEXED handlers as separate libraries, diff --git a/NEWS b/NEWS index 2dcf6e6bb..1d7721c1b 100644 --- a/NEWS +++ b/NEWS @@ -357,6 +357,9 @@ Open Plans: ** in 64-bit environments, the maximum field size was increased from 268435456 bytes (999999998 bytes for OCCURS UNBOUNDED) to 2 GB +** the call-stack on error / in the dump file now contains all parameters given + to the program via command line options, if any + ** in case of any runtime features being used that are not available an error is generated during compile (may be reduced to a warning by -Wunsupported or be suppressed by -Wno-unsupported) and if the feature is actually used diff --git a/bin/ChangeLog b/bin/ChangeLog index 577fcb2ad..e933cac7d 100644 --- a/bin/ChangeLog +++ b/bin/ChangeLog @@ -16,6 +16,10 @@ * cobfile.c: fixed compiler warnings -Wunused-result * cobfile.c: handle --quiet to output less progress info +2022-07-15 Simon Sobisch + + * cobcrun.c: no module name check (done in libcob now) + 2022-06-28 Simon Sobisch * cobcrun.c: added -dumpversion (called from libcob) diff --git a/bin/cobcrun.c b/bin/cobcrun.c index 180cc96c6..9b88cfe4c 100644 --- a/bin/cobcrun.c +++ b/bin/cobcrun.c @@ -419,24 +419,23 @@ main (int argc, char **argv) return 1; } - if (strlen (argv[arg_shift]) > COB_MAX_NAMELEN) { - /* note: we allow up to COB_MAX_WORDLEN for relaxed syntax... */ - fprintf (stderr, _("%s: PROGRAM name exceeds %d characters"), argv[0], COB_MAX_NAMELEN); - putc ('\n', stderr); - fflush (stderr); - return 1; - } - - /* Initialize the COBOL system, resolve the PROGRAM name */ - /* and invoke, wrapped in a STOP RUN, if found */ - /* note: we use cob_init_nomain here as there are no functions */ - /* linked here we want to provide for the COBOL environment */ + /* Initialize the COBOL system, ... */ + /* Note: we use cob_init_nomain here as there are no functions + linked here we want to provide for the COBOL environment */ cob_init_nomain (argc - arg_shift, &argv[arg_shift]); if (print_runtime_wanted) { print_runtime_conf (); putc ('\n', stdout); } - /* Note: cob_resolve_cobol takes care for call errors, no need to check here */ + /* ... verify and resolve the PROGRAM name, ... */ + /* Note: cob_resolve_cobol takes care for call errors, + because of the last parameter; no need to check here afterwards; + another program may use "0" and check for function pointer != NULL */ unifunc.funcvoid = cob_resolve_cobol (argv[arg_shift], 0, 1); + + /* ... then invoke, wrapped in a STOP RUN */ + /* Note: we requested a program exit if resolving had issues, + so are only still running if we have a a valid, _likely_ COBOL + function to execute */ cob_stop_run (unifunc.funcint()); } diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 865531bda..e3de7d4f5 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -237,6 +237,74 @@ * tree.c (cb_build_picture), tree.h: return cb_picture instead of cb_tree as all but one caller directly use it that way +2022-07-14 Matthew Remacle + + * tree.c (literal_for_diagnostic): fixed #844 stack-based buffer overflow + +2022-07-14 Simon Sobisch + + * config.def, config.c: changed defaultbyte option from "INT" to ANY" + with explicit check for "init" (GnuCOBOL default behavior, now also + allowing to set it after it was set different) and "none" (in + preparation of missing feature, for now => implicit 0) + +2022-07-12 Simon Sobisch + + * scanner.l (read_literal): do the necessary conversion for national + literals (simple approach, only working with source in iso-8859-15 + or plain ascii) + * typeck.c (get_value): return correct numeric value for national + (utf16) literals + * tree.c (cb_build_intrinsic): fixed optimized length generation for + national fields and literals + * typeck.c (cb_validate_program_environment): refactored, + reducing variable scope and extracted (validate_alphabet) and + (check_class_duplicates); call the later depending on + cb_warn_additional, no need to test if the final result is ignored + * typeck.c (validate_alphabet): adjustments for national literals, + now partially supported + * scanner.l: moved static literal_error to local variable, + passing it (to error_literal); return a valid literal in case of + literal errors (intead of cb_error_node) to prevent spurious + follow-up errors on their use + +2022-07-08 Simon Sobisch + + * parser.y (cancel_body): preparation for CANCEL ALL + +2022-07-06 Nicolas Berthier + + * cobc.h: define function purity attribute COB_A_PURE + * cobc.h, cobc.c, pplex.l (cobc_get_indicator_column, + cobc_get_text_column, cobc_get_indicator, cobc_get_margin_a, + cobc_get_margin_b): encapsulate source format-related variables with + pure functions + * cobc.c: drop source format-related macros + * cobc.c (cobc_print_info): silence a warning with string indexing + +2022-07-05 Nicolas Berthier + + * pplex.l, parser.y: parse DISPLAY and ACCEPT statements in DEFAULT + SECTION (GCOS 7 extension) + +2022-07-04 Nicolas Berthier + + FR #29 support for ACUCOBOL-GT Terminal format + FR #230 support for X/Open Free-form format + * cobc.h, cobc.c: extend cb_format enum with VARIABLE, TERMINAL, XOPEN, + XCARD, CRT, and COBOLX source formats + * ppparse.y: extend SOURCEFORMAT directive + * cobc.c: drop IS_DEBUG_LINE macro to improve support for new source + formats + * cobc.c, flag.def: add new flag -fformat and remove flag + indicator-column + * cobc.h, pplex.l (cobc_deciph_source_format, cobc_set_source_format, + cobc_get_source_format): encapsulate source format configuration into + preprocessor lexer + * pplex.l (ppinput): add support for ACU terminal and X/Open indicators, + as well as floating margin B + * pplex.l (check_listing): do not output sequence number of short lines + 2022-07-01 Simon Sobisch * field.c (validate_blank_when_zero): iterate over pic->str @@ -257,18 +325,34 @@ * cobc.c, help.c: added -dumpversion +2022-06-27 Simon Sobisch + + * typeck.c (numeric_children_screen_pos_type): ignore redefined + fields + * field.c (cb_resolve_redefines): always search candidate with (small) + word list first, instead of checking the complete parent for a same + name with case-insensitive name comparison + +2022-06-24 Nicolas Berthier + + * cobc.c, config.def, flag.def, ppparse.y: requalify indicator-column as + a flag instead of a dialect option + +2022-06-17 Nicolas Berthier + + * config.def, typeck.c (cb_emit_accept_name, cb_build_display_name): + rely on new option device-mnemonics (boolean) instead of + standard-define to accept device name mnemonics for DISPLAY and ACCEPT + 2022-06-10 Ron Norman * flag.def,config.def : Moved defaultbyte from flag to config * cobc.h,help.c,codegen.c : Add define CB_CONFIG_SINT as signed 'int' * config.c (cb_config_entry): for CB_INT check for a single character Also check for word 'ignore' and make no changes - -2022-06-10 Ron Norman - * codegen.c : Improvement of code emitted for INITIALIZE of tables - Initial table values, then clear next, - then propagate through remainder of the table + Initial table values, then clear next, + then propagate through remainder of the table 2022-05-31 Simon Sobisch @@ -319,6 +403,11 @@ * cobc.c (process_translate) [HAVE_8DOT3_FILENAMES]: fixed missing variable definition +2022-03-29 Nicolas Berthier + + * ppparse.y (literal_token): support SPACE or SPACES figurative + constant as second operand of partial replacing phrases + 2022-03-28 Ron Norman * cobc.c : Added calls to cobc_getenv_path which will check for @@ -335,6 +424,10 @@ * tree.c (cb_init_parse_constants), tree.h, cobc.c: renamed from cb_init_constants +2022-03-11 Fabrice Le Fessant + + * config.def, parser.y: add support for the STOP ERROR statement + 2022-03-10 Simon Sobisch * pplex.l (next_word_is_comment_paragraph_name): extracted from (ppinput) @@ -389,15 +482,57 @@ * codegen.c: removed check for "has condition a reference" or disabled this within [COB_TREE_DEBUG] +2022-02-07 David Declerck + + * config.def, parser.y: allow DEPENDING clause in RECORD CONTAINS + 2022-02-06 Ron Norman * codegen.c: if verb changes then emit trace/debug code, too +2022-02-04 David Declerck + + * cobc.c, cobc.h, config.def, pplex.l, ppparse.y: make the + indicator column configurable + +2022-02-04 David Declerck + + * parser.y, reserved.c, scanner.l, typeck.c: Add GCOS-specific mnemonics + ALTERNATE-CONSOLE, ALTERNATE CONSOLE and TERMINAL + +2022-02-04 David Declerck + + * parser.y: allow the WITH CONVERSION clause right after DISPLAY (ignored) + +2022-01-28 Fabrice Le Fessant + + * warning.def, pplex.l: split warning for missing newlines, it now + can be disabled by -Wno-missing-newline instead of -Wno-others + 2022-01-28 Simon Sobisch * typeck.c (cb_emit_write): changed configuration check and warning for cb_sequential_advancing to dialect variant +2022-01-27 Nicolas Berthier + + * pplex.l, ppparse.y: add support for CONTROL DIVISION (GCOS 7 + extension); only SUBSTITUTION SECTION is handled yet + * config.def: new control-division option + +2022-01-25 Nicolas Berthier + + * pplex.l, ppparse.y, config.h: support COPY and REPLACE + statements with partial REPLACING operands specified using + literals + * config.def: new option partial-replacing-with-literal + * cobc.h, pplex.l (ppparse_verify): feature verification while in + ppparse.y + * pplex.l (ppparse_error): shift newline counter by one when + reporting an error when in ppparse.y + * ppparse.y (unquote, fix_filename): factorize code for + unquotation of alphanumeric literals + 2022-01-25 Ron Norman * field.c: Check that COMP-X size does not exceed what is supported @@ -550,7 +685,6 @@ WRITE ADVANCING was used then default to LINE SEQUENTIAL * typeck.c: If ORGANIZATION not specific and WRITE ADVANCING default to LINE SEQUENTIAL based on 'record-sequential-advancing' - 2021-11-08 Ron Norman @@ -4804,7 +4938,7 @@ * tree.c (cb_name_1): output name for USER FUNCTIONs -2017-01-11 Mário Matos +2017-01-11 Mário Matos * codegen.c (output_entry_function): fixed bug #349 (compatibility for C89 / _MSC_VER < 1800) - moved @@ -6637,11 +6771,11 @@ * parser.y, reserved.c, typeck.c: Added parser support for OCCURS DYNAMIC along with CAPACITY clause as not implemented -2014-09-08 Philipp Böhme +2014-09-08 Philipp Böhme * cobc.c (process) [_MSC_VER]: bugfix in output filter -2014-09-03 Philipp Böhme +2014-09-03 Philipp Böhme * cobc.c, cobc.h: added cobc_free() function (Own freeing functions for debugging purposes. @@ -6689,11 +6823,11 @@ * pplex.l: fixed bug #86 whitespace handling for IDENTIFICATION DIVISION and DEBUGGING MODE -2014-07-10 Philipp Böhme +2014-07-10 Philipp Böhme * typeck.c (cb_emit_sort_init): calculation of table key offset fixed -2014-07-02 Philipp Böhme +2014-07-02 Philipp Böhme * cobc.c [_MSC_VER]: filter output of cl.exe (instead of redirecting to NUL), errors are printed in non-verbose mode now; new: (read_buffer_line) @@ -6732,7 +6866,7 @@ * parser.y: Added extension "USE AT PROGRAM START/END" as not implemented -2014-05-14 Philipp Böhme +2014-05-14 Philipp Böhme * cobc.c: Catch and treat error when no disc space is available for output files @@ -6745,7 +6879,7 @@ * parser.y: Added extension "GOBACK/EXIT PROGRAM RETURNING/GIVING x" -2014-04-29 Philipp Böhme +2014-04-29 Philipp Böhme * codeoptim.c: Fixed bug in COB_ADD_PACKED_INT. Computing COMP-3 failed in MSVC-build versions, diff --git a/cobc/cobc.c b/cobc/cobc.c index 4bd4d9933..35d987dfb 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -123,14 +123,6 @@ FILE *cb_listing_file = NULL; #define CB_LINE_LENGTH 1024 /* hint: we only read PPLEX_BUF_LEN bytes */ #define CB_READ_AHEAD 800 /* lines to read ahead */ -/* TODO: add new compiler configuration flags for this*/ -#define CB_MARGIN_A cb_indicator_column -#define CB_MARGIN_B 11 /* careful, for COBOL 85 this would be 11, - for COBOL 2002 (removed it) would be 7 */ -#define CB_INDICATOR CB_MARGIN_A - 1 -#define CB_SEQUENCE cb_text_column /* the only configuration available...*/ -#define CB_ENDLINE (cb_text_column + cb_indicator_column + 1) - #define CB_MAX_LINES 55 #define CB_LIST_PICSIZE 80 #define CB_PRINT_LEN 132 @@ -138,11 +130,6 @@ FILE *cb_listing_file = NULL; char print_data[CB_PRINT_LEN + 1]; size_t pd_off; -#define IS_DEBUG_LINE(line) ((line)[CB_INDICATOR] == 'D') -#define IS_CONTINUE_LINE(line) ((line)[CB_INDICATOR] == '-') -#define IS_COMMENT_LINE(line) \ - ((line)[CB_INDICATOR] == '*' || (line)[CB_INDICATOR] == '/') - FILE *cb_src_list_file = NULL; int cb_listing_page = 0; int cb_listing_wide = 0; @@ -161,12 +148,9 @@ struct list_files *cb_current_file = NULL; struct cob_time current_compile_time = { 0 }; struct tm current_compile_tm = { 0 }; -enum cb_format cb_source_format = CB_FORMAT_FIXED; #if 0 /* ancient OSVS registers that need special runtime handling - low priority */ enum cb_current_date current_date = CB_DATE_MDY; #endif -int cb_text_column; -int cb_indicator_column; int cb_id = 0; int cb_pic_id = 0; int cb_attr_id = 0; @@ -2449,7 +2433,7 @@ cobc_print_info (void) cobc_var_print ("COB_OBJECT_EXT", COB_OBJECT_EXT, 0); cobc_var_print ("COB_MODULE_EXT", COB_MODULE_EXT, 0); if (!verbose_output && COB_EXE_EXT[0] == '.') { - cobc_var_print ("COB_EXE_EXT", COB_EXE_EXT + 1, 0); + cobc_var_print ("COB_EXE_EXT", &COB_EXE_EXT[1], 0); } else { cobc_var_print ("COB_EXE_EXT", COB_EXE_EXT, 0); } @@ -3302,13 +3286,13 @@ process_command_line (const int argc, char **argv) break; case 'F': - /* --free */ - cb_source_format = CB_FORMAT_FREE; + /* --free, alias of `-fformat=free` */ + cobc_set_source_format (CB_FORMAT_FREE); break; case 'f': - /* --fixed */ - cb_source_format = CB_FORMAT_FIXED; + /* --fixed, alias of `-fformat=fixed` */ + cobc_set_source_format (CB_FORMAT_FIXED); break; case 'q': @@ -3625,6 +3609,13 @@ process_command_line (const int argc, char **argv) cb_max_errors = n; break; + case 16: + /* -fformat= */ + if (cobc_deciph_source_format (cob_optarg) != 0) { + cobc_err_exit (COBC_INV_PAR, "-fformat"); + } + break; + case 8: /* -fdump= : Add sections for dump code generation */ cobc_def_dump_opts (cob_optarg, 1); @@ -4953,7 +4944,7 @@ preprocess (struct filename *fn) /* Save default exceptions and flags in case program directives change them */ memcpy(save_exception_table, cb_exception_table, sizeof(struct cb_exception) * COB_EC_MAX); - save_source_format = cb_source_format; + save_source_format = cobc_get_source_format (); save_fold_copy = cb_fold_copy; save_fold_call = cb_fold_call; save_ref_mod_zero_length = cb_ref_mod_zero_length; @@ -4963,7 +4954,7 @@ preprocess (struct filename *fn) /* Restore default exceptions and flags */ memcpy(cb_exception_table, save_exception_table, sizeof(struct cb_exception) * COB_EC_MAX); - cb_source_format = save_source_format; + cobc_set_source_format (save_source_format); cb_fold_copy = save_fold_copy; cb_fold_call = save_fold_call; cb_ref_mod_zero_length = save_ref_mod_zero_length; @@ -5050,7 +5041,7 @@ set_listing_header_code (void) "............................."); if (cb_listing_wide) { if (cb_listing_file_struct->source_format == CB_FORMAT_FIXED - && cb_text_column == 72 && cb_indicator_column == 7) { + && cobc_get_text_column () == 72) { strcat (cb_listing_header, "SEQUENCE"); } else { strcat (cb_listing_header, @@ -6218,14 +6209,17 @@ get_next_listing_line (FILE *fd, char **pline, int fixed) } if (fixed) { + const unsigned int endline = + cobc_get_text_column () + + cobc_get_indicator_column () + 1; #if 1 /* Simon: that should be portable enough */ - int size = (unsigned int)CB_ENDLINE - i; + const int size = endline - i; if (size > 0) { memset (&out_line[i], ' ', (size_t)size); - i = (unsigned int)CB_ENDLINE; + i = endline; } #else - while (i < (unsigned int)CB_ENDLINE) { + while (i < endline) { out_line[i++] = ' '; } #endif @@ -6244,7 +6238,7 @@ static COB_INLINE COB_A_INLINE char * get_first_nonspace (char *line, const enum cb_format source_format) { if (source_format != CB_FORMAT_FREE) { - return get_next_nonspace (line + CB_INDICATOR + 1); + return get_next_nonspace (line + cobc_get_indicator () + 1); } else { return get_next_nonspace (line); } @@ -6299,7 +6293,7 @@ line_has_page_eject (char *line, const enum cb_format source_format) { char *directive_start; - if (source_format != CB_FORMAT_FREE && line[CB_INDICATOR] == '/') { + if (source_format != CB_FORMAT_FREE && line[cobc_get_indicator ()] == '/') { return 1; } else { directive_start = get_directive_start (line, source_format); @@ -6399,9 +6393,11 @@ print_fixed_line (const int line_num, char pch, char *line) int len = strlen (line); const int max_chars_on_line = cb_listing_wide ? 112 : 72; const char *format_str; + const int indicator = cobc_get_indicator (); + const int text_column = cobc_get_text_column (); - if (line[CB_INDICATOR] == '&') { - line[CB_INDICATOR] = '-'; + if (line[indicator] == '&') { + line[indicator] = '-'; pch = '+'; } @@ -6415,7 +6411,7 @@ print_fixed_line (const int line_num, char pch, char *line) (void)terminate_str_at_first_trailing_space (print_data); print_program_data (print_data); - if (cb_text_column == 72) { + if (text_column == 72) { break; } pch = '+'; @@ -6545,7 +6541,7 @@ compare_prepare (char *cmp_line, char *pline[CB_READ_AHEAD], int out_pos = 0; int line_idx; int in_string = 0; - int last_col = CB_SEQUENCE; + int last_col = cobc_get_text_column (); int last_nonspace; cmp_line[0] = 0; @@ -6635,14 +6631,16 @@ adjust_line_numbers (struct list_files *cfile, int line_num, int adjust) } static COB_INLINE COB_A_INLINE int -is_debug_line (char *line, int fixed) +is_debug_line (char *line, int fixed, int acudebug) { if (line == NULL || line[0] == 0) { return 0; } return !cb_flag_debugging_line - && ((fixed && IS_DEBUG_LINE (line)) - || (!fixed && !strncasecmp (line, "D ", 2))); + && ((fixed && line[cobc_get_indicator ()] == 'D') + || (!fixed && (acudebug + ? !strncasecmp (line, "\\D", 2) + : !strncasecmp (line, "D ", 2)))); } static COB_INLINE COB_A_INLINE int @@ -6650,9 +6648,12 @@ is_comment_line (char *line, int fixed) { if (line == NULL || line[0] == 0) { return 0; + } else { + const int indicator = cobc_get_indicator (); + return fixed + ? line[indicator] == '*' || line[indicator] == '/' + : !strncmp (line, "*>", 2); } - return (fixed && IS_COMMENT_LINE (line)) - || (!fixed && !strncmp (line, "*>", 2)); } static int @@ -6664,8 +6665,8 @@ is_continuation_line (char *line, int fixed) return 0; } if (fixed) { - /* check for "-" in column 7 */ - if (IS_CONTINUE_LINE (line)) { + /* check for "-" in indicator column */ + if (line [cobc_get_indicator ()] == '-') { return 1; } } else { @@ -6695,6 +6696,9 @@ static void make_new_continuation_line (const char *cfile_name, char *pline[CB_READ_AHEAD], int * const pline_cnt, int line_num) { + const int margin_a = cobc_get_margin_a (1); + const int indicator = cobc_get_indicator (); + const int sequence_col = cobc_get_text_column (); abort_if_too_many_continuation_lines (*pline_cnt + 1, cfile_name, line_num); if (pline[*pline_cnt + 1] == NULL) { @@ -6702,9 +6706,9 @@ make_new_continuation_line (const char *cfile_name, char *pline[CB_READ_AHEAD], } strcpy (pline[*pline_cnt + 1], pline[*pline_cnt]); strcpy (pline[*pline_cnt], pline[*pline_cnt - 1]); - memset (&pline[*pline_cnt][CB_MARGIN_A], ' ', - CB_SEQUENCE - CB_MARGIN_A); - pline[*pline_cnt][CB_INDICATOR] = '&'; + memset (&pline[*pline_cnt][margin_a], ' ', + sequence_col - margin_a); + pline[*pline_cnt][indicator] = '&'; (*pline_cnt)++; } @@ -6721,6 +6725,7 @@ add_token_over_multiple_lines (const char *cfile_name, int * const out_col) { int tok_char = 0; + const int sequence_col = cobc_get_text_column (); #ifdef DEBUG_REPLACE fprintf (stdout, " new_token_len = %d\n", new_token_len); @@ -6734,7 +6739,7 @@ add_token_over_multiple_lines (const char *cfile_name, /* Move to the next line when reach the end of the current one. */ - if (*out_col == CB_SEQUENCE) { + if (*out_col == sequence_col) { #ifdef DEBUG_REPLACE fprintf (stdout, " NEW pline[%2d] = %s\n", *out_line, pline[*out_line]); @@ -6770,6 +6775,9 @@ reflow_replaced_fixed_format_text (const char *cfile_name, char *pline[CB_READ_A int out_line; int force_next_line; int new_token_len; + const int margin_b = cobc_get_margin_b (1); + const int indicator = cobc_get_indicator (); + const int sequence_col = cobc_get_text_column (); new_token = cobc_malloc (strlen(newline) + 2); new_line_ptr = get_next_token (newline, new_token, token_terminator); @@ -6781,8 +6789,8 @@ reflow_replaced_fixed_format_text (const char *cfile_name, char *pline[CB_READ_A (first_nonspace < last) && isspace ((unsigned char)(pline[0][first_nonspace])); first_nonspace++); - if (first_nonspace >= CB_MARGIN_B) { - first_col = CB_MARGIN_B; + if (first_nonspace >= margin_b) { + first_col = margin_b; } /* For each line, */ @@ -6793,7 +6801,7 @@ reflow_replaced_fixed_format_text (const char *cfile_name, char *pline[CB_READ_A /* Add as many token as possible to the current line. */ while (new_line_ptr && !force_next_line) { new_token_len = strlen (new_token); - if (new_token_len >= (CB_SEQUENCE - first_col)) { + if (new_token_len >= (sequence_col - first_col)) { /* If the new token does not fit on this line, reflow it onto the next line. @@ -6827,7 +6835,7 @@ reflow_replaced_fixed_format_text (const char *cfile_name, char *pline[CB_READ_A } if (out_col == first_col) { - pline[out_line][CB_INDICATOR] = ' '; + pline[out_line][indicator] = ' '; } while (out_col < last) { pline[out_line][out_col++] = ' '; @@ -6911,7 +6919,8 @@ print_replace_text (struct list_files *cfile, FILE *fd, char *to_ptr; char *newline; const int fixed = (cfile->source_format == CB_FORMAT_FIXED); - int first_col = fixed ? CB_MARGIN_A : 0; + const int acudebug = (cfile->source_format == CB_FORMAT_ACUTERM); + int first_col = fixed ? cobc_get_margin_a (1) : 0; int last; int multi_token; int match = 0; @@ -7058,7 +7067,7 @@ print_replace_text (struct list_files *cfile, FILE *fd, adjust_line_numbers (cfile, line_num, -1); overread = 1; } - if (is_debug_line (pline[pline_cnt], fixed)) { + if (is_debug_line (pline[pline_cnt], fixed, acudebug)) { adjust_line_numbers (cfile, line_num, -1); overread = 1; } @@ -7076,7 +7085,7 @@ print_replace_text (struct list_files *cfile, FILE *fd, pline[pline_cnt][0] = 0; eof = 1; } - if (is_debug_line (pline[pline_cnt], fixed) + if (is_debug_line (pline[pline_cnt], fixed, acudebug) || is_comment_line (pline[pline_cnt], fixed)) { adjust_line_numbers (cfile, line_num, -1); goto next_rec; @@ -7246,7 +7255,7 @@ print_replace_main (struct list_files *cfile, FILE *fd, struct list_files *cur; int i; const int fixed = (cfile->source_format == CB_FORMAT_FIXED); - const int first_col = fixed ? CB_MARGIN_A : 0; + const int first_col = fixed ? cobc_get_margin_a (1) : 0; int is_copy_line; int is_replace_line; int is_replace_off = 0; @@ -7360,6 +7369,7 @@ print_program_code (struct list_files *cfile, int in_copy) int i; int line_num = 1; const int fixed = (cfile->source_format == CB_FORMAT_FIXED); + const int indicator = cobc_get_indicator (); int eof = 0; int pline_cnt = 0; char *pline[CB_READ_AHEAD] = { NULL }; @@ -7450,7 +7460,7 @@ print_program_code (struct list_files *cfile, int in_copy) /* Print each line except the last. */ for (i = 0; i < pline_cnt; i++) { if (pline[i][0]) { - if (fixed && pline[i][CB_INDICATOR] == '&') { + if (fixed && pline[i][indicator] == '&') { print_line (cfile, pline[i], line_num, in_copy); } else { print_line (cfile, pline[i], line_num + i, in_copy); @@ -8696,7 +8706,7 @@ process_file (struct filename *fn, int status) cb_current_file = cb_listing_file_struct; cb_current_file->copy_tail = NULL; /* may include an old reference */ cb_current_file->name = cobc_strdup (fn->source); - cb_current_file->source_format = cb_source_format; + cb_current_file->source_format = cobc_get_source_format (); force_new_page_for_next_line (); } @@ -8874,8 +8884,8 @@ main (int argc, char **argv) finish_setup_compiler_env (); finish_setup_internal_env (); - cb_text_column = cb_config_text_column; - cb_indicator_column = 7; + /* Reset source format in case text column has been configured manually. */ + cobc_set_source_format (cobc_get_source_format ()); memset (cb_listing_header, 0, sizeof (cb_listing_header)); /* If -P=file specified, all lists go to this file */ diff --git a/cobc/cobc.h b/cobc/cobc.h index 8ce0d4ef3..443323319 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -46,6 +46,12 @@ #include "../libcob/sysdefines.h" +#ifdef HAVE_ATTRIBUTE_PURE +#define COB_A_PURE __attribute__((pure)) +#else +#define COB_A_PURE +#endif + /* Defines for access() */ #ifndef F_OK #define F_OK 0 @@ -70,7 +76,13 @@ /* Source format enum */ enum cb_format { CB_FORMAT_FIXED = 0, - CB_FORMAT_FREE + CB_FORMAT_FREE, + CB_FORMAT_VARIABLE, /* MF's Variable format */ + CB_FORMAT_XOPEN_FFF, /* X/Open Free-form format */ + CB_FORMAT_ICOBOL_XCARD, /* ICOBOL xCard */ + CB_FORMAT_ICOBOL_CRT, /* ICOBOL Free-form format (CRT) */ + CB_FORMAT_ACUTERM, /* ACU Terminal format, named "TERMINAL" */ + CB_FORMAT_COBOLX, /* GCOS's COBOLX */ }; #if 0 /* ancient OSVS registers that need special runtime handling - low priority */ @@ -331,11 +343,9 @@ struct list_files { extern struct list_files *cb_current_file; -extern enum cb_format cb_source_format; #if 0 /* ancient OSVS registers that need special runtime handling - low priority */ extern enum cb_current_date current_date; #endif -extern int cb_text_column; /* end of area B (in single-byte characters) */ extern int cb_mf_ibm_comp; extern int cb_cob_line_num; extern int cb_all_files_xfd; @@ -602,8 +612,18 @@ extern int ppcopy (const char *, const char *, struct cb_replace_list *); extern void pp_set_replace_list (struct cb_replace_list *, const cob_u32_t); +extern unsigned int ppparse_verify (const enum cb_support tag, + const char *feature); extern void ppparse_error (const char *); +extern int cobc_deciph_source_format (const char *); +extern void cobc_set_source_format (const enum cb_format); +extern enum cb_format cobc_get_source_format (void) COB_A_PURE; +extern int cobc_get_indicator_column (void) COB_A_PURE; +extern int cobc_get_text_column (void) COB_A_PURE; +extern int cobc_get_indicator (void) COB_A_PURE; +extern int cobc_get_margin_a (int indicator_width) COB_A_PURE; +extern int cobc_get_margin_b (int indicator_width) COB_A_PURE; /* parser (in scanner.l, parser.y) */ #if !defined (COB_IN_SCANNER ) && !defined (COB_IN_PPLEX) && \ diff --git a/cobc/codegen.c b/cobc/codegen.c index 4f993cf30..c6cc9eeb8 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -4326,7 +4326,11 @@ output_param (cb_tree x, int id) break; case CB_TAG_REPORT_LINE: /* NOTE: do not use CB_REFERENCE_P because 'x' has a tag of CB_TAG_REPORT_LINE */ +#if 1 /* FIXME: Should have expected type! */ r = (struct cb_reference *)x; +#else + r = CB_REFERENCE (x); +#endif f = CB_FIELD (r->value); output ("&%s%d", CB_PREFIX_REPORT_LINE, f->id); break; @@ -5249,11 +5253,12 @@ propagate_table (cb_tree x, int bgn_idx) struct cb_field *f = cb_code_field (x); const unsigned int occ = (unsigned int)f->occurs_max; cob_uli_t len = (cob_uli_t)f->size; - size_t maxlen = len * occ; + cob_uli_t maxlen = len * occ; unsigned int j = 1; - if (bgn_idx < 1) + if (bgn_idx < 1) { bgn_idx = 1; + } if (gen_init_working || (!chk_field_variable_size (f) @@ -5261,39 +5266,40 @@ propagate_table (cb_tree x, int bgn_idx) && !f->depending)) { /* Table size is known at compile time */ /* Generate inline 'memcpy' to propagate the array data */ - output_block_open (); - output_prefix (); - output ("cob_u8_ptr b_ptr = "); - output_data(x); - if (bgn_idx > 1) { - output (" + %ld",len * (bgn_idx - 1)); - maxlen -= len * (bgn_idx - 1); - } - output (";"); - output_newline (); - - /* double the chunks each time */ - do { + if (occ > 1) { + output_block_open (); output_prefix (); - output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", len, len); - output ("\t/* %s: %6u thru %u */", - f->name, j + bgn_idx, j * 2 + bgn_idx - 1); + output ("cob_u8_ptr b_ptr = "); + output_data (x); + if (bgn_idx > 1) { + output (" + %ld",len * (bgn_idx - 1)); + maxlen -= len * (bgn_idx - 1); + } + output (";"); output_newline (); - j = j * 2; - len = len * 2; - } while ((j * 2) < occ); - /* missing piece after last chunk */ - if (j < occ - && maxlen > len) { - output_prefix (); - output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", - len, maxlen - len); - output ("\t/* %s: %6u thru %u */", - f->name, j + bgn_idx, occ); - output_newline (); + /* double the chunks each time */ + do { + output_prefix (); + output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", len, len); + output ("\t/* %s: %6u thru %u */", + f->name, j + bgn_idx, j * 2 + bgn_idx - 1); + output_newline (); + j = j * 2; + len = len * 2; + } while ((j * 2) < occ); + /* missing piece after last chunk */ + if (j < occ + && maxlen > len) { + output_prefix (); + output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", + len, maxlen - len); + output ("\t/* %s: %6u thru %u */", + f->name, j + bgn_idx, occ); + output_newline (); + } + output_block_close (); } - output_block_close (); } else { /* Table size is only known at run time */ output_prefix (); @@ -5341,6 +5347,10 @@ initialize_uniform_char (const struct cb_field *f, return '0'; case COB_TYPE_ALPHANUMERIC: return ' '; +#if 1 /* TODO: proper initialization of NATIONAL data */ + case COB_TYPE_NATIONAL: + return ' '; +#endif default: return -1; } @@ -5915,9 +5925,9 @@ output_initialize_occurs (struct cb_initialize *p, cb_tree x) cb_tree list; cb_tree l; int k, offset, idx, idx_clr, total_occurs, simple_occurs; - int idxtbl[COB_MAX_SUBSCRIPTS+1]; - int occtbl[COB_MAX_SUBSCRIPTS+1]; - struct cb_field *pftbl[COB_MAX_SUBSCRIPTS+1]; + int idxtbl[COB_MAX_SUBSCRIPTS+1] = { 0 }; + int occtbl[COB_MAX_SUBSCRIPTS+1] = { 0 }; + struct cb_field *pftbl[COB_MAX_SUBSCRIPTS+1] = { NULL }; f = cb_code_field (x); if (f->flag_occurs @@ -5926,10 +5936,12 @@ output_initialize_occurs (struct cb_initialize *p, cb_tree x) simple_occurs = 1; else simple_occurs = 0; +#if 0 /* CHECKME: the init above should be fine */ for (idx=0; idx <= COB_MAX_SUBSCRIPTS; idx++) { idxtbl[idx] = 0; pftbl[idx] = NULL; } +#endif total_occurs = 1; idx_clr = 0; for (idx = 0, pf = f; pf; pf = pf->parent) { @@ -6131,6 +6143,9 @@ output_initialize_compound (struct cb_initialize *p, cb_tree x) if (f->occurs_max > 1) { + /* all exceptions should have been raised above, + so temporarily detach from the reference */ + ref->check = NULL; ref->length = NULL; for (pf = f; pf && !pf->flag_occurs_values; pf = pf->parent); diff --git a/cobc/config.c b/cobc/config.c index f7dc109b9..cfc2b8c6d 100644 --- a/cobc/config.c +++ b/cobc/config.c @@ -203,14 +203,12 @@ check_valid_value (const char *fname, const int line, const char *name, const ch return ret; } -#if 0 /* unused */ static void unsupported_value (const char *fname, const int line, const char *name, const char *val) { configuration_error (fname, line, 1, _("unsupported value '%s' for configuration tag '%s'"), val, name); } -#endif static void split_and_iterate_on_comma_separated_str ( @@ -756,7 +754,6 @@ cb_config_entry (char *buff, const char *fname, const int line) return -1; } break; - /* for enums without a string value: set max_value and fall through to CB_INT */ } else if (strcmp (name, "dpc-in-data") == 0) { if (strcmp (val, "none") == 0) { cb_dpc_in_data = CB_DPC_IN_NONE; @@ -771,6 +768,40 @@ cb_config_entry (char *buff, const char *fname, const int line) return -1; } break; + } else if (strcmp (name, "defaultbyte") == 0) { + if (strcmp (val, "init") == 0) { + /* generate default initialization per INITIALIZE rules */ + cb_default_byte = -1; + break; + } + if (strcmp (val, "none") == 0) { + cb_default_byte = -2; +#if 1 /* TODO: do not generate any default initialization for fields without VALUE, + only the storage (best performance, least reproducibility); for now warn + if specified on command line (allowing config files be correct already) */ + if (strcmp (fname, "-fdefaultbyte=none") == 0) { + unsupported_value (fname, line, name, val); + } + cb_default_byte = 0; /* at least a single fixed value for now... */ +#endif + break; + } + /* otherwise init by character (transformed to number */ + /* convert quoted character to number */ + if (val[0] == '"' && val[1] != 0 && val[2] == '"' && val[3] == 0) { + cb_default_byte = val[1]; + break; + } else + /* convert character to number (as quotes will commonly + be removed when given on shell) */ + if (val[1] == 0 && (val[0] <= '0' || val[0] >= '9')) { + cb_default_byte = val[0]; + break; + } + /* just use decimal as character number */ + config_table[i].min_value = 0; + config_table[i].max_value = 255; + /* fall through */ /* for enums without a string value: set max_value and fall through to CB_INT */ } else if (strcmp (name, "standard-define") == 0) { config_table[i].max_value = CB_STD_MAX - 1; @@ -785,14 +816,7 @@ cb_config_entry (char *buff, const char *fname, const int line) /* LCOV_EXCL_STOP */ case CB_INT: - if (strcmp (val, "ignore") == 0) - break; - if (val[1] == 0 - && (islower(val[0]) || isupper(val[0]))) { - int v = val[0]; - sprintf(valx,"%d",v); - val = valx; - } + /* check for number */ for (j = 0; val[j]; j++) { if (val[j] < '0' || val[j] > '9') { invalid_value (fname, line, name, val, NULL, 0, 0); diff --git a/cobc/config.def b/cobc/config.def index 760fe6b1d..efa9120c2 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -49,10 +49,10 @@ CB_CONFIG_STRING (cb_reserved_words, "reserved-words", _("use of complete/fixed /* Integer flags */ CB_CONFIG_INT (cb_tab_width, "tab-width", 1, 12, CB_XRANGE(1,12), - _("set number of spaces that are assumed for tabs")) + _("number of spaces that are assumed for tabs")) CB_CONFIG_INT (cb_config_text_column, "text-column", 72, 255, CB_XRANGE(72,255), - _("set right margin for source (fixed format only)")) + _("right margin column number for fixed-form reference-format")) CB_CONFIG_INT (cb_pic_length, "pic-length", 1, COB_MINI_MAX, _(""), _("maximum number of characters allowed in the PICTURE character-string")) @@ -66,11 +66,6 @@ CB_CONFIG_INT (cb_lit_length, "literal-length", 1, COB_MAX_LITERAL_LEN, _(""), - _("initialize fields without VALUE to \n" - " * decimal 0..255 representing a character\n" - " * default: initialize to picture")) - CB_CONFIG_INT (cb_align_record, "align-record", 0, 256, CB_XRANGE(0,256), _("align WORKING-STORAGE/LOCAL-STORAGE record on boundary")) @@ -83,6 +78,14 @@ CB_CONFIG_BOOLEAN (cb_align_opt, "align-opt", /* Flags with required parameter and special values */ +CB_CONFIG_ANY (signed int, cb_default_byte, "defaultbyte", + _("default initialization for fields without VALUE, may be one of\n" + " * character in quotes\n" + " * decimal 0..255 representing a character\n" + " * \"init\" to initialize to PICTURE/USAGE\n" + " * \"none\" to do no explicit initialization\n" + " * default: \"init\"")) + CB_CONFIG_ANY (enum cb_std_def, cb_std_define, "standard-define", NULL) /* Used Standard (set via -std) */ CB_CONFIG_ANY (enum cb_binary_size_options, cb_binary_size, "binary-size", @@ -186,11 +189,21 @@ CB_CONFIG_BOOLEAN (cb_move_nonnumlit_to_numeric_is_zero, "move-non-numeric-lit-t CB_CONFIG_BOOLEAN (cb_implicit_assign_dynamic_var, "implicit-assign-dynamic-var", _("implicitly define a variable if an ASSIGN DYNAMIC does not match any data item")) +CB_CONFIG_BOOLEAN (cb_device_mnemonics, "device-mnemonics", + _("specifying device by mnemonic")) + /* Support flags */ CB_CONFIG_SUPPORT (cb_comment_paragraphs, "comment-paragraphs", _("comment paragraphs in IDENTIFICATION DIVISION (AUTHOR, DATE-WRITTEN, ...)")) +CB_CONFIG_SUPPORT (cb_control_division, "control-division", + _("CONTROL DIVISION")) + +CB_CONFIG_SUPPORT (cb_partial_replacing_with_literal, + "partial-replacing-with-literal", + _("partial replacing with literal")) + CB_CONFIG_SUPPORT (cb_memory_size_clause, "memory-size-clause", _("MEMORY-SIZE clause")) @@ -241,6 +254,9 @@ CB_CONFIG_SUPPORT (cb_stop_literal_statement, "stop-literal-statement", CB_CONFIG_SUPPORT (cb_stop_identifier_statement, "stop-identifier-statement", _("STOP-identifier statement")) +CB_CONFIG_SUPPORT (cb_stop_error_statement, "stop-error-statement", + _("STOP ERROR statement")) + CB_CONFIG_SUPPORT (cb_debugging_mode, "debugging-mode", _("DEBUGGING MODE and debugging indicator")) @@ -427,3 +443,5 @@ CB_CONFIG_SUPPORT (cb_vsam_status, "vsam-status", CB_CONFIG_SUPPORT (cb_self_call_recursive, "self-call-recursive", _("CALL to own PROGRAM-ID implies RECURSIVE attribute")) +CB_CONFIG_SUPPORT (cb_record_contains_depending_clause, "record-contains-depending-clause", + _("DEPENDING clause in RECORD CONTAINS")) diff --git a/cobc/field.c b/cobc/field.c index 279f41b1a..0e04dd47a 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -637,31 +637,32 @@ cb_resolve_redefines (struct cb_field *field, cb_tree redefines) return NULL; } - /* Resolve the name in the current group (if any) */ - if (field->parent && field->parent->children) { - for (f = field->parent->children; f; f = f->sister) { - if (strcasecmp (f->name, name) == 0) { - break; - } - } - if (f == NULL) { - cb_error_x (x, _("'%s' is not defined in '%s'"), name, field->parent->name); - return NULL; - } - } else { - /* Get last defined name */ - candidate = NULL; - items = r->word->items; - for (; items; items = CB_CHAIN (items)) { - if (CB_FIELD_P (CB_VALUE (items))) { - candidate = CB_VALUE (items); - } - } - if (!candidate) { + /* Get last defined name */ + /* note: chaining over these are much faster than chaining over the complete + parent using strcasecmp */ + for (items = r->word->items; items; items = CB_CHAIN (items)) { + const cb_tree value = CB_VALUE (items); + if (CB_FIELD_P (value)) { + candidate = value; + /* we want to get the last, so no "break" here */ + } + } + if (!candidate) { + if (field->parent) { + cb_error_x (x, _("'%s' is not defined in '%s'"), + name, field->parent->name); + } else { undefined_error (redefines); - return NULL; } - f = CB_FIELD_PTR (candidate); + return NULL; + } + f = CB_FIELD_PTR (candidate); + + /* Check if candidate is in the current group (if any) */ + if (field->parent && field->parent != f->parent) { + cb_error_x (x, _ ("'%s' is not defined in '%s'"), + name, field->parent->name); + return NULL; } /* Check level number */ diff --git a/cobc/flag.def b/cobc/flag.def index 218e3c847..f167c3e78 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -63,6 +63,11 @@ CB_FLAG_RQ (cb_max_errors, 1, "max-errors", 128, 7, /* Flags with required parameter and no associated variable */ +CB_FLAG_NQ (1, "format", 16, + _(" -fformat=[FIXED|FREE|VARIABLE|XOPEN|XCARD|CRT|TERMINAL|COBOLX]\n" + " reference format\n" + " * default: FIXED")) + CB_FLAG_NQ (1, "intrinsics", 10, /* added to cb_intrinsic_list */ _(" -fintrinsics=[ALL|intrinsic function name(,name,...)]\n" " intrinsics to be used without FUNCTION keyword")) diff --git a/cobc/parser.y b/cobc/parser.y index 78a565ecc..415490a88 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -3372,6 +3372,7 @@ nested_list: depth = 0; setup_from_identification = 0; } + _control_division /* GCOS extension */ source_element_list ; @@ -3559,6 +3560,51 @@ _prototype_procedure_division_header: } ; +/* CONTROL DIVISION (GCOS extension) */ + +_control_division: + /* empty */ +| CONTROL DIVISION TOK_DOT + { + cb_verify (cb_control_division, "CONTROL DIVISION"); + } + _default_section +; + +_default_section: + /* empty */ +| DEFAULT SECTION TOK_DOT + _default_clauses + { + cobc_cs_check = 0; + } +; + +_default_clauses: + /*empty*/ +| _default_accept_clause + _default_display_clause + TOK_DOT +; + +_default_accept_clause: + /* empty */ +| ACCEPT _is word_or_terminal + { + CB_PENDING ("ACCEPT statement in DEFAULT SECTION"); + /* TODO: setup_default_accept ($3); */ + } +; + +_default_display_clause: + /* empty */ +| DISPLAY _is word_or_terminal + { + CB_PENDING ("DISPLAY statement in DEFAULT SECTION"); + /* TODO: setup_default_display ($3); */ + } +; + /* PROGRAM body */ _program_body: @@ -4200,7 +4246,7 @@ special_name: /* Mnemonic name clause */ mnemonic_name_clause: - WORD + word_or_terminal { check_headers_present (COBC_HD_ENVIRONMENT_DIVISION, COBC_HD_CONFIGURATION_SECTION, @@ -4218,6 +4264,11 @@ mnemonic_name_clause: mnemonic_choices ; +word_or_terminal: + WORD { $$ = $1; } + /* under GCOS, this reserved name can also be a system name */ +| TERMINAL { $$ = cb_build_reference("TERMINAL"); } + mnemonic_choices: _is CRT { @@ -6227,12 +6278,19 @@ record_clause: } } | RECORD _contains integer TO integer _characters + _record_depending /* GCOS extension */ { check_repeated ("RECORD", SYN_CLAUSE_4, &check_duplicate); if (current_file->organization == COB_ORG_LINE_SEQUENTIAL) { cb_warning (cb_warn_additional, _("RECORD clause ignored for LINE SEQUENTIAL")); } else { set_record_size ($3, $5); + if ($7) { + cb_verify (cb_record_contains_depending_clause, "RECORD CONTAINS DEPENDING"); + current_file->record_depending = $7; + current_file->flag_check_record_varying_limits = + current_file->record_min == 0 || current_file->record_max == 0; + } } } | RECORD _is VARYING _in _size _from_integer _to_integer _characters @@ -6240,16 +6298,15 @@ record_clause: { check_repeated ("RECORD", SYN_CLAUSE_4, &check_duplicate); set_record_size ($6, $7); + current_file->record_depending = $9; current_file->flag_check_record_varying_limits = current_file->record_min == 0 || current_file->record_max == 0; } ; _record_depending: -| DEPENDING _on reference - { - current_file->record_depending = $3; - } + /* empty */ { $$ = NULL; } +| DEPENDING _on reference { $$ = $3; } ; _from_integer: @@ -12167,11 +12224,21 @@ cancel_statement: ; cancel_body: + cancel_list +| ALL + { + const char *all_name = "CANCEL ALL"; + struct cb_literal *all = build_literal (CB_CATEGORY_ALPHANUMERIC, all_name, strlen (all_name)); + cb_emit_cancel (CB_TREE(all)); + } +; + +cancel_list: id_or_lit_or_program_name { cb_emit_cancel ($1); } -| cancel_body id_or_lit_or_program_name +| cancel_list id_or_lit_or_program_name { cb_emit_cancel ($2); } @@ -12461,6 +12528,10 @@ display_body: cb_emit_command_line ($1); } | screen_or_device_display _common_exception_phrases +| _with CONVERSION screen_or_device_display _common_exception_phrases + { + CB_PENDING ("DISPLAY WITH CONVERSION"); + } | display_erase /* note: may also be part of display_pos_specifier */ | display_pos_specifier | display_message_box @@ -12595,7 +12666,7 @@ display_upon: { upon_value = cb_build_display_mnemonic ($2); } -| UPON WORD +| UPON word_or_terminal { upon_value = cb_build_display_name ($2); } @@ -15812,6 +15883,13 @@ stop_statement: check_unreached = 1; cobc_cs_check = 0; } +| STOP ERROR /* GCOS */ + { + begin_statement (STMT_STOP_ERROR, 0); + cb_verify (cb_stop_error_statement, cb_statement_name[STMT_STOP_ERROR]); + cb_emit_stop_error (); + check_unreached = 1; + } | STOP stop_argument { begin_statement (STMT_STOP, 0); diff --git a/cobc/pplex.l b/cobc/pplex.l index c388180ac..dd42e73a4 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -131,7 +131,6 @@ struct plex_stack { /* Global variables */ - /* Local variables */ static char *plexbuff1 = NULL; static char *plexbuff2 = NULL; @@ -149,6 +148,14 @@ static int quotation_mark = 0; static int listing_line = 0; static int requires_listing_line; static int requires_new_line = 0; +static enum cb_format source_format; +static int indicator_column = 7; +static int text_column = 72; /* end of area B (in single-byte + characters) */ +static int floating_area_b = 0; /* whether indicator is optional */ +static int fill_continued_alnums = 1; /* whether continued alphanumeric + literals should be filled with + spaces up to text column */ static char display_msg[PPLEX_BUFF_LEN]; @@ -187,6 +194,8 @@ DEFNUM_LITERAL [+-]?[0-9]*[\.]*[0-9]+ %x COBOL_WORDS_DIRECTIVE_STATE %x COPY_STATE %x PSEUDO_STATE +%x CONTROL_DIVISION_STATE +%x SUBSTITUTION_SECTION_STATE %x SOURCE_DIRECTIVE_STATE %x DEFINE_DIRECTIVE_STATE %x ON_OFF_DIRECTIVE_STATE @@ -447,7 +456,65 @@ DEFNUM_LITERAL [+-]?[0-9]*[\.]*[0-9]+ return CONTROL_STATEMENT; } +"CONTROL"[ ,;\n]+"DIVISION" { + /* Syntax extension for GCOS: such a division may include a SUBSTITUTION + SECTION that records source text replacement statements, along with a + DEFAULT SECTION where compile-time defaults are specified. */ + /* cf `ppparse.y`, grammar entry `program_with_control_division`, along + with `parser.y`, entry `_control_division`. */ + ppecho (yytext, 0, (int)yyleng); + yy_push_state (CONTROL_DIVISION_STATE); + return CONTROL_DIVISION; +} + +{ + "SUBSTITUTION"[ ,;\n]+"SECTION" { + yy_push_state (SUBSTITUTION_SECTION_STATE); + return SUBSTITUTION_SECTION; + } + \. { + /* Pass dots to the parser to handle DEFAULT SECTION. */ + ppecho (yytext, 0, (int)yyleng); + return DOT; + } +} + +{ + "REPLACE" { + yy_push_state (COPY_STATE); + return REPLACE; + } + \. { + /* Intercept dots within the SUBSTITUTION SECTION */ + return DOT; + } +} + +{ + "DEFAULT"[ ,;\n]+"SECTION" { + /* Pop any control division-related start condition state. */ + while (YY_START == CONTROL_DIVISION_STATE || + YY_START == SUBSTITUTION_SECTION_STATE) + yy_pop_state (); + ppecho (yytext, 0, (int)yyleng); + } + [,;]?\n { + ECHO; + check_listing (yytext, 0); + cb_source_line++; + } + [,;]?[ ]+ { /* ignore */ } +} + + ("ID"|"IDENTIFICATION")[ ,;\n]+"DIVISION" { + /* Pop any control division-related start condition state. */ + while (YY_START == CONTROL_DIVISION_STATE || + YY_START == SUBSTITUTION_SECTION_STATE) + yy_pop_state (); /* Allow comment sentences/paragraphs */ comment_allowed = 1; ppecho (yytext, 0, (int)yyleng); @@ -617,9 +684,10 @@ COBOL_WORDS_DIRECTIVE_STATE>{ { "FORMAT" { return FORMAT; } "IS" { return IS; } - "FIXED" { return FIXED; } - "FREE" { return FREE; } - "VARIABLE" { return VARIABLE; } + {WORD} { + pplval.s = cobc_plex_strdup (yytext); + return VARIABLE_NAME; + } } { @@ -988,7 +1056,7 @@ ENDIF_DIRECTIVE_STATE>{ /* Restore variables */ current_replace_list = current_copy_info->replacing; quotation_mark = current_copy_info->quotation_mark; - cb_source_format = current_copy_info->source_format; + cobc_set_source_format (current_copy_info->source_format); copy_stack = current_copy_info->next; cobc_free (current_copy_info->dname); @@ -1115,7 +1183,7 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) current_copy_info->replacing = current_replace_list; current_copy_info->line = cb_source_line; current_copy_info->quotation_mark = quotation_mark; - current_copy_info->source_format = cb_source_format; + current_copy_info->source_format = cobc_get_source_format (); current_copy_info->next = copy_stack; current_copy_info->containing_files = old_list_file; @@ -1324,10 +1392,123 @@ ppcopy (const char *name, const char *lib, struct cb_replace_list *replace_list) return -1; } +/* `newline_count` is one line ahead when the two functions below are called + (from `ppparse.y`). */ + +unsigned int +ppparse_verify (const enum cb_support tag, const char *feature) +{ + return cb_plex_verify (newline_count-1, tag, feature); +} + void ppparse_error (const char *err_msg) { - cb_plex_error (newline_count, "%s", err_msg); + cb_plex_error (newline_count-1, "%s", err_msg); +} + +/* Sets `source_format`, `indicator_column`, `text_column`, + `floating_area_b`, and `fill_continued_alnums`, based on the given source + format. */ +void +cobc_set_source_format (const enum cb_format sf) { + source_format = sf; + + switch (source_format) { + case CB_FORMAT_XOPEN_FFF: + case CB_FORMAT_ICOBOL_CRT: + case CB_FORMAT_ACUTERM: + case CB_FORMAT_COBOLX: + indicator_column = 1; + floating_area_b = source_format != CB_FORMAT_COBOLX; + fill_continued_alnums = 0; + break; + default: + indicator_column = 7; + floating_area_b = 0; + fill_continued_alnums = 1; + break; + } + + switch (source_format) { + case CB_FORMAT_FIXED: + text_column = cb_config_text_column; /* 72 by default */ + break; + case CB_FORMAT_VARIABLE: + /* This value matches most MF Visual COBOL 4.0 version. */ + text_column = 250; + break; + case CB_FORMAT_XOPEN_FFF: + text_column = 80; + break; + case CB_FORMAT_ACUTERM: + case CB_FORMAT_ICOBOL_CRT: + /* CHECKME: + https://sf.net/p/gnucobol/feature-requests/29/#c2d0/8d2f */ + text_column = 320; + break; + case CB_FORMAT_COBOLX: + case CB_FORMAT_ICOBOL_XCARD: + text_column = 255; + break; + case CB_FORMAT_FREE: + /* text-column should be ignored: put an invalid value to catch + some bugs? */ + text_column = -1; + break; + } +} + +COB_A_PURE enum cb_format cobc_get_source_format (void) { return source_format; } +COB_A_PURE int cobc_get_indicator_column (void) { return indicator_column; } +COB_A_PURE int cobc_get_text_column (void) { return text_column; } + +/* The three functions below return indexes on the lines (starting from 0), not + character positions (counted from 1). */ +COB_A_PURE int cobc_get_indicator (void) { + return indicator_column - 1; +} +COB_A_PURE int cobc_get_margin_a (const int indicator_width) { + return indicator_column + indicator_width - 1; +} +COB_A_PURE int cobc_get_margin_b (const int indicator_width) { + /* careful, for COBOL 2002 there is no margin B */ + return indicator_column + indicator_width + 3; +} + +static int +cobc_parse_source_format (enum cb_format *const out, const char *const sfname) { + enum cb_format format; + if (!cb_strcasecmp (sfname, "FIXED")) { + format = CB_FORMAT_FIXED; + } else if (!cb_strcasecmp (sfname, "FREE")) { + format = CB_FORMAT_FREE; + } else if (!cb_strcasecmp (sfname, "VARIABLE")) { + format = CB_FORMAT_VARIABLE; + } else if (!cb_strcasecmp (sfname, "XOPEN")) { + format = CB_FORMAT_XOPEN_FFF; + } else if (!cb_strcasecmp (sfname, "XCARD")) { + format = CB_FORMAT_ICOBOL_XCARD; + } else if (!cb_strcasecmp (sfname, "CRT")) { + format = CB_FORMAT_ICOBOL_CRT; + } else if (!cb_strcasecmp (sfname, "TERMINAL")) { + format = CB_FORMAT_ACUTERM; + } else if (!cb_strcasecmp (sfname, "COBOLX")) { + format = CB_FORMAT_COBOLX; + } else { + return 1; /* invalid argument */ + } + *out = format; + return 0; +} + +int cobc_deciph_source_format (const char* const sfname) { + enum cb_format format; + if (cobc_parse_source_format (&format, sfname) == 0) { + cobc_set_source_format (format); + return 0; + } + return 1; } void @@ -1474,7 +1655,7 @@ get_new_listing_file (void) cb_current_file->copy_tail = newfile; newfile->copy_line = cb_source_line; - newfile->source_format = cb_source_format; + newfile->source_format = cobc_get_source_format (); old_list_file = cb_current_file; cb_current_file = newfile; } @@ -1624,6 +1805,7 @@ ppinput (char *buff, const size_t max_size) size_t gotcr; size_t line_overflow; size_t continuation; + size_t indicator_width; int ipchar; int i,k; int n; @@ -1738,7 +1920,7 @@ start: [but only during ppinput() in pplex.l ?] Workaround for now: Temporary newline_count + 1 */ - if (cb_source_format == CB_FORMAT_FREE) { + if (source_format == CB_FORMAT_FREE) { if (line_overflow == 0) { cb_plex_warning (cb_missing_newline, newline_count + 1, _("line not terminated by a newline")); @@ -1768,24 +1950,24 @@ start: if (memcmp("<<<<<<<", buff, 7) == 0 || memcmp("=======", buff, 7) == 0 || memcmp(">>>>>>>", buff, 7) == 0) { - /* FIXME: the different line numbers (see test "conflict markers" + /* FIXME: the different line numbers (see test "conflict markers" are definitely a bug to solve in short time */ - if (cb_source_format == CB_FORMAT_FREE) { + if (source_format == CB_FORMAT_FREE) { ++newline_count; } cb_plex_error (newline_count, _("version control conflict marker in file")); - if (cb_source_format != CB_FORMAT_FREE) { + if (source_format != CB_FORMAT_FREE) { ++newline_count; } goto start; } } - if (cb_source_format == CB_FORMAT_FREE) { + if (source_format == CB_FORMAT_FREE) { bp = buff; } else { - if (n < 8) { + if (n <= indicator_column) { /* Line too short */ newline_count++; goto start; @@ -1798,16 +1980,15 @@ start: } } - /* Check if text is longer than cb_text_column */ - if (cb_source_format == CB_FORMAT_FIXED - && n > cb_text_column + 1) { + /* Check if text is longer than text_column */ + if (n > text_column + 1) { /* Show warning if it is not whitespace (postponed after checking for comments by setting line_overflow to first column that leads to "source text too long") */ if (cb_warn_opt_val[cb_warn_column_overflow] && line_overflow == 0) { - for (coln = cb_text_column; coln < n; ++coln) { + for (coln = text_column; coln < n; ++coln) { if (buff[coln] != ' ' && buff[coln] != '\n') { line_overflow = coln; break; @@ -1817,21 +1998,21 @@ start: line_overflow = 0; } /* Remove it */ - buff[cb_text_column] = '\n'; - buff[cb_text_column + 1] = 0; - n = cb_text_column + 1; + buff[text_column] = '\n'; + buff[text_column + 1] = 0; + n = text_column + 1; } else { line_overflow = 0; } - memset (buff, ' ', (size_t)6); - /* Note we allow directive lines to start at column 7 */ - bp = &buff[6]; + memset (buff, ' ', (size_t)(indicator_column - 1)); + /* Note we allow directive lines to start in the indicator column */ + bp = &buff[indicator_column - 1]; /* Special case: acucomment must be checked here as we'd pass comments as directives otherwise */ - if (cb_flag_acucomment && buff[6] == '$') { - buff[6] = '*'; + if (cb_flag_acucomment && buff[indicator_column - 1] == '$') { + buff[indicator_column - 1] = '*'; } } /* @@ -1942,7 +2123,7 @@ start: } /* Return when free format (no floating comments removed!) */ - if (cb_source_format == CB_FORMAT_FREE) { + if (source_format == CB_FORMAT_FREE) { within_comment = 0; if (newline_count) { memmove (buff + newline_count, buff, (size_t)n + 1); @@ -1955,11 +2136,21 @@ start: /* Fixed format */ - /* Check the indicator (column 7) */ - switch (buff[6]) { + /* Check the indicator */ + indicator_width = 1; + switch (buff[indicator_column - 1]) { case ' ': + if (floating_area_b) { /* indicator is optional */ + indicator_width = 0; + } break; case '-': + if (source_format == CB_FORMAT_XOPEN_FFF) { + /* X/Open free-form does not interpret '-' as + continuation indicator */ + indicator_width = 0; + break; + } if (within_comment) { cb_plex_error (newline_count, _("invalid continuation in comment entry")); @@ -1973,6 +2164,19 @@ start: break; case 'd': case 'D': + if (source_format == CB_FORMAT_ACUTERM) { + indicator_width = 0; + break; /* ACU terminal: this 'D' denotes a nominal text line */ + } else if (source_format == CB_FORMAT_XOPEN_FFF) { + if (buff[indicator_column - 1] == 'D' && + buff[indicator_column] == ' ') { + indicator_width = 2; + } else { + /* X/Open free-form: not a debugging line */ + indicator_width = 0; + break; + } + } /* Debugging line */ (void) cb_verify (cb_debugging_mode, _("debugging indicator")); if (cb_flag_debugging_line) { @@ -1984,10 +2188,32 @@ start: case '/': /* Comment line requested page-break in listing */ newline_count++; goto start; + case '\\': + if (buff[indicator_column] == 'D' && + source_format == CB_FORMAT_ACUTERM) { + /* ACUTERM debugging line */ + (void) cb_verify (cb_debugging_mode, _("debugging indicator")); + indicator_width = 2; + if (cb_flag_debugging_line) { + break; + } + } else { + /* Invalid ACU terminal indicator? */ + cb_plex_error (newline_count, + _("invalid indicator '\\' at column %d"), + indicator_column); + } + newline_count++; + goto start; default: + if (floating_area_b) { /* indicator is optional */ + indicator_width = 0; + break; + } /* Invalid indicator */ cb_plex_error (newline_count, - _("invalid indicator '%c' at column 7"), buff[6]); + _("invalid indicator '%c' at column %d"), + buff[indicator_column - 1], indicator_column); /* Note: Treat as comment line to allow further parsing instead of aborting compilation */ newline_count++; @@ -1997,13 +2223,13 @@ start: /* Skip comments that follow after AUTHORS, etc. */ if (within_comment) { /* Check all of "Area A" */ - for (ipchar = 7; ipchar < (n - 1) && ipchar < 11; ++ipchar) { - if (buff[ipchar] != ' ') { - ipchar = 0; - break; - } - } - if (ipchar) { + const int margin_a = cobc_get_margin_a (indicator_width); + const int margin_b = cobc_get_margin_b (indicator_width); + const int ipchar_max = (n - 1 < margin_b) ? n - 1 : margin_b; + for (ipchar = margin_a; + ipchar < ipchar_max && buff[ipchar] == ' '; + ++ipchar); + if (ipchar == ipchar_max) { newline_count++; goto start; } @@ -2011,17 +2237,20 @@ start: } /* Skip blank lines */ - for (i = 7; buff[i] == ' '; ++i) { - ; - } - + for (i = indicator_column; buff[i] == ' '; ++i); if (buff[i] == '\n') { newline_count++; goto start; } - buff[6] = ' '; - bp = buff + 7; + /* Substitute spaces for indicator */ + { + const int margin_a = cobc_get_margin_a (indicator_width); + for (i = indicator_column - 1; i < margin_a; i++) { + buff[i] = ' '; + } + bp = buff + margin_a; + } if (continuation) { /* Line continuation */ @@ -2069,7 +2298,7 @@ start: /* remove indicator "source text too long" if the column leading to the indicator comes after the floating comment */ - if (i < cb_text_column) { + if (i < text_column) { line_overflow = 0; } /* Set to null, 'i' is predecremented further below */ @@ -2080,7 +2309,7 @@ start: /* Literal start */ quotation_mark = buff[i]; } else if (quotation_mark == buff[i]) { - if (i == cb_text_column - 1) { + if (i == text_column - 1) { /* Consecutive quotation */ consecutive_quotation = 1; } else { @@ -2096,8 +2325,10 @@ start: if (!consecutive_quotation) { need_continuation = 1; } - for (; i < cb_text_column;) { - buff[i++] = ' '; + if (fill_continued_alnums) { + for (; i < text_column;) { + buff[i++] = ' '; + } } buff[i] = 0; } else { @@ -2116,12 +2347,12 @@ start: buff[i + 1] = 0; } - /* Show warning if text is longer than cb_text_column + /* Show warning if text is longer than text_column and not whitespace (postponed here) */ if (line_overflow != 0) { cb_plex_warning (cb_warn_source_after_code, newline_count, _("source text after program-text area (column %d)"), - cb_text_column); + text_column); } if (continuation) { @@ -2389,11 +2620,12 @@ check_listing (const char *text, const unsigned int comment) fprintf (cb_listing_file, "%6d%c", ++listing_line, c); } - if (requires_listing_line && cb_source_format != CB_FORMAT_FREE && - strlen (text) > 6) { - s = &text[6]; + if (requires_listing_line && + source_format != CB_FORMAT_FREE && + strlen (text) >= indicator_column) { + s = &text[indicator_column - 1]; } else { - s = text; + s = ""; /* do not output sequence area */ } fputs (s, cb_listing_file); if (strchr (text, '\n')) { diff --git a/cobc/ppparse.y b/cobc/ppparse.y index b1d1bafab..82fec0f33 100644 --- a/cobc/ppparse.y +++ b/cobc/ppparse.y @@ -67,16 +67,38 @@ static enum cb_directive_action current_cmd = PLEX_ACT_IF; /* Local functions */ +/* Strips the given string from its quotation characters, if any. Returns its + argument as is otherwise. */ static char * -fix_filename (char *name) +unquote (char *name) { - /* remove quotation from alphanumeric literals */ - if (name[0] == '\'' || name[0] == '\"') { + size_t size; + if ((name[0] == '\'' || name[0] == '"') && (size = strlen (name)) > 1 && + (name[0] == name[size - 1])) { + name[size - 1] = '\0'; name++; - name[strlen (name) - 1] = 0; } return name; } +#define fix_filename(filename) unquote (filename) + +static char * +literal_token (char *t, int allow_spaces) +{ + if (t[0] == '\'' || t[0] == '"') { + (void) ppparse_verify (cb_partial_replacing_with_literal, + _("partial replacing with literal")); + } else if (allow_spaces && (strcmp ("SPACE", t) == 0 || + strcmp ("SPACES", t) == 0)) { + (void) ppparse_verify (cb_partial_replacing_with_literal, + _("partial replacing with literal")); + t[0] = '\0'; + } else { + ppparse_error (_("unexpected COBOL word in partial replacement " + "phrase")); + } + return unquote (t); +} static char * fold_lower (char *name) @@ -128,7 +150,7 @@ ppp_set_value (struct cb_define_struct *p, const char *value) const char *s; size_t size; unsigned int dotseen; - + p->value = NULL; p->sign = 0; p->int_part = 0; @@ -471,7 +493,7 @@ append_to_turn_list (struct cb_text_list *ec_names, int enable, int with_locatio l->next = NULL; /* The line number is set properly in the scanner */ l->line = -1; - + if (cb_turn_list) { for (turn_list_end = cb_turn_list; turn_list_end->next; @@ -598,12 +620,12 @@ ppparse_clear_vars (const struct cb_define_struct *p) %token LEAP_SECOND_DIRECTIVE +%token CONTROL_DIVISION "CONTROL DIVISION" +%token SUBSTITUTION_SECTION "SUBSTITUTION SECTION" + %token SOURCE_DIRECTIVE %token FORMAT %token IS -%token FIXED -%token FREE -%token VARIABLE %token CALL_DIRECTIVE %token COBOL @@ -700,6 +722,7 @@ ppparse_clear_vars (const struct cb_define_struct *p) %type alnum_equality %type alnum_equality_list %type ec_list +%type unquoted_literal %type copy_replacing %type replacing_list @@ -716,13 +739,46 @@ ppparse_clear_vars (const struct cb_define_struct *p) %% +program_structure: + CONTROL_DIVISION DOT program_with_control_division +| statement_list +; + +/* GCOS 7 COBOL85 ref. manual p. 136: [...] If the replace-entry is present in +the Substitution Section of the Control Division of a source program, that +source program, including all contained programs, must contain no REPLACE +statement. Thankfully this helps avoiding some conflicts. */ +program_with_control_division: + statement_list +| control_division_no_replace statement_no_replace statement_list +| control_division_no_replace +| control_division_with_replace DOT statement_no_replace_list +; + +control_division_no_replace: + SUBSTITUTION_SECTION DOT +; + +control_division_with_replace: + /* The period could be optional. */ + SUBSTITUTION_SECTION DOT replace_statement +; + statement_list: | statement_list statement ; +statement_no_replace_list: +| statement_no_replace_list statement_no_replace +; + statement: - copy_statement DOT + statement_no_replace | replace_statement DOT +; + +statement_no_replace: + copy_statement DOT | directive TERMINATOR | listing_statement | CONTROL_STATEMENT control_options _dot TERMINATOR @@ -825,15 +881,9 @@ set_choice: fprintf (ppout, "#ADDSYN %s %s\n", l->text, l->next->text); } } -| ASSIGN LITERAL +| ASSIGN unquoted_literal { char *p = $2; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; if (!cb_strcasecmp (p, "EXTERNAL")) { fprintf (ppout, "#ASSIGN %d\n", (int)CB_ASSIGN_EXT_FILE_NAME_REQUIRED); @@ -841,22 +891,16 @@ set_choice: fprintf (ppout, "#ASSIGN %d\n", (int)CB_ASSIGN_VARIABLE_DEFAULT); } else { ppp_error_invalid_option ("ASSIGN", p); - } + } } | BOUND { /* Enable EC-BOUND-SUBSCRIPT checking */ append_to_turn_list (ppp_list_add (NULL, "EC-BOUND-SUBSCRIPT"), 1, 0); } -| CALLFH LITERAL +| CALLFH unquoted_literal { - char *p = $2; - /* Remove surrounding quotes/brackets */ - size_t size; - ++p; - size = strlen (p) - 1; - p[size] = '\0'; - fprintf (ppout, "#CALLFH \"%s\"\n", p); + fprintf (ppout, "#CALLFH \"%s\"\n", $2); } | CALLFH { @@ -874,15 +918,9 @@ set_choice: /* Enable EC-DATA-INCOMPATIBLE checking */ append_to_turn_list (ppp_list_add (NULL, "EC-DATA-INCOMPATIBLE"), 1, 0); } -| COMP1 LITERAL +| COMP1 unquoted_literal { char *p = $2; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; if (!cb_strcasecmp (p, "BINARY")) { cb_binary_comp_1 = 1; @@ -892,15 +930,9 @@ set_choice: ppp_error_invalid_option ("COMP1", p); } } -| DPC_IN_DATA LITERAL +| DPC_IN_DATA unquoted_literal { char *p = $2; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; if (!cb_strcasecmp (p, "XML")) { cb_dpc_in_data = CB_DPC_IN_XML; @@ -912,15 +944,9 @@ set_choice: ppp_error_invalid_option ("DPC-IN-DATA", p); } } -| FOLDCOPYNAME _as LITERAL +| FOLDCOPYNAME _as unquoted_literal { char *p = $3; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; if (!cb_strcasecmp (p, "UPPER")) { cb_fold_copy = COB_FOLD_UPPER; @@ -976,7 +1002,7 @@ set_choice: /* Disable EC-BOUND-SUBSCRIPT and -REF-MOD checking */ struct cb_text_list *txt = ppp_list_add (NULL, "EC-BOUND-SUBSCRIPT"); txt = ppp_list_add (txt, "EC-BOUND-REF-MOD"); - + append_to_turn_list (txt, 0, 0); } | NOODOSLIDE @@ -1001,30 +1027,15 @@ set_choice: fprintf (ppout, "#REMOVE %s\n", l->text); } } -| SOURCEFORMAT _as LITERAL +| SOURCEFORMAT _as unquoted_literal { char *p = $3; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; - if (!cb_strcasecmp (p, "FIXED")) { - cb_source_format = CB_FORMAT_FIXED; - cb_text_column = cb_config_text_column; - } else if (!cb_strcasecmp (p, "FREE")) { - cb_source_format = CB_FORMAT_FREE; - } else if (!cb_strcasecmp (p, "VARIABLE")) { - cb_source_format = CB_FORMAT_FIXED; - /* This value matches most MF Visual COBOL 4.0 version. */ - cb_text_column = 250; - } else { + if (cobc_deciph_source_format (p) != 0) { ppp_error_invalid_option ("SOURCEFORMAT", p); } if (cb_src_list_file) { - cb_current_file->source_format = cb_source_format; + cb_current_file->source_format = cobc_get_source_format (); } } | SOURCEFORMAT _as error @@ -1041,7 +1052,7 @@ set_choice: { char *p = $2; char ep = 0; - + /* Remove surrounding quotes/brackets */ if (p) { size_t size; @@ -1161,32 +1172,18 @@ refmod_directive: ; source_directive: - _format _is format_type + _format _is VARIABLE_NAME { + if (cobc_deciph_source_format ($3) != 0) { + ppp_error_invalid_option ("SOURCE", $3); + } if (cb_src_list_file) { - cb_current_file->source_format = cb_source_format; + cb_current_file->source_format = cobc_get_source_format (); } } -; - -format_type: - FIXED - { - cb_source_format = CB_FORMAT_FIXED; - cb_text_column = cb_config_text_column; - } -| FREE - { - cb_source_format = CB_FORMAT_FREE; - } -| VARIABLE - { - cb_source_format = CB_FORMAT_FIXED; - cb_text_column = 500; - } -| GARBAGE +| _format _is LITERAL { - cb_error (_("invalid %s directive"), "SOURCE"); + ppp_error_invalid_option ("SOURCE", $3); YYERROR; } ; @@ -1661,6 +1658,10 @@ text_partial_src: { $$ = ppp_list_add (NULL, $2); } +| TOKEN + { + $$ = ppp_list_add (NULL, literal_token ($1, 0)); + } ; text_partial_dst: @@ -1672,6 +1673,10 @@ text_partial_dst: { $$ = ppp_list_add (NULL, $2); } +| TOKEN + { + $$ = ppp_list_add (NULL, literal_token ($1, 1)); + } ; token_list: @@ -1741,6 +1746,23 @@ lead_trail: } ; +unquoted_literal: + LITERAL + { + /* Do not reuse unquote as some literals here may be delimited with + parentheses */ + char *p = $1; + size_t size; + + /* Remove surrounding quotes/brackets */ + ++p; + size = strlen (p) - 1; + p[size] = '\0'; + + $$ = p; + } +; + /* Optional keywords */ _override: diff --git a/cobc/reserved.c b/cobc/reserved.c index 43a9e686f..ceb35ebcc 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -60,6 +60,9 @@ static struct system_name_struct system_name_table[] = { {"SYSERR", CB_DEVICE_NAME, CB_DEVICE_SYSERR, CB_FEATURE_ACTIVE}, {"STDERR", CB_DEVICE_NAME, CB_DEVICE_SYSERR, CB_FEATURE_ACTIVE}, {"CONSOLE", CB_DEVICE_NAME, CB_DEVICE_CONSOLE, CB_FEATURE_ACTIVE}, + {"ALTERNATE-CONSOLE", CB_DEVICE_NAME, CB_DEVICE_CONSOLE, CB_FEATURE_ACTIVE}, + {"ALTERNATE CONSOLE", CB_DEVICE_NAME, CB_DEVICE_CONSOLE, CB_FEATURE_ACTIVE}, + {"TERMINAL", CB_DEVICE_NAME, CB_DEVICE_CONSOLE, CB_FEATURE_ACTIVE}, {"C01", CB_FEATURE_NAME, CB_FEATURE_C01, CB_FEATURE_ACTIVE}, {"C02", CB_FEATURE_NAME, CB_FEATURE_C02, CB_FEATURE_ACTIVE}, {"C03", CB_FEATURE_NAME, CB_FEATURE_C03, CB_FEATURE_ACTIVE}, @@ -813,7 +816,7 @@ static struct cobc_reserved default_reserved_words[] = { 0, 0 }, { "CONVERSION", 0, 1, CONVERSION, /* Extension */ - 0, CB_CS_ACCEPT + 0, CB_CS_ACCEPT | CB_CS_DISPLAY }, { "CONVERTING", 0, 0, CONVERTING, /* 2002 */ 0, 0 diff --git a/cobc/scanner.l b/cobc/scanner.l index f62734552..8ae70549f 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -157,7 +157,6 @@ static size_t pic2_size; static unsigned int last_token_is_dot = 0; static unsigned int integer_is_label = 0; static unsigned int inside_bracket = 0; -static unsigned int literal_error; static char err_msg[COB_MINI_BUFF]; /* Function declarations */ @@ -906,6 +905,11 @@ H#[0-9A-Za-z]+ { } } +"ALTERNATE"[ ,;\n]+"CONSOLE"/[ .,;\n] { + count_lines (yytext); + yylval = cb_build_reference ("ALTERNATE CONSOLE"); + RETURN_TOK (WORD); +} "SWITCH"[ ]+([0-9][0-9]?|[A-Z])/[ .,;\n] { /* ACUCOBOL extension: switch-names with space and with letter */ @@ -1284,7 +1288,7 @@ H#[0-9A-Za-z]+ { %% static void -error_literal (const char *type, const char *literal) +error_literal (const char *type, const char *literal, unsigned int literal_error) { if (!literal_error) { char lit_out[CB_ERR_LITMAX + 1]; @@ -1313,7 +1317,6 @@ error_literal (const char *type, const char *literal) } #endif } - literal_error++; cb_error ("%s", err_msg); } @@ -1322,8 +1325,7 @@ read_literal (const char mark, const char *type) { size_t i; int c; - - literal_error = 0; + unsigned int literal_error = 0; i = 0; /* read until a not-escaped mark is found (see break) @@ -1358,10 +1360,13 @@ read_literal (const char mark, const char *type) for (escaped) mark before checking the max length */ if (i++ == cb_lit_length) { snprintf (err_msg, COB_MINI_MAX, - _("literal length exceeds %d characters"), + _("literal length exceeds %u characters"), cb_lit_length); plex_buff[cb_lit_length] = 0; /* ensure valid C-string for error message */ - error_literal ("", plex_buff); + error_literal ("", plex_buff, literal_error); + if (!literal_error) { + literal_error = cb_lit_length; + } } } if (c == EOF @@ -1371,8 +1376,11 @@ read_literal (const char mark, const char *type) ) { snprintf (err_msg, COB_MINI_MAX, _("missing terminating %c character"), mark); - plex_buff[plex_size - 1] = 0; /* ensure valid C-string for error message */ - error_literal ("", plex_buff); + plex_buff[i] = 0; /* ensure valid C-string for error message */ + error_literal ("", plex_buff, literal_error); + if (!literal_error) { + literal_error = i; + } } /* FIXME: Exact behavior should depend on level of support: @@ -1399,6 +1407,20 @@ read_literal (const char mark, const char *type) if (type[0] != 'N') { yylval = cb_build_alphanumeric_literal (plex_buff, i); } else { + /* poor-man's conversion iso-8859 -> utf-16 */ + /* "!a0" = x'21613000' -> nx'00210061003000' */ + size_t new_size = i * 2; + if (new_size + 1 > plex_size) { + plex_size = new_size + 1; + plex_buff = cobc_realloc (plex_buff, plex_size); + } + plex_buff[new_size] = 0; + while (i) { + i--; + plex_buff[i * 2 + 1] = plex_buff [i]; + plex_buff[i * 2] = 0; + } + i = new_size; if (type[1] != 'C') { if (cb_verify (cb_national_literals, _("national literal"))) { CB_UNFINISHED (_("national literal")); @@ -1420,9 +1442,8 @@ scan_x (const char *text, const char *type) char *dst; size_t curr_len; size_t result_len; - int c; - - literal_error = 0; + char c; + unsigned int literal_error = 0; /* Remark: The standard allows for 8,191 (normal/national/boolean) character positions */ @@ -1434,8 +1455,7 @@ scan_x (const char *text, const char *type) curr_len--; if (curr_len == 0) { cb_verify (cb_zero_length_lit, _("zero-length literal")); - plex_buff[0] = '\0'; - plex_buff[1] = '\0'; + memset (plex_buff, 0, 5); cb_warning (COBC_WARN_FILLER, _("hexadecimal literal has zero length; X'00' will be assumed")); if (type[0] == 'B') { @@ -1448,39 +1468,50 @@ scan_x (const char *text, const char *type) RETURN_TOK (LITERAL); } + /* ensure buffers don't get too big */ + if (curr_len > (size_t)cb_lit_length + 1) { + curr_len = cb_lit_length + 1; + } if (curr_len + 1 > plex_size) { plex_size = curr_len + 1; - plex_buff = cobc_realloc (plex_buff, plex_size); + cobc_free (plex_buff); + plex_buff = cobc_malloc (plex_size); } memcpy (plex_buff, text, curr_len); if (type[0] == 'X') { result_len = curr_len / 2; /* characters, two half-bytes (hex) = 1 byte */ } else if (type[0] == 'B') { + result_len = curr_len * 4; /* boolean characters B -> 1110 */ if (!cb_verify (cb_hexadecimal_boolean, _("hexadecimal-boolean literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } - result_len = curr_len * 4; /* boolean characters B -> 1110 */ + /* GnuCOBOL currently only support 64 bit booleans */ if (result_len > 64) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) result_len, 64); - error_literal (type, plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) result_len, 64); + error_literal (type, plex_buff, literal_error++); + /* we'll get an overflow below, but that's no problem, + an alternative would be to incement *text to only parse 64 / 4 + characters but that leads to not verified data, which is + more important as the compilation will error-exit in any case */ } } else { + result_len = curr_len / (2 * COB_NATIONAL_SIZE); if (!cb_verify (cb_national_hex_literals, _("hexadecimal-national literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + yylval = cb_build_national_literal ("", 1); + RETURN_TOK (LITERAL); + } else { + CB_UNFINISHED (_("national literal")); } - CB_UNFINISHED (_("national literal")); - result_len = curr_len / (2 * COB_NATIONAL_SIZE); /* national characters */ } if (result_len > cb_lit_length) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) result_len, cb_lit_length); - error_literal (type, plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) result_len, cb_lit_length); + error_literal (type, plex_buff, literal_error++); } p = (char *)text; @@ -1491,13 +1522,13 @@ scan_x (const char *text, const char *type) /* hexadecimal-boolean */ cob_u64_t val = 0; for (; *p != *e; p++) { - c = (int) *p; + c = *p; if ('0' <= c && c <= '9') { - val = (val << 4) + ((cob_u64_t)c - '0'); + c = c - '0'; } else if ('A' <= c && c <= 'F') { - val = (val << 4) + ((cob_u64_t)c - 'A' + 10); + c = c - 'A' + 10; } else if ('a' <= c && c <= 'f') { - val = (val << 4) + ((cob_u64_t)c - 'a' + 10); + c = c - 'a' + 10; } else { snprintf (err_msg, COB_MINI_MAX, _("literal contains invalid character '%c'"), c); @@ -1505,15 +1536,13 @@ scan_x (const char *text, const char *type) memcpy (plex_buff, text, curr_len + 1); plex_buff[curr_len] = 0; } - error_literal (type, plex_buff); + error_literal (type, plex_buff, literal_error++); /* By not breaking immediately, we detect any following - invalid chars + invalid chars */ - continue; + c = 0; } - } - if (literal_error != 0) { - goto error; + val = (val << 4) + c; } sprintf ((char *)plex_buff, CB_FMT_LLU, val); yylval = cb_build_numeric_literal (0, (const void *)plex_buff, 0); @@ -1537,18 +1566,16 @@ scan_x (const char *text, const char *type) memcpy (plex_buff, text, curr_len + 1); plex_buff[curr_len] = 0; } - error_literal (type, plex_buff); + error_literal (type, plex_buff, literal_error++); /* By not breaking immediately, we detect any following invalid chars */ - continue; + c = 0; } - if (literal_error == 0) { - if (high) { - *dst = (cob_u8_t)(c << 4); - } else { - *dst++ += (cob_u8_t)c; - } + if (high) { + *dst = (cob_u8_t)(c << 4); + } else { + *dst++ += (cob_u8_t)c; } high = 1 - high; } @@ -1561,10 +1588,7 @@ scan_x (const char *text, const char *type) memcpy (plex_buff, text, curr_len + 1); plex_buff[curr_len] = 0; } - error_literal (type, plex_buff); - } - if (literal_error != 0) { - goto error; + error_literal (type, plex_buff, literal_error++); } if (type[0] != 'N') { yylval = cb_build_alphanumeric_literal (plex_buff, (size_t)(dst - plex_buff)); @@ -1574,87 +1598,80 @@ scan_x (const char *text, const char *type) } RETURN_TOK (LITERAL); - -error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int scan_z (const char *text, const char *type) { - size_t currlen; - - literal_error = 0; - - /* currlen includes the terminating quote */ - currlen = strlen (text); - if ((currlen - 1) > cb_lit_length) { - currlen--; + /* curr_len includes the terminating quote */ + size_t curr_len = strlen (text); + + if (curr_len == 1) { + curr_len--; + snprintf (err_msg, COB_MINI_MAX, + _("%s literals must contain at least one character"), + type); + error_literal (type, "", 0); + yylval = cb_build_alphanumeric_literal ("", 1); + RETURN_TOK (LITERAL); + } + if ((unsigned long)(curr_len - 1) > cb_lit_length) { + curr_len--; snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) currlen, cb_lit_length); - error_literal (type, text); - goto error; - } else if (currlen == 1) { - currlen--; - snprintf (err_msg, COB_MINI_MAX, - _("%s literals must contain at least one character"), - type); - error_literal (type, ""); - goto error; - } - if (currlen > plex_size) { - plex_size = currlen; - plex_buff = cobc_realloc (plex_buff, plex_size); - } - memcpy (plex_buff, text, currlen); - plex_buff[currlen - 1] = 0; + _("literal length %lu exceeds %u characters"), + (unsigned long) curr_len, cb_lit_length); + error_literal (type, text, 0); + curr_len = cb_lit_length + 1; /* ensure buffers don't get too big */ + } + if (curr_len > plex_size) { + plex_size = curr_len; + cobc_free (plex_buff); + plex_buff = cobc_malloc (plex_size); + } + memcpy (plex_buff, text, curr_len); + plex_buff[curr_len - 1] = 0; /* Count is correct here as the trailing quote is now a null */ - yylval = cb_build_alphanumeric_literal (plex_buff, currlen); + yylval = cb_build_alphanumeric_literal (plex_buff, curr_len); if (type[0] == 'L') { CB_LITERAL(yylval)->llit = 1; } RETURN_TOK (LITERAL); - - error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int scan_h (const char *text, const char *type) { - size_t currlen; + size_t curr_len; char *p; cob_u64_t val = 0; int c; + unsigned int literal_error = 0; - literal_error = 0; - - if (type[1] == '#' && - !cb_verify (cb_acu_literals, _("ACUCOBOL numeric literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + if (type[1] == '#' + && !cb_verify (cb_acu_literals, _("ACUCOBOL numeric literal"))) { + /* note: early exit with valid literal */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } - /* currlen can include the terminating quote */ - currlen = strlen (text); - memcpy (plex_buff, text, currlen + 1); + /* curr_len can include the terminating quote */ + curr_len = strlen (text); + memcpy (plex_buff, text, curr_len + 1); if (type[1] != '#') { - currlen--; - if (currlen == 0) { + curr_len--; + if (curr_len == 0) { cb_error (_("H literals must contain at least one character")); - goto error; + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } - plex_buff[currlen] = 0; + plex_buff[curr_len] = 0; } - if (currlen > 16) { + if (curr_len > 16) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) currlen, 16); - error_literal ("hex", plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) curr_len, 16); + error_literal ("hex", plex_buff, literal_error++); } for (p = plex_buff; *p != 0; p++) { @@ -1668,11 +1685,11 @@ scan_h (const char *text, const char *type) } else { snprintf (err_msg, COB_MINI_MAX, _("literal contains invalid character '%c'"), c); - error_literal (type, plex_buff); + error_literal (type, plex_buff, literal_error++); /* By not breaking immediately, we detect any following invalid chars */ - continue; + c = 0; } val = (val << 4) + c; @@ -1681,25 +1698,20 @@ scan_h (const char *text, const char *type) if (type[1] == '#') { /* limit for ACUCOBOL literals: UINT_MAX */ if (val > UINT_MAX) { - snprintf (err_msg, COB_MINI_MAX, - _("literal exceeds limit %u"), UINT_MAX); - error_literal (type, plex_buff); + if (curr_len <= 16) { + snprintf (err_msg, COB_MINI_MAX, + _("literal exceeds limit %u"), UINT_MAX); + error_literal (type, plex_buff, literal_error++); + } + val = UINT_MAX; } } - if (literal_error) { - goto error; - } - /* Duplication? */ sprintf ((char *)plex_buff, CB_FMT_LLU, val); yylval = cb_build_numeric_literal (0, (const void *)plex_buff, 0); RETURN_TOK (LITERAL); - -error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int @@ -1709,50 +1721,56 @@ scan_b (const char *text, const char *type) COBOL 2002 allows up to 160 boolean characters --> both identical to "literal-length" maximum GnuCOBOL currently only supports 64 boolean characters, - check if it works to concatenate after 64 characters, similar to read_literal() + more need a different storage */ - size_t currlen; + size_t curr_len; char *p; cob_u64_t val = 0; int c; + unsigned int literal_error = 0; - literal_error = 0; - - /* currlen can include the terminating quote */ - currlen = strlen (text); + /* curr_len can include the terminating quote */ + curr_len = strlen (text); if (type[1] == 0) { if (!cb_verify (cb_numeric_boolean, _("numeric boolean literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + /* early exit possible as complete literal is consumed */ + curr_len = 0; } - if (currlen == 1) { + if (curr_len == 1) { cb_verify (cb_zero_length_lit, _("zero-length literal")); cb_warning (COBC_WARN_FILLER, _("Boolean literal has zero length; B'0' will be assumed")); + } + if (curr_len <= 1) { /* FIXME: we should really build a boolean literal... */ yylval = cb_build_numeric_literal (0, "0", 0); RETURN_TOK (LITERAL); } } else { if (!cb_verify (cb_acu_literals, _("ACUCOBOL numeric literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } }; - if (currlen >= plex_size) { - currlen = plex_size - 1; + if (curr_len >= plex_size) { + curr_len = plex_size - 1; } - memcpy (plex_buff, text, currlen + 1); + memcpy (plex_buff, text, curr_len + 1); if (type[1] == 0) { - currlen--; + curr_len--; } - plex_buff[currlen] = 0; - if (currlen > 64) { + plex_buff[curr_len] = 0; + if (curr_len > 64) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) currlen, 64); - error_literal (type, plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) curr_len, 64); + error_literal (type, plex_buff, literal_error++); + /* we'll get an overflow below, but that's no problem, + an alternative would be to incement *text to only parse 64 / 4 + characters but that leads to not verified data, which is + more important as the compilation will error-exit in any case */ } for (p = plex_buff; *p != 0; p++) { @@ -1764,8 +1782,8 @@ scan_b (const char *text, const char *type) } else { snprintf (err_msg, COB_MINI_MAX, _("literal contains invalid character '%c'"), c); - error_literal (type, plex_buff); - continue; + error_literal (type, plex_buff, literal_error++); + c = 0; } val = (val << 1) + c; @@ -1773,78 +1791,75 @@ scan_b (const char *text, const char *type) if (type[1] == '#') { /* limit for ACUCOBOL literals: UINT_MAX */ if (val > UINT_MAX) { - snprintf (err_msg, COB_MINI_MAX, - _("literal exceeds limit %u"), UINT_MAX); - error_literal (type, plex_buff); + if (curr_len <= 64) { + snprintf (err_msg, COB_MINI_MAX, + _("literal exceeds limit %u"), UINT_MAX); + error_literal (type, plex_buff, literal_error); + } + val = UINT_MAX; } } - if (literal_error) { - goto error; - } - sprintf ((char *)plex_buff, CB_FMT_LLU, val); /* FIXME: we should likely build a boolean literal ... */ yylval = cb_build_numeric_literal (0, (const void *)plex_buff, 0); RETURN_TOK (LITERAL); - - error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int scan_o (const char *text, const char *type) { - size_t currlen; - char *p; + size_t curr_len; cob_u64_t val = 0; - int c; - - literal_error = 0; + char *p; + char c; + unsigned int literal_error = 0; if (type[0] == '%') { if (!cb_verify (cb_hp_octal_literals, _("HP COBOL octal literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + /* early exit possible as complete literal is consumed */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } } else { if (!cb_verify (cb_acu_literals, _("ACUCOBOL numeric literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + /* early exit possible as complete literal is consumed */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } } - currlen = strlen (text); - memcpy (plex_buff, text, currlen + 1); - if (currlen > 22) { + curr_len = strlen (text); + memcpy (plex_buff, text, curr_len + 1); + if (curr_len > 22) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) currlen, 22); - error_literal (type, plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) curr_len, 22); + error_literal (type, plex_buff, literal_error++); } for (p = plex_buff; *p != 0; p++) { - c = (int) *p; - if (!('0' <= c && c <= '7')) { + c = *p; + if ('0' <= c && c <= '7') { + c = c - '0'; + } else { snprintf (err_msg, COB_MINI_MAX, _("literal contains invalid character '%c'"), c); - error_literal (type, plex_buff); - continue; + error_literal (type, plex_buff, literal_error++); + c = 0; } - c = c - '0'; val = (val << 3) + c; } /* limit for ACUCOBOL literals: UINT_MAX */ if (val > UINT_MAX) { - snprintf (err_msg, COB_MINI_MAX, - _("literal exceeds limit %u"), UINT_MAX); - error_literal (type, plex_buff); - } - - if (literal_error) { - goto error; + if (curr_len <= 22) { + snprintf (err_msg, COB_MINI_MAX, + _("literal exceeds limit %u"), UINT_MAX); + error_literal (type, plex_buff, literal_error++); + } + val = UINT_MAX; } if (type[0] == '%') { @@ -1864,10 +1879,6 @@ scan_o (const char *text, const char *type) yylval = cb_build_numeric_literal (0, (const void *)plex_buff, 0); RETURN_TOK (LITERAL); - - error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int @@ -1896,6 +1907,7 @@ scan_numeric (const char *text) char *s; int sign; int scale; + size_t curr_len; /* Get sign */ sign = get_sign (*p); @@ -1914,22 +1926,22 @@ scan_numeric (const char *text) /* Note that leading zeroes are not removed from the literal. */ - if (strlen (p) > COB_MAX_DIGITS) { + curr_len = strlen (p); + + if (curr_len > COB_MAX_DIGITS) { /* Absolute limit */ snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds maximum of %d digits"), - (int) strlen (p), COB_MAX_DIGITS); - error_literal ("num", text); - yylval = cb_error_node; - } else if (strlen (p) > cb_numlit_length) { + _("literal length %lu exceeds maximum of %u digits"), + (unsigned long) curr_len, COB_MAX_DIGITS); + error_literal ("num", text, 0); + p[COB_MAX_DIGITS] = 0; + } else if (curr_len > cb_numlit_length) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d digits"), - (int) strlen (p), cb_numlit_length); - error_literal ("num", text); - yylval = cb_error_node; - } else { - yylval = cb_build_numeric_literal (sign, p, scale); + _("literal length %lu exceeds %u digits"), + (unsigned long) curr_len, cb_numlit_length); + error_literal ("num", text, 0); } + yylval = cb_build_numeric_literal (sign, p, scale); RETURN_TOK (LITERAL); } @@ -1983,8 +1995,7 @@ scan_floating_numeric (const char *text) char *exponent_pos; char result[128] = { '\0' }; - - literal_error = 0; + unsigned int literal_error = 0; /* Separate into significand and exponent */ n = sscanf (text, COB_FLOAT_DIGITS_WIDTH "[0-9.,+-]%*1[Ee]%7[0-9.,+-]", @@ -2039,18 +2050,18 @@ scan_floating_numeric (const char *text) /* note: same message in tree.c for floating-point numeric-edited item */ snprintf (err_msg, COB_MINI_MAX, _("significand has more than %d digits"), COB_FLOAT_DIGITS_MAX); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } else { if (strchr (exponent_pos, current_program->decimal_point)) { snprintf (err_msg, COB_MINI_MAX, _("exponent has decimal point")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } else { if (strlen (exponent_pos) > 4) { /* note: same message in tree.c for floating-point numeric-edited item */ snprintf (err_msg, COB_MINI_MAX, _("exponent has more than 4 digits")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } else { n = sscanf (exponent_pos, "%d", &exponent); /* We check the return for silencing warnings, but @@ -2080,7 +2091,7 @@ scan_floating_numeric (const char *text) if (!(-6143 <= exponent && exponent <= 6144)) { snprintf (err_msg, COB_MINI_MAX, _("exponent not between -6143 and 6144")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } } } @@ -2089,22 +2100,22 @@ scan_floating_numeric (const char *text) if (sig_sign == -1) { snprintf (err_msg, COB_MINI_MAX, _("significand of 0 must be positive")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } if (exponent != 0) { snprintf (err_msg, COB_MINI_MAX, _("exponent of 0 must be 0")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } if (exp_sign == -1) { snprintf (err_msg, COB_MINI_MAX, _("exponent of 0 must be positive")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } } if (literal_error) { - yylval = cb_error_node; + yylval = cb_build_numeric_literal (0, "0", 0); RETURN_TOK (LITERAL); } diff --git a/cobc/tree.c b/cobc/tree.c index ceae92f0f..c9664649e 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -7172,6 +7172,10 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, double drslt, dval; char result[64]; + /* 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, + which allows also for optimized use of it */ numargs = (int)cb_list_length (args); if (isuser) { @@ -7430,17 +7434,34 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, fld = CB_FIELD_PTR (x); if (!cb_field_variable_size (fld) && !fld->flag_any_length) { - if (!(fld->pic - && (fld->pic->category == CB_CATEGORY_NATIONAL - || fld->pic->category == CB_CATEGORY_NATIONAL_EDITED))) - return cb_build_length (x); + int len = fld->size; + char buff[32]; + if (cbp->intr_enum != CB_INTR_BYTE_LENGTH) { + /* CHECKME: why don't we just check the category? + Maybe needs to enforce field validation (see cb_build_length) */ + if ( fld->pic + && (fld->pic->category == CB_CATEGORY_NATIONAL + || fld->pic->category == CB_CATEGORY_NATIONAL_EDITED)) { + len /= COB_NATIONAL_SIZE; + } + } + sprintf (buff, "%d", len); + return cb_build_numeric_literal (0, buff, 0); } } else if (CB_LITERAL_P (x)) { - /* FIXME: we currently generate national constants as alphanumeric constants */ - if (cbp->intr_enum != CB_INTR_BYTE_LENGTH - || (CB_TREE_CATEGORY (x) != CB_CATEGORY_NATIONAL_EDITED - && CB_TREE_CATEGORY (x) != CB_CATEGORY_NATIONAL)) - return cb_build_length (x); + unsigned int len = CB_LITERAL(x)->size; + char buff[32]; + if (cbp->intr_enum != CB_INTR_BYTE_LENGTH) { + enum cb_category cat = CB_TREE_CATEGORY (x); + /* CHECKME: why don't we just check the category? + Maybe needs to enforce field validation (see cb_build_length) */ + if (cat == CB_CATEGORY_NATIONAL + || cat == CB_CATEGORY_NATIONAL_EDITED) { + len /= COB_NATIONAL_SIZE; + } + } + sprintf (buff, "%u", len); + return cb_build_numeric_literal (0, buff, 0); } return make_intrinsic (func, cbp, args, NULL, NULL, 0); @@ -7551,6 +7572,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, case CB_INTR_HIGHEST_ALGEBRAIC: case CB_INTR_LOWEST_ALGEBRAIC: + /* 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); @@ -7587,11 +7609,13 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, case CB_INTR_DISPLAY_OF: case CB_INTR_NATIONAL_OF: + /* TODO: resolve for literals */ return make_intrinsic (func, cbp, args, cb_int1, refmod, 0); case CB_INTR_BIT_OF: case CB_INTR_HEX_OF: + /* TODO: resolve for literals */ x = CB_VALUE (args); if (!CB_REF_OR_FIELD_P (x) && !CB_LITERAL_P (x)) { @@ -7601,6 +7625,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, return make_intrinsic (func, cbp, args, NULL, refmod, 0); case CB_INTR_BIT_TO_CHAR: case CB_INTR_HEX_TO_CHAR: + /* TODO: resolve for literals */ x = CB_VALUE (args); if (!CB_REF_OR_FIELD_P (x) &&!CB_LITERAL_P (x)) { diff --git a/cobc/tree.h b/cobc/tree.h index 9e332ebdb..fc7abd3f6 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2430,6 +2430,8 @@ extern void cb_emit_start (cb_tree, cb_tree, cb_tree, cb_tree); extern void cb_emit_stop_run (cb_tree); +extern void cb_emit_stop_error (void); + extern void cb_emit_stop_thread (cb_tree); extern void cb_emit_string (cb_tree, cb_tree, cb_tree); diff --git a/cobc/typeck.c b/cobc/typeck.c index 259578c8b..67086252d 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -3770,80 +3770,61 @@ cb_validate_collating (cb_tree collating_sequence) return 0; } -void -cb_validate_program_environment (struct cb_program *prog) +static void +validate_alphabet (cb_tree alphabet) { - cb_tree x; - cb_tree y; - cb_tree l; - cb_tree ls; - struct cb_alphabet_name *ap; - struct cb_class_name *cp; - unsigned char *data; - size_t dupls; - size_t unvals; - size_t count; - int lower; - int upper; - int size; - int n; - int i; - int pos; - int lastval; - int tableval; - int values[256]; - int charvals[256]; - int dupvals[256]; + struct cb_alphabet_name *ap = CB_ALPHABET_NAME (alphabet); + unsigned int n; - /* Check ALPHABET clauses */ - /* Complicated by difference between code set and collating sequence */ - for (l = prog->alphabet_name_list; l; l = CB_CHAIN (l)) { - ap = CB_ALPHABET_NAME (CB_VALUE (l)); - - /* Native */ - if (ap->alphabet_type == CB_ALPHABET_NATIVE) { - for (n = 0; n < 256; n++) { - ap->values[n] = n; - ap->alphachr[n] = n; - } - continue; + /* Native */ + if (ap->alphabet_type == CB_ALPHABET_NATIVE) { + for (n = 0; n < 256; n++) { + ap->values[n] = n; + ap->alphachr[n] = n; } + return; + } - /* ASCII */ - if (ap->alphabet_type == CB_ALPHABET_ASCII) { - for (n = 0; n < 256; n++) { + /* ASCII */ + if (ap->alphabet_type == CB_ALPHABET_ASCII) { + for (n = 0; n < 256; n++) { #ifdef COB_EBCDIC_MACHINE - ap->values[n] = (int)cob_refer_ascii[n]; - ap->alphachr[n] = (int)cob_refer_ascii[n]; + ap->values[n] = (int)cob_refer_ascii[n]; + ap->alphachr[n] = (int)cob_refer_ascii[n]; #else - ap->values[n] = n; - ap->alphachr[n] = n; + ap->values[n] = n; + ap->alphachr[n] = n; #endif - } - continue; } + return; + } - /* EBCDIC */ - if (ap->alphabet_type == CB_ALPHABET_EBCDIC) { - for (n = 0; n < 256; n++) { + /* EBCDIC */ + if (ap->alphabet_type == CB_ALPHABET_EBCDIC) { + for (n = 0; n < 256; n++) { #ifdef COB_EBCDIC_MACHINE - ap->values[n] = n; - ap->alphachr[n] = n; + ap->values[n] = n; + ap->alphachr[n] = n; #else - ap->values[n] = (int)cob_refer_ebcdic[n]; - ap->alphachr[n] = (int)cob_refer_ebcdic[n]; + ap->values[n] = (int)cob_refer_ebcdic[n]; + ap->alphachr[n] = (int)cob_refer_ebcdic[n]; #endif - } - continue; } + return; + } + + /* Custom alphabet */ + { + cb_tree l, x; + size_t count = 0; + int unvals = 0, dupls = 0; + int lastval = 0, tableval = 0; + int pos = 0; + int i; + int values[256]; + int charvals[256]; + int dupvals[256]; - /* Custom alphabet */ - dupls = 0; - unvals = 0; - pos = 0; - count = 0; - lastval = 0; - tableval = 0; for (n = 0; n < 256; n++) { values[n] = -1; charvals[n] = -1; @@ -3853,21 +3834,24 @@ cb_validate_program_environment (struct cb_program *prog) } ap->low_val_char = 0; ap->high_val_char = 255; - for (y = ap->custom_list; y; y = CB_CHAIN (y)) { + for (l = ap->custom_list; l; l = CB_CHAIN (l)) { pos++; if (count > 255) { unvals = pos; break; } - x = CB_VALUE (y); + x = CB_VALUE (l); if (CB_PAIR_P (x)) { /* X THRU Y */ - lower = get_value (CB_PAIR_X (x)); - upper = get_value (CB_PAIR_Y (x)); + int lower = get_value (CB_PAIR_X (x)); + int upper = get_value (CB_PAIR_Y (x)); lastval = upper; if (!count) { ap->low_val_char = lower; } + /* regression in NATIONAL literals as + thpose are unfinished; would be fine + with national alphabet in general */ if (lower < 0 || lower > 255) { unvals = pos; continue; @@ -3902,6 +3886,7 @@ cb_validate_program_environment (struct cb_program *prog) } } } else if (CB_LIST_P (x)) { + cb_tree ls; /* X ALSO Y ... */ if (!count) { ap->low_val_char = get_value (CB_VALUE (x)); @@ -3911,6 +3896,9 @@ cb_validate_program_environment (struct cb_program *prog) if (!CB_CHAIN (ls)) { lastval = n; } + /* regression in NATIONAL literals as + those are unfinished; would be fine + with national alphabet in general */ if (n < 0 || n > 255) { unvals = pos; continue; @@ -3950,23 +3938,49 @@ cb_validate_program_environment (struct cb_program *prog) ap->values[n] = tableval++; count++; } else if (CB_LITERAL_P (x)) { - size = (int)CB_LITERAL (x)->size; - data = CB_LITERAL (x)->data; + int size = (int)CB_LITERAL (x)->size; + unsigned char* data = CB_LITERAL (x)->data; if (!count) { ap->low_val_char = data[0]; } lastval = data[size - 1]; - for (i = 0; i < size; i++) { - n = data[i]; - if (values[n] != -1) { - dupvals[n] = n; - dupls = 1; + if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NATIONAL) { + for (i = 0; i < size; i++) { + n = data[i]; + if (values[n] != -1) { + dupvals[n] = n; + dupls = 1; + } + values[n] = n; + charvals[n] = n; + ap->alphachr[tableval] = n; + ap->values[n] = tableval++; + count++; + } + } else { + for (i = 0; i < size; i++) { + /* assuming we have UTF16BE here */ + if (data[i] == 0) { + /* only checking lower entries, all others, + which are currently only possible with + national-hex literals are not checked + TODO: add a list of values for those and + iterate over the list */ + n = data[++i]; + if (values[n] != -1) { + dupvals[n] = n; + dupls = 1; + } + values[n] = n; + charvals[n] = n; + ap->values[n] = tableval; + } else { + n = data[i++]; + n = n * 255 + data[i]; + } + ap->alphachr[tableval++] = n; + count++; } - values[n] = n; - charvals[n] = n; - ap->alphachr[tableval] = n; - ap->values[n] = tableval++; - count++; } } else { n = get_value (x); @@ -3990,31 +4004,29 @@ cb_validate_program_environment (struct cb_program *prog) } } if (dupls || unvals) { - cb_tree alphabet = CB_VALUE (l); if (dupls) { - /* FIXME: can't handle UTF8 / NATIONAL values */ - char dup_vals[256]; + char errmsg[256]; i = 0; for (n = 0; n < 256; n++) { if (dupvals[n] != -1) { if (i > 240) { - i += sprintf (dup_vals + i, ", ..."); + i += sprintf (&errmsg[i], ", ..."); break; } if (i) { - i += sprintf (dup_vals + i, ", "); + i += sprintf (&errmsg[i], ", "); } if (isprint (n)) { - dup_vals[i++] = (char)n; + errmsg[i++] = (char)n; } else { - i += sprintf (dup_vals + i, "x'%02x'", n); + i += sprintf (&errmsg[i], "x'%02x'", n); } }; } - dup_vals[i] = 0; + errmsg[i] = 0; cb_error_x (alphabet, _("duplicate character values in alphabet '%s': %s"), - ap->name, dup_vals); + ap->name, errmsg); } if (unvals) { cb_error_x (alphabet, @@ -4059,6 +4071,81 @@ cb_validate_program_environment (struct cb_program *prog) } } } +} + +static void +check_class_duplicates (cb_tree class_name) +{ + struct cb_class_name* cp = CB_CLASS_NAME (class_name); + size_t dupls = 0; + int values[256] = { 0 }; + cb_tree l; + +#if 0 /* should not be necessary with init above */ + memset (values, 0, sizeof (values)); +#endif + for (l = cp->list; l; l = CB_CHAIN (l)) { + cb_tree x = CB_VALUE (l); + if (CB_PAIR_P (x)) { + /* X THRU Y */ + int lower = get_value (CB_PAIR_X (x)); + int upper = get_value (CB_PAIR_Y (x)); + int i; + for (i = lower; i <= upper; i++) { + if (values[i]) { + dupls = 1; + } else { + values[i] = 1; + } + } + } else { + int n; + if (CB_NUMERIC_LITERAL_P (x)) { + n = get_value (x); + if (values[n]) { + dupls = 1; + } else { + values[n] = 1; + } + } else if (CB_LITERAL_P (x)) { + int size = (int)CB_LITERAL (x)->size; + unsigned char* data = CB_LITERAL (x)->data; + int i; + for (i = 0; i < size; i++) { + n = data[i]; + if (values[n]) { + dupls = 1; + } else { + values[n] = 1; + } + } + } else { + n = get_value (x); + if (values[n]) { + dupls = 1; + } else { + values[n] = 1; + } + } + } + } + if (dupls) { + cb_warning_x (cb_warn_additional, class_name, + _("duplicate character values in class '%s'"), + cb_name (class_name)); + } +} + +void +cb_validate_program_environment (struct cb_program *prog) +{ + cb_tree l; + + /* Check ALPHABET clauses */ + /* Complicated by difference between code set and collating sequence */ + for (l = prog->alphabet_name_list; l; l = CB_CHAIN (l)) { + validate_alphabet (CB_VALUE (l)); + } /* Reset HIGH/LOW-VALUES */ cb_low = cb_norm_low; @@ -4066,80 +4153,28 @@ cb_validate_program_environment (struct cb_program *prog) /* Check and generate SYMBOLIC clauses */ for (l = prog->symbolic_char_list; l; l = CB_CHAIN (l)) { + cb_tree x; if (CB_VALUE (l)) { - y = cb_ref (CB_VALUE (l)); - if (y == cb_error_node) { + x = cb_ref (CB_VALUE (l)); + if (x == cb_error_node) { continue; } - if (!CB_ALPHABET_NAME_P (y)) { - cb_error_x (y, _("invalid ALPHABET name")); + if (!CB_ALPHABET_NAME_P (x)) { + cb_error_x (x, _("invalid ALPHABET name")); continue; } } else { - y = NULL; + x = NULL; } - cb_build_symbolic_chars (CB_PURPOSE (l), y); + cb_build_symbolic_chars (CB_PURPOSE (l), x); } - /* Check CLASS clauses */ - for (l = prog->class_name_list; l; l = CB_CHAIN (l)) { - cp = CB_CLASS_NAME (CB_VALUE (l)); - /* LCOV_EXCL_START */ - if (cp == NULL) { /* keep the analyzer happy... */ - cobc_err_msg ("invalid CLASS detected"); /* not translated as highly unlikely */ - COBC_ABORT (); - } - /* LCOV_EXCL_STOP */ - dupls = 0; - memset (values, 0, sizeof(values)); - for (y = cp->list; y; y = CB_CHAIN (y)) { - x = CB_VALUE (y); - if (CB_PAIR_P (x)) { - /* X THRU Y */ - lower = get_value (CB_PAIR_X (x)); - upper = get_value (CB_PAIR_Y (x)); - for (i = lower; i <= upper; i++) { - if (values[i]) { - dupls = 1; - } else { - values[i] = 1; - } - } - } else { - if (CB_NUMERIC_LITERAL_P (x)) { - n = get_value (x); - if (values[n]) { - dupls = 1; - } else { - values[n] = 1; - } - } else if (CB_LITERAL_P (x)) { - size = (int)CB_LITERAL (x)->size; - data = CB_LITERAL (x)->data; - for (i = 0; i < size; i++) { - n = data[i]; - if (values[n]) { - dupls = 1; - } else { - values[n] = 1; - } - } - } else { - n = get_value (x); - if (values[n]) { - dupls = 1; - } else { - values[n] = 1; - } - } - } - } - if (dupls) { - cb_warning_x (cb_warn_additional, CB_VALUE(l), - _("duplicate character values in class '%s'"), - cb_name (CB_VALUE(l))); - } + /* Check CLASS clauses for duplicates */ + if (cb_warn_additional) { + for (l = prog->class_name_list; l; l = CB_CHAIN (l)) { + check_class_duplicates (CB_VALUE (l)); } + } /* Resolve the program collating sequences */ if (cb_validate_collating (prog->collating_sequence)) { @@ -4151,7 +4186,7 @@ cb_validate_program_environment (struct cb_program *prog) /* Resolve the program classification */ if (prog->classification && prog->classification != cb_int1) { - x = cb_ref (prog->classification); + cb_tree x = cb_ref (prog->classification); if (!CB_LOCALE_NAME_P (x)) { cb_error_x (prog->classification, _("'%s' is not a locale name"), @@ -4727,7 +4762,7 @@ cb_validate_program_data (struct cb_program *prog) && !cb_odoslide) { xerr = x; cb_error_x (x, - _ ("'%s' cannot have nested OCCURS DEPENDING"), + _("'%s' cannot have nested OCCURS DEPENDING"), cb_name (x)); } odo_level++; @@ -4750,7 +4785,7 @@ cb_validate_program_data (struct cb_program *prog) && x != xerr) { xerr = x; cb_error_x (x, - _ ("'%s' cannot have OCCURS DEPENDING because of '%s'"), + _("'%s' cannot have OCCURS DEPENDING because of '%s'"), cb_name (x), p->sister->name); break; } @@ -7743,6 +7778,7 @@ numeric_children_screen_pos_type (struct cb_field* child) if (!child) return 0; for (; child; child = child->sister) { + if (child->redefines) continue; if (!numeric_screen_pos_type (child)) { return 0; } @@ -8229,10 +8265,7 @@ cb_emit_accept_name (cb_tree var, cb_tree name) switch (CB_SYSTEM_NAME (sys)->token) { case CB_DEVICE_CONSOLE: case CB_DEVICE_SYSIN: - /* possibly others allow this, too, consider adding a config option */ - if (cb_std_define != CB_STD_IBM - && cb_std_define != CB_STD_MVS - && cb_std_define != CB_STD_MF + if (!cb_device_mnemonics && !cb_relaxed_syntax_checks) { cb_warning_x (COBC_WARN_FILLER, name, _("'%s' is not defined in SPECIAL-NAMES"), CB_NAME (name)); @@ -9418,12 +9451,9 @@ cb_build_display_name (cb_tree x) cb_error_x (x, _("'%s' is not an output device"), name); return cb_error_node; } - /* possibly others allow this, too, consider adding a config option */ - if (cb_std_define != CB_STD_IBM - && cb_std_define != CB_STD_MVS - && cb_std_define != CB_STD_MF + if (!cb_device_mnemonics && !cb_relaxed_syntax_checks) { - /* ... especially as this is not allowed and therefore should raise an error... */ + /* TODO: this is not allowed and therefore should raise an error */ cb_warning_x (COBC_WARN_FILLER, x, _("'%s' is not defined in SPECIAL-NAMES"), name); } @@ -13791,6 +13821,12 @@ cb_emit_stop_run (cb_tree x) cb_emit (CB_BUILD_FUNCALL_1 ("cob_stop_run", cb_build_cast_int (x))); } +void +cb_emit_stop_error (void) +{ + cb_emit (CB_BUILD_FUNCALL_0 ("cob_stop_error")); +} + void cb_emit_stop_thread (cb_tree handle) { @@ -14020,7 +14056,7 @@ cb_build_unstring_into (cb_tree name, cb_tree delimiter, cb_tree count) delimiter = cb_int0; } if (count == NULL - || error_if_not_int_field_or_has_pic_p ("COUNT", count)) { + || error_if_not_int_field_or_has_pic_p ("COUNT", count)) { count = cb_int0; } return CB_BUILD_FUNCALL_3 ("cob_unstring_into", name, delimiter, count); diff --git a/config/ChangeLog b/config/ChangeLog index 8a33a54da..51b56e6aa 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -17,23 +17,63 @@ * *.conf: changed top-level-occurs-clause "skip" to "unconformable" +2022-07-14 Simon Sobisch + + * general: set defaultbyte to "none" for standard COBOL, 32 to " " + +2022-07-12 Simon Sobisch + + * ibm-strict.conf, mvs-strict.conf, gcos-strict.conf, bs2000-strict.conf: + adjusted defaultbyte to 0 + 2022-07-01 Simon Sobisch * general: removed alias VALUES=VALUE, now a separate word +2022-06-24 Nicolas Berthier + + * general: remove indicator-column option, which is now a flag + +2022-06-17 Nicolas Berthier + + * general: added config option device-mnemonics (boolean) + 2022-06-10 Ron Norman * general: add 'defaultbyte' +2022-05-25 Nicolas Berthier + + * general: added option partial-replacing-with-literal + +2022-03-11 Fabrice Le Fessant + + * general: add a stop-error-statement option to allow configuring + the support of the STOP ERROR statement + +2022-02-07 David Declerck + + * general: add a record-contains-depending-clause option to allow + configuring the support of the DEPENDING clause in RECORD CONTAINS + 2022-02-07 David Declerck * gcos-strict.conf, gcos.conf, gcos.words: added config files for GCOS 7 (Bull) dialect +2022-02-04 David Declerck + + * general: add an indicator-column option to allow customizing + the position of the indicator + +2022-01-27 Nicolas Berthier + + * general: added option control-division + 2021-11-14 Ron Norman * mf.words: Add MF specific names B-EXOR, B-LEFT, B-RIGHT for bit - operations + operations 2021-11-09 Ron Norman @@ -692,7 +732,7 @@ * default.inc, Makefile.am: New files. -Copyright 2003,2005-2007-2010,2014-2021 Free Software Foundation, Inc. +Copyright 2003,2005-2007-2010,2014-2022 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/config/acu-strict.conf b/config/acu-strict.conf index 1a4a1cd6b..1708b7eeb 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -183,6 +183,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: acu @@ -195,6 +198,8 @@ dpc-in-data: xml # verify alter-statement: obsolete comment-paragraphs: obsolete # not verified yet +partial-replacing-with-literal: ok +control-division: unconformable call-overflow: ok data-records-clause: obsolete # not verified yet debugging-mode: ok @@ -217,6 +222,7 @@ padding-character-clause: obsolete # not verified yet section-segments: ignore # not verified yet stop-literal-statement: obsolete # not verified yet stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -271,9 +277,10 @@ assign-ext-dyn: ok assign-disk-from: unconformable vsam-status: ignore self-call-recursive: skip -align-record: 4 +record-contains-depending-clause: unconformable +align-record: 4 align-opt: no -defaultbyte: 32 +defaultbyte: " " # use fixed word list, synonyms and exceptions specified there reserved-words: ACU diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index 8ac9d4719..50e6f8792 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -180,6 +180,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -192,6 +195,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: unconformable +control-division: unconformable +partial-replacing-with-literal: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -214,6 +219,7 @@ padding-character-clause: ignore section-segments: obsolete stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable # TYPEDEF is reserved but unused usage-type: unconformable @@ -268,9 +274,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok self-call-recursive: skip -align-record: 8 +record-contains-depending-clause: unconformable +align-record: 8 align-opt: no -defaultbyte: ignore +defaultbyte: 0 # not verified yet, but likely to be as IBM # use fixed word list, synonyms and exceptions specified there reserved-words: BS2000 diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 7e0403bf1..b8998266a 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -179,6 +179,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -191,6 +194,8 @@ dpc-in-data: xml alter-statement: unconformable comment-paragraphs: unconformable +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: archaic data-records-clause: unconformable debugging-mode: obsolete @@ -213,6 +218,7 @@ padding-character-clause: obsolete section-segments: unconformable stop-literal-statement: unconformable stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok usage-type: unconformable @@ -266,9 +272,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: none # "undefined" # archaic in COBOL2002 and currently not available as dialect features: # 1: MOVE of alphanumeric figurative constants to numeric items diff --git a/config/cobol2014.conf b/config/cobol2014.conf index 2779f2759..88763ff8e 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -179,6 +179,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -191,6 +194,8 @@ dpc-in-data: xml alter-statement: unconformable comment-paragraphs: unconformable +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: archaic data-records-clause: unconformable debugging-mode: unconformable @@ -214,6 +219,7 @@ padding-character-clause: unconformable section-segments: unconformable stop-literal-statement: unconformable stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok usage-type: unconformable @@ -266,9 +272,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: none # "undefined" # use fixed word list, synonyms and exceptions specified there reserved-words: COBOL2014 diff --git a/config/cobol85.conf b/config/cobol85.conf index c02e9fff1..c80328182 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2021 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -179,6 +179,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -191,6 +194,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -213,6 +218,7 @@ padding-character-clause: ok section-segments: obsolete stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -266,9 +272,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: none # "undefined" # obsolete in COBOL85 and currently not available as dialect features: # 1: All literal with numeric or numeric edited item diff --git a/config/default.conf b/config/default.conf index cecc93c15..4117cee6a 100644 --- a/config/default.conf +++ b/config/default.conf @@ -199,6 +199,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: gc @@ -211,6 +214,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: obsolete call-overflow: archaic data-records-clause: obsolete debugging-mode: ok @@ -234,6 +239,7 @@ occurs-max-length-without-subscript: no section-segments: ignore stop-literal-statement: obsolete stop-identifier-statement: obsolete +stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok usage-type: ok @@ -288,9 +294,10 @@ assign-ext-dyn: ok assign-disk-from: ok vsam-status: ignore self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: init # use complete word list; synonyms and exceptions are specified below reserved-words: default diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 9da8b3b44..38e3cb776 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -181,6 +181,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: yes + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -193,6 +196,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: ok +partial-replacing-with-literal: ok call-overflow: archaic data-records-clause: obsolete debugging-mode: ok @@ -216,6 +221,7 @@ padding-character-clause: ok section-segments: obsolete stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: ok same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -268,9 +274,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: obsolete align-record: 0 # TODO: verify align-opt: no # TODO: verify -defaultbyte: ignore +defaultbyte: 0 # use fixed word list, synonyms and exceptions specified there reserved-words: GCOS diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index da8d4379d..7de96d8d2 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -178,6 +178,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: yes + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -190,6 +193,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -213,6 +218,7 @@ padding-character-clause: obsolete section-segments: ignore stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -265,9 +271,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 8 align-opt: yes -defaultbyte: ignore +defaultbyte: 0 # use fixed word list, synonyms and exceptions specified there reserved-words: IBM diff --git a/config/lax.conf-inc b/config/lax.conf-inc index 1c34a1c9e..96039f63c 100644 --- a/config/lax.conf-inc +++ b/config/lax.conf-inc @@ -65,6 +65,7 @@ screen-section-rules: gc alter-statement: +obsolete comment-paragraphs: ok +control-division: +obsolete call-overflow: ok data-records-clause: +obsolete debugging-mode: ok diff --git a/config/mf-strict.conf b/config/mf-strict.conf index 3a91afa0a..621e071ac 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -181,6 +181,9 @@ move-non-numeric-lit-to-numeric-is-zero: yes # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: yes + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: mf @@ -193,6 +196,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -215,6 +220,7 @@ padding-character-clause: obsolete section-segments: ignore stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable # only supports USAGE type-name usage-type: ok @@ -269,9 +275,10 @@ assign-ext-dyn: ok assign-disk-from: ok vsam-status: ok self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 8 align-opt: yes -defaultbyte: 32 +defaultbyte: " " # use fixed word list, synonyms and exceptions specified there reserved-words: MF diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index f090c69c4..2519c6c35 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -178,6 +178,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: yes + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -190,6 +193,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +partial-replacing-with-literal: unconformable +control-division: unconformable call-overflow: ok # not verified yet data-records-clause: obsolete debugging-mode: ok @@ -212,6 +217,7 @@ padding-character-clause: obsolete section-segments: ignore stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -265,9 +271,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 8 align-opt: yes -defaultbyte: ignore +defaultbyte: 0 # not verified yet, but likely to be as IBM # use fixed word list, synonyms and exceptions specified there reserved-words: MVS diff --git a/config/realia-strict.conf b/config/realia-strict.conf index f9cf2a67e..a5789d6a4 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -183,6 +183,9 @@ move-non-numeric-lit-to-numeric-is-zero: yes # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: xopen @@ -195,6 +198,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: ok +control-division: unconformable # not verified yet +partial-replacing-with-literal: unconformable # not verified yet call-overflow: ok data-records-clause: ignore debugging-mode: unconformable @@ -217,6 +222,7 @@ padding-character-clause: ignore section-segments: unconformable stop-literal-statement: ok stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -271,9 +277,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: " " # not verified, but possibly like ACU/MF # use fixed word list, synonyms and exceptions specified there reserved-words: realia diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 3156b34de..47878c71a 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -184,6 +184,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # not verified yet # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: rm @@ -196,6 +199,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -218,6 +223,7 @@ padding-character-clause: ok section-segments: obsolete stop-literal-statement: obsolete stop-identifier-statement: ok +stop-error-statement: unconformable same-as-clause: ok type-to-clause: unconformable usage-type: unconformable @@ -272,9 +278,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 4 align-opt: no -defaultbyte: ignore +defaultbyte: " " # not verified, but possibly like ACU/MF # obsolete in COBOL85 and currently not available as dialect features: # 1: All literal with numeric or numeric edited item diff --git a/config/xopen.conf b/config/xopen.conf index 0181ac52d..0d450e97b 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2021 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -183,6 +183,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: xopen @@ -200,6 +203,8 @@ dpc-in-data: xml alter-statement: warning # should not be used ... comment-paragraphs: warning # should not be used ... +partial-replacing-with-literal: unconformable +control-division: unconformable call-overflow: ok data-records-clause: warning # should not be used ... debugging-mode: ok @@ -223,6 +228,7 @@ section-segments: unconformable # complete module removed # reportwriter and communication: complete modules removed stop-literal-statement: warning # should not be used ... stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -275,10 +281,11 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable +self-call-recursive: skip +record-contains-depending-clause: obsolete align-record: 0 align-opt: no -defaultbyte: ignore -self-call-recursive: skip +defaultbyte: none # "not specifically defined in Standard COBOL" # obsolete in COBOL85 and currently not available as dialect features: # 1: All literal with numeric or numeric edited item diff --git a/doc/ChangeLog b/doc/ChangeLog index 0e4f7cdf1..2011550ce 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,4 +1,8 @@ +2022-07-04 Nicolas Berthier + + * gnucobol.texi: document newly supported source formats + 2022-06-28 Simon Sobisch * gnucobol.texi: minor additions diff --git a/doc/gnucobol.texi b/doc/gnucobol.texi index 52801b651..2f4395f3e 100644 --- a/doc/gnucobol.texi +++ b/doc/gnucobol.texi @@ -418,26 +418,63 @@ Place the output into @var{file}. @node Source format @subsection Source format -GnuCOBOL supports both fixed and free source format. -The default format is the fixed format. -This can be overridden either by the -@code{>>SOURCE [FORMAT] [IS] @{FIXED|FREE@}} directive, -or by one of the following options: +GnuCOBOL supports fixed, free, Microfocus' Variable, X/Open Free-form, +ICOBOL xCard and Free-form, ACUCOBOL-GT Terminal, and COBOLX source +formats. The default format is the fixed format. This can be +overridden either by the @code{>>SOURCE [FORMAT] [IS] +@{FIXED|FREE|VARIABLE|XOPEN|XCARD|CRT|TERMINAL|COBOLX@}} directive, or +by one of the following options: @table @code -@item -free, -F +@item -free, -F, -fformat=free Free format. The program-text area starts in column 1 and continues till the end of line (effectively 255 characters in GnuCOBOL). -@item -fixed +@item -fixed, -fformat=fixed Fixed format. Source code is divided into: columns 1-6, the sequence number area; column 7, the indicator area; columns 8-72, the program-text area; and columns 72-80 as the reference area.@footnote{Historically, fixed format was based on 80-character punch cards.} +@item -fformat=variable +Microfocus' Variable format. Identical to the fixed format above except +for the program-text area which extends up to column 250 instead of 72. + +@item -fformat=xopen +X/Open Free-form format. The program-text area may start in column 1 +unless an indicator is present, and lines may contain up to 80 +characters. Indicator for debugging lines is @code{D } instead of +@code{D} or @code{d}. + +@item -fformat=xcard +ICOBOL xCard format. Variable format with right margin set at column +255 instead of 250. + +@item -fformat=crt +ICOBOL Free-form format (CRT). Similar to the X/Open format above, with +lines containing up to 320 characters and single-character debugging +line indicators (@code{D} or @code{d}). + +@item -fformat=terminal +ACUCOBOL-GT Terminal format. Similar to the CRT format above, with +indicator for debugging lines being @code{\D} instead of @code{D} or +@code{d}. This format is mostly compatible with VAX COBOL terminal +source format. + +@item -fformat=cobolx +COBOLX format. This format is similar to the CRT format above, except +that the indicator area is always present in column 1; the program-text +area starts in column 2 and extends up to the end of the record. Lines +may contain up to 255 characters. + @end table +Note that with source formats @code{XOPEN}, @code{CRT}, @code{TERMINAL}, +and @code{COBOLX}, missing spaces are not inserted within continued +alphanumeric literals that are truncated before the right margin. + + @node Warning options @subsection Warning options diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 285bd686c..17beaed68 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -239,6 +239,13 @@ error status and fatal exception (no runtime exit) along with a warning if the runtime is not configured for XML / JSON +2022-07-15 Simon Sobisch + + * call.c (cob_resolve_internal): added check for module name length, + fixed compiler warnings + * call.c (cob_call): switched argument table from dynamic allocation + to stack allocation + 2022-07-10 Simon Sobisch * screenio.c [__PDCURSES__] (cob_exit_screen): execute @@ -248,11 +255,20 @@ * common.c, coblocal.h, screenio.c (cob_exit_screen_from_signal): only minimal screenio exit from signal handler +2022-07-08 Simon Sobisch + + * call.c (cob_cancel): preparation for CANCEL ALL + 2022-07-04 Ron Norman * Updated Copyright date to include 2022 * Reverted back to using D-ISAM and V-ISAM names +2022-06-23 Simon Sobisch + + * strings.c (cob_unstring_into): minor performance-tweak + for UNSTRING with a single DELIMITED BY phrase + 2022-06-21 Simon Sobisch * Makefile.am: always build INDEXED handlers as separate libraries @@ -360,6 +376,7 @@ check and marker range before checking all marker bytes in range * strings.c: increase use of direct pointer comparisons instead of accessing char arrays or its positions for INSPECT + 2022-04-29 Simon Sobisch * screenio.c: adjustments for XCurses defines @@ -389,6 +406,10 @@ compiler into directory different that declared when compiler was built +2022-03-11 Fabrice Le Fessant + + * common.c, common.h: add support for the STOP ERROR statement + 2022-02-21 Ron Norman * move.c (cob_move_display_to_packed): If P used in PIC adjust data move diff --git a/libcob/call.c b/libcob/call.c index d4eb5f89e..83f812955 100644 --- a/libcob/call.c +++ b/libcob/call.c @@ -767,7 +767,7 @@ cob_encode_invalid_chars (const unsigned char* const name, /** encode given name \param name to encode - \param name_buff to place the encoded name to + \param name_buff to place the encoded name to (unchanged, when no encoding necessary) \param buff_size available \param fold_case may be COB_FOLD_UPPER or COB_FOLD_LOWER \return size of the encoded name, negative if the buffer size would be exceeded @@ -818,13 +818,13 @@ static void * cob_resolve_internal (const char *name, const char *dirent, const int fold_case, int module_type) { - const unsigned char *s; void *func; struct struct_handle *preptr; lt_dlhandle handle; size_t i; - char call_entry_buff[COB_MINI_BUFF]; - unsigned char call_entry2_buff[COB_MINI_BUFF]; + char call_entry_buff[COB_MINI_BUFF]; /* entry name, possibly encoded */ + unsigned char call_module_buff[COB_MAX_NAMELEN + 1]; + const unsigned char *s; /* LCOV_EXCL_START */ if (!cobglobptr) { @@ -839,10 +839,21 @@ cob_resolve_internal (const char *name, const char *dirent, return func; } - s = (const unsigned char *)name; + if (strlen (name) > COB_MAX_NAMELEN) { + /* note: we allow up to COB_MAX_WORDLEN for relaxed syntax... */ + snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX, + module_type == COB_MODULE_TYPE_PROGRAM + ? _("%s: PROGRAM name exceeds %d characters") + : _("%s: FUNCTION name exceeds %d characters"), + name, COB_MAX_NAMELEN); + set_resolve_error (module_type); + return NULL; + } - /* Encode program name, including case folding */ - cob_encode_program_id (s, (unsigned char *)call_entry_buff, + /* Encode program name, including case folding, + put to call_entry_buff, may tripple the size */ + cob_encode_program_id ((const unsigned char *)name, + (unsigned char *)call_entry_buff, COB_MINI_MAX, fold_case); #ifndef COB_BORKED_DLOPEN @@ -893,29 +904,10 @@ cob_resolve_internal (const char *name, const char *dirent, } #endif #endif - - s = (const unsigned char *)name; - - /* Check if name needs conversion */ - if (cobsetptr->name_convert != 0) { - unsigned char *p = call_entry2_buff; - for (; *s; ++s, ++p) { - if (cobsetptr->name_convert == 1 && isupper (*s)) { - *p = (cob_u8_t) tolower (*s); - } else if (cobsetptr->name_convert == 2 && islower (*s)) { - *p = (cob_u8_t) toupper (*s); - } else { - *p = *s; - } - } - *p = 0; - s = call_entry2_buff; - } - /* Search external modules */ resolve_error_buff[CALL_BUFF_MAX] = 0; #ifdef __OS400__ - strcpy (call_filename_buff, s); + strcpy (call_filename_buff, name); for (p = call_filename_buff; *p; ++p) { *p = (cob_u8_t)toupper(*p); } @@ -931,6 +923,26 @@ cob_resolve_internal (const char *name, const char *dirent, } } #else + /* Check if *module name* needs conversion */ + /* CHECKME: why do we separate this by COB_LOAD_CASE + from the entry points, which are a compile-time setup only? */ + if (cobsetptr->name_convert != 0) { + cob_u8_t* p = call_module_buff; + for (s = (const unsigned char *)name; *s; ++s, ++p) { + if (cobsetptr->name_convert == 1 && isupper (*s)) { + *p = (cob_u8_t)tolower (*s); + } else if (cobsetptr->name_convert == 2 && islower (*s)) { + *p = (cob_u8_t)toupper (*s); + } else { + *p = *s; + } + } + *p = 0; + s = call_module_buff; + } else { + s = (const unsigned char *)name; + } + if (dirent) { snprintf (call_filename_buff, (size_t)COB_NORMAL_MAX, "%s%s.%s", dirent, (char *)s, COB_MODULE_EXT); @@ -1303,6 +1315,17 @@ cob_cancel (const char *name) cob_hard_failure (); } /* LCOV_EXCL_STOP */ + + /* CANCEL ALL (acu extension) */ + if (strcmp (name, "CANCEL ALL") == 0) { + /* TODO: add list of all modules in CALL (with marker preloaded or not) + then when setting the COB_MODULE_PTR via cob_module_global_enter add + it also to this new list; + then drop in CANCEL and use here canceling non-active COBOL + and - for physical cancel only - also the "not COBOL" ones */ + return; + } + entry = cob_chk_dirp (name); #ifdef COB_ALT_HASH @@ -1365,7 +1388,7 @@ cob_cancel_field (const cob_field *f, const struct cob_call_struct *cs) int cob_call (const char *name, const int argc, void **argv) { - void **pargv; + void *pargv[MAX_CALL_FIELD_PARAMS] = { 0 }; cob_call_union unifunc; int i; @@ -1383,7 +1406,6 @@ cob_call (const char *name, const int argc, void **argv) } /* LCOV_EXCL_STOP */ unifunc.funcvoid = cob_resolve_cobol (name, 0, 1); - pargv = cob_malloc (MAX_CALL_FIELD_PARAMS * sizeof(void *)); /* Set number of parameters */ cobglobptr->cob_call_params = argc; cobglobptr->cob_call_from_c = 1; @@ -1474,7 +1496,6 @@ cob_call (const char *name, const int argc, void **argv) #endif #endif ); - cob_free (pargv); return i; } diff --git a/libcob/common.c b/libcob/common.c index ccfa731f9..26eb5d1a8 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -3187,6 +3187,13 @@ handle_core_on_error () return core_on_error; } +void +cob_stop_error (void) +{ + cob_runtime_error ("STOP ERROR"); + cob_hard_failure (); +} + void cob_hard_failure () { diff --git a/libcob/common.h b/libcob/common.h index c1d46f3bf..61569c0b6 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1876,6 +1876,7 @@ COB_EXPIMP void cob_module_leave (cob_module *); COB_EXPIMP void cob_module_free (cob_module **); DECLNORET COB_EXPIMP void cob_stop_run (const int) COB_A_NORETURN; +DECLNORET COB_EXPIMP void cob_stop_error (void) COB_A_NORETURN; DECLNORET COB_EXPIMP void cob_fatal_error (const enum cob_fatal_error) COB_A_NORETURN; DECLNORET COB_EXPIMP void cob_hard_failure_internal (const char *) COB_A_NORETURN; DECLNORET COB_EXPIMP void cob_hard_failure (void) COB_A_NORETURN; diff --git a/libcob/intrinsic.c b/libcob/intrinsic.c index d5f8b44f5..644bfb45a 100644 --- a/libcob/intrinsic.c +++ b/libcob/intrinsic.c @@ -3580,6 +3580,7 @@ cob_intr_binop (cob_field *f1, const int op, cob_field *f2) /* Intrinsics */ +/* FUNCTION LENGTH - amount of positions */ cob_field * cob_intr_length (cob_field *srcfield) { @@ -3600,6 +3601,8 @@ cob_intr_length (cob_field *srcfield) return curr_field; } + +/* FUNCTION BYTE-LENGTH (or, as an extension: LENGTH-AN) - amount of bytes */ cob_field * cob_intr_byte_length (cob_field *srcfield) { diff --git a/libcob/strings.c b/libcob/strings.c index 58fee3d6f..5629e8d34 100644 --- a/libcob/strings.c +++ b/libcob/strings.c @@ -512,7 +512,7 @@ cob_inspect_init (cob_field *var, const cob_u32_t replacing) one-time cob_inspect_init_converting --> cob_inspect_init_common (setting up memory) multiple: - cob_inspect_start (setting inspect_start/end) + cob_inspect_start (setting inspect_start/end) cob_inspect_before (optional, adjusting inspect_end) cob_inspect_after (optional, adjusting inspect_start) one-time cob_inspect_converting (actual converstion) */ @@ -830,6 +830,16 @@ cob_string_finish (void) } /* UNSTRING */ +/* an UNSTRING is split into multiple parts: + one-time cob_unstring_init (setting up memory and static variables) + 0..n : + cob_unstring_delimited (setting delimiter struct entries) + 1..n: + cob_unstring_into (to handle a single target + [optional with counter and/or delimiter]) + optional: + cob_unstring_tallying setting TALLYING (amount of targets set) + one-time cob_unstring_finish (setting the string pointer / overflow exception) */ void cob_unstring_init (cob_field *src, cob_field *ptr, const size_t num_dlm) @@ -877,78 +887,122 @@ cob_unstring_delimited (cob_field *dlm, const cob_u32_t all) void cob_unstring_into (cob_field *dst, cob_field *dlm, cob_field *cnt) { - unsigned char *p; - unsigned char *dp; - unsigned char *s; unsigned char *dlm_data; unsigned char *start; size_t dlm_size = 0; - int i; - int srsize; - int dlsize; int match_size = 0; if (cobglobptr->cob_exception_code) { + /* commonly COB_EC_OVERFLOW_UNSTRING: the specified WITH POINTER was + too big, all other functions must be returned early; + TODO: adjust cobc to only call if cob_unstring_init was + sucessfull / has no exception */ return; } - if (unstring_offset >= (int)unstring_src->size) { + if (unstring_offset >= unstring_src->size) { + /* overflow from the last iteration (multiple INTO targets) */ return; } - start = unstring_src->data + unstring_offset; dlm_data = NULL; + start = unstring_src->data + unstring_offset; + + /* no delimiter - just split into DELIMITED BY SIZE */ if (unstring_ndlms == 0) { + /* necessary for correct unstring offset: minimal size */ + /* Note: field->size and therefore offset + are guaranteed to be < INT_MAX by cobc */ match_size = cob_min_int ((int)COB_FIELD_SIZE (dst), (int)unstring_src->size - unstring_offset); cob_str_memcpy (dst, start, match_size); unstring_offset += match_size; + + /* DELIMITED BY [ALL] x [.. OR [ALL] z] */ } else { - int brkpt = 0; - srsize = (int) unstring_src->size; - s = unstring_src->data + srsize; - for (p = start; p < s; ++p) { - for (i = 0; i < unstring_ndlms; ++i) { - dlsize = (int) dlm_list[i].uns_dlm.size; - dp = dlm_list[i].uns_dlm.data; - if (p + dlsize > s) { - continue; - } - if (!memcmp (p, dp, (size_t)dlsize)) { /* delimiter equal */ + + const int srsize = (int)unstring_src->size; + unsigned char *p; + unsigned char *dp; + int found = 0; + + /* note: duplicate code for performance as most cases + have either none or a single delimiter */ + if (unstring_ndlms == 1) { + const struct dlm_struct dlms = dlm_list[0]; + const int dlsize = (int) dlms.uns_dlm.size; + const unsigned char *s = unstring_src->data + srsize - dlsize + 1; + dp = dlms.uns_dlm.data; + + for (p = start; p < s; ++p) { + if (!memcmp (p, dp, (size_t)dlsize)) { /* delimiter matches */ match_size = (int)(p - start); /* count in */ cob_str_memcpy (dst, start, match_size); /* into */ unstring_offset += match_size + dlsize; /* with pointer */ dlm_data = dp; dlm_size = dlsize; - if (dlm_list[i].uns_all) { /* delimited by all */ - for (p += dlsize ; p < s; p += dlsize) { - if (p + dlsize > s) { - break; - } + if (dlms.uns_all) { /* delimited by all */ + for (p += dlsize; p < s; p += dlsize) { if (memcmp (p, dp, (size_t)dlsize)) { break; } unstring_offset += dlsize; } } - brkpt = 1; + found = 1; break; } } - if (brkpt) { - break; + } else { + const unsigned char *s = unstring_src->data + srsize; + int i; + for (p = start; p < s; ++p) { + for (i = 0; i < unstring_ndlms; ++i) { + const struct dlm_struct dlms = dlm_list[i]; + const int dlsize = (int)dlms.uns_dlm.size; + const unsigned char *s2 = s - dlsize + 1; + if (p > s2) { + continue; + } + dp = dlms.uns_dlm.data; + if (!memcmp (p, dp, (size_t)dlsize)) { /* delimiter matches */ + match_size = (int)(p - start); /* count in */ + cob_str_memcpy (dst, start, match_size); /* into */ + unstring_offset += match_size + dlsize; /* with pointer */ + dlm_data = dp; + dlm_size = dlsize; + if (dlms.uns_all) { /* delimited by all */ + for (p += dlsize; p < s2; p += dlsize) { + if (memcmp (p, dp, (size_t)dlsize)) { + break; + } + unstring_offset += dlsize; + } + } + found = 1; + break; + } + } + if (found) { + break; + } } } - if (!brkpt) { - /* No match */ + + /* if none of the delimiters matched, match to end */ + if (!found) { match_size = (int)(unstring_src->size - unstring_offset); cob_str_memcpy (dst, start, match_size); unstring_offset = (int) unstring_src->size; - dlm_data = NULL; } } unstring_count++; + /* note: per any known dialect both DELIMITER IN and COUNT IN are only + allowed if there is a DELIMITED BY phrase; the GnuCOBOL parser + does allow this (did so since the first implementation) */ + + /* set DELIMITER IN */ if (dlm) { if (dlm_data) { cob_str_memcpy (dlm, dlm_data, (int) dlm_size); @@ -959,6 +1013,7 @@ cob_unstring_into (cob_field *dst, cob_field *dlm, cob_field *cnt) } } + /* set COUNT IN */ if (cnt) { cob_set_int (cnt, match_size); } @@ -974,6 +1029,7 @@ void cob_unstring_finish (void) { if (unstring_offset < (int)unstring_src->size) { + /* overflow from any iteration -> overflow exception */ cob_set_exception (COB_EC_OVERFLOW_UNSTRING); } diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index f1981ddf8..eece758a3 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -1,4 +1,4 @@ -## Copyright (C) 2014-2021 Free Software Foundation, Inc. +## Copyright (C) 2014-2022 Free Software Foundation, Inc. ## Written by Simon Sobisch ## ## This file is part of GnuCOBOL. @@ -409,7 +409,7 @@ name: "Empty Conf" ]) # check if incomplete configuration result in error -AT_CHECK([$COMPILE_ONLY -conf=test.conf prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -conf=test.conf prog.cob], [97], [], [configuration error: test.conf: missing definitions: no definition of 'reserved-words' @@ -419,10 +419,10 @@ test.conf: missing definitions: no definition of 'word-length' no definition of 'literal-length' no definition of 'numeric-literal-length' - no definition of 'defaultbyte' no definition of 'align-record' no definition of 'keycompress' no definition of 'align-opt' + no definition of 'defaultbyte' no definition of 'standard-define' no definition of 'binary-size' no definition of 'binary-byteorder' @@ -457,7 +457,10 @@ test.conf: missing definitions: no definition of 'numeric-pointer' no definition of 'move-non-numeric-lit-to-numeric-is-zero' no definition of 'implicit-assign-dynamic-var' + no definition of 'device-mnemonics' no definition of 'comment-paragraphs' + no definition of 'control-division' + no definition of 'partial-replacing-with-literal' no definition of 'memory-size-clause' no definition of 'multiple-file-tape-clause' no definition of 'label-records-clause' @@ -473,6 +476,7 @@ test.conf: missing definitions: no definition of 'goto-statement-without-name' no definition of 'stop-literal-statement' no definition of 'stop-identifier-statement' + no definition of 'stop-error-statement' no definition of 'debugging-mode' no definition of 'use-for-debugging' no definition of 'padding-character-clause' @@ -535,6 +539,10 @@ test.conf: missing definitions: no definition of 'assign-disk-from' no definition of 'vsam-status' no definition of 'self-call-recursive' + no definition of 'record-contains-depending-clause' +cobc: too many errors + +cobc: aborting ]) AT_CLEANUP @@ -819,3 +827,52 @@ cobc: error: please check environment variables as noted above ) AT_CLEANUP + + +AT_SETUP([cobc configuration: source format]) +AT_KEYWORDS([configuration misc format]) + +AT_DATA([fixed.cob], [ + *Example prog in fixed format (the default) + IDENTIFICATION DIVISION. + PROGRAM-ID. fixed. + DATA DIVISION. + WORKING-STORAGE SECTION. + / + PROCEDURE DIVISION. + D DISPLAY 'START' + DISPLAY ' 20 30 40 50 60 ' + DISPLAY ' 20 30 40 50 60 + - ' 70' + D DISPLAY 'STOP' + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY -fformat=unknown fixed.cob], [1], [], +[cobc: error: invalid parameter: -fformat +]) +AT_CHECK([$COMPILE_ONLY -fixed fixed.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -fformat=fixed fixed.cob], [0], [], []) + +AT_DATA([wide.cob], [ + *Example prog in fixed format with wider record length + IDENTIFICATION DIVISION. + PROGRAM-ID. wide. + DATA DIVISION. + WORKING-STORAGE SECTION. + / + PROCEDURE DIVISION. + DISPLAY ' 20 30 40 50 60 70 ' + DISPLAY ' 20 30 40 50 60 70 + - ' 80' + STOP RUN. +]) +AT_CHECK([$COMPILE_ONLY -fformat=fixed wide.cob], [1], [], +[wide.cob:10: error: continuation character expected +wide.cob:9: error: invalid literal: ' ...' +wide.cob:9: error: missing terminating ' character +wide.cob:9: error: syntax error, unexpected end of file +]) +AT_CHECK([$COMPILE_ONLY -ftext-column=80 wide.cob], [0], [], []) + +AT_CLEANUP diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index 874eef4ba..28c788a1c 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -5467,6 +5467,35 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP +AT_SETUP([Invalid source format]) +AT_KEYWORDS([extensions runmisc]) + +AT_DATA([unknown.cob], [ + >>SOURCE FORMAT UNKNOWN + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + STOP RUN. +]) +AT_DATA([lit.cob], [ + >>SOURCE FORMAT "literal" + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE unknown.cob], [1], [], +[unknown.cob:2: error: invalid SOURCE directive option 'UNKNOWN' +]) +AT_CHECK([$COMPILE lit.cob], [1], [], +[lit.cob:2: error: invalid SOURCE directive option +lit.cob:2: error: PROGRAM-ID header missing +]) + +AT_CLEANUP + + AT_SETUP([Variable format]) AT_KEYWORDS([extensions runmisc]) @@ -5486,6 +5515,195 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [Hello! ]) +# Check that manually setting -ftext-column in combination with +# variable source format isstill allowed: -ftext-column now impacts +# fixed format only; 250 is the default right margin for variable +# format. +AT_DATA([fit.cob], [ +000010 IDENTIFICATION DIVISION. +000020 PROGRAM-ID. fit. +000040 PROCEDURE DIVISION. +000050 DISPLAY "Hello!" +000060 STOP RUN. +]) +AT_CHECK([$COMPILE -fformat=variable -ftext-column=250 fit.cob], [0], [], []) +AT_CHECK([$COMPILE -fformat=variable -ftext-column=72 -o fit fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[Hello! +]) + +AT_CLEANUP + + +AT_SETUP([COBOLX format]) +AT_KEYWORDS([extensions runmisc]) + +AT_DATA([prog.cob], [ + >>SOURCE FORMAT COBOLX + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. +* area B can extend up to character position 255 + PROCEDURE DIVISION. +/ + DISPLAY "Hello!" + DISPLAY "Hi!" +DDISPLAY "Hey!" +D DISPLAY "Bye!" +* trucated alphanumeric literals are not padded with spaces + DISPLAY " 20 30 40 50 60 70 80 90 100 110 120 130 +- " 140 150 160 170 180 190 200 210 220 230 240 250" + . +]) +# " (closing quote) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[Hello! +Hi! + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 +]) +AT_CHECK([$COMPILE -fdebugging-line -o prog prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[Hello! +Hi! +Hey! +Bye! + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 +]) + +AT_CLEANUP + + +AT_SETUP([X/Open free-form format]) +AT_KEYWORDS([fundamental xopen extensions]) + +AT_DATA([prog.cob], [ +* Sample program in X/Open free-form format. + +IDENTIFICATION DIVISION. +PROGRAM-ID. prog. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. +/ Beginning of the code +DISPLAY "OK" NO ADVANCING +* If debug: +D DISPLAY "KO" NO ADVANCING +STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=xopen prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) +AT_CHECK([$COMPILE -fformat=xopen -fdebugging-line -o prog prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKKO], []) + +AT_DATA([fit.cob], [ +* Sample program in X/Open format, and with longer lines and truncated literals. + +IDENTIFICATION DIVISION. +PROGRAM-ID. fit. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. +DISPLAY ' 20 30 40 50 60 70 79' +D DISPLAY ' 20 30 40 50 60 70 79' +STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=xopen fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[ 20 30 40 50 60 70 79 +], []) +AT_CHECK([$COMPILE -fformat=xopen -fdebugging-line -o fit fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[ 20 30 40 50 60 70 79 + 20 30 40 50 60 70 79 +], []) + +AT_CLEANUP + + +AT_SETUP([TERMINAL format]) +AT_KEYWORDS([fundamental extensions]) + +# FIXME: For now, only comment paragraphs can be used to check proper +# handling of margin B w.r.t indicators; better tests shall be +# implemented once area A/B checking will be available + +AT_DATA([prog.cob], [ +* Sample program in ACU terminal format. + +IDENTIFICATION DIVISION. +PROGRAM-ID. prog. +AUTHOR. + Somebody. +\D Somebody else. + One last author. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. + DISPLAY "OK" NO ADVANCING + END-DISPLAY. +\D DISPLAY "KO" NO ADVANCING +\D END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=terminal -fcomment-paragraphs=ok prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) +AT_CHECK([$COMPILE -fformat=terminal -fcomment-paragraphs=ok -fdebugging-line -o prog prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKKO], []) + +AT_DATA([marginberr.cob], [ +IDENTIFICATION DIVISION. +PROGRAM-ID. marginberr. +AUTHOR. +* Comment paragraph where margin B depends on indicator width: + Somebody +\D Somebody else. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. + DISPLAY "OK" NO ADVANCING + STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=terminal -fcomment-paragraphs=ok -fdebugging-line marginberr.cob], [1], [], +[marginberr.cob:7: error: ENVIRONMENT DIVISION header missing +marginberr.cob:7: error: CONFIGURATION SECTION header missing +marginberr.cob:7: error: SPECIAL-NAMES header missing +marginberr.cob:7: error: invalid system-name 'Somebody' +marginberr.cob:7: error: syntax error, unexpected ELSE, expecting CRT or Identifier +]) + +AT_DATA([fit.cob], [ +* Sample program in ACU terminal format, and with longer lines and truncated literals. + +IDENTIFICATION DIVISION. +PROGRAM-ID. fit. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. + DISPLAY ' 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319' +\D DISPLAY ' 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319' +\D END-DISPLAY. + DISPLAY ' 20 30 40 50 60 70 80 90 100 110 120 130 +- ' 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319' + STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=terminal fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[ 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 +], []) +AT_CHECK([$COMPILE -fformat=terminal -fdebugging-line -o fit fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[ 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 +], []) + AT_CLEANUP diff --git a/tests/testsuite.src/run_functions.at b/tests/testsuite.src/run_functions.at index e92050833..9e600cece 100644 --- a/tests/testsuite.src/run_functions.at +++ b/tests/testsuite.src/run_functions.at @@ -1,4 +1,4 @@ -## Copyright (C) 2003-2012, 2014-2020 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2014-2022 Free Software Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart ## ## This file is part of GnuCOBOL. @@ -416,6 +416,8 @@ AT_DATA([prog.cob], [ 01 Y PIC X(4) VALUE "HI.". 01 BIN PIC 9(9) BINARY VALUE 12. 01 PAC PIC 9(5) COMP-3 VALUE 1234. + 01 N9 PIC 9(2) USAGE NATIONAL VALUE 12. + 01 NX PIC N(2) VALUE N"!". 01 HEXX PIC X(10). 88 HEXX-FILLER VALUE ALL "-". PROCEDURE DIVISION. @@ -459,6 +461,36 @@ AT_DATA([prog.cob], [ >> END-IF DISPLAY "UNEXPECTED HEX-VALUE OF z'01': " HEXX. + SET HEXX-FILLER TO TRUE + STRING FUNCTION HEX-OF (' ') DELIMITED BY SIZE INTO HEXX. + IF HEXX NOT = "20--------" + DISPLAY "UNEXPECTED HEX-VALUE OF ' ': " HEXX. + + SET HEXX-FILLER TO TRUE + STRING FUNCTION HEX-OF (n' ') DELIMITED BY SIZE INTO HEXX. + IF HEXX NOT = "0020------" + DISPLAY "UNEXPECTED HEX-VALUE OF n' ': " HEXX. + + *> FIXME: Failing with "3132------" -> missing padding + *> -> codegen issue for initialization / move + *> and libcob issue at least for MOVE + *> SET HEXX-FILLER TO TRUE + *> STRING FUNCTION HEX-OF (N9) DELIMITED BY SIZE INTO HEXX. + *> IF HEXX NOT = "00310032--" + *> DISPLAY "UNEXPECTED HEX-VALUE OF N9: " HEXX. + + *> FIXME: Failing with "00212020--" -> bad padding + *> -> codegen issue for initialization / move + *> and libcob issue at least for MOVE + *> SET HEXX-FILLER TO TRUE + *> STRING FUNCTION HEX-OF (NX) DELIMITED BY SIZE INTO HEXX. + *> IF HEXX NOT = "00210020--" + *> DISPLAY "UNEXPECTED HEX-VALUE OF NX: " HEXX. + + *> setting up test data: + SET HEXX-FILLER TO TRUE + STRING FUNCTION HEX-OF (z"01") DELIMITED BY SIZE INTO HEXX. + IF FUNCTION HEX-TO-CHAR (HEXX(1:6)) NOT = z"01" DISPLAY "UNEXPECTED CHAR VALUE, does not match z'01': " HEXX (1:6). @@ -477,7 +509,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COMPILE -Wno-unfinished prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP @@ -1748,6 +1780,9 @@ AT_DATA([prog.cob], [ 01 X PIC S9(4)V9(4) VALUE -1.5. 01 N PIC N(9). 01 TEST-FLD PIC S9(04)V9(02). + 01 TEST-TAB. + 05 T-ENTRIES PIC 99 VALUE 10. + 05 TEST-ENTRY PIC X OCCURS 1 TO 10 DEPENDING ON T-ENTRIES. PROCEDURE DIVISION. MOVE FUNCTION LENGTH ( X ) TO TEST-FLD @@ -1793,13 +1828,24 @@ AT_DATA([prog.cob], [ DISPLAY 'LENGTH n"a0" wrong: ' TEST-FLD END-DISPLAY END-IF + MOVE 10 TO T-ENTRIES + MOVE FUNCTION LENGTH ( TEST-TAB) + TO TEST-FLD + IF TEST-FLD NOT = 12 + DISPLAY 'LENGTH TEST-TAB (10 entries): ' TEST-FLD + END-DISPLAY + END-IF + MOVE 1 TO T-ENTRIES + MOVE FUNCTION LENGTH ( TEST-TAB) + TO TEST-FLD + IF TEST-FLD NOT = 3 + DISPLAY 'LENGTH TEST-TAB (1 entry): ' TEST-FLD + END-DISPLAY + END-IF STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob], [0], [], -[prog.cob:7: warning: handling of USAGE NATIONAL is unfinished; implementation is likely to be changed -prog.cob:48: warning: handling of national literal is unfinished; implementation is likely to be changed -]) +AT_CHECK([$COMPILE -Wno-unfinished prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP diff --git a/tests/testsuite.src/run_initialize.at b/tests/testsuite.src/run_initialize.at index f64c8a8cf..b034a233a 100644 --- a/tests/testsuite.src/run_initialize.at +++ b/tests/testsuite.src/run_initialize.at @@ -253,7 +253,7 @@ AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - *01 FAILED PIC 9(4) COMP-5 VALUE ZERO. + 01 FAILED PIC 9(4) COMP-5 VALUE ZERO. 01 G. 02 G2 OCCURS 3. 03 X PIC 9 VALUE ZERO. @@ -267,30 +267,31 @@ AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. DISPLAY "Compile failed: " G "." DISPLAY " should be: " "09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ." - * ADD 1 TO FAILED + ADD 1 TO FAILED END-IF. INITIALIZE G. IF G NOT = "00 0 0 0 0 00 0 0 0 0 00 0 0 0 0 " DISPLAY "INITIALIZE failed: " G "." DISPLAY " should be: " "00 0 0 0 0 00 0 0 0 0 00 0 0 0 0 ." - * ADD 1 TO FAILED + ADD 1 TO FAILED END-IF. INITIALIZE G ALL TO VALUE. IF G NOT = "09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ" DISPLAY "INIT VALUE failed: " G "." DISPLAY " should be: " "09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ." - * ADD 1 TO FAILED + ADD 1 TO FAILED + END-IF. + IF FAILED = ZERO + DISPLAY "All INITIALIZE tests passed." END-IF. - * IF FAILED = ZERO - * DISPLAY "All INITIALIZE tests passed." - * END-IF STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +AT_CHECK([$COMPILE -std=default prog.cob ], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [All INITIALIZE tests passed. +], []) AT_CLEANUP diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index e4272737a..b4edb8879 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -5273,6 +5273,31 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [1]) AT_CLEANUP +AT_SETUP([STOP ERROR]) +AT_KEYWORDS([runmisc]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + CALL "prog2". + DISPLAY "Whatever". + STOP RUN. + END PROGRAM prog. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + PROCEDURE DIVISION. + STOP ERROR. +]) + +AT_CHECK([$COMPILE prog.cob -fstop-error-statement=ok], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], +[libcob: prog.cob:12: error: STOP ERROR +]) + +AT_CLEANUP + + AT_SETUP([SYMBOLIC clause]) AT_KEYWORDS([runmisc ALPHABET]) diff --git a/tests/testsuite.src/syn_copy.at b/tests/testsuite.src/syn_copy.at index 6e03a7f91..2b354aaad 100644 --- a/tests/testsuite.src/syn_copy.at +++ b/tests/testsuite.src/syn_copy.at @@ -523,6 +523,80 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKOK]) AT_CLEANUP +AT_SETUP([COPY: partial replacement with literals]) +AT_KEYWORDS([copy gcos]) + +AT_DATA([copy.inc], [ + 01 TEST-VAR PIC X(2) VALUE "OK". + 01 NORM-VAR PIC X(2) VALUE "OK". +]) + +AT_DATA([copy2.inc], [ + 01 TEST-FIRST PIC X(2) VALUE "OK". + 01 TEST-SECOND PIC X(2) VALUE "OK". +]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + COPY "copy.inc" + REPLACING LEADING "TEST" BY "FIRST" + LEADING "NORM" BY "SECOND". + COPY "copy2.inc" + REPLACING TRAILING "FIRST" BY "VAR1" + TRAILING "SECOND" BY "VAR2". + PROCEDURE DIVISION. + DISPLAY FIRST-VAR NO ADVANCING + END-DISPLAY. + DISPLAY SECOND-VAR NO ADVANCING + END-DISPLAY. + DISPLAY TEST-VAR1 NO ADVANCING + END-DISPLAY. + DISPLAY TEST-VAR2 NO ADVANCING + END-DISPLAY. + STOP RUN. +]) +AT_CHECK([$COMPILE -fpartial-replacing-with-literal=ok prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKOKOKOK]) +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=error prog.cob], [1], [], +[prog.cob:7: error: partial replacing with literal used +prog.cob:7: error: partial replacing with literal used +prog.cob:8: error: partial replacing with literal used +prog.cob:8: error: partial replacing with literal used +prog.cob:10: error: partial replacing with literal used +prog.cob:10: error: partial replacing with literal used +prog.cob:11: error: partial replacing with literal used +prog.cob:11: error: partial replacing with literal used +]) + +AT_DATA([prog_err.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + COPY "copy.inc" + REPLACING LEADING TEST BY "FIRST" + LEADING "NORM" BY SECOND. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=ok prog_err.cob], [1], [], +[prog_err.cob:7: error: unexpected COBOL word in partial replacement phrase +prog_err.cob:8: error: unexpected COBOL word in partial replacement phrase +]) +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=unconformable prog_err.cob], [1], [], +[prog_err.cob:7: error: unexpected COBOL word in partial replacement phrase +prog_err.cob:7: error: partial replacing with literal does not conform to GnuCOBOL +prog_err.cob:8: error: partial replacing with literal does not conform to GnuCOBOL +prog_err.cob:8: error: unexpected COBOL word in partial replacement phrase +]) + +AT_CLEANUP + + AT_SETUP([COPY: recursive replacement]) AT_KEYWORDS([copy]) @@ -577,3 +651,33 @@ AT_CHECK([$COMPILE -free prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) AT_CLEANUP + + +AT_SETUP([REPLACE: partial replacement with SPACES figurative constant]) +AT_KEYWORDS([replace gcos acu]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + REPLACE LEADING "PREFIX-" BY SPACES + TRAILING "-SUFFIX" BY SPACE. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 PREFIX-VAR1 PIC X(2) VALUE "OK". + 01 VAR2-SUFFIX PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + DISPLAY VAR1 NO ADVANCING. + DISPLAY VAR2 NO ADVANCING. + STOP RUN. +]) + +AT_DATA([prog_err.cob], [ + COPY prog REPLACING LEADING SPACES BY "PREFIX-". +]) + +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=ok prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=ok prog_err.cob], [1], [], +[prog_err.cob:2: error: unexpected COBOL word in partial replacement phrase +]) + +AT_CLEANUP diff --git a/tests/testsuite.src/syn_file.at b/tests/testsuite.src/syn_file.at index 252f26060..c1b24c960 100644 --- a/tests/testsuite.src/syn_file.at +++ b/tests/testsuite.src/syn_file.at @@ -862,6 +862,27 @@ AT_DATA([prog.cob], [ STOP RUN. ]) +AT_DATA([prog2.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT TEST-FILE ASSIGN TO 'FILE-TEST' + ORGANIZATION IS SEQUENTIAL. + DATA DIVISION. + FILE SECTION. + FD TEST-FILE + RECORD CONTAINS 12 TO 125 CHARACTERS + DEPENDING ON RECORDSIZE. + 01 TEST-REC. + 05 FILLER PIC X(40). + PROCEDURE DIVISION. + OPEN INPUT TEST-FILE. + CLOSE TEST-FILE. + STOP RUN. +]) + # FIXME: the check misses "prog.cob:40: error: RECORD DEPENDING item must be unsigned numeric" AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:20: error: 'RECORDSIZE' is not defined @@ -875,6 +896,13 @@ prog.cob:26: error: RECORD DEPENDING must reference a data-item prog.cob:34: warning: RECORD DEPENDING item 'RECORDSIZE3' should be defined in WORKING-STORAGE, LOCAL-STORAGE or LINKAGE SECTION prog.cob:40: warning: RECORD DEPENDING item 'RECORDSIZE4' should be defined in WORKING-STORAGE, LOCAL-STORAGE or LINKAGE SECTION ]) +AT_CHECK([$COMPILE_ONLY -frecord-contains-depending-clause=error prog2.cob], [1], [], +[prog2.cob:13: error: RECORD CONTAINS DEPENDING used +prog2.cob:13: error: 'RECORDSIZE' is not defined +]) +AT_CHECK([$COMPILE_ONLY -frecord-contains-depending-clause=ok prog2.cob], [1], [], +[prog2.cob:13: error: 'RECORDSIZE' is not defined +]) AT_CLEANUP diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 5712541bb..d069a28f0 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -6938,13 +6938,13 @@ AT_DATA([prog.cob], [ 01 n PIC 9. PROCEDURE DIVISION. - MOVE X'' TO x - MOVE H'' TO x - MOVE Z'' TO x - MOVE L'' TO x - MOVE N"" TO nat + MOVE X'' TO x + MOVE H'' TO n + MOVE Z'' TO x + MOVE L'' TO x + MOVE N"" TO nat MOVE NX'' TO nat - MOVE B"" TO n + MOVE B"" TO n MOVE BX"" TO n . ]) @@ -8689,3 +8689,176 @@ AT_CLEANUP # TODO: add missing tests for syntax errors in >>IF/ELSE/END + +AT_SETUP([CONTROL DIVISION]) +AT_KEYWORDS([control gcos]) + +AT_DATA([empty.cob], [ + CONTROL DIVISION. + IDENTIFICATION DIVISION. + PROGRAM-ID. empty. +]) + +AT_CHECK([$COMPILE_ONLY -fcontrol-division=ok empty.cob], [0], [], []) + +AT_DATA([replace.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + REPLACE ==TEST-VAR== BY ==VAR==. + IDENTIFICATION DIVISION. + PROGRAM-ID. replace. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-VAR PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok replace.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./replace], [0], [OK], []) +AT_CHECK([$COMPILE replace.cob], [1], [], +[replace.cob:2: error: CONTROL DIVISION does not conform to GnuCOBOL +]) + +AT_CLEANUP + + +AT_SETUP([CONTROL: empty default section]) +AT_KEYWORDS([control gcos]) + +AT_DATA([prog.cob], [ + CONTROL DIVISION. + DEFAULT SECTION. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) +AT_CHECK([$COMPILE prog.cob], [1], [], +[prog.cob:2: error: CONTROL DIVISION does not conform to GnuCOBOL +]) + +AT_CLEANUP + + +AT_SETUP([CONTROL: default section]) +AT_KEYWORDS([control gcos]) + +AT_DATA([prog.cob], [ + CONTROL DIVISION. + DEFAULT SECTION. + ACCEPT ALTERNATE CONSOLE + DISPLAY IS TERMINAL + . + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok prog.cob], [0], [], +[prog.cob:4: warning: ACCEPT statement in DEFAULT SECTION is not implemented +prog.cob:5: warning: DISPLAY statement in DEFAULT SECTION is not implemented +]) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) +AT_CHECK([$COMPILE prog.cob], [1], [], +[prog.cob:2: error: CONTROL DIVISION does not conform to GnuCOBOL +prog.cob:4: warning: ACCEPT statement in DEFAULT SECTION is not implemented +prog.cob:5: warning: DISPLAY statement in DEFAULT SECTION is not implemented +]) + +AT_CLEANUP + + +AT_SETUP([CONTROL: substitution & default section]) +AT_KEYWORDS([control gcos]) + +AT_DATA([empties.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + DEFAULT SECTION. + IDENTIFICATION DIVISION. + PROGRAM-ID. empties. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok empties.cob], [0], [], []) + +AT_DATA([empty0.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + DEFAULT SECTION. + ACCEPT ALTERNATE CONSOLE + . + IDENTIFICATION DIVISION. + PROGRAM-ID. empty0. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok empty0.cob], [0], [], +[empty0.cob:5: warning: ACCEPT statement in DEFAULT SECTION is not implemented +]) + +AT_DATA([empty1.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + REPLACE "KO" BY "OK". + DEFAULT SECTION. + IDENTIFICATION DIVISION. + PROGRAM-ID. empty1. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR PIC X(2) VALUE "KO". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok empty1.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./empty1], [0], [OK], []) + +AT_DATA([prog.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + REPLACE IISS BY IS + TERM BY TERMINAL + "KO" BY "OK". + DEFAULT SECTION. + ACCEPT ALTERNATE CONSOLE + DISPLAY IISS TERM + . + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR PIC X(2) VALUE "KO". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok prog.cob], [0], [], +[prog.cob:8: warning: ACCEPT statement in DEFAULT SECTION is not implemented +prog.cob:9: warning: DISPLAY statement in DEFAULT SECTION is not implemented +]) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) + +AT_CLEANUP diff --git a/tests/testsuite.src/syn_screen.at b/tests/testsuite.src/syn_screen.at index 13ddba744..c8d9fe35c 100644 --- a/tests/testsuite.src/syn_screen.at +++ b/tests/testsuite.src/syn_screen.at @@ -1,4 +1,4 @@ -## Copyright (C) 2014-2021 Free Software Foundation, Inc. +## Copyright (C) 2014-2022 Free Software Foundation, Inc. ## Written by Simon Sobisch, Edward Hart, Ron Norman ## ## This file is part of GnuCOBOL. @@ -137,11 +137,21 @@ AT_DATA([prog.cob], [ 01 curs-4 PIC 9(8) VALUE 0101. 01 curs-5 PIC X(4). + 01 SCREEN-POS. + 03 SPOS PIC 9(04) VALUE ZERO. + 03 WS2-CURS REDEFINES SPOS. + 05 SLIN PIC 9(02). + 05 SCOL PIC 9(02). + PROCEDURE DIVISION. *> Valid AT clauses DISPLAY "a" AT curs-1 DISPLAY "a" AT curs-2 DISPLAY "a" AT posc + DISPLAY "a" AT posc + DISPLAY "a" AT SPOS + DISPLAY "a" AT WS2-CURS + DISPLAY "a" AT SCREEN-POS *> Invalid AT clauses DISPLAY "a" AT curs-3 @@ -153,11 +163,11 @@ AT_DATA([prog.cob], [ ]) AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], -[prog.cob:24: error: value in AT clause must have 4 or 6 digits -prog.cob:25: error: value in AT clause must have 4 or 6 digits -prog.cob:26: error: value in AT clause is not numeric -prog.cob:27: error: value in AT clause must have 4 or 6 digits -prog.cob:29: error: cannot specify figurative constant ZERO in AT clause +[prog.cob:34: error: value in AT clause must have 4 or 6 digits +prog.cob:35: error: value in AT clause must have 4 or 6 digits +prog.cob:36: error: value in AT clause is not numeric +prog.cob:37: error: value in AT clause must have 4 or 6 digits +prog.cob:39: error: cannot specify figurative constant ZERO in AT clause ]) AT_CLEANUP @@ -827,3 +837,23 @@ prog.cob:13: warning: 'FILLER' has FROM, TO or USING without PIC; PIC will be im ]) AT_CLEANUP + + +AT_SETUP([DISPLAY WITH CONVERSION]) +AT_KEYWORDS([DISPLAY]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY WITH CONVERSION "Whatever". + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], +[prog.cob:7: warning: DISPLAY WITH CONVERSION is not implemented +]) + +AT_CLEANUP diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 0a71e2854..655c917b2 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -746,9 +746,19 @@ AT_CHECK([$COBCRUN noprog], [1], [], AT_CHECK([$COBCRUN -q -M], [1], [], [cobcrun: option requires an argument -- 'M' ]) -# FIXME - The following doesn't seem to work correct, -# we expect an error about missing module name -#AT_CHECK([$COBCRUN -q -M noprog], [1], [], []) +AT_CHECK([$COBCRUN -q -M noprog], [1], [], +[cobcrun: missing PROGRAM name +Try 'cobcrun --help' for more information. +]) +# this was previously checked in cobcrun, now only done in the runtime +AT_CHECK([$COBCRUN ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL], [1], [], +[libcob: error: ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL: PROGRAM name exceeds 31 characters +]) +# 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 +]) AT_CLEANUP