From 330a1c74a6a94133e61f0def88beac068c8095f5 Mon Sep 17 00:00:00 2001 From: David Declerck Date: Wed, 20 Nov 2024 15:50:19 +0100 Subject: [PATCH] Merge SVN 5065, 5066 --- cobc/ChangeLog | 19 +++ cobc/cobc.c | 4 +- cobc/field.c | 177 ++++++++++++++------ cobc/parser.y | 13 +- cobc/tree.c | 37 +++-- cobc/tree.h | 3 + cobc/typeck.c | 177 ++++++++++---------- tests/testsuite.src/listings.at | 66 +++----- tests/testsuite.src/syn_definition.at | 41 ++--- tests/testsuite.src/syn_misc.at | 226 +++++++++++++------------- tests/testsuite.src/syn_occurs.at | 22 ++- 11 files changed, 452 insertions(+), 333 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 7968351dc..897d353c4 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -64,6 +64,25 @@ * cobc.c: disable unreached code removement with -O0, but keep it unchanged for -g + * field.c (validate_field_1): moved check for duplicate report LINE and + "OCCURS with multi COLUMNs" here, originally found in (compute_size) + * field.c (get_max_int_val): new function to get the highest algebraic + integer value + * field.c (compute_size): limit internal computed maximum for UNBOUNDED + item to the maximum value that can be stored in its DEPENDING on item + * field.c (compute_size): set items that are too big to a fixed value + to return eraly on follow-up checks + * field.c (compute_size): disabled check for missing PIC for NATIONAL + and BCD USAGE + * tree.c (cb_field_variable_address), tree.h: disabled unused function + * tree.c (cb_field_has_unbounded), tree.h: new function checking both + field and any of the child elements to be UNBOUNDED + * typeck.c (cb_validate_program_data): validate DEPENDING ON to be numeric + * typeck.c (cb_build_identifier): skip compile-time checks for ref-mod + on UNBOUNDED items as size is not known + * parser.y (occurs_clause): don't set flag_unbounded in parent + * cobc.c (print_fields): don't output (wrong) size for group items with + OCCURS UNBOUNDED sub-fields 2023-05-23 Simon Sobisch diff --git a/cobc/cobc.c b/cobc/cobc.c index 53266c707..d2d2f82b7 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -5664,7 +5664,7 @@ print_fields (struct cb_field *top, int *found) /* group never has a PICTURE ... */ got_picture = 0; } else { - /* ...stilll output definitions for TYPEDEF / SAME AS */ + /* ...still output definitions for TYPEDEF / SAME AS */ got_picture = set_picture (top, picture, picture_len); } } else { @@ -5675,7 +5675,7 @@ print_fields (struct cb_field *top, int *found) got_picture = set_picture (top, picture, picture_len); } - if (top->flag_any_length || top->flag_unbounded) { + if (top->flag_any_length || cb_field_has_unbounded (top)) { pd_off = sprintf (print_data, "????? "); } else if (top->flag_occurs && !got_picture) { pd_off = sprintf (print_data, "%05d ", top->size * top->occurs_max); diff --git a/cobc/field.c b/cobc/field.c index 26765e7a1..0957f2eef 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -1245,15 +1245,17 @@ validate_any_length_item (struct cb_field *f) cb_error_x (x, _("'%s' ANY LENGTH cannot be BASED/EXTERNAL"), cb_name (x)); return 1; } - if (f->flag_occurs || f->depending || - f->children || f->values || f->flag_blank_zero) { + if (f->flag_occurs || f->depending || f->children || f->values || f->flag_blank_zero) { cb_error_x (x, _("'%s' ANY LENGTH has invalid definition"), cb_name (x)); return 1; } if (!f->pic) { const char *pic = f->flag_any_numeric ? "9" : "X"; f->pic = cb_build_picture (pic); - } else if (f->flag_any_numeric) { + return 0; + } + + if (f->flag_any_numeric) { if (f->pic->category != CB_CATEGORY_NUMERIC) { cb_error_x (x, _("'%s' ANY NUMERIC must be PIC 9"), f->name); @@ -1265,7 +1267,7 @@ validate_any_length_item (struct cb_field *f) f->name); } /* - TO-DO: Replace pic->category check with f->usage == CB_USAGE_NATIONAL. + TODO: Replace pic->category check with f->usage == CB_USAGE_NATIONAL. Currently NATIONAL items are marked as having USAGE DISPLAY. */ if (!((f->pic->size == 1 && f->usage == CB_USAGE_DISPLAY) @@ -1332,7 +1334,8 @@ validate_occurs (const struct cb_field * const f) /* Validate OCCURS DEPENDING */ if (f->depending) { - /* Cache field for later checking */ + /* Cache field for later checking as the depending field may not be + available until the program is completely parsed */ cb_depend_check = cb_list_add (cb_depend_check, x); if (!cb_odoslide && !cb_complex_odo) { @@ -1380,8 +1383,8 @@ validate_redefines (const struct cb_field * const f) } /* Check variable occurrence */ - if (f->depending || - (!f->flag_picture_l && cb_field_variable_size (f))) { + if (f->depending + || (!f->flag_picture_l && cb_field_variable_size (f))) { cb_error_x (x, _("'%s' cannot be variable length"), f->name); } if (!f->redefines->flag_picture_l && cb_field_variable_size (f->redefines)) { @@ -1686,7 +1689,7 @@ validate_justified_right (const struct cb_field * const f) { const cb_tree x = CB_TREE (f); - /* TO-DO: Error if no PIC? */ + /* TODO: Error if no PIC? */ if (f->flag_justified && f->pic @@ -1775,7 +1778,7 @@ validate_multi_value (const struct cb_field * const f) total_occurs = 1; do { if (p->flag_occurs - && p->occurs_max > 1) { + && p->occurs_max > 1) { total_occurs *= p->occurs_max; } p = p->parent; @@ -1889,11 +1892,11 @@ warn_from_to_using_without_pic (const struct cb_field * const f) if ((f->screen_from || f->screen_to) && !f->pic) { const cb_tree x = CB_TREE (f); - /* TO-DO: Change to dialect option */ + /* TODO: Change to dialect option */ cb_warning_x (cb_warn_additional, x, _("'%s' has FROM, TO or USING without PIC; PIC will be implied"), cb_name (x)); - /* TO-DO: Add setting of PIC below here or move warnings to the code which sets the PIC */ + /* TODO: Add setting of PIC below here or move warnings to the code which sets the PIC */ return 1; } else { return 0; @@ -1906,11 +1909,11 @@ warn_pic_for_numeric_value_implied (const struct cb_field * const f) 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 */ + /* TODO: Change to dialect option */ cb_warning_x (cb_warn_additional, x, _("'%s' has numeric VALUE without PIC; PIC will be implied"), cb_name (x)); - /* TO-DO: Add setting of PIC below here or move warnings to the code which sets the PIC */ + /* TODO: Add setting of PIC below here or move warnings to the code which sets the PIC */ return 1; } else { return 0; @@ -1945,7 +1948,7 @@ error_pic_for_numeric_value (const struct cb_field * const f) static void error_from_to_using_without_pic (const struct cb_field * const f) { - /* TO-DO: Replace warning, like in validate_elem_screen_clauses_std? */ + /* TODO: Replace warning, like in validate_elem_screen_clauses_std? */ if ((f->screen_from || f->screen_to) && !f->pic) { cb_error_x (CB_TREE (f), _("cannot have FROM, TO or USING without PIC")); } @@ -1987,7 +1990,7 @@ validate_elem_screen_clauses_std (struct cb_field * const f) cb_error_x (x, _("'%s' cannot have PIC without FROM, TO, USING or numeric VALUE"), cb_name (x)); } else if (f->values) { - /* TO-DO: Add setting of PIC below here or move warnings to the code which sets the PIC */ + /* TODO: Add setting of PIC below here or move warnings to the code which sets the PIC */ error_pic_for_numeric_value (f); } else if (f->screen_from || f->screen_to) { error_from_to_using_without_pic (f); @@ -2213,7 +2216,7 @@ validate_elementary_item (struct cb_field *f) /* Validate PICTURE */ ret |= validate_pic (f); - /* TO-DO: This is not validation and should be elsewhere. */ + /* TODO: This is not validation and should be elsewhere. */ switch (f->usage) { case CB_USAGE_DISPLAY: if (current_program @@ -2274,7 +2277,7 @@ validate_elementary_item (struct cb_field *f) break; } - /* TO-DO: Also move, this is not validation */ + /* TODO: Also move, this is not validation */ if (f->flag_blank_zero && f->pic && f->pic->category == CB_CATEGORY_NUMERIC) { @@ -2410,10 +2413,6 @@ validate_field_1 (struct cb_field *f) return 1; } - if (f->flag_any_length) { - return validate_any_length_item (f); - } - x = CB_TREE (f); if (f->level == 77) { if (f->storage != CB_STORAGE_WORKING @@ -2423,6 +2422,10 @@ validate_field_1 (struct cb_field *f) } } + if (f->flag_any_length) { + return validate_any_length_item (f); + } + if (f->flag_external) { validate_external (f); } else @@ -2431,7 +2434,7 @@ validate_field_1 (struct cb_field *f) } if (f->flag_occurs) { - /* TO-DO: Not validation, so should not be in this function! */ + /* TODO: Not validation, so should not be in this function! */ cb_tree l; for (l = f->index_list; l; l = CB_CHAIN (l)) { CB_FIELD_PTR (CB_VALUE (l))->flag_is_global = f->flag_is_global; @@ -2440,7 +2443,6 @@ validate_field_1 (struct cb_field *f) validate_occurs (f); } - if (f->level == 66) { /* no check for redefines here */ return 0; @@ -2817,32 +2819,82 @@ get_last_child (struct cb_field *f) return f; } +/* get highest numeric integer value that may be stored in field 'f', + everything after the decimal point is stripped, non-numeric and float + data return 0 */ static int -compute_size (struct cb_field *f) +get_max_int_val (struct cb_field *f) { - struct cb_field *c; - int size = 0; - cob_s64_t size_check = 0; - int align_size; - int pad; - int unbounded_items = 0; - int unbounded_parts = 1; + int max_val; - int maxsz; - struct cb_field *c0; + switch (f->usage) { + case CB_USAGE_BINARY: + case CB_USAGE_COMP_5: + case CB_USAGE_COMP_X: + case CB_USAGE_COMP_N: + case CB_USAGE_INDEX: + if (f->flag_real_binary || !cb_binary_truncate) { + max_val = f->size * 8; + if (f->pic->have_sign) { + max_val--; + } + max_val = cob_s32_pow (2, max_val); + break; + } + /* Fall-through */ + case CB_USAGE_DISPLAY: + if (CB_TREE_CATEGORY (f) != CB_CATEGORY_NUMERIC + && CB_TREE_CATEGORY (f) != CB_CATEGORY_NUMERIC_EDITED) { + return 0; + } + /* Fall-through */ + case CB_USAGE_PACKED: + case CB_USAGE_COMP_6: + max_val = cob_s32_pow (10, f->pic->digits) - 1; + break; + default: + return 0; + } - if (f->level == 66) { - /* Rename */ + if (f->pic->scale > 0) { + return max_val / cob_s32_pow (10, f->pic->scale); + } + if (f->pic->scale < 0) { + return max_val * cob_s32_pow (10, -f->pic->scale); + } + return max_val; +} + +/* computes this field's and its children's size and offset */ +static int +compute_size (struct cb_field *f) +{ + if (f->level == 66) { /* RENAMES */ if (f->rename_thru) { - f->size = f->rename_thru->offset + f->rename_thru->size - - f->redefines->offset; - } else { + f->size = f->rename_thru->offset + + f->rename_thru->size - f->redefines->offset; + } else if (f->redefines) { f->size = f->redefines->size; + } else { + f->size = 1; /* error case: invalid REDEFINES */ } return f->size; } + /* early exit if we're already calculated as "too big" */ + if (f->size == COB_MAX_FIELD_SIZE + 1) { + return f->size; + } + if (f->children) { + cob_s64_t size_check = 0; + int align_size; + int pad; + int unbounded_items = 0; + int unbounded_parts = 1; + + struct cb_field *c; + /* Groups */ if (f->flag_synchronized) { /* TODO: handle this "per dialect", some disallow this (per ANSI85) or ignore it */ @@ -2862,7 +2914,8 @@ compute_size (struct cb_field *f) && c->size * c->occurs_max > c->redefines->size * c->redefines->occurs_max) { if (cb_verify_x (CB_TREE (c), cb_larger_redefines, _("larger REDEFINES"))) { - maxsz = c->redefines->size * c->redefines->occurs_max; + struct cb_field *c0; + int maxsz = c->redefines->size * c->redefines->occurs_max; for (c0 = c->redefines->sister; c0 != c; c0 = c0->sister) { if (c0->size * c0->occurs_max > maxsz) { maxsz = c0->size * c0->occurs_max; @@ -2883,8 +2936,15 @@ compute_size (struct cb_field *f) c->offset = f->offset + (int) size_check; compute_size (c); if (c->flag_unbounded) { + const int max_odo_value = get_max_int_val (CB_FIELD_PTR (c->depending)); unbounded_items++; + /* computed MAX */ c->occurs_max = (COB_MAX_UNBOUNDED_SIZE / c->size / unbounded_parts) - 1; + /* maximum from ODO field */ + if (max_odo_value != 0 + && max_odo_value < c->occurs_max) { + c->occurs_max = max_odo_value; + } } size_check += (cob_s64_t)c->size * c->occurs_max; @@ -2931,7 +2991,7 @@ compute_size (struct cb_field *f) case CB_USAGE_FP_BIN128: case CB_USAGE_FP_DEC64: case CB_USAGE_FP_DEC128: - if (c->size == 2 + if (c->size == 2 || c->size == 4 || c->size == 8 || c->size == 16) { @@ -2993,7 +3053,7 @@ compute_size (struct cb_field *f) if (f->storage != CB_STORAGE_REPORT) get_last_child (f)->offset += pad; } else { - /* ToDo: add appropriate message (untranslated) */ + /* TODO: add appropriate message (untranslated) */ COBC_ABORT (); /* LCOV_EXCL_LINE */ } } @@ -3012,6 +3072,7 @@ compute_size (struct cb_field *f) cb_error_x (CB_TREE (f), _("'%s' cannot be larger than %d bytes"), f->name, COB_MAX_FIELD_SIZE); + size_check = COB_MAX_FIELD_SIZE + 1; } if (size_check <= INT_MAX) { f->size = (int) size_check; @@ -3019,6 +3080,7 @@ compute_size (struct cb_field *f) f->size = INT_MAX; } } else if (!f->flag_is_external_form) { + int size = 0; /* Elementary item */ switch (f->usage) { @@ -3070,9 +3132,15 @@ compute_size (struct cb_field *f) } compute_binary_size (f, size); break; + case CB_USAGE_ERROR: + /* Fall-through */ case CB_USAGE_DISPLAY: - if (f->pic == NULL) + if (f->pic == NULL) { + /* should only happen for fields where we already raised + an error and could not create an implied PICTURE eitehr */ + f->size = 1; break; + } /* boolean items without USAGE BIT */ if (f->pic->category == CB_CATEGORY_BOOLEAN) { f->size = f->pic->size / 8; @@ -3082,28 +3150,39 @@ compute_size (struct cb_field *f) break; } f->size = f->pic->size; + if (f->pic->have_sign && f->flag_sign_separate) { + f->size++; + } /* note: size check for single items > INT_MAX done in tree.c */ if (f->size > COB_MAX_FIELD_SIZE) { cb_error_x (CB_TREE (f), _("'%s' cannot be larger than %d bytes"), f->name, COB_MAX_FIELD_SIZE); - } - if (f->pic->have_sign && f->flag_sign_separate) { - f->size++; + f->size = COB_MAX_FIELD_SIZE + 1; } break; case CB_USAGE_NATIONAL: - if (f->pic != NULL) - f->size = f->pic->size * COB_NATIONAL_SIZE; +#if 0 /* should be always available here */ + if (f->pic == NULL) { + break; + } +#endif + f->size = f->pic->size * COB_NATIONAL_SIZE; break; case CB_USAGE_PACKED: - if (f->pic == NULL) +#if 0 /* should be always available here */ + if (f->pic == NULL) { break; + } +#endif f->size = f->pic->size / 2 + 1; break; case CB_USAGE_COMP_6: - if (f->pic == NULL) +#if 0 /* should be always available here */ + if (f->pic == NULL) { break; + } +#endif f->size = (f->pic->size + 1) / 2; break; case CB_USAGE_INDEX: diff --git a/cobc/parser.y b/cobc/parser.y index bdb396b7e..cc0cc4e03 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -798,7 +798,7 @@ setup_occurs_min_max (cb_tree occurs_min, cb_tree occurs_max) if (cb_syntax_check (_("TO phrase without DEPENDING phrase"))) { cb_note (COBC_WARN_FILLER, 0, _("maximum number of occurrences assumed to be exact number")); - current_field->occurs_min = 1; /* CHECKME: why using 1 ? */ + current_field->occurs_min = 1; /* as done by IBM + MF */ } } if (current_field->occurs_max <= current_field->occurs_min) { @@ -809,7 +809,7 @@ setup_occurs_min_max (cb_tree occurs_min, cb_tree occurs_max) current_field->occurs_max = 0; /* UNBOUNDED */ } } else { - current_field->occurs_min = 1; /* CHECKME: why using 1 ? */ + current_field->occurs_min = 1; /* as done by IBM + MF */ current_field->occurs_max = cb_get_int (occurs_min); if (current_field->depending) { cb_verify (cb_odo_without_to, _("OCCURS DEPENDING ON without TO phrase")); @@ -952,7 +952,7 @@ check_headers_present (const cob_flags_t lev1, const cob_flags_t lev2, } /* - TO-DO: Refactor header checks - have several header_checks: division_header, + TODO: Refactor header checks - have several header_checks: division_header, section_header, paragraph_header, sentence_type */ static void @@ -6900,7 +6900,7 @@ communication_description_entry: current_program->cd_list); } else { current_cd = NULL; - /* TO-DO: Is this necessary? */ + /* TODO: Is this necessary? */ if (current_program->cd_list) { current_program->cd_list = CB_CHAIN (current_program->cd_list); @@ -8375,9 +8375,12 @@ occurs_clause: DEPENDING _on reference _occurs_keys_and_indexed { current_field->flag_unbounded = 1; +#if 0 /* Why should we do this? If this is relevant then it likely needs to be done + either to the field founder or to the complete list of parents up to it. */ if (current_field->parent) { current_field->parent->flag_unbounded = 1; } +#endif current_field->depending = $7; /* most of the field attributes are set when parsing the phrases */; setup_occurs (); @@ -17148,7 +17151,7 @@ use_file_exception: current_section->flag_declarative_exit = 1; current_section->flag_real_label = 1; current_section->flag_skip_label = 0; - /* TO-DO: Use cobc_ec_turn? */ + /* TODO: Use cobc_ec_turn? */ CB_EXCEPTION_ENABLE (COB_EC_I_O) = 1; if (use_global_ind) { current_section->flag_global = 1; diff --git a/cobc/tree.c b/cobc/tree.c index 84b8e07c9..b8a190099 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -1224,8 +1224,8 @@ get_suppress_cond (cb_tree record, enum cb_ml_type type, cb_tree suppress_cond = NULL; if (!record) { - /* TO-DO: Output check that all child elements are suppressed */ - /* TO-DO: Move this check to the callee? */ + /* TODO: Output check that all child elements are suppressed */ + /* TODO: Move this check to the callee? */ return NULL; } @@ -1610,6 +1610,17 @@ cb_tree_type (const cb_tree x, const struct cb_field *f) #endif } +/* check if field or any of the child elements has UNBOUNDED */ +int +cb_field_has_unbounded (struct cb_field *f) +{ + if (f->flag_unbounded) { + return 1; + } + f = cb_field_variable_size (f); + return (f && f->flag_unbounded); +} + int cb_fits_int (const cb_tree x) { @@ -3062,7 +3073,7 @@ char_to_precedence_idx (const cob_pic_symbol *str, return 1; } - /* To-do: Allow floating-point PICTURE strings */ + /* TODO: Allow floating-point PICTURE strings */ /* case '+': */ /* Exponent symbol */ /* return 3; */ @@ -4378,26 +4389,26 @@ cb_field_variable_size (const struct cb_field *f) return NULL; } +#if 0 /* unused */ +/* check if field 'f' has a variable address (one of the fields + before the current one has a DEPENDING ON) */ unsigned int -cb_field_variable_address (const struct cb_field *fld) +cb_field_variable_address (const struct cb_field *f) { - const struct cb_field *p; - const struct cb_field *f; - - f = fld; + const struct cb_field *p; for (p = f->parent; p; f = f->parent, p = f->parent) { for (p = p->children; p != f; p = p->sister) { - if (p->depending || - (!p->flag_picture_l && cb_field_variable_size (p))) { + if (p->depending + || (!p->flag_picture_l && cb_field_variable_size (p))) { return 1; } } } return 0; } +#endif -/* Check if field 'pfld' is subordinate to field 'f' */ - +/* check if field 'pfld' is subordinate to field 'f' */ int cb_field_subordinate (const struct cb_field *pfld, const struct cb_field *f) { @@ -5428,7 +5439,7 @@ cb_finalize_cd (struct cb_cd *cd, struct cb_field *records) } for (p = records; p; p = p->sister) { - /* TO-DO: Check record size is exactly 87 chars */ + /* TODO: Check record size is exactly 87 chars */ p->cd = cd; if (p != cd->record) { diff --git a/cobc/tree.h b/cobc/tree.h index 6a50a3b01..d3158294e 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2102,6 +2102,7 @@ extern int cb_tree_type (const cb_tree, const struct cb_field *); extern int cb_category_is_alpha (cb_tree); extern int cb_category_is_national (cb_tree); +extern int cb_field_has_unbounded (struct cb_field *); extern int cb_fits_int (const cb_tree); extern int cb_fits_long_long (const cb_tree); extern int cb_get_int (const cb_tree); @@ -2166,7 +2167,9 @@ extern int cb_field_size (const cb_tree x); #define FIELD_SIZE_UNKNOWN -1 extern struct cb_field *cb_field_founder (const struct cb_field * const); extern struct cb_field *cb_field_variable_size (const struct cb_field *); +#if 0 /* unused */ extern unsigned int cb_field_variable_address (const struct cb_field *); +#endif extern int cb_field_subordinate (const struct cb_field *, const struct cb_field *); diff --git a/cobc/typeck.c b/cobc/typeck.c index b4a6f7525..e05b8c220 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2770,19 +2770,27 @@ cb_build_identifier (cb_tree x, const int subchk) } } #endif - if (f->usage == CB_USAGE_NATIONAL ) { - pseudosize = f->size / 2; - } else if (f->pic && f->pic->orig && f->pic->orig[0] == 'U') { - pseudosize = f->size / 4; + if (f->flag_any_length) { + pseudosize = 0 - f->size; } else { - pseudosize = f->size; + if (f->usage == CB_USAGE_NATIONAL) { + pseudosize = f->size / 2; + } else if (f->pic && f->pic->orig && f->pic->orig[0] == 'U') { + pseudosize = f->size / 4; + } else { + /* note: child elements under UNBOUNDED are not included! */ + pseudosize = f->size; + } + if (cb_field_has_unbounded (f)) { + pseudosize *= -1; + } } if (r->offset) { /* Compile-time check */ if (CB_LITERAL_P (r->offset) && !cb_is_field_unbounded (f)) { offset = cb_get_int (r->offset); - if (f->flag_any_length) { + if (pseudosize < 0) { if (offset < 1) { cb_error_x (x, _("offset must be greater than zero")); } else if (r->length && CB_LITERAL_P (r->length)) { @@ -2827,7 +2835,7 @@ cb_build_identifier (cb_tree x, const int subchk) /* FIXME: needs to be supported for zero length literals */ if (length < 1) { cb_error_x (x, _("length must be greater than zero")); - } else if (!f->flag_any_length && length > pseudosize) { + } else if (pseudosize > 0 && pseudosize <= length) { if (cb_reference_bounds_check == CB_WARNING) { cb_warning_x (cb_warn_additional, x, _("length of '%s' out of bounds: %d"), name, length); @@ -2871,8 +2879,10 @@ cb_build_identifier (cb_tree x, const int subchk) temp /* field is variable size */ ? cb_build_cast_int (temp) : f->flag_any_length ? - CB_BUILD_CAST_LENGTH (v) : - cb_int (pseudosize), + CB_BUILD_CAST_LENGTH (v) /* known via field.size */ : + pseudosize < 0 ? + CB_BUILD_CAST_LENGTH (x) /* needs to be runtime-calculated */ : + cb_int (pseudosize), cb_build_cast_int (r->offset), r->length ? cb_build_cast_int (r->length) : @@ -2963,11 +2973,11 @@ cb_build_const_length (cb_tree x) cb_error (_("reference modification not allowed here")); return cb_error_node; } - } else if (!CB_FIELD_P(x)) { + } else if (!CB_FIELD_P (x)) { return cb_error_node; } - f = CB_FIELD (cb_ref (x)); + f = CB_FIELD_PTR (x); cb_validate_field (f); if (f->flag_any_length) { cb_error (_("ANY LENGTH item not allowed here")); @@ -3461,7 +3471,7 @@ cb_validate_parameters_and_returning (struct cb_program *prog, cb_tree using_lis } -/* TO-DO: Add params differing in BY REFERENCE/VALUE and OPTIONAL to testsuite */ +/* TODO: Add params differing in BY REFERENCE/VALUE and OPTIONAL to testsuite */ static struct cb_program * try_get_program (cb_tree prog_ref) @@ -3471,7 +3481,7 @@ try_get_program (cb_tree prog_ref) cb_tree ref; if (CB_LITERAL_P (prog_ref) - /* && TO-DO: Check user wants checks on this kind of CALL. */) { + /* && TODO: Check user wants checks on this kind of CALL. */) { name_str = (char *) CB_LITERAL (prog_ref)->data; program = cb_find_defined_program_by_name (name_str); } else if (CB_REFERENCE_P (prog_ref)) { @@ -3481,7 +3491,7 @@ try_get_program (cb_tree prog_ref) } if (CB_FIELD_P (ref) && CB_FIELD (ref)->flag_item_78 - /* && TO-DO: Check user wants checks on this kind of CALL. */) { + /* && TODO: Check user wants checks on this kind of CALL. */) { name_str = (char *) CB_LITERAL (CB_VALUE (CB_FIELD (ref)->values))->data; program = cb_find_defined_program_by_name (name_str); } else if (CB_PROTOTYPE_P (ref)) { @@ -3640,7 +3650,7 @@ error_if_items_differ (const char *element_name, *prototype_error_header_shown = 1; } - /* To-do: Indicate location of the items in error. */ + /* TODO: Indicate location of the items in error. */ if (is_parameter) { cb_note (cb_warn_repository_checks, 0, _("parameters #%d ('%s' in the definition and '%s' in the prototype) differ"), @@ -3836,7 +3846,7 @@ check_argument_conformance (struct cb_program *program, cb_tree argument_tripple /* Check BY REFERENCE/CONTENT/VALUE is correct. */ if ((arg_mode == CB_CALL_BY_REFERENCE || arg_mode == CB_CALL_BY_CONTENT) && param_mode != CB_CALL_BY_REFERENCE) { - /* TO-DO: Improve name of CB_VALUE (argument_tripple) */ + /* TODO: Improve name of CB_VALUE (argument_tripple) */ cb_warning_x (cb_warn_repository_checks, arg_tree, _("expected argument #%d, %s, to be passed BY VALUE"), param_num, cb_name (arg_tree)); @@ -3889,7 +3899,7 @@ check_argument_conformance (struct cb_program *program, cb_tree argument_tripple if (arg_mode == CB_CALL_BY_REFERENCE) { if (CB_TREE_CLASS (param) == CB_CLASS_POINTER) { if (CB_TREE_CATEGORY (arg_tree) != CB_TREE_CATEGORY (param)) { - /* To-do: Improve error message */ + /* TODO: Improve error message */ cb_warning_x (cb_warn_repository_checks, arg_tree, _("argument #%d is a different type of pointer than the parameter"), param_num); @@ -4004,13 +4014,13 @@ cb_check_conformance (cb_tree prog_ref, cb_tree using_list, call_returning_field = CB_FIELD (cb_ref (returning)); if (prog_returning_field->flag_any_length && !call_returning_field->flag_any_length) { - /* To-do: Check! */ + /* TODO: Check! */ cb_warning_x (cb_warn_repository_checks, returning, _("the RETURNING item is of a fixed size, not ANY LENGTH")); } if (!items_have_same_data_clauses (call_returning_field, prog_returning_field, 0)) { - /* TO-DO: Improve message! */ + /* TODO: Improve message! */ cb_warning_x (cb_warn_repository_checks, returning, _("RETURNING item %s is not a valid type"), cb_name (CB_TREE (call_returning_field))); @@ -4708,7 +4718,7 @@ validate_relative_key_field (struct cb_file *file) file->name, key_field->name); } - /* TO-DO: Check if key_field is an integer based on USAGE */ + /* TODO: Check if key_field is an integer based on USAGE */ if (key_field->pic != NULL) { if (key_field->pic->category == CB_CATEGORY_NUMERIC && key_field->pic->scale != 0) { @@ -4797,7 +4807,7 @@ validate_file_status (cb_tree fs) cb_tree x = cb_ref (fs); - /* TO-DO: If not defined, implicitly define PIC XX */ + /* TODO: If not defined, implicitly define PIC XX */ if (x == cb_error_node) { return; } @@ -5038,7 +5048,7 @@ cb_validate_program_data (struct cb_program *prog) if (prog->crt_status) { prog->crt_status = cb_validate_crt_status (prog->crt_status, NULL); } else { - /* TO-DO: Add to registers list */ + /* TODO: Add to registers list */ l = cb_build_reference ("COB-CRT-STATUS"); x = cb_try_ref (l); if (x == cb_error_node) { @@ -5076,7 +5086,13 @@ cb_validate_program_data (struct cb_program *prog) if (cb_validate_one (q->depending)) { q->depending = cb_error_node; } else if (cb_ref (q->depending) != cb_error_node) { - depfld = CB_FIELD_PTR (q->depending); + cb_tree dep_x = q->depending; + if (cb_tree_category (dep_x) != CB_CATEGORY_NUMERIC) { + cb_error_x (dep_x, _ ("'%s' is not numeric"), cb_name (dep_x)); + q->depending = cb_error_node; + } else { + depfld = CB_FIELD_PTR (q->depending); + } if (chk_field_variable_address (depfld) ) { if (cb_depending_on_not_fixed == CB_WARNING) { cb_warning_x (COBC_WARN_FILLER, CB_TREE (depfld), @@ -8211,7 +8227,7 @@ emit_display_external_form (cb_tree x) if (f->children) { found += emit_display_external_form (f_ref); } else { - /* TO-DO: Is CB_FIELD (cb_ref (f_ref)) == f? */ + /* TODO: Is CB_FIELD (cb_ref (f_ref)) == f? */ f_ref_field = CB_FIELD (cb_ref (f_ref)); if (f_ref_field->external_form_identifier) { ext_form_id = f_ref_field->external_form_identifier; @@ -11190,9 +11206,9 @@ cb_check_overlapping (struct cb_field *src_f, struct cb_field *dst_f, dst_off += cb_get_int (dr->offset) - 1; } - if (src_size == 0 || dst_size == 0 || - cb_field_variable_size (src_f) || - cb_field_variable_size (dst_f)) { + if (src_size == 0 || dst_size == 0 + || cb_field_variable_size (src_f) + || cb_field_variable_size (dst_f)) { /* overlapping possible, would need more checks */ return 1; } @@ -12705,7 +12721,7 @@ cb_build_move_literal (cb_tree src, cb_tree dst) p = buff + f->size - 1; } #if 0 /* Simon: negative zero back by disabling the following code -´ included without documentation by Roger in 2.0 */ +´ included without documentation by Roger in 2.0 */ if (!n) { /* Zeros */ /* EBCDIC - store sign otherwise nothing */ @@ -13126,7 +13142,7 @@ cb_build_move (cb_tree src, cb_tree dst) return ret; } -/* TO-DO: Shouldn't this include validate_move()? */ +/* TODO: Shouldn't this include validate_move()? */ static int cb_check_move (cb_tree src, cb_tree dsts, const int emit_error) { @@ -14504,16 +14520,15 @@ cb_emit_sort_using (cb_tree file, cb_tree l) } /* LCOV_EXCL_STOP */ for (; l; l = CB_CHAIN (l)) { - cb_tree use_ref = cb_ref (CB_VALUE (l)); - const struct cb_file *use_file = CB_FILE (use_ref); - if (use_file->organization == COB_ORG_SORT) { + cb_tree use_file = cb_ref (CB_VALUE (l)); + if (CB_FILE (use_file)->organization == COB_ORG_SORT) { cb_error_x (CB_TREE (current_statement), _("invalid %s parameter"), current_statement->statement == STMT_MERGE ? "MERGE USING" : "SORT USING"); } cb_emit (CB_BUILD_FUNCALL_2 ("cob_file_sort_using", - rtree, use_ref)); + rtree, use_file)); } } @@ -15345,9 +15360,8 @@ error_if_not_alnum_or_national (cb_tree ref, const char *name) /* note: at least with Enterprise COBOL utf8 is explicit forbidden here */ cb_error_x (ref, _("%s must be alphanumeric or national"), name); return 1; - } else { - return 0; } + return 0; } static int @@ -15356,18 +15370,17 @@ error_if_figurative_constant (cb_tree ref, const char *name) if (cb_is_figurative_constant (ref)) { cb_error_x (ref, _("%s may not be a figurative constant"), name); return 1; - } else { - return 0; } + return 0; } static int is_subordinate_to (cb_tree ref, cb_tree parent_ref) { - struct cb_field *f = CB_FIELD (cb_ref (ref))->parent; - struct cb_field *parent = CB_FIELD (cb_ref (parent_ref)); + const struct cb_field *f = CB_FIELD_PTR (ref); + struct cb_field *parent = CB_FIELD_PTR (parent_ref); - for (; f; f = f->parent) { + for (f = f->parent; f; f = f->parent) { if (f == parent) { return 1; } @@ -15395,16 +15408,15 @@ error_if_not_child_of_input_record (cb_tree ref, cb_tree input_record, if (!is_subordinate_to (ref, input_record)) { cb_error_x (ref, _("%s must be a child of the input record"), name); return 1; - } else { - return 0; } + return 0; } static int is_ignored_child_in_ml_gen (cb_tree ref, cb_tree parent_ref) { - struct cb_field *f = CB_FIELD (cb_ref (ref)); - struct cb_field *parent = CB_FIELD (cb_ref (parent_ref)); + const struct cb_field *parent = CB_FIELD_PTR (parent_ref); + struct cb_field *f = CB_FIELD_PTR (ref); for (; f && f != parent; f = f->parent) { if (cb_field_is_ignored_in_ml_gen (f)) { @@ -15421,59 +15433,54 @@ error_if_ignored_in_ml_gen (cb_tree ref, cb_tree input_record, const char *name) if (is_ignored_child_in_ml_gen (ref, input_record)) { cb_error_x (ref, _("%s may not be an ignored item in JSON/XML GENERATE"), name); return 1; - } else { - return 0; } + return 0; } static int error_if_not_elementary (cb_tree ref, const char *name) { - if (CB_FIELD (cb_ref (ref))->children) { + if (CB_FIELD_PTR (ref)->children) { cb_error_x (ref, _("%s must be elementary"), name); return 1; - } else { - return 0; } + return 0; } static int error_string_not_usage_display_or_national (cb_tree ref) { - struct cb_field *f = CB_FIELD (cb_ref (ref)); + const struct cb_field *f = CB_FIELD_PTR (ref); if (! (CB_FIELD (cb_ref (ref))->usage == CB_USAGE_DISPLAY || CB_FIELD (cb_ref (ref))->usage == CB_USAGE_NATIONAL)) { cb_error_x (ref, _("STRING item '%s' must be USAGE DISPLAY or NATIONAL"), f->name); return 1; - } else { - return 0; } + return 0; } static int error_if_not_usage_display_or_national (cb_tree ref, const char *name) { - if (! (CB_FIELD (cb_ref (ref))->usage == CB_USAGE_DISPLAY - || CB_FIELD (cb_ref (ref))->usage == CB_USAGE_NATIONAL)) { + const struct cb_field *f = CB_FIELD_PTR (ref); + if (f->usage != CB_USAGE_DISPLAY + && f->usage != CB_USAGE_NATIONAL) { cb_error_x (ref, _("%s must be USAGE DISPLAY or NATIONAL"), name); return 1; - } else { - return 0; } + return 0; } static int error_if_not_integer_ref (cb_tree ref, const char *name) { - struct cb_field *field = CB_FIELD (cb_ref (ref)); - - if (CB_TREE_CATEGORY (field) == CB_CATEGORY_NUMERIC - && field->pic && field->pic->scale > 0) { + const struct cb_field *f = CB_FIELD_PTR (ref); + if (CB_TREE_CATEGORY (f) == CB_CATEGORY_NUMERIC + && f->pic && f->pic->scale > 0) { cb_error_x (ref, _("%s must be an integer"), name); return 1; - } else { - return 0; } + return 0; } static int @@ -15499,12 +15506,12 @@ syntax_check_ml_gen_receiving_item (cb_tree out) static int all_children_are_ignored (struct cb_field * const f) { - struct cb_field *child; + struct cb_field *child; for (child = f->children; child; child = child->sister) { if (!cb_field_is_ignored_in_ml_gen (child) - && !(child->children - && all_children_are_ignored (child))) { + && !(child->children + && all_children_are_ignored (child))) { return 0; } } @@ -15527,7 +15534,7 @@ static int all_children_ok_qualified_by_only (struct cb_field * const f, struct cb_field * const qualifier) { - struct cb_field *child; + struct cb_field *child; for (child = f->children; child; child = child->sister) { if (child->flag_filler) { @@ -15568,7 +15575,7 @@ contains_occurs_item (const struct cb_field * const f, const int check_siblings) static int syntax_check_ml_gen_input_rec (cb_tree from) { - int error = 0; + int error = 0; struct cb_field *from_field; if (cb_validate_one (from)) { @@ -15593,7 +15600,7 @@ syntax_check_ml_gen_input_rec (cb_tree from) } if (!all_children_ok_qualified_by_only (from_field, from_field)) { - /* TO-DO: Output the name of the child with the nonunique name */ + /* TODO: Output the name of the child with the nonunique name */ cb_error_x (from, _("JSON/XML GENERATE input record has subrecords with non-unique names")); error = 1; } @@ -15759,18 +15766,16 @@ static int syntax_check_ml_gen_type_list (cb_tree type_list, cb_tree input) { cb_tree l; - cb_tree type_pair; - cb_tree ref; - cb_tree type; - int error = 0; + int error = 0; for (l = type_list; l; l = CB_CHAIN (l)) { - type_pair = CB_VALUE (l); - ref = CB_PAIR_X (type_pair); - type = CB_PAIR_Y (type_pair); + cb_tree type_pair = CB_VALUE (l); + cb_tree ref = CB_PAIR_X (type_pair); + cb_tree type = CB_PAIR_Y (type_pair); if (cb_validate_one (ref) - || cb_validate_one (type)) { - return 1; + || cb_validate_one (type)) { + error = 1; + continue; } error |= error_if_subscript_or_refmod (ref, _("TYPE OF item")); @@ -15781,7 +15786,7 @@ syntax_check_ml_gen_type_list (cb_tree type_list, cb_tree input) error = 1; } else { error |= error_if_ignored_in_ml_gen (ref, input, - _("TYPE OF item")); + _("TYPE OF item")); } } @@ -15796,7 +15801,7 @@ syntax_check_when_list (struct cb_ml_suppress_clause *suppress) const char *name; for (l = suppress->when_list; l; l = CB_CHAIN (l)) { - /* TO-DO: Handle DISPLAY-1 if/when it is supported. */ + /* TODO: Handle DISPLAY-1 if/when it is supported. */ if (CB_VALUE (l) == cb_space) { error |= error_if_not_usage_display_or_national (suppress->identifier, _("SUPPRESS WHEN SPACE item")); @@ -15820,10 +15825,10 @@ syntax_check_ml_gen_suppress_list (cb_tree suppress_list, cb_tree input) { int error = 0; cb_tree l; - struct cb_ml_suppress_clause *suppress; for (l = suppress_list; l; l = CB_CHAIN (l)) { - suppress = CB_ML_SUPPRESS (CB_VALUE (l)); + const struct cb_ml_suppress_clause *suppress + = CB_ML_SUPPRESS (CB_VALUE (l)); if (!suppress->identifier) { continue; } @@ -15833,11 +15838,11 @@ syntax_check_ml_gen_suppress_list (cb_tree suppress_list, cb_tree input) } error |= error_if_subscript_or_refmod (suppress->identifier, - _("SUPPRESS item")); + _("SUPPRESS item")); if (suppress->when_list) { error |= error_if_not_elementary (suppress->identifier, - _("SUPPRESS item with WHEN clause")); + _("SUPPRESS item with WHEN clause")); } if (error_if_not_child_of_input_record (suppress->identifier, input, @@ -15845,7 +15850,7 @@ syntax_check_ml_gen_suppress_list (cb_tree suppress_list, cb_tree input) error = 1; } else { error |= error_if_ignored_in_ml_gen (suppress->identifier, - input, _("SUPPRESS item")); + input, _("SUPPRESS item")); } error |= syntax_check_when_list (suppress); @@ -15875,8 +15880,8 @@ syntax_check_ml_generate (cb_tree out, cb_tree from, cb_tree count, error |= syntax_check_ml_gen_type_list (type_list, from); error |= syntax_check_ml_gen_suppress_list (suppress_list, from); - /* TO-DO: Warn if out is probably too short */ - /* TO-DO: Warn if count_in may overflow */ + /* TODO: Warn if out is probably too short */ + /* TODO: Warn if count_in may overflow */ return error; } diff --git a/tests/testsuite.src/listings.at b/tests/testsuite.src/listings.at index 6e3036b7e..916668529 100644 --- a/tests/testsuite.src/listings.at +++ b/tests/testsuite.src/listings.at @@ -2227,7 +2227,7 @@ AT_CLEANUP AT_SETUP([Symbols: simple]) -AT_KEYWORDS([listing COMP]) +AT_KEYWORDS([listing symbols COMP]) AT_CAPTURE_FILE([prog.lst]) @@ -2379,7 +2379,7 @@ AT_CLEANUP AT_SETUP([Symbols: pointer]) -AT_KEYWORDS([listing 64bit]) +AT_KEYWORDS([listing symbols 64bit]) AT_CAPTURE_FILE([prog.lst]) @@ -2657,7 +2657,7 @@ AT_CLEANUP AT_SETUP([Symbols: multiple programs/functions]) -AT_KEYWORDS([listing program function]) +AT_KEYWORDS([listing symbols program function]) AT_CAPTURE_FILE([prog.lst]) @@ -2782,8 +2782,8 @@ AT_CHECK([gcdiff prog18.lst prog.lst], [0], [], []) AT_CLEANUP -AT_SETUP([Symbols: OCCURS/REDEFINES]) -AT_KEYWORDS([listing]) +AT_SETUP([Symbols: OCCURS and REDEFINES]) +AT_KEYWORDS([listing symbols UNBOUNDED]) AT_CAPTURE_FILE([prog.lst]) @@ -2816,50 +2816,23 @@ AT_DATA([prog.cob], [ 10 FILLER PIC X(01). 05 FLD3 PIC X(3). 05 FLD4 PIC X(4). + LINKAGE SECTION. + 01 O1 PIC X OCCURS UNBOUNDED DEPENDING ON FL4. + 01 O2. + 05 O-START PIC X(42). + 05 FILLER OCCURS UNBOUNDED DEPENDING ON FL9. + 07 O-ENTRY. + 10 O-E1 PIC 9(24). + 10 O-E2 PIC XXX. PROCEDURE DIVISION. STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -fcomplex-odo -t prog.lst -ftsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -fcomplex-odo -t prog.lst -fno-tsource -ftsymbols prog.cob], [0], [], []) AT_DATA([prog19.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY Page 0001 -LINE PG/LN A...B............................................................ - -000001 -000002 IDENTIFICATION DIVISION. -000003 PROGRAM-ID. prog. -000004 ENVIRONMENT DIVISION. -000005 CONFIGURATION SECTION. -000006 DATA DIVISION. -000007 WORKING-STORAGE SECTION. -000008 78 I VALUE 20. -000009 78 J VALUE 5000. -000010 78 M VALUE 5. -000011 01 SETUP-REC. -000012 05 FL1 PIC X(04). -000013 05 FL2 PIC ZZZZZ. -000014 05 FL3 PIC 9(04). -000015 05 FL4 PIC 9(08) COMP. -000016 05 FL5 PIC 9(04) COMP-4. -000017 05 FL6 PIC Z,ZZZ.99. -000018 05 FL7 PIC S9(05) SIGN LEADING SEPARATE. -000019 05 FL8 PIC X(04). -000020 05 FL9 REDEFINES FL8 PIC 9(04). -000021 05 FLA. -000022 10 FLB OCCURS I TIMES. -000023 15 FLC PIC X(02). -000024 10 FLD PIC X(20). -000025 05 FLD1 PIC X(100). -000026 05 FLD2 OCCURS M TO J TIMES DEPENDING ON FL5. -000027 10 FILLER PIC X(01). -000028 05 FLD3 PIC X(3). -000029 05 FLD4 PIC X(4). -000030 PROCEDURE DIVISION. -000031 STOP RUN. - GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY Page 0002 - SIZE TYPE LVL NAME PICTURE WORKING-STORAGE SECTION @@ -2884,6 +2857,17 @@ SIZE TYPE LVL NAME PICTURE 00003 ALPHANUMERIC 05 FLD3 X(3) 00004 ALPHANUMERIC 05 FLD4 X(4) + LINKAGE SECTION + +????? ALPHANUMERIC 01 O1 X, OCCURS 0 TO UNBOUNDED + +????? GROUP 01 O2 +00042 ALPHANUMERIC 05 O-START X(42) +????? GROUP 05 FILLER OCCURS 0 TO UNBOUNDED +00027 GROUP 07 O-ENTRY +00024 NUMERIC 10 O-E1 9(24) +00003 ALPHANUMERIC 10 O-E2 XXX + 0 warnings in compilation group 0 errors in compilation group diff --git a/tests/testsuite.src/syn_definition.at b/tests/testsuite.src/syn_definition.at index 3ac642c9c..60ac9ad94 100644 --- a/tests/testsuite.src/syn_definition.at +++ b/tests/testsuite.src/syn_definition.at @@ -159,8 +159,7 @@ AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. PROCEDURE DIVISION. - DISPLAY X - END-DISPLAY. + DISPLAY X. STOP RUN. ]) @@ -181,8 +180,7 @@ AT_DATA([prog.cob], [ WORKING-STORAGE SECTION. 01 X PIC X. PROCEDURE DIVISION. - DISPLAY X IN G - END-DISPLAY. + DISPLAY X IN G. STOP RUN. ]) @@ -205,8 +203,7 @@ AT_DATA([prog.cob], [ 02 X PIC X. 01 Y PIC X. PROCEDURE DIVISION. - DISPLAY Y IN G - END-DISPLAY. + DISPLAY Y IN G. STOP RUN. ]) @@ -860,8 +857,7 @@ AT_DATA([prog.cob], [ 01 G2. 02 X PIC X. PROCEDURE DIVISION. - DISPLAY X - END-DISPLAY. + DISPLAY X. STOP RUN. ]) @@ -886,8 +882,7 @@ AT_DATA([prog.cob], [ 02 X. 03 X PIC X. PROCEDURE DIVISION. - DISPLAY X - END-DISPLAY. + DISPLAY X. STOP RUN. ]) @@ -915,8 +910,7 @@ AT_DATA([prog.cob], [ 02 X. 03 Y PIC X. PROCEDURE DIVISION. - DISPLAY Y IN X - END-DISPLAY. + DISPLAY Y IN X. STOP RUN. ]) @@ -944,8 +938,7 @@ AT_DATA([prog.cob], [ 02 X. 03 Z PIC X VALUE "Z". PROCEDURE DIVISION. - DISPLAY Z IN X NO ADVANCING - END-DISPLAY. + DISPLAY Z IN X NO ADVANCING. STOP RUN. ]) @@ -2081,7 +2074,7 @@ AT_DATA([prog.cob], [ 03 i PIC X. 03 j OCCURS 5 TIMES. 05 k PIC X. - 05 l PIC X. + 05 l PIC 9. 03 m PIC 9. 03 n POINTER, SYNC. 03 o. @@ -2162,12 +2155,12 @@ AT_DATA([prog.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. 01 MESSAGE-TEXT-2 EXTERNAL. - 02 AUSGABE-FILE-NAME PIC X(50). + 02 AUSGABE-FILE-NAME PIC X(50). 02 FILLER REDEFINES AUSGABE-FILE-NAME. - 05 FILLER PIC 9999. + 05 FILLER PIC 9999. 02 AUSGABE-FILE-NAME-2. - 05 FILLER PIC 9999. - 05 DETAIL-NO PIC 9999. + 05 FILLER PIC 9999. + 05 DETAIL-NO PIC 9999. 02 FILLER SAME AS AUSGABE-FILE-NAME. 77 OUTPUT-NAME SAME AS DETAIL-NO GLOBAL. @@ -2191,11 +2184,11 @@ AT_DATA([badprog.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. 01 MESSAGE-TEXT-2. - 02 AUSGABE-FILE-NAME PIC X(50). - 02 F1 SAME AS MESSAGE-TEXT-2. - 01 MT2 SAME AS MESSAGE-TEXT-2. - 05 FILLER PIC 9999. - 01 MT3 SAME AS MESSAGE-TEXT-2 PIC X. + 02 AUSGABE-FILE-NAME PIC X(50). + 02 F1 SAME AS MESSAGE-TEXT-2. + 01 MT2 SAME AS MESSAGE-TEXT-2. + 05 FILLER PIC 9999. + 01 MT3 SAME AS MESSAGE-TEXT-2 PIC X. 77 OUTPUT-NAME SAME AS MESSAGE-TEXT-2. ]) diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 05d2760a3..d95f79575 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -982,10 +982,10 @@ AT_DATA([prog.cob], [ 01 x PIC 9(5). PROCEDURE DIVISION. - *> Ok + *> Ok INSPECT "abcde" TALLYING x FOR CHARACTERS CHARACTERS - *> Not ok + *> Not ok INSPECT "abcde" TALLYING x FOR ALL LEADING TRAILING ALL ALL ALL TRAILING INSPECT "abcde" TALLYING x FOR x FOR LEADING "a" @@ -3526,49 +3526,49 @@ AT_KEYWORDS([misc reserved words]) # note: currently not checked - should all be seen before first IDENTIFICATION DIVISION AT_DATA([prog.cob], [ - *> Valid + *> Valid >>COBOL-WORDS RESERVE "CAT" - *> Valid (GC-extension) + *> Valid (GC-extension) >>COBOL-WORDS RESERVE "doggy" "catty" "mouse" - *> Valid + *> Valid >>COBOL-WORDS EQUATE "VALUE" WITH "VA" - *> Invalid - Bread is not reserved. + *> Invalid - Bread is not reserved. >>COBOL-WORDS EQUATE "BREAD" WITH "BARA" - *> Invalid - ID is already reserved + *> Invalid - ID is already reserved >>COBOL-WORDS EQUATE "IDENTIFICATION" WITH "ID" - *> Valid, BREAD is not reserved. + *> Valid, BREAD is not reserved. >>COBOL-WORDS SUBSTITUTE "program" BY "bread" - *> Valid (GC-extension) + *> Valid (GC-extension) >>COBOL-WORDS SUBSTITUTE "DIVISION" BY "DIV", "JUST" BY "JS" - *> Invalid - Bread is not reserved. + *> Invalid - Bread is not reserved. >>COBOL-WORDS SUBSTITUTE "BREAD" BY "BARA" - *> Invalid - ID is already reserved + *> Invalid - ID is already reserved >>COBOL-WORDS SUBSTITUTE "IDENTIFICATION" BY "ID" - *> Invalid - needs BY, not WITH - *> FIXME: error-recovery is bad, see below - *> >>COBOL-WORDS SUBSTITUTE "INITIALIZE" WITH "INIT" + *> Invalid - needs BY, not WITH + *> FIXME: error-recovery is bad, see below + *> >>COBOL-WORDS SUBSTITUTE "INITIALIZE" WITH "INIT" - *> Valid + *> Valid >>COBOL-WORDS UNDEFINE "BREAD" - *> Valid (GC-extension) + *> Valid (GC-extension) >>COBOL-WORDS UNDEFINE "DOGGY" "CATTY" - *> Invalid in Standard COBOL, must be a defined word + *> Invalid in Standard COBOL, must be a defined word >>COBOL-WORDS UNDEFINE "BREAD" - *> FIXME: error-recovery is bad, see below - *>>COBOL-WORDS REMOVE "BREAD" + *> FIXME: error-recovery is bad, see below + *>>COBOL-WORDS REMOVE "BREAD" IDENTIFICATION DIV. PROGRAM-ID. prog. DATA DIV. WORKING-STORAGE SECTION. - *> Check EQUATE and SUBSTITUTE work correctly + *> Check EQUATE and SUBSTITUTE work correctly 01 just PIC XX VA "1" JS. - *> Check RESERVE + *> Check RESERVE 01 cat PIC 9 VA 1. - *> Check UNDEFINE + *> Check UNDEFINE 01 dog PIC 9 VA 1. ]) @@ -3600,31 +3600,31 @@ AT_KEYWORDS([misc extensions ADDRSV ADDSYN MAKESYN OVERRIDE REMOVE]) # note: currently not checked - should all be seen before first IDENTIFICATION DIVISION AT_DATA([prog.cob], [ - *> Valid + *> Valid $SET ADDRSV"DOG""CAT" $SET ADD-RSV "doggy" "catty" - *> Valid + *> Valid $SET ADD-SYN "VALUE" = "VA" - *> Invalid - Bread is not reserved. + *> Invalid - Bread is not reserved. $SET ADDSYN "BREAD" = "BARA" - *> Invalid - ID is already reserved + *> Invalid - ID is already reserved $SET ADDSYN "IDENTIFICATION" = "ID" - *> Valid + *> Valid $SET MAKESYN(PROGRAM) = (FUNCTION) - *> Invalid - BREAD is not reserved. + *> Invalid - BREAD is not reserved. $SET MAKESYN "BREAD" = "PROGRAM" $SET MAKE-SYN "program" = "bread" - *> Valid + *> Valid $SET OVERRIDE "DIVISION" = "DIV" "JUST" = "JS" - *> Invalid - Bread is not reserved + *> Invalid - Bread is not reserved $SET OVERRIDE "BREAD" = "BARA" - *>Invalid - ID is already reserved; note: MF documents this rule but - *> does not check it and applies the line; we do it better on purpose :-) + *>Invalid - ID is already reserved; note: MF documents this rule but + *> does not check it and applies the line; we do it better on purpose :-) $SET OVERRIDE "IDENTIFICATION" = "ID" - *> Valid - note: MF rules does allow reserving not reserved words + *> Valid - note: MF rules does allow reserving not reserved words $SET REMOVE "BREAD" (BARA)REMOVE(DOG) IDENTIFICATION DIV. @@ -3632,11 +3632,11 @@ AT_DATA([prog.cob], [ DATA DIV. WORKING-STORAGE SECTION. - *> Check ADDSYN and OVERRIDE work correctly + *> Check ADDSYN and OVERRIDE work correctly 01 just PIC XX VA "1" JS. - *> Check ADDRSV + *> Check ADDRSV 01 cat PIC 9 VA 1. - *> Check REMOVE + *> Check REMOVE 01 dog PIC 9 VA 1. ]) @@ -3665,9 +3665,9 @@ AT_KEYWORDS([misc]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. - *> Valid + *> Valid >> TURN ec-i-o f CHECKING ON - *> Invalid + *> Invalid >> TURN dd CHECKING ON >> TURN ec-all f CHECKING ON >> TURN EC-I-O-invalid-KEY not-exist CHECKING OFF @@ -3951,7 +3951,7 @@ AT_XFAIL_IF([true]) # needs updating AT_DATA([prog.cob], [ - *> Prototype and definition have different signatures. + *> Prototype and definition have different signatures. IDENTIFICATION DIVISION. FUNCTION-ID. invalid-1 PROTOTYPE. @@ -3972,7 +3972,7 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION USING x returning y. END FUNCTION invalid-1. - *> Prototype and definition have different signatures. + *> Prototype and definition have different signatures. IDENTIFICATION DIVISION. PROGRAM-ID. invalid-2 PROTOTYPE. DATA DIVISION. @@ -3981,7 +3981,7 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION USING x. END PROGRAM invalid-2. - *> Prototype and definition have matching signatures. + *> Prototype and definition have matching signatures. IDENTIFICATION DIVISION. FUNCTION-ID. valid-1 PROTOTYPE. @@ -4043,7 +4043,7 @@ AT_DATA([prog.cob], [ . END FUNCTION valid-1. - *> Prototypes must be at start of compilation group. + *> Prototypes must be at start of compilation group. IDENTIFICATION DIVISION. PROGRAM-ID. invalid-3. @@ -5603,14 +5603,14 @@ AT_DATA([prog.cob], [ data division. working-storage section. 01 item-01. - 05 item-05-a pointer. - 05 item-05-b pic x(01). - 01 myk-01 constant global as length of item-01. - 01 myk-02 constant is global as length item-05-a. - 01 myk-03 constant global as length of pointer. *> extension - 01 myk-04 constant global as byte-length of item-01. + 05 item-05-a pointer. + 05 item-05-b pic x(01). + 01 myk-01 constant as length of item-01. + 01 myk-02 constant is global as length item-05-a. + 01 myk-03 constant global as length of pointer. *> extension + 01 myk-04 constant global as byte-length of item-01. 01 myk-05 constant is global as byte-length item-05-a. - 01 myk-06 constant global as byte-length of pointer. *> extension + 01 myk-06 constant as byte-length of pointer. *> extension ]) AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], []) @@ -5626,12 +5626,12 @@ AT_DATA([prog.cob], [ DATA DIVISION. LINKAGE SECTION. - *> Valid + *> Valid 01 valid-1 PIC X ANY LENGTH. 01 valid-2 PIC N ANY LENGTH. 01 valid-3 PIC 9 ANY NUMERIC. - *> Invalid + *> Invalid 01 invalid-1 PIC A ANY LENGTH. 01 invalid-2 PIC Z ANY LENGTH. 01 invalid-3 PIC 9 ANY LENGTH. @@ -5714,10 +5714,10 @@ AT_SETUP([SET SOURCEFORMAT syntax checks]) AT_KEYWORDS([misc extensions source directives]) AT_DATA([prog.cob], [ - *> Valid + *> Valid $set sourceformat(free) $ SET SOURCEFORMAT"FIXED" - *> Invalid + *> Invalid $SET SOURCEFORMAT"hi!" $SET SOURCEFORMAT() $SET sourceformat'mis-matched" @@ -6114,113 +6114,113 @@ AT_DATA([prog.cob], [ 03 with-attrs-child PIC X. PROCEDURE DIVISION. - *> Receiving area is not alphanumeric or national. + *> Receiving area is not alphanumeric or national. XML GENERATE bool-item FROM str - *> Receiving area is JUSTIFIED RIGHT. + *> Receiving area is JUSTIFIED RIGHT. XML GENERATE just-item FROM str - *> Receiving area is subscripted or ref-mod'd. + *> Receiving area is subscripted or ref-mod'd. XML GENERATE table-entry (1) FROM str XML GENERATE long-str (1:100) FROM str - *> Input record cannot be function identifier. + *> Input record cannot be function identifier. XML GENERATE long-str FROM FUNCTION CHAR(4) - *> Input record cannot be ref-mod'd. + *> Input record cannot be ref-mod'd. XML GENERATE long-str FROM str (2:1) - *> " " is not RENAMES (children may be RENAMES). + *> " " is not RENAMES (children may be RENAMES). XML GENERATE long-str FROM renames-item - *> Non-ignored items of the input record must: - *> * alphabetic, alphanumeric, national, numeric or index. - *> * there must be at least one item. - *> * each non-FILLER name must be unique within the input record. + *> Non-ignored items of the input record must: + *> * alphabetic, alphanumeric, national, numeric or index. + *> * there must be at least one item. + *> * each non-FILLER name must be unique within the input record. XML GENERATE long-str FROM invalid-sub-elt-rec *> XXXXXXXXX ptr element is invalid XML GENERATE long-str FROM all-filler-rec - *> COUNT IN field must be an integer. + *> COUNT IN field must be an integer. XML GENERATE long-str FROM str COUNT float-item - *> COUNT IN field must not have P in PIC. + *> COUNT IN field must not have P in PIC. XML GENERATE long-str FROM str COUNT pic-p-item - *> ENCODING codepage must be unsigned integer. - *> If receiving area is national, codepage must be 1200. - *> " " " alphanumeric, codepage must be 1208 or EBCDIC - *> page supported with XML. + *> ENCODING codepage must be unsigned integer. + *> If receiving area is national, codepage must be 1200. + *> " " " alphanumeric, codepage must be 1208 or EBCDIC + *> page supported with XML. - *> WITH ATTRIBUTES, generated immediate children must be - *> * elementary - *> * be non-FILLER - *> * not be OCCURS - *> * not be subject of a TYPE phrase. + *> WITH ATTRIBUTES, generated immediate children must be + *> * elementary + *> * be non-FILLER + *> * not be OCCURS + *> * not be subject of a TYPE phrase. XML GENERATE long-str FROM with-attrs-does-nothing WITH ATTRIBUTES TYPE OF with-attrs-child IS ELEMENT - *> NAMESPACE must be a valid URI. + *> NAMESPACE must be a valid URI. XML GENERATE long-str FROM str NAMESPACE "<>" - *> NAMESPACE and -PREFIX must be alphanumeric or national. + *> NAMESPACE and -PREFIX must be alphanumeric or national. XML GENERATE long-str FROM str NAMESPACE bool-item NAMESPACE-PREFIX bool-item - *> " " " may not be figurative constants. + *> " " " may not be figurative constants. XML GENERATE long-str FROM str NAMESPACE SPACES NAMESPACE-PREFIX QUOTES - *> NAMESPACE-PREFIX must be a valid XML name. + *> NAMESPACE-PREFIX must be a valid XML name. XML GENERATE long-str FROM str NAMESPACE "http://www.w3.org/xml" NAMESPACE-PREFIX X"00" - *> NAME items must reference input record or its children. + *> NAME items must reference input record or its children. XML GENERATE long-str FROM rec NAME OF child-1 IS "c1", long-str IS "c2", rec IS "r" - *> NAME items cannot be reference modified or subscripted. + *> NAME items cannot be reference modified or subscripted. XML GENERATE long-str FROM rec NAME OF child-1 (1:2) IS "c1" - *> NAME items may not be ignored by the statement. + *> NAME items may not be ignored by the statement. XML GENERATE long-str FROM rec NAME OF child-1a IS "c1a" - *> NAME literals must be valid XML names. + *> NAME literals must be valid XML names. XML GENERATE long-str FROM rec NAME OF child-1 IS X"00" - *> TYPE items must be elementary and children of input record. + *> TYPE items must be elementary and children of input record. XML GENERATE long-str FROM rec TYPE OF child-3 IS ELEMENT, long-str IS CONTENT, rec IS CONTENT - *> TYPE items cannot be ref-mod'd or subscripted. + *> TYPE items cannot be ref-mod'd or subscripted. XML GENERATE long-str FROM rec TYPE OF child-1 (1:3) IS ATTRIBUTE, child-3-1 (1) IS CONTENT - *> TYPE items may not be ignored by the statement + *> TYPE items may not be ignored by the statement XML GENERATE long-str FROM rec TYPE OF child-1a IS ELEMENT - *> TYPE ATTRIBUTE items must satisfy the conditions for WITH - *> ATTRIBUTES. (Covered by the above.) + *> TYPE ATTRIBUTE items must satisfy the conditions for WITH + *> ATTRIBUTES. (Covered by the above.) - *> SUPPRESS WHEN items must be: - *> * elementary - *> * not ignored - *> * child of input record. + *> SUPPRESS WHEN items must be: + *> * elementary + *> * not ignored + *> * child of input record. XML GENERATE long-str FROM rec SUPPRESS child-3 WHEN SPACES, child-1a WHEN SPACES, rec WHEN SPACES - *> All SUPPRESS items must not be functions + *> All SUPPRESS items must not be functions XML GENERATE long-str FROM rec SUPPRESS FUNCTION CHAR(5) WHEN SPACE - *> All SUPPRESS items must not be ref-mod'd or subscripted. + *> All SUPPRESS items must not be ref-mod'd or subscripted. XML GENERATE long-str FROM rec SUPPRESS child-1 (1:3) WHEN ZERO, child-3-1 (1) WHEN SPACES - *> If non-WHEN SUPPRESS items may be groups. (No error message here.) + *> If non-WHEN SUPPRESS items may be groups. (No error message here.) XML GENERATE long-str FROM rec SUPPRESS child-3 - *> If SUPPRESS WHEN ZEROES, item is not DISPLAY-1. - *> If SUPPRESS WHEN SPACES, item must be USAGE DISPLAY, DISPLAY-1 or - *> NATIONAL + *> If SUPPRESS WHEN ZEROES, item is not DISPLAY-1. + *> If SUPPRESS WHEN SPACES, item must be USAGE DISPLAY, DISPLAY-1 or + *> NATIONAL XML GENERATE long-str FROM bool-area SUPPRESS bool-item WHEN SPACES - *> If SUPPRESS WHEN LOW-/HIGH-VALUES, item must be USAGE DISPLAY or - *> NATIONAL. If item is a zoned/national decimal item, it must be - *> an integer. + *> If SUPPRESS WHEN LOW-/HIGH-VALUES, item must be USAGE DISPLAY or + *> NATIONAL. If item is a zoned/national decimal item, it must be + *> an integer. XML GENERATE long-str FROM bool-area SUPPRESS bool-item WHEN LOW-VALUES, zoned-decimal WHEN HIGH-VALUE - *> (For generic WHEN phrases, invalid items above are ignored.) + *> (For generic WHEN phrases, invalid items above are ignored.) GOBACK. ]) @@ -7724,7 +7724,7 @@ AT_KEYWORDS([gcos]) AT_DATA([prog.cob], [ CONTROL DIVISION. SUBSTITUTION SECTION. - *> This REPLACE in Area A is ignored for now: + *> This REPLACE in Area A is ignored for now: REPLACE IISS BY IS TERM BY TERMINAL "KO" BY "OK". @@ -7762,8 +7762,8 @@ AT_DATA([prog_extraneous_depending.cob], [ PROGRAM-ID. prog_extraneous_depending. DATA DIVISION. WORKING-STORAGE SECTION. - 1 L COMP-1. - 1 F-DAT PICTURE X(10) DEPENDING ON L. + 1 L COMP-1. + 1 F-DAT PICTURE X(10) DEPENDING ON L. PROCEDURE DIVISION. MOVE SPACES TO F-DAT STOP RUN. @@ -7777,7 +7777,7 @@ AT_DATA([prog_missing_depending.cob], [ PROGRAM-ID. prog_missing_depending. DATA DIVISION. WORKING-STORAGE SECTION. - 1 F-DAT PICTURE LX(10). + 1 F-DAT PICTURE LX(10). PROCEDURE DIVISION. MOVE SPACES TO F-DAT STOP RUN. @@ -7811,12 +7811,12 @@ AT_DATA([prog_errs.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. 1 W-LGS. - 2 LGS PICTURE X(10). + 2 LGS PICTURE X(10). 1 W-DATA. - 2 L-DAT PICTURE LX(10) DEPENDING ON LGS. - 2 L-ERR1 PICTURE L9 DEPENDING ON LGS. - 2 L-ERR2 PICTURE XXXXLA(2) DEPENDING ON LGS. - 2 L-ERR3 PICTURE LX(1) DEPENDING ON LGS JUSTIFIED. + 2 L-DAT PICTURE LX(10) DEPENDING ON LGS. + 2 L-ERR1 PICTURE L9 DEPENDING ON LGS. + 2 L-ERR2 PICTURE XXXXLA(2) DEPENDING ON LGS. + 2 L-ERR3 PICTURE LX(1) DEPENDING ON LGS JUSTIFIED. PROCEDURE DIVISION. STOP RUN. ]) @@ -7827,6 +7827,8 @@ prog_errs.cob:11: error: L must be at start of PICTURE string prog_errs.cob:11: error: L cannot follow A or X prog_errs.cob:11: error: only USAGE DISPLAY may specify a variable-length PICTURE prog_errs.cob:12: error: 'L-ERR3' cannot have JUSTIFIED RIGHT clause +prog_errs.cob:9: error: 'LGS' is not numeric +prog_errs.cob:12: error: 'LGS' is not numeric ]) AT_DATA([prog.cob], [ @@ -7834,8 +7836,8 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 1 LGS PICTURE X(10). - 1 L-DAT PICTURE LX(10) DEPENDING ON LGS. + 1 LGS PICTURE 9(10). + 1 L-DAT PICTURE LX(10) DEPENDING ON LGS. PROCEDURE DIVISION. STOP RUN. ]) diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at index 6a2c0d965..c5db3e61e 100644 --- a/tests/testsuite.src/syn_occurs.at +++ b/tests/testsuite.src/syn_occurs.at @@ -1,4 +1,4 @@ -## Copyright (C) 2003-2012, 2015-2022 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2015-2023 Free Software Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart ## ## This file is part of GnuCOBOL. @@ -184,6 +184,17 @@ AT_DATA([prog3.cob], [ 77 I PIC 9. ]) +AT_DATA([prog4.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G-1. + 02 G-2 OCCURS 10. + 03 X PIC X(10) OCCURS 1 TO 4 DEPENDING ON I. + 77 I PIC X. +]) + AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:7: error: 'G-2' cannot have an OCCURS clause due to 'X' ]) @@ -200,6 +211,15 @@ AT_CHECK([$COMPILE_ONLY prog3.cob prog2.cob], [1], [], prog2.cob:8: error: 'X' cannot have nested OCCURS DEPENDING ]) +AT_CHECK([$COMPILE_ONLY prog4.cob], [1], [], +[prog4.cob:7: error: 'G-2' cannot have an OCCURS clause due to 'X' +prog4.cob:8: error: 'I' is not numeric +]) + +AT_CHECK([$COMPILE_ONLY -fcomplex-odo prog4.cob], [1], [], +[prog4.cob:8: error: 'I' is not numeric +]) + AT_CLEANUP