From bb173aeb22059593be4533ba9fedf6001ee4b260 Mon Sep 17 00:00:00 2001 From: David Declerck Date: Thu, 18 Jul 2024 15:11:10 +0200 Subject: [PATCH] Merge SVN 4795 --- cobc/ChangeLog | 9 + cobc/codegen.c | 68 ++++-- cobc/field.c | 298 ++++++++++++++++-------- cobc/parser.y | 185 +++++++++++++-- cobc/reserved.c | 3 + cobc/scanner.l | 2 +- cobc/tree.c | 57 ++++- cobc/tree.h | 23 +- cobc/typeck.c | 74 +++--- tests/testsuite.src/run_initialize.at | 13 +- tests/testsuite.src/run_reportwriter.at | 2 +- tests/testsuite.src/syn_file.at | 8 +- tests/testsuite.src/syn_misc.at | 51 ++-- 13 files changed, 572 insertions(+), 221 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 47279ebcb..47d2a2bb9 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -78,6 +78,15 @@ * parser.y, tree.c (cb_build_vary), tree.h: cleanup to not use static variables in the parser for creation of the rw vary items + * parser.y, reserved.c: full parsing for COBOL2002 and BS2000 + multi VALUE entries via VALUES [ARE] + * parser.y, field.c, tree.h, codegen.c, tree.c, scanner.l: new struct + cb_table_values to store the complex parsing result, only embed the VALUE + in a list when actually necessary, and use these adjustments in syntax + and codegen + * field.c: check all multi-values for correct type an length; + verify that only up to max amount entries are specified; + TODO: complete handling of FROM/TO/REPEATED clause 2022-10-19 Simon Sobisch diff --git a/cobc/codegen.c b/cobc/codegen.c index e41f9f35f..f3f59cf10 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -823,14 +823,15 @@ static int chk_field_multi_values (struct cb_field *f) { struct cb_field *fc; + if (f->values - && CB_CHAIN (f->values)) { + && CB_LIST_P (f->values)) { + /* multi-value entry */ return 1; } - if (f->values - && CB_VALUE (f->values)) { - if (CB_LITERAL_P (CB_VALUE(f->values)) - && CB_LITERAL (CB_VALUE(f->values))->all) { + if (f->values) { + if (CB_LITERAL_P (f->values) + && CB_LITERAL (f->values)->all) { return 1; } if (f->flag_occurs) { @@ -5625,7 +5626,20 @@ output_initialize_one (struct cb_initialize *p, cb_tree x) /* Initialize by value */ if (p->val && f->values) { - value = CB_VALUE (f->values); + if (!CB_LIST_P (f->values)) { + /* common case: simple VALUE */ + value = f->values; + } else { + /* multiple VALUE, either from report-format + or from the complex table-format; + get the first one here */ + value = CB_VALUE (f->values); + if (CB_TAB_VALS_P (value)) { + /* get the first entry of many */ + value = CB_TAB_VALS (value)->values; + value = CB_VALUE (value); + } + } /* Check for non-standard OCCURS */ if ((f->level == 1 || f->level == 77) && f->flag_occurs && !p->flag_init_statement) { @@ -5971,19 +5985,19 @@ output_initialize_occurs (struct cb_initialize *p, cb_tree x) idx_stop = 0; offset = f->offset; list = f->values; - /* TODO: move check to parser and translate msgid */ - k = cb_list_length (f->values) - total_occurs; - if (k > 0) { - cb_error_x ((cb_tree)f, "%s has %d more value%s than needed", - f->name,k,k>1?"s":""); - return; - } l = list; while (!idx_stop) { pf = pftbl[0]; pf->flag_occurs = 0; pf->occurs_max = 0; - if (list && CB_CHAIN (list)) { /* Multiple VALUEs present */ + if (list && CB_LIST_P (list)) { /* Multiple VALUEs present */ + l = CB_VALUE (list); + if (CB_TAB_VALS_P (l)) { + /* FIXME: handle FROM TO/REPEATED */ + l = CB_TAB_VALS (l)->values; + } else { + l = list; + } for (idx_clr = 0; l && !idx_stop; idx_clr++, l = CB_CHAIN (l)) { f->values = l; f->offset = get_table_offset ( offset, idx, idxtbl, occtbl, pftbl); @@ -6194,8 +6208,6 @@ output_initialize (struct cb_initialize *p) && !p->flag_init_statement) { cb_tree x; switch (type) { - case INITIALIZE_NONE: - return; case INITIALIZE_ONE: output_initialize_occurs (p, p->var); output_initialize_chaining (f, p); @@ -6238,8 +6250,6 @@ output_initialize (struct cb_initialize *p) output_newline (); } switch (type) { - case INITIALIZE_NONE: - return; case INITIALIZE_ONE: output_initialize_occurs (p, p->var); output_initialize_chaining (f, p); @@ -10679,11 +10689,25 @@ output_report_one_field (struct cb_report *r, struct cb_field *f, int idx, int o } else { value = CB_VALUE (f->values); } + +/* + if (field_val) { + value = field_val; + if (CB_LIST_P (value)) { + field_val = CB_CHAIN (field_val); + / * CHECKME: we get here with an _actual_ list in RW case + but drop all entries but the first one... * / + value = CB_VALUE (value); // is literal (tag 8) + if (CB_TAB_VALS_P (value)) { + value = CB_TAB_VALS (value)->values; + value = CB_VALUE (value); + } + } +*/ } else if (f->report_source && CB_LITERAL_P (f->report_source)) { value = f->report_source; } - if (value && CB_TREE_TAG (value) == CB_TAG_LITERAL) { char *val, *out; @@ -11855,12 +11879,6 @@ output_module_register_init (cb_tree reg, const char *name) return; } - /* LCOV_EXCL_START */ - if (!CB_REF_OR_FIELD_P (reg)) { - CB_TREE_TAG_UNEXPECTED_ABORT (reg); - } - /* LCOV_EXCL_STOP */ - if (CB_REFERENCE_P (reg)) { reg = cb_ref (reg); if (CB_FIELD_P (reg) && !CB_FIELD (reg)->count) { diff --git a/cobc/field.c b/cobc/field.c index 959e4e7a0..44199ceda 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -46,6 +46,7 @@ /* Function prototypes */ static unsigned int validate_field_1 (struct cb_field *f); +static unsigned int validate_multi_value (const struct cb_field * const f); static int compute_size (struct cb_field *f); static void compute_binary_size (struct cb_field *f, const int size); @@ -67,7 +68,7 @@ static char op_prec [CB_MAX_OPS+1]; static cob_s64_t op_val [CB_MAX_OPS+1]; static int op_scale[CB_MAX_OPS+1]; -/* Is list of values really an expression */ +/* Is constant expression list in value really an expression? */ static int cb_is_expr (cb_tree ch) { @@ -75,7 +76,7 @@ cb_is_expr (cb_tree ch) int num; if (op_pos >= 0) { - for (num=0; num < CB_MAX_OPS; num++) { + for (num = 0; num < CB_MAX_OPS; num++) { op_type [num] = ' '; op_prec [num] = 0; op_val [num] = 0; @@ -992,13 +993,31 @@ is_numeric_field (struct cb_field *f) return is_numeric_usage (f->usage); } +static cb_tree +get_first_value (const struct cb_field * const f) +{ + cb_tree x = f->values; + if (CB_INVALID_TREE (x)) + return NULL; /* no value / error */ + + if (!CB_LIST_P (x)) + return x; /* simple VALUE */ + + x = CB_VALUE (x); + if (CB_TAB_VALS_P (x)) { + x = CB_TAB_VALS (x)->values; + x = CB_VALUE (x); + } + return x; +} + /* create an implicit picture for items that miss it but need one, return 1 if not possible */ static unsigned int create_implicit_picture (struct cb_field *f) { + cb_tree first_value = get_first_value (f); cb_tree x = CB_TREE (f); - cb_tree first_value; char *pp; struct cb_literal *lp; struct cb_field *p; @@ -1007,26 +1026,21 @@ create_implicit_picture (struct cb_field *f) int ret; char pic[24]; - if (f->values) { - first_value = CB_VALUE (f->values); - if (first_value == cb_error_node) { - first_value = NULL; - } else { - if (CB_LITERAL_P (first_value)) { - size_implied = (int)CB_LITERAL (first_value)->size; - is_numeric = CB_NUMERIC_LITERAL_P (first_value); - } else if (CB_CONST_P (first_value)) { - size_implied = 1; - if (first_value == cb_zero) { - is_numeric = 1; - } else { - is_numeric = 0; - } - /* LCOV_EXCL_START */ + if (first_value) { + if (CB_LITERAL_P (first_value)) { + size_implied = (int)CB_LITERAL (first_value)->size; + is_numeric = CB_NUMERIC_LITERAL_P (first_value); + } else if (CB_CONST_P (first_value)) { + size_implied = 1; + if (first_value == cb_zero) { + is_numeric = 1; } else { - CB_TREE_TAG_UNEXPECTED_ABORT (x); - /* LCOV_EXCL_STOP */ + is_numeric = 0; } + /* LCOV_EXCL_START */ + } else { + CB_TREE_TAG_UNEXPECTED_ABORT (x); + /* LCOV_EXCL_STOP */ } } else { first_value = NULL; @@ -1188,6 +1202,7 @@ create_implicit_picture (struct cb_field *f) return ret; } +/* note: this also adjusts the field! */ static unsigned int validate_any_length_item (struct cb_field *f) { @@ -1375,6 +1390,10 @@ validate_group (struct cb_field *f) cb_name (x)); ret = 1; } + + if (f->values && CB_LIST_P (f->values)) { + ret |= validate_multi_value (f); + } for (f = f->children; f; f = f->sister) { ret |= validate_field_1 (f); @@ -1701,24 +1720,67 @@ validate_blank_when_zero (const struct cb_field * const f) } } -static void -validate_elem_value (const struct cb_field * const f) +/* Validate multiple VALUEs */ +static unsigned int +validate_multi_value (const struct cb_field * const f) { - const cb_tree x = CB_TREE (f); - const struct cb_field *p; - if (f->values != NULL - && f->storage != CB_STORAGE_REPORT - && (CB_PAIR_P (CB_VALUE (f->values)) || CB_CHAIN (f->values))) { - for (p = f; p && !p->flag_occurs; p = p->parent); - if (p == NULL - || !p->flag_occurs - || f->children) - cb_error_x (x, _("only level 88 items may have multiple values")); + int num_of_values = 0; + int total_occurs, k; + + if (!CB_TAB_VALS_P (CB_VALUE (f->values))) { + /* simple option: list of literals */ + num_of_values = cb_list_length (f->values); + } else { + cb_tree vals; + int repeated_to_end = 0; + for (vals = f->values; vals; vals = CB_CHAIN (vals)) { + /* FIXME: this is wrong, works only if "FROM" is 1 + and there is REPEATED TO END / TO ... */ + const struct cb_table_values *val_entries = CB_TAB_VALS (CB_VALUE (vals)); + int entries_in_this_list = cb_list_length (val_entries->values); + cb_tree repeated = val_entries->repeat_times; + if (repeated == cb_null) { + if (repeated_to_end++) { + /* TODO: check exact syntax, may only be specified once */ + } + repeated = NULL; + } + if (repeated) { + entries_in_this_list *= cb_get_int (repeated); + } + /* TODO: Check that there is no overlapping */ + num_of_values += entries_in_this_list; + } + } + + { + const struct cb_field *p; + total_occurs = 1; + for (p = f; p; p = p->parent) { + if (p->flag_occurs + && p->occurs_max > 1) { + total_occurs *= p->occurs_max; + } + } } + k = num_of_values - total_occurs; + if (k > 0) { + cb_error_x (CB_TREE (f), + _("elements in VALUE clause for '%s' (%d) exceed max amount (%d)"), + f->name, num_of_values, total_occurs); + return 1; + } + return 0; +} +static void +validate_elem_value (const struct cb_field * const f) +{ /* ISO+IEC+1989-2002: 13.16.42.2-10 */ if (cb_warn_opt_val[cb_warn_ignored_initial_val] != COBC_WARN_DISABLED) { + const cb_tree x = CB_TREE (f); + const struct cb_field *p; for (p = f; p; p = p->parent) { if (p->flag_external) { cb_warning_x (cb_warn_ignored_initial_val, x, @@ -1737,37 +1799,38 @@ static void warn_full_on_numeric_items_is_useless (const struct cb_field * const f) { if ((f->screen_flag & COB_SCREEN_FULL) - && f->pic && f->pic->category == CB_CATEGORY_NUMERIC) { + && f->pic && f->pic->category == CB_CATEGORY_NUMERIC) { cb_warning_x (cb_warn_additional, CB_TREE (f), - _("FULL has no effect on numeric items; you may want REQUIRED or PIC Z")); + _("FULL has no effect on numeric items; you may want REQUIRED or PIC Z")); } } static int has_std_needed_screen_clause (const struct cb_field * const f) { - const cb_tree val = f->values ? CB_VALUE (f->values) : cb_error_node; - return ( f->pic - && (f->screen_from - || f->screen_to - || CB_NUMERIC_LITERAL_P (val))) - || ((CB_LITERAL_P (val) - || CB_CONST_P (val)) - && (CB_TREE_CATEGORY (val) == CB_CATEGORY_ALPHANUMERIC - || CB_TREE_CATEGORY (val) == CB_CATEGORY_BOOLEAN - || CB_TREE_CATEGORY (val) == CB_CATEGORY_NATIONAL)) - || f->screen_flag & COB_SCREEN_BELL - || f->screen_flag & COB_SCREEN_BLANK_LINE - || f->screen_flag & COB_SCREEN_BLANK_SCREEN - || f->screen_flag & COB_SCREEN_ERASE_EOL - || f->screen_flag & COB_SCREEN_ERASE_EOS; + cb_tree first_value = get_first_value (f); + return (f ->pic + && (f->screen_from + || f->screen_to + || (first_value && CB_NUMERIC_LITERAL_P (first_value)))) + || (first_value + && (CB_LITERAL_P (first_value) + || CB_CONST_P (first_value)) + && (CB_TREE_CATEGORY (first_value) == CB_CATEGORY_ALPHANUMERIC + || CB_TREE_CATEGORY (first_value) == CB_CATEGORY_BOOLEAN + || CB_TREE_CATEGORY (first_value) == CB_CATEGORY_NATIONAL)) + || f->screen_flag & COB_SCREEN_BELL + || f->screen_flag & COB_SCREEN_BLANK_LINE + || f->screen_flag & COB_SCREEN_BLANK_SCREEN + || f->screen_flag & COB_SCREEN_ERASE_EOL + || f->screen_flag & COB_SCREEN_ERASE_EOS; } static void error_value_figurative_constant(const struct cb_field * const f) { - if (f->values - && cb_is_figurative_constant (CB_VALUE (f->values))) { + cb_tree first_value = get_first_value (f); + if (first_value && cb_is_figurative_constant (first_value)) { cb_error_x (CB_TREE (f), _("VALUE may not contain a figurative constant")); } } @@ -1800,7 +1863,8 @@ warn_from_to_using_without_pic (const struct cb_field * const f) static int warn_pic_for_numeric_value_implied (const struct cb_field * const f) { - if (f->values && CB_NUMERIC_LITERAL_P (CB_VALUE (f->values))) { + cb_tree first_value = get_first_value (f); + if (first_value && CB_NUMERIC_LITERAL_P (first_value)) { const cb_tree x = CB_TREE (f); /* TO-DO: Change to dialect option */ cb_warning_x (cb_warn_additional, x, @@ -1832,7 +1896,8 @@ error_pic_without_from_to_using (const struct cb_field * const f) static void error_pic_for_numeric_value (const struct cb_field * const f) { - if (f->values && CB_NUMERIC_LITERAL_P (CB_VALUE (f->values))) { + cb_tree first_value = get_first_value (f); + if (first_value && CB_NUMERIC_LITERAL_P (first_value)) { cb_error_x (CB_TREE (f), _("cannot have numeric VALUE without PIC")); } } @@ -1849,8 +1914,9 @@ error_from_to_using_without_pic (const struct cb_field * const f) static void error_value_numeric (const struct cb_field * const f) { - if (f->values - && CB_TREE_CATEGORY (CB_VALUE (f->values)) == CB_CATEGORY_NUMERIC) { + cb_tree first_value = get_first_value (f); + if (first_value + && CB_TREE_CATEGORY (first_value) == CB_CATEGORY_NUMERIC) { cb_error_x (CB_TREE (f), _("VALUE item may not be numeric")); } } @@ -2077,7 +2143,8 @@ validate_field_clauses (cb_tree x, struct cb_field *f) } } -/* Perform validation of a non-66-or-88-level elementary item. */ +/* Perform validation of a non-66-or-88-level elementary item. + note: this actually adjusts the field ! */ static unsigned int validate_elementary_item (struct cb_field *f) { @@ -2095,6 +2162,9 @@ validate_elementary_item (struct cb_field *f) if (f->values) { validate_elem_value (f); + if (CB_LIST_P (f->values)) { + ret |= validate_multi_value (f); + } } if (!ret && f->storage == CB_STORAGE_SCREEN) { validate_elem_screen (f); @@ -2344,6 +2414,40 @@ validate_field_1 (struct cb_field *f) validate_redefines (f); } + if (f->storage == CB_STORAGE_REPORT) { + if (f->report_num_col > 1) { + if (f->flag_occurs) { + if (!f->flag_occurs_multi_col) + cb_error_x (CB_TREE (f), _("OCCURS and multi COLUMNs is not allowed")); + } else { + /* FIXME: this is not a "real" validation*/ + f->occurs_max = f->occurs_min = f->report_num_col; + f->flag_occurs = 1; + f->indexes = 1; + } + f->flag_occurs_multi_col = 1; + } + if ((f->report_flag & COB_REPORT_LINE) + && !(f->report_flag & COB_REPORT_LINE_PLUS) + && f->parent + && f->parent->children != f) { + /* check all _previous_ definitions for a LINE clause, + if it is there then drop the LINE clause of this field */ + struct cb_field *c; + for (c = f->parent->children; c && c != f; c = c->sister) { + if ((c->report_flag & COB_REPORT_LINE) + && !(c->report_flag & COB_REPORT_LINE_PLUS) + && c->report_line == f->report_line) { + cb_warning_x (cb_warn_additional, CB_TREE (f), + _("duplicate LINE %d ignored"), f->report_line); + f->report_line = 0; + f->report_flag &= ~COB_REPORT_LINE; + break; + } + } + } + } + if (f->children) { sts = validate_group (f); } else { @@ -2686,19 +2790,6 @@ compute_size (struct cb_field *f) int maxsz; struct cb_field *c0; - if (f->storage == CB_STORAGE_REPORT) { - if (f->report_num_col > 1) { - if (f->flag_occurs) { - if (!f->flag_occurs_multi_col) - cb_error_x (CB_TREE (f), _("OCCURS and multi COLUMNs is not allowed")); - } else { - f->occurs_max = f->occurs_min = f->report_num_col; - f->flag_occurs = 1; - f->indexes = 1; - } - f->flag_occurs_multi_col = 1; - } - } if (f->level == 66) { /* Rename */ if (f->rename_thru) { @@ -2709,22 +2800,6 @@ compute_size (struct cb_field *f) } return f->size; } - if (f->storage == CB_STORAGE_REPORT - && (f->report_flag & COB_REPORT_LINE) - && !(f->report_flag & COB_REPORT_LINE_PLUS) - && f->parent - && f->parent->children != f) { - for (c = f->parent->children; c && c != f; c = c->sister) { - if ((c->report_flag & COB_REPORT_LINE) - && !(c->report_flag & COB_REPORT_LINE_PLUS) - && c->report_line == f->report_line) { - cb_warning_x (cb_warn_additional, CB_TREE (f), - _("duplicate LINE %d ignored"), f->report_line); - f->report_line = 0; - f->report_flag &= ~COB_REPORT_LINE; - } - } - } if (f->children) { /* Groups */ @@ -3087,9 +3162,21 @@ compute_size (struct cb_field *f) return f->size; } +/* validate list of simple VALUEs */ +static int +validate_field_value_list (cb_tree values, struct cb_field* f) +{ + int ret = 0; + for (; values; values = CB_CHAIN (values)) { + ret += validate_move (CB_VALUE (values), CB_TREE (f), 1, NULL); + } + return ret; +} + static int validate_field_value (struct cb_field *f) { + int ret = 0; if (f->values) { if (f->usage != CB_USAGE_CONTROL) { if (f->flag_picture_l) { @@ -3098,7 +3185,22 @@ validate_field_value (struct cb_field *f) _("variable-length PICTURE"), "VALUE"); f->values = NULL; } else { - validate_move (CB_VALUE (f->values), CB_TREE (f), 1, NULL); + cb_tree x = f->values; + if (!CB_LIST_P (x)) { + /* simple, single VALUE */ + ret += validate_move (x, CB_TREE (f), 1, NULL); + } else if (!CB_TAB_VALS_P (CB_VALUE (x))) { + /* list of simple VALUEs */ + ret += validate_field_value_list (x, f); + } else { + /* list of complex entries (table-format) for OCCURS */ + for (; x; x = CB_CHAIN (x)) { + const struct cb_table_values *vals + = CB_TAB_VALS (CB_VALUE (x)); + /* check for the value entry types */ + ret += validate_field_value_list (vals->values, f); + } + } } } else { /* CHECK: possibly add validation according to control type */ @@ -3107,11 +3209,11 @@ validate_field_value (struct cb_field *f) if (f->children) { for (f = f->children; f; f = f->sister) { - validate_field_value (f); + ret += validate_field_value (f); } } - return 0; + return ret; } void @@ -3154,7 +3256,11 @@ cb_validate_field (struct cb_field *f) check_compx (f); } - validate_field_value (f); + if (!f->flag_internal_register) { + /* don't check internal ones, these ought to be fine + and would otherwise be checked on each run of cobc */ + validate_field_value (f); + } if (f->flag_is_global) { struct cb_field *c; #if 0 /* CHECKME: Why should we adjust the field count here? */ @@ -3213,16 +3319,18 @@ cb_validate_78_item (struct cb_field *f, const cob_u32_t no78add) prec = 0; } - if (cb_is_expr (f->values) ) { - f->values = CB_LIST_INIT (cb_evaluate_expr (f->values, prec)); + if (CB_LIST_P (f->values) && cb_is_expr (f->values) ) { + f->values = cb_evaluate_expr (f->values, prec); } x = CB_TREE (f); noadd = no78add; - if (CB_INVALID_TREE (f->values) - || CB_INVALID_TREE(CB_VALUE(f->values))) { + if (CB_INVALID_TREE (f->values)) { level_require_error (x, "VALUE"); noadd = 1; + } else if (CB_LIST_P (f->values) + && CB_INVALID_TREE (CB_VALUE (f->values))) { + noadd = 1; } if (f->pic || f->flag_occurs) { @@ -3547,7 +3655,7 @@ cb_is_figurative_constant (const cb_tree x) || x == cb_norm_high || x == cb_quote || (CB_REFERENCE_P (x) - && CB_REFERENCE (x)->flag_all); + && CB_REFERENCE (x)->flag_all); } int diff --git a/cobc/parser.y b/cobc/parser.y index 41a6108d9..dac8946d5 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -2947,6 +2947,7 @@ set_record_size (cb_tree min, cb_tree max) %token REMOVAL %token RENAMES %token REORG_CRITERIA "REORG-CRITERIA" +%token REPEATED %token REPLACE /* remark: not used here */ %token REPLACING %token REPORT @@ -4729,15 +4730,13 @@ symbolic_constant: user_entry_name _is literal { struct cb_field *f; - cb_tree v; - v = CB_LIST_INIT ($3); - f = CB_FIELD (cb_build_constant ($1, v)); + f = CB_FIELD (cb_build_constant ($1, $3)); f->flag_item_78 = 1; f->flag_constant = 1; f->flag_is_global = 1; f->level = 1; - f->values = v; + f->values = $3; cb_needs_01 = 1; /* Ignore return value */ (void)cb_validate_78_item (f, 0); @@ -7126,7 +7125,7 @@ constant_entry: if (level != 1) { cb_error (_("CONSTANT item not at 01 level")); } else if ($5) { - if (cb_verify(cb_constant_01, "01 CONSTANT")) { + if (cb_verify (cb_constant_01, "01 CONSTANT")) { x = cb_build_constant ($2, $5); CB_FIELD (x)->flag_item_78 = 1; CB_FIELD (x)->flag_constant = 1; @@ -7156,30 +7155,40 @@ constant_entry: ; constant_source: - _as value_item_list + _as constant_expression_list { - $$ = $2; + /* this can be a list containing an arithmetic expression */ + if (CB_LIST_P ($2) && !CB_CHAIN ($2)) { + $$ = CB_VALUE ($2); + } else { + $$ = $2; + } } | FROM WORD { - $$ = CB_LIST_INIT(cb_build_const_from ($2)); + $$ = cb_build_const_from ($2); } ; constant_78_source: constant_expression_list { + /* this can be a list containing an arithmetic expression */ if (CB_VALID_TREE (current_field)) { - current_field->values = $1; + if (CB_LIST_P ($1) && !CB_CHAIN ($1)) { + current_field->values = CB_VALUE ($1); + } else { + current_field->values = $1; + } } } | START _of identifier { - current_field->values = CB_LIST_INIT (cb_build_const_start (current_field, $3)); + current_field->values = cb_build_const_start (current_field, $3); } | NEXT { - current_field->values = CB_LIST_INIT (cb_build_const_next (current_field)); + current_field->values = cb_build_const_next (current_field); } ; @@ -8072,14 +8081,14 @@ occurs_clause: } ; -_occurs_to_integer: +_occurs_from_integer: /* empty */ { $$ = NULL; } -| TO integer { $$ = $2; } +| FROM integer { $$ = $2; } ; -_occurs_from_integer: +_occurs_to_integer: /* empty */ { $$ = NULL; } -| FROM integer { $$ = $2; } +| TO integer { $$ = $2; } ; _occurs_integer_to: @@ -8284,13 +8293,127 @@ based_clause: /* VALUE clause */ value_clause: - value_is_are value_item_list + /* normal format for data items: single VALUE, stored as-is */ + VALUE _is value_item { check_repeated ("VALUE", SYN_CLAUSE_12, &check_pic_duplicate); - current_field->values = $2; + current_field->values = $3; } + /* normal format for data items: single VALUE, stored as-is, + OSVS extension "VALUES ARE"; for now disabled in favor of + BS2000 table-format without FROM +| VALUES _are value_item + { + check_repeated ("VALUE", SYN_CLAUSE_12, &check_pic_duplicate); + current_field->values = $3; + } */ + /* COBOL2002 table-format with mandatory FROM, optional TO */ +| VALUES _are value_table_item_list + { + /* note: "VALUE _is" would also be correct, but we ignore that + because of parser conflicts */ + check_repeated ("VALUE", SYN_CLAUSE_12, &check_pic_duplicate); + current_field->values = $3; + } +/* BS2000 table-format without FROM (implied 1,1,1,1) and optional REPEATED */ +| VALUES _are value_item_list _repeated_phrase + { + /* note: "VALUE _is" would also be correct, but we ignore that + because of parser conflicts */ + cb_tree value_table_item = cb_build_table_values ($3, NULL, NULL, $4); + /* note: this format can actually be specified multiple times, + but we expect the part without FROM first */ + check_repeated ("VALUE", SYN_CLAUSE_12, &check_pic_duplicate); + current_field->values = CB_LIST_INIT (value_table_item); + } +/* BS2000 table-format with FROM and optional REPEATED */ +| VALUES from_subscripts _are value_item_list _repeated_phrase + { + /* note: "VALUE _is" would also be correct, but we ignore that + because of parser conflicts */ + cb_tree value_table_item = cb_build_table_values ($4, $2, NULL, $5); + /* note: this format can actually be specified multiple times */ + if (!current_field->values) { + check_repeated ("VALUE", SYN_CLAUSE_12, &check_pic_duplicate); + current_field->values = CB_LIST_INIT (value_table_item); + } else { + current_field->values = cb_list_add (current_field->values, value_table_item); + } + } +; + +value_table_item_list: + value_table_item { $$ = CB_LIST_INIT ($1); } +| value_table_item_list value_table_item { $$ = cb_list_add ($1, $2); } +; + +value_table_item: +value_item_list from_subscripts _to_subscripts +{ + /* note: actual matching to amount of subs (OCCURS) is + postponed as this phrase can be specified later + and/or in a higher level */ + + cb_tree to_subs = $3; + if (to_subs) { + if (cb_list_length ($2) != cb_list_length (to_subs)) { + cb_error_x (to_subs, _("amount of entries in FROM and TO must match")); + to_subs = NULL; + } else { + cb_tree f = $2, t = to_subs; + while (f) { + int f_idx = cb_get_int (CB_VALUE (f)); + int t_idx = cb_get_int (CB_VALUE (t)); + if (f_idx > t_idx) { + cb_error_x ($2, + _("entry in FROM (%d) must be <= entry in TO (%d)"), + f_idx, t_idx); + break; + } + f = CB_CHAIN (f); + t = CB_CHAIN (t); + } + } + } + $$ = cb_build_table_values ($1, $2, $3, NULL); + } +; + +from_subscripts: + FROM from_to_subscripts { $$ = $2; } ; +_to_subscripts: + /* empty */ { $$ = NULL; } +| TO from_to_subscripts { $$ = $2; } +; + +from_to_subscripts: + TOK_OPEN_PAREN subscripts TOK_CLOSE_PAREN + { + $$ = cb_list_reverse ($2); + } +; + +_repeated_phrase: + /* empty */ { $$ = NULL; } +| REPEATED unsigned_pos_integer _times { $$ = $2; } +| REPEATED _to END { $$ = cb_null; } + +; + +subscripts: + unsigned_pos_integer %prec SHIFT_PREFER + { + $$ = CB_LIST_INIT ($1); + } +| subscripts _e_sep unsigned_pos_integer %prec SHIFT_PREFER + { + $$ = cb_list_add ($1, $3); + } +; + + value_is_are: VALUE _is | VALUES _are @@ -8302,8 +8425,16 @@ value_item_list: ; value_item: - lit_or_length THRU lit_or_length { $$ = CB_BUILD_PAIR ($1, $3); } -| constant_expression + constant_expression +; + + +value_clause_report: + value_is_are value_item_list + { + check_repeated ("VALUE", SYN_CLAUSE_12, &check_pic_duplicate); + current_field->values = $2; + } ; @@ -8316,7 +8447,7 @@ value_clause_condition: ; value_item_list_in_alphabet: - value_item_list + value_item_condition_list /* the following is correct, passes parser, but is matched in places where it shouldn't (record key), therefore disabled for now | value_item_list _in alphabet_name @@ -8327,6 +8458,16 @@ value_item_list_in_alphabet: */ ; +value_item_condition_list: + value_item_condition { $$ = CB_LIST_INIT ($1); } +| value_item_condition_list value_item_condition { $$ = cb_list_add ($1, $2); } +; + +value_item_condition: + lit_or_length THRU lit_or_length { $$ = CB_BUILD_PAIR ($1, $3); } +| constant_expression +; + _false_or_content_validation: /* empty */ @@ -8891,7 +9032,7 @@ report_group_option: | blank_clause | source_clause | sum_clause_list -| value_clause +| value_clause_report | present_when_condition | group_indicate_clause | report_occurs_clause @@ -9732,7 +9873,7 @@ screen_value_clause: cb_error (_("missing %s"), "VALUE"); } check_repeated ("VALUE", SYN_CLAUSE_12, &check_pic_duplicate); - current_field->values = CB_LIST_INIT ($2); + current_field->values = $2; } ; diff --git a/cobc/reserved.c b/cobc/reserved.c index 9a534a798..d285e492b 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -2402,6 +2402,9 @@ static struct cobc_reserved default_reserved_words[] = { { "REORG-CRITERIA", 0, 1, REORG_CRITERIA, /* OS/VS extension */ 0, CB_CS_I_O_CONTROL }, + { "REPEATED", 0, 0, REPEATED, /* BS2000 */ + 0 /* Should be for VALUE only in GC */, 0 + }, { "REPLACE", 0, 0, REPLACE, /* 2002 */ 0, 0 }, diff --git a/cobc/scanner.l b/cobc/scanner.l index 9978afd33..4bbf601ad 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -1107,7 +1107,7 @@ H#[0-9A-Za-z]+ { if (p78->chk_const && p78->not_const) { break; } - x = CB_VALUE (p78->fld_78->values); + x = p78->fld_78->values; if (CB_LITERAL_P (x)) { /* duplicate the constant literal to assign current source location */ diff --git a/cobc/tree.c b/cobc/tree.c index 003948db1..98c11f75f 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -730,6 +730,40 @@ cb_name_1 (char *s, cb_tree x, const int size) break; } + /* LCOV_EXCL_START */ + case CB_TAG_LIST: { + cb_tree l; + size_real = snprintf (s, size, "LIST"); + if (size_real + 4 > size) goto game_over; + s += size_real; + for (l = x; l; l = CB_CHAIN (l)) { + const size_t size_left = size - (s - orig); + char *s_orig = s; + size_t size_element; + size_element = snprintf (s, size_left, (l == x) ? ": " : ", "); + size_element += cb_name_1 (s + size_element, CB_VALUE (l), size_left); + if (size_element > size_left + 4) { + /* if we don't have enough room: go out leaving s unchanged */ + s_orig[0] = '\0'; + goto game_over; + } + size_real += size_element; + s += size_element; + } + sprintf (s, ")"); + size_real++; + break; + } + /* LCOV_EXCL_STOP */ + + /* LCOV_EXCL_START */ + case CB_TAG_TAB_VALS: { + size_real = snprintf (s, size, "VALUE (table-format) "); + size_real += cb_name_1 (s + size_real, CB_TAB_VALS (x)->values, size - size_real); + break; + } + /* LCOV_EXCL_STOP */ + case CB_TAG_INTRINSIC: { const struct cb_intrinsic *cbit = CB_INTRINSIC (x); if (!cbit->isuser) { @@ -2378,6 +2412,10 @@ cb_enum_explain (const enum cb_tag tag) return "ML SUPPRESS CHECKS"; case CB_TAG_CD: return "COMMUNICATION DESCRIPTION"; + case CB_TAG_VARY: + return "REPORT VARYING"; + case CB_TAG_TAB_VALS: + return "VALUE list (table-format)"; default: { /* whenever we get here, someone missed to add to the list above... */ @@ -3413,7 +3451,7 @@ get_number_in_parentheses (const unsigned char ** p, return 1; } - item_value = CB_VALUE (CB_FIELD (item)->values); + item_value = CB_FIELD (item)->values; if (!CB_NUMERIC_LITERAL_P (item_value)) { cb_error (_("'%s' is not a numeric literal"), name_buff); *error_detected = 1; @@ -3934,6 +3972,19 @@ cb_build_vary (cb_tree var, cb_tree from, cb_tree by) return x; } +/* VALUE: multiple entries (table-format) */ + +cb_tree +cb_build_table_values (cb_tree values, cb_tree from, cb_tree to, cb_tree times) +{ + struct cb_table_values *vals + = make_tree (CB_TAG_TAB_VALS, CB_CATEGORY_UNKNOWN, sizeof (struct cb_table_values)); + vals->values = values; + vals->from = from; + vals->to = to; + vals->repeat_times = times; + return CB_TREE (vals); +} /* Field */ cb_tree @@ -3974,7 +4025,7 @@ cb_build_constant (cb_tree name, cb_tree value) x = cb_build_field (name); x->category = cb_tree_category (value); CB_FIELD (x)->storage = CB_STORAGE_CONSTANT; - CB_FIELD (x)->values = CB_LIST_INIT (value); + CB_FIELD (x)->values = value; return x; } @@ -4410,7 +4461,7 @@ add_report_sum (struct cb_report *r, char *buff, int dig, int dec) } s = CB_FIELD (cb_build_field (cb_build_reference (buff))); s->pic = cb_build_picture (pic); - s->values = CB_LIST_INIT (cb_zero); + s->values = cb_zero; s->storage = CB_STORAGE_WORKING; s->usage = CB_USAGE_DISPLAY; s->report = r; diff --git a/cobc/tree.h b/cobc/tree.h index 9fcd793b5..b2590b3c3 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -133,7 +133,8 @@ enum cb_tag { CB_TAG_ML_SUPPRESS, /* JSON/XML GENERATE SUPPRESS clause */ CB_TAG_ML_TREE, /* JSON/XML GENERATE output tree */ CB_TAG_ML_SUPPRESS_CHECKS, /* JSON/XML GENERATE SUPPRESS checks */ - CB_TAG_VARY /* Report line description */ + CB_TAG_VARY, /* Report line description */ + CB_TAG_TAB_VALS /* VALUE entries in table-format */ /* When adding a new entry, please remember to add it to cb_enum_explain in tree.c as well. */ }; @@ -837,6 +838,20 @@ struct cb_vary { #define CB_VARY(x) (CB_TREE_CAST (CB_TAG_VARY, struct cb_vary, x)) #define CB_VARY_P(x) (CB_TREE_TAG (x) == CB_TAG_VARY) +/* multi VALUE entries (table-format) */ + +struct cb_table_values { + struct cb_tree_common common; /* Common values */ + cb_tree values; /* list of literals*/ + cb_tree from; /* NULL or list of subscripts start */ + cb_tree to; /* NULL or list of subscripts stop */ + cb_tree repeat_times; /* NULL or integer to repeat the values, + or cb_null for "repeat to end" */ +}; + +#define CB_TAB_VALS(x) (CB_TREE_CAST (CB_TAG_TAB_VALS, struct cb_table_values, x)) +#define CB_TAB_VALS_P(x) (CB_TREE_TAG (x) == CB_TAG_TAB_VALS) + /* Field */ struct cb_field { @@ -844,7 +859,10 @@ struct cb_field { const char *name; /* Original name */ const char *ename; /* Externalized name */ cb_tree depending; /* OCCURS ... DEPENDING ON */ - cb_tree values; /* VALUE */ + cb_tree values; /* VALUES, in the simple case: direct value; + for level 78 _can_ be a list (expression), + for level 88 and RW be either a list or direct value, + for VALUES ARE (table-format) a list of table_values */ cb_tree false_88; /* 88 FALSE clause */ cb_tree index_list; /* INDEXED BY */ cb_tree external_form_identifier; /* target of IDENTIFIED BY @@ -2019,6 +2037,7 @@ extern struct cb_picture *cb_build_binary_picture (const char *, extern cb_tree cb_build_field (cb_tree); extern cb_tree cb_build_vary (cb_tree, cb_tree, cb_tree); +extern cb_tree cb_build_table_values (cb_tree, cb_tree, cb_tree, cb_tree); extern cb_tree cb_build_implicit_field (cb_tree, const int); extern cb_tree cb_build_constant (cb_tree, cb_tree); extern int cb_build_generic_register (const char *, const char *, struct cb_field **); diff --git a/cobc/typeck.c b/cobc/typeck.c index afff500d3..89efb25bb 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -1918,7 +1918,7 @@ cb_build_generic_register (const char *name, const char *external_definition, } } if (lit) { - field->values = CB_LIST_INIT (lit); + field->values = lit; } } @@ -2006,7 +2006,7 @@ cb_build_register_internal_code (const char* name, const char* definition) field->usage = CB_USAGE_BINARY; field->pic = cb_build_picture ("S9(9)"); cb_validate_field (field); - field->values = CB_LIST_INIT (cb_zero); + field->values = cb_zero; field->flag_no_init = 1; field->flag_is_global = 1; field->flag_internal_register = 1; @@ -2450,17 +2450,12 @@ cb_tree cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by, struct cb_field *qual) { - struct cb_field *f; + struct cb_field *f = CB_FIELD (cb_build_field (x)); - f = CB_FIELD (cb_build_field (x)); f->usage = CB_USAGE_INDEX; cb_validate_field (f); - if (values) { - f->values = CB_LIST_INIT (values); - } - if (qual) { - f->index_qual = qual; - } + f->values = values; + f->index_qual = qual; f->flag_indexed_by = !!indexed_by; if (f->flag_indexed_by) f->flag_real_binary = 1; @@ -2870,7 +2865,7 @@ cb_build_identifier (cb_tree x, const int subchk) } if (f->storage == CB_STORAGE_CONSTANT) { - return CB_VALUE (f->values); + return f->values; } return x; @@ -4712,55 +4707,66 @@ validate_file_status (cb_tree fs) struct cb_field *fs_field; enum cb_category category; + cb_tree x = cb_ref (fs); + /* TO-DO: If not defined, implicitly define PIC XX */ - if (fs == cb_error_node - || cb_ref (fs) == cb_error_node) { + if (x == cb_error_node) { return; } - if (!CB_FIELD_P (cb_ref (fs))) { - cb_error (_("FILE STATUS '%s' is not a field"), CB_NAME (fs)); + if (!CB_FIELD_P (x) + || CB_FIELD (x)->flag_constant) { + cb_error_x (fs, _("FILE STATUS '%s' is not a field"), CB_NAME (fs)); + return; } - fs_field = CB_FIELD_PTR (fs); - category = cb_tree_category (CB_TREE (fs_field)); + fs_field = CB_FIELD (x); + category = cb_tree_category (x); if (category == CB_CATEGORY_ALPHANUMERIC) { /* ok */ } else if (category == CB_CATEGORY_NUMERIC) { if (fs_field->pic && fs_field->pic->scale != 0) { - cb_error_x (fs, _("FILE STATUS '%s' may not be a decimal or have a PIC with a P"), - CB_NAME (fs)); + cb_error_x (fs, + _("FILE STATUS '%s' may not be a decimal or have a PIC with a P"), + fs_field->name); + return; } - cb_warning_x (cb_warn_additional, fs, _("FILE STATUS '%s' is a numeric field, but I-O status codes are not numeric in general"), - CB_NAME (fs)); + cb_warning_x (cb_warn_additional, fs, + _("FILE STATUS '%s' is a numeric field, but I-O status codes are not numeric in general"), + fs_field->name); } else { - cb_error_x (fs, _("FILE STATUS '%s' must be alphanumeric or numeric field"), - CB_NAME (fs)); + cb_error_x (fs, + _("FILE STATUS '%s' must be an alphanumeric or numeric field"), + fs_field->name); return; } if (fs_field->usage != CB_USAGE_DISPLAY) { - cb_error_x (fs, _("FILE STATUS '%s' must be USAGE DISPLAY"), - CB_NAME (fs)); + cb_error_x (fs, + _("FILE STATUS '%s' must be USAGE DISPLAY"), + fs_field->name); } /* Check file status is two characters long */ if (fs_field->size != 2) { - cb_error_x (fs, _("FILE STATUS '%s' must be 2 characters long"), - CB_NAME (fs)); + cb_error_x (fs, + _("FILE STATUS '%s' must be 2 characters long"), + fs_field->name); } if (fs_field->storage != CB_STORAGE_WORKING - && fs_field->storage != CB_STORAGE_LOCAL - && fs_field->storage != CB_STORAGE_LINKAGE) { - cb_error_x (fs, _("FILE STATUS '%s' must be in WORKING-STORAGE, LOCAL-STORAGE or LINKAGE"), - CB_NAME (fs)); + && fs_field->storage != CB_STORAGE_LOCAL + && fs_field->storage != CB_STORAGE_LINKAGE) { + cb_error_x (fs, + _("FILE STATUS '%s' must be in WORKING-STORAGE, LOCAL-STORAGE or LINKAGE"), + fs_field->name); } if (fs_field->flag_odo_relative) { - cb_error_x (fs, _("FILE STATUS '%s' may not be located after an OCCURS DEPENDING field"), - CB_NAME (fs)); + cb_error_x (fs, + _("FILE STATUS '%s' may not be located after an OCCURS DEPENDING field"), + fs_field->name); } } @@ -4850,7 +4856,7 @@ validate_assign_name (struct cb_file * const f, /* If assign is a 78-level, change assign to the 78-level's literal. */ p = check_level_78 (CB_NAME (assign)); if (p) { - char *c = (char *)CB_LITERAL(CB_VALUE(p->values))->data; + char *c = (char *)CB_LITERAL (p->values)->data; assign = CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, c, strlen (c))); f->assign = assign; return; diff --git a/tests/testsuite.src/run_initialize.at b/tests/testsuite.src/run_initialize.at index ea749f051..c76e6b687 100644 --- a/tests/testsuite.src/run_initialize.at +++ b/tests/testsuite.src/run_initialize.at @@ -290,7 +290,6 @@ AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. ]) AT_CHECK([$COMPILE prog.cob], [0], [], []) -#AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [All INITIALIZE tests passed. ], []) @@ -637,17 +636,17 @@ AT_DATA([prog.cob], [ 05 GRP1 OCCURS 3 TIMES. 10 GRPX PIC X(99). 05 MONTH-IN-YEAR OCCURS 13 TIMES PICTURE X(3) - VALUE "jan" "feb" "mar" "apr" + VALUES "jan" "feb" "mar" "apr" "may" "jun" "jul" "aug" "sep" "oct" "nov" "dec". 05 DAYS-IN-MONTH OCCURS 13 TIMES PICTURE 9(2) BINARY - VALUE 31 28 31 30 31 30 31 31 30 31 30 31. + VALUES 31 28 31 30 31 30 31 31 30 31 30 31. 05 DAYS-MONTHS OCCURS 2 TIMES. 06 DAYX-MONTHX OCCURS 4 TIMES. 07 DAY-MONTH OCCURS 3 TIMES. 10 XXX1 PICTURE X VALUE " ". 10 MONTHS PICTURE X(3) - VALUE "Jan" "Feb" "Mar" "Apr" + VALUES "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" "JAN" "FEB" "MAR" "APR" @@ -655,11 +654,11 @@ AT_DATA([prog.cob], [ "SEP" "OCT" "NOV" "DEC". 10 SEPX PICTURE XX VALUE ", ". 10 DAYS PICTURE 99 - VALUE 31 28 31 30 31 30 31 31 30 31 30 31 + VALUES 31 28 31 30 31 30 31 31 30 31 30 31 91 28 91 90 91 90 91 91 90 91 90 91. 10 PER PICTURE X VALUE ".". - 07 FLR PICTURE X(4) VALUE " " " " " " " " - " " " " " " " <*>". + 07 FLR PICTURE X(4) VALUES " " " " " " " " + " " " " " " " <*>". PROCEDURE DIVISION. diff --git a/tests/testsuite.src/run_reportwriter.at b/tests/testsuite.src/run_reportwriter.at index 44e3a0f20..1c0aacaf6 100644 --- a/tests/testsuite.src/run_reportwriter.at +++ b/tests/testsuite.src/run_reportwriter.at @@ -10299,7 +10299,7 @@ AT_DATA([prog.cob], [ MOVE "WAG2" TO TAG2 (1), TAG2 (2), TAG2 (3). ]) -AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COMPILE -save-temp prog.cob], [0], [], []) AT_CHECK([export PRINTOUT=tstrwv.txt $COBCRUN_DIRECT ./prog], [0], diff --git a/tests/testsuite.src/syn_file.at b/tests/testsuite.src/syn_file.at index 7176a15f3..ece36696d 100644 --- a/tests/testsuite.src/syn_file.at +++ b/tests/testsuite.src/syn_file.at @@ -1541,17 +1541,15 @@ AT_CHECK([$COMPILE_ONLY -fodoslide prog.cob], [1], [], prog.cob:18: error: 'non-existent' is not defined prog.cob:9: warning: FILE STATUS 'gs' is a numeric field, but I-O status codes are not numeric in general prog.cob:10: error: FILE STATUS 'hs' must be in WORKING-STORAGE, LOCAL-STORAGE or LINKAGE -prog.cob:11: error: FILE STATUS 'js' must be alphanumeric or numeric field +prog.cob:11: error: FILE STATUS 'js' must be an alphanumeric or numeric field prog.cob:12: warning: FILE STATUS 'ks' is a numeric field, but I-O status codes are not numeric in general prog.cob:12: error: FILE STATUS 'ks' must be USAGE DISPLAY prog.cob:13: error: FILE STATUS 'ls' may not be a decimal or have a PIC with a P -prog.cob:13: warning: FILE STATUS 'ls' is a numeric field, but I-O status codes are not numeric in general prog.cob:14: error: FILE STATUS 'ms' may not be a decimal or have a PIC with a P -prog.cob:14: warning: FILE STATUS 'ms' is a numeric field, but I-O status codes are not numeric in general prog.cob:15: error: FILE STATUS 'ns' must be 2 characters long prog.cob:16: error: FILE STATUS 'os' may not be located after an OCCURS DEPENDING field -prog.cob:17: error: FILE STATUS 'ps' must be alphanumeric or numeric field -prog.cob:19: error: FILE STATUS 'rs' must be alphanumeric or numeric field +prog.cob:17: error: FILE STATUS 'ps' must be an alphanumeric or numeric field +prog.cob:19: error: FILE STATUS 'rs' is not a field ]) AT_CLEANUP diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 90f884ac6..89c72c282 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -8469,35 +8469,35 @@ AT_CLEANUP AT_SETUP([OCCURS too many VALUEs]) -AT_KEYWORDS([Initialize]) +AT_KEYWORDS([initialize VALUE]) AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. + IDENTIFICATION DIVISION. PROGRAM-ID. prog. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - DATA DIVISION. - WORKING-STORAGE SECTION. - - 01 WS. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + DATA DIVISION. + WORKING-STORAGE SECTION. + + 01 WS. 05 IX1 PIC 99. 05 IX2 PIC 99. 05 IX3 PIC 99. 05 GRP1 OCCURS 3 TIMES. 10 GRPX PIC X(99). 05 MONTH-IN-YEAR OCCURS 13 TIMES PICTURE X(3) - VALUE "jan" "feb" "mar" "apr" + VALUES "jan" "feb" "mar" "apr" "may" "jun" "jul" "aug" - "sep" "oct" "nov" "dec" + "sep" "oct" "nov" "dec" "Hi" "Bye" "Dog". - 05 DAYS-IN-MONTH OCCURS 13 TIMES PICTURE 9(2) BINARY - VALUE 31 28 31 30 31 30 31 31 30 31 30 31. + 05 DAYS-IN-MONTH OCCURS 13 TIMES PICTURE 9(2) BINARY + VALUES 31 28 31 30 31 30 31 31 30 31 30 31. 05 DAYS-MONTHS OCCURS 2 TIMES. 06 DAYX-MONTHX OCCURS 4 TIMES. 07 DAY-MONTH OCCURS 3 TIMES. 10 XXX1 PICTURE X VALUE " ". 10 MONTHS PICTURE X(3) - VALUE "Jan" "Feb" "Mar" "Apr" + VALUES "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" "JAN" "FEB" "MAR" "APR" @@ -8505,38 +8505,37 @@ AT_DATA([prog.cob], [ "SEP" "OCT" "NOV" "DEC" "Bye". 10 SEPX PICTURE XX VALUE ", ". 10 DAYS PICTURE 99 - VALUE 31 28 31 30 31 30 31 31 30 31 30 31 + VALUES 31 28 31 30 31 30 31 31 30 31 30 31 91 28 91 90 91 90 91 91 90 91 90 91. 10 PER PICTURE X VALUE ".". - 07 FLR PICTURE X(4) VALUE " " " " " " " " + 07 FLR PICTURE X(4) VALUES " " " " " " " " " " " " " " " " " <*>". - + PROCEDURE DIVISION. - - INIT-RTN. + + INIT-RTN. DISPLAY "Simple OCCURS with multi VALUES". PERFORM VARYING IX1 FROM 1 BY 1 UNTIL IX1 > 13 DISPLAY IX1 ": " - MONTH-IN-YEAR (IX1) " has " + MONTH-IN-YEAR (IX1) " has " DAYS-IN-MONTH (IX1) " days" END-DISPLAY END-PERFORM. DISPLAY "Complex OCCURS with multi VALUES". PERFORM VARYING IX3 FROM 1 BY 1 UNTIL IX3 > 2 PERFORM VARYING IX2 FROM 1 BY 1 UNTIL IX2 > 4 - DISPLAY IX3 "-" IX2 ": " - DAYX-MONTHX (IX3, IX2) + DISPLAY IX3 "-" IX2 ": " + DAYX-MONTHX (IX3, IX2) END-DISPLAY END-PERFORM END-PERFORM. STOP RUN. ]) -# FIXME: errors currently only with full compilation -AT_CHECK([$COMPILE prog.cob], [1], [], -[prog.cob:15: error: MONTH-IN-YEAR has 2 more values than needed -prog.cob:26: error: MONTHS has 1 more value than needed -prog.cob:38: error: FLR has 1 more value than needed +AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +[prog.cob:15: error: elements in VALUE clause for 'MONTH-IN-YEAR' (15) exceed max amount (13) +prog.cob:26: error: elements in VALUE clause for 'MONTHS' (25) exceed max amount (24) +prog.cob:38: error: elements in VALUE clause for 'FLR' (9) exceed max amount (8) ]) AT_CLEANUP