From cd0615a8b4f1cd2669cd7c47b25ff683c64d68de Mon Sep 17 00:00:00 2001 From: David Declerck Date: Fri, 21 Jun 2024 14:49:46 +0200 Subject: [PATCH] Merge SVN 4681 --- cobc/ChangeLog | 22 ++ cobc/cobc.c | 15 +- cobc/codegen.c | 28 +- cobc/config.def | 3 + cobc/field.c | 34 ++- cobc/parser.y | 98 +++++-- cobc/tree.c | 137 ++++++---- cobc/tree.h | 3 +- cobc/typeck.c | 58 ++-- config/ChangeLog | 4 + config/acu-strict.conf | 1 + config/bs2000-strict.conf | 1 + config/cobol2002.conf | 1 + config/cobol2014.conf | 1 + config/cobol85.conf | 1 + config/default.conf | 1 + config/gcos-strict.conf | 1 + config/ibm-strict.conf | 1 + config/lax.conf-inc | 1 + config/mf-strict.conf | 1 + config/mvs-strict.conf | 1 + config/realia-strict.conf | 1 + config/rm-strict.conf | 1 + config/xopen.conf | 1 + tests/testsuite.src/configuration.at | 6 +- tests/testsuite.src/run_extensions.at | 376 +++++++++++++++++++++++++- tests/testsuite.src/syn_misc.at | 93 +++++++ 27 files changed, 764 insertions(+), 127 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index a19076b6c..bd15fa49f 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -276,6 +276,28 @@ literal errors (intead of cb_error_node) to prevent spurious follow-up errors on their use +2022-07-12 Nicolas Berthier + + * parser.y: add DEPENDING ON for picture strings with an `L` + character + * config.def: new option picture-l + * tree.h (struct cb_picture, struct cb_field), tree.c + (cb_field_variable_size, cb_field_variable_address), typeck.c + (cb_build_identifier, cb_validate_program_data, cb_emit_initialize) + (cb_emit_move_corresponding, emit_move_corresponding), codegen.c + (chk_field_variable_size, chk_field_variable_address) + (out_odoslide_fld_offset): add support for `L` characters in picture + strings, variable-length alphanumeric fields (GCOS extension) + * field.c (validate_field_value): PIC L fields may not have VALUE clause + * field.c (validate_occurs): allow PIC L fields in OCCURS groups + * field.c (validate_redefines): allow more liberal REDEFINES of + fields with PIC L + * field.c (validate_group): A PIC L data-item cannot be JUSTIFIED + or BLANK WHEN ZERO + * typeck.c (emit_move_corresponding): simplified code + * codegen.c (output_base, output_initialize_uniform): small code + refactorings + 2022-07-08 Simon Sobisch * parser.y (cancel_body): preparation for CANCEL ALL diff --git a/cobc/cobc.c b/cobc/cobc.c index 35d987dfb..97b577b91 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -2862,6 +2862,15 @@ process_command_line (const int argc, char **argv) long_options, &idx, 1)) >= 0) { switch (c) { + case 7: + /* -fmax-errors= : Maximum errors until abort */ + n = cobc_deciph_optarg (cob_optarg, 0); + if (n < 0) { + cobc_err_exit (COBC_INV_PAR, "-fmax-errors"); + } + cb_max_errors = n; + break; + case '?': /* Unknown option or ambiguous */ if (verbose_output >= 1) { @@ -3602,11 +3611,7 @@ process_command_line (const int argc, char **argv) case 7: /* -fmax-errors= : Maximum errors until abort */ - n = cobc_deciph_optarg (cob_optarg, 0); - if (n < 0) { - cobc_err_exit (COBC_INV_PAR, "-fmax-errors"); - } - cb_max_errors = n; + /* This option was processed in the first getopt-run */ break; case 16: diff --git a/cobc/codegen.c b/cobc/codegen.c index 5c9c87ce7..76f4313ea 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -51,7 +51,7 @@ /* Type of initialization to be done */ enum cobc_init_type { INITIALIZE_NONE = 0, /* no init (beause of FILLER, REDEFINES, ...) */ - INITIALIZE_ONE, /* initialize a single varialbe */ + INITIALIZE_ONE, /* initialize a single variable */ INITIALIZE_COMPOUND, /* init structure */ INITIALIZE_DEFAULT /* init to default-byte value / PIC (USAGE) */ }; @@ -799,6 +799,8 @@ chk_field_variable_size (struct cb_field *f) f->vsize = fc; break; } + } else if (fc->flag_picture_l) { + continue; } else if ((p = chk_field_variable_size (fc)) != NULL) { f->vsize = p; break; @@ -865,7 +867,10 @@ chk_field_variable_address (struct cb_field *fld) 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 || chk_field_variable_size (p)) { + /* Skip PIC L fields as their representation + have constant length */ + if (p->depending || + (!p->flag_picture_l && chk_field_variable_size (p))) { fld->flag_vaddr_done = 1; fld->vaddr = 1; return 1; @@ -888,7 +893,7 @@ out_odoslide_fld_offset (struct cb_field *p, struct cb_field *fld) if (p == fld) /* Single field */ return 1; - if (p->children) { + if (p->children && !p->flag_picture_l) { if (out_odoslide_grp_offset (p, fld)) return 1; } else { @@ -1146,7 +1151,6 @@ static void output_base (struct cb_field *f, const cob_u32_t no_output) { struct cb_field *f01; - struct cb_field *p; /* LCOV_EXCL_START */ if (f->flag_item_78) { @@ -1196,7 +1200,7 @@ output_base (struct cb_field *f, const cob_u32_t no_output) if (cb_odoslide) { out_odoslide_offset (f01, f); } else { - struct cb_field *v; + struct cb_field *v, *p; for (p = f->parent; p; f = f->parent, p = f->parent) { for (p = p->children; p != f; p = p->sister) { v = chk_field_variable_size (p); @@ -1761,10 +1765,9 @@ output_attr (const cb_tree x) case COB_TYPE_GROUP: case COB_TYPE_ALPHANUMERIC: if (f->flag_justified) { - id = lookup_attr (type, 0, 0, COB_FLAG_JUSTIFIED, NULL, 0); - } else { - id = lookup_attr (type, 0, 0, 0, NULL, 0); + flags |= COB_FLAG_JUSTIFIED; } + id = lookup_attr (type, 0, 0, flags, NULL, 0); break; default: if (f->pic->have_sign) { @@ -5557,15 +5560,12 @@ output_initialize_uniform (cb_tree x, const int c, const int size) } else { output ("memset ("); output_data (x); - if (size <= 0) { - output (", %d, ", c); - output_size (x); - output (");"); - } else if (CB_REFERENCE_P(x) && CB_REFERENCE(x)->length) { + if (size <= 0 || + (CB_REFERENCE_P(x) && CB_REFERENCE(x)->length)) { output (", %d, ", c); output_size (x); output (");"); - } else if (!gen_init_working + } else if (!gen_init_working && (f->flag_unbounded || !(cb_complex_odo || cb_odoslide)) && chk_field_variable_size (f) != NULL) { output (", %d, ", c); diff --git a/cobc/config.def b/cobc/config.def index efa9120c2..61f1b78c2 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -445,3 +445,6 @@ CB_CONFIG_SUPPORT (cb_self_call_recursive, "self-call-recursive", CB_CONFIG_SUPPORT (cb_record_contains_depending_clause, "record-contains-depending-clause", _("DEPENDING clause in RECORD CONTAINS")) + +CB_CONFIG_SUPPORT (cb_picture_l, "picture-l", + _("PICTURE string with 'L' character")) diff --git a/cobc/field.c b/cobc/field.c index c8fe36e4f..f94d8a206 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -940,7 +940,7 @@ copy_into_field (struct cb_field *source, struct cb_field *target) "LIKE", cb_get_usage_string (target->usage)); target->flag_invalid = 1; } - + #if 0 /* TODO, also syntax-check for usage here */ if (target->cat is_numeric) { sprintf (pic, "9(%d)", size_implied); @@ -1179,7 +1179,7 @@ create_implicit_picture (struct cb_field *f) ret = 1; } } - + /* Checkme: should we raise an error for !cb_relaxed_syntax_checks? */ if (!ret) { cb_warning_x (cb_warn_additional, x, _("defining implicit picture size %d for '%s'"), @@ -1312,6 +1312,7 @@ validate_occurs (const struct cb_field * const f) /* The data item that contains a OCCURS DEPENDING clause shall not be subordinate to a data item that has an OCCURS clause */ for (p = f->parent; p; p = p->parent) { + if (p->flag_picture_l) continue; if (p->flag_occurs) { cb_error_x (CB_TREE (p), _("'%s' cannot have an OCCURS clause due to '%s'"), @@ -1346,10 +1347,11 @@ validate_redefines (const struct cb_field * const f) } /* Check variable occurrence */ - if (f->depending || 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 (cb_field_variable_size (f->redefines)) { + if (!f->redefines->flag_picture_l && cb_field_variable_size (f->redefines)) { cb_error_x (x, _("the original definition '%s' cannot be variable length"), f->redefines->name); } @@ -1366,10 +1368,18 @@ validate_group (struct cb_field *f) group_error (x, "PICTURE"); } if (f->flag_justified) { - group_error (x, "JUSTIFIED RIGHT"); + if (!f->flag_picture_l) + group_error (x, "JUSTIFIED RIGHT"); + else + cb_error_x (x, _("'%s' cannot have JUSTIFIED RIGHT clause"), + cb_name (x)); } if (f->flag_blank_zero) { - group_error (x, "BLANK WHEN ZERO"); + if (!f->flag_picture_l) + group_error (x, "BLANK WHEN ZERO"); + else + cb_error_x (x, _("'%s' cannot have BLANK WHEN ZERO clause"), + cb_name (x)); } if (f->storage == CB_STORAGE_SCREEN && @@ -2336,6 +2346,7 @@ validate_field_1 (struct cb_field *f) validate_occurs (f); } + if (f->level == 66) { /* no check for redefines here */ return 0; @@ -2861,7 +2872,7 @@ compute_size (struct cb_field *f) } /* Ensure items within OCCURS are aligned correctly. */ - if (f->occurs_max > 1 + if (f->occurs_max > 1 && occur_align_size > 1 && (size_check % occur_align_size) != 0) { pad = occur_align_size - (size_check % occur_align_size); @@ -3094,7 +3105,14 @@ validate_field_value (struct cb_field *f) { if (f->values) { if (f->usage != CB_USAGE_CONTROL) { - validate_move (CB_VALUE (f->values), CB_TREE (f), 1, NULL); + if (f->flag_picture_l) { + cb_error_x (CB_TREE (f), + _("%s and %s are mutually exclusive"), + _("variable-length PICTURE"), "VALUE"); + f->values = NULL; + } else { + validate_move (CB_VALUE (f->values), CB_TREE (f), 1, NULL); + } } else { /* CHECK: possibly add validation according to control type */ } diff --git a/cobc/parser.y b/cobc/parser.y index 415490a88..c2f700e19 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -237,7 +237,7 @@ static enum key_clause_type key_type; static int ext_dyn_specified; static enum cb_assign_device assign_device; - + static enum cb_display_type display_type; static int is_first_display_item; static cb_tree advancing_value; @@ -1927,7 +1927,7 @@ check_not_88_level (cb_tree x) /* invalidate field to prevent same error in typeck.c (validate_one) */ /* FIXME: If we really need the additional check here then we missed a call to cb_validate_one() somewhere */ - return cb_error_node; + return cb_error_node; #endif } else { return x; @@ -3660,7 +3660,7 @@ program_id_paragraph: setup_prototype ($3, $4, COB_MODULE_TYPE_PROGRAM, 1); - + if ($5) { if (!current_program->nested_level) { cb_error (_("COMMON may only be used in a contained program")); @@ -3669,7 +3669,7 @@ program_id_paragraph: cb_add_common_prog (current_program); } } - + /* TODO: do that more clean, this and above was only moved here to fix a shift/reduce conflict with program prototype */ if (save_tree == cb_int1) { @@ -5036,7 +5036,7 @@ file_control_entry: SELECT flag_optional undefined_word { char buff[COB_MINI_BUFF]; - + check_headers_present (COBC_HD_ENVIRONMENT_DIVISION, COBC_HD_INPUT_OUTPUT_SECTION, COBC_HD_FILE_CONTROL, 0); @@ -7435,31 +7435,75 @@ volatile_clause: picture_clause: PICTURE /* token from scanner, includes full picture definition */ - _pic_locale_format { check_repeated ("PICTURE", SYN_CLAUSE_4, &check_pic_duplicate); current_field->pic = CB_PICTURE ($1); /* always returned, invalid picture will have size == 0 */ - - if (CB_VALID_TREE ($2)) { - if ( (current_field->pic->category != CB_CATEGORY_NUMERIC - && current_field->pic->category != CB_CATEGORY_NUMERIC_EDITED) - || strpbrk (current_field->pic->orig, " CRDB-*") /* the standard seems to forbid also ',' */) { - cb_error_x ($1, _("a locale-format PICTURE string must only consist of '9', '.', '+', 'Z' and the currency-sign")); - } else { - /* TODO: check that not we're not within a CONSTANT RECORD */ - CB_PENDING_X ($1, "locale-format PICTURE"); - } - } + } + _pic_locale_format_or_depending_on + { + if ((!current_field->pic || current_field->pic->variable_length) && + !current_field->flag_picture_l) { + /* Current field with PIC L was not translated */ + cb_error_x (CB_TREE (current_field->pic), + _("%s requires DEPENDING clause"), + _("variable-length PICTURE")); + } } ; -_pic_locale_format: +_pic_locale_format_or_depending_on: /* empty */ - { $$ = NULL; } | LOCALE _is_locale_name SIZE _is integer { - /* $2 -> optional locale-name to be used */ - $$ = $5; + /* $2 -> optional locale-name to be used */ + if ((current_field->pic->category != CB_CATEGORY_NUMERIC && + current_field->pic->category != CB_CATEGORY_NUMERIC_EDITED) || + strpbrk (current_field->pic->orig, " CRDBL-*") /* the standard seems to forbid also ',' */) { + cb_error_x (CB_TREE (current_field->pic), + _("a locale-format PICTURE string must only consist of '9', '.', '+', 'Z' and the currency-sign")); + } else { + /* TODO: check that not we're not within a CONSTANT RECORD */ + CB_PENDING_X (CB_TREE (current_field->pic), "locale-format PICTURE"); + } + } +| DEPENDING _on reference + { + cb_tree depending = $3; + if (!current_field->pic->variable_length) { + cb_error_x ($3, _("DEPENDING clause needs either an " + "OCCURS clause or a variable-length " + "PICTURE")); + } else if (current_field->pic->category != CB_CATEGORY_ALPHABETIC && + current_field->pic->category != CB_CATEGORY_ALPHANUMERIC) { + cb_error_x ($3, _("only USAGE DISPLAY may specify a " + "variable-length PICTURE")); + } else if (current_storage == CB_STORAGE_SCREEN || + current_storage == CB_STORAGE_REPORT) { + cb_error_x ($3, _("%s not allowed in %s"), + _("variable-length PICTURE"), + enum_explain_storage (current_storage)); + } else { + /* Implicitly translate `PIC Lc... DEPENDING N` (where + `c` may actually only be `X` or `A`) into a group + with a single sub-field `PIC c OCCURS 1 TO N`. */ + const char pic[2] = { current_field->pic->orig[1], 0}; + struct cb_field * const chld = + CB_FIELD (cb_build_field (cb_build_filler ())); + chld->pic = cb_build_picture (pic); + chld->storage = current_field->storage; + chld->depending = depending; + chld->flag_occurs = 1; + chld->occurs_min = 1; + chld->occurs_max = current_field->pic->size - 1; + chld->parent = current_field; + current_field->children = chld; + cobc_parse_free (current_field->pic); + current_field->pic = NULL; + } + /* Raise this flag in the error cases above, to avoid unrelated + warning or error messages upon tentative validation of + redefines. */ + current_field->flag_picture_l = 1; } ; @@ -7474,7 +7518,6 @@ _is_locale_name: } ; - locale_name: WORD { @@ -7487,7 +7530,6 @@ locale_name: } ; - /* TYPE TO clause, optional "TO", fixed to clean conflicts for screen-items */ type_to_clause: @@ -10339,7 +10381,7 @@ procedure_division: current_program->entry_convention = cb_int (CB_CONV_COBOL); } header_check |= COBC_HD_PROCEDURE_DIVISION; - + cb_check_definition_matches_prototype (current_program); } _procedure_declaratives @@ -11406,7 +11448,7 @@ accp_attr: if (current_program->cursor_pos) { emit_duplicate_clause_message ("CURSOR"); } else { - /* TODO: actually reasonable and easy extension: an + /* TODO: actually reasonable and easy extension: an *offset within the field* [auto-correct to 1/max] (when variable also stored back on return) */ @@ -13865,7 +13907,7 @@ goback_statement: GOBACK { begin_statement (STMT_GOBACK, 0); } - goback_exit_body + goback_exit_body { check_unreached = 1; cb_emit_exit (1U); @@ -15323,7 +15365,7 @@ send_body_mcs: _to FIXME - workaround: expeciting TO here */ TO - x from_identifier + x from_identifier /* FIXME: conflict because the RETURNING could belong to the exception phrases _common_exception_phrases FIXME - workaround end */ @@ -15361,7 +15403,7 @@ from_identifier: { } ; - + /* FIXME later: too many conflicts here _send_raising: %prec SHIFT_PREFER diff --git a/cobc/tree.c b/cobc/tree.c index a26340333..a662bfeaa 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -2946,6 +2946,20 @@ find_floating_insertion_str (const cob_pic_symbol *str, *last = str - 1; } +/* Number of character types in picture strings */ +/* + The 25 character types are: + B , . + + + CR cs cs Z Z + + cs cs 9 A L S V P P 1 N E + 0 - - DB * * - - X + / + Duplicates indicate floating/non-floating insertion symbols and/or left/right + of decimal point positon. +*/ +#define CB_PIC_CHAR_TYPES 25 +#define CB_FIRST_NON_P_DIGIT_CHAR_TYPE 9 +#define CB_LAST_NON_P_DIGIT_CHAR_TYPE 15 +#define CB_PIC_S_CHAR_TYPE 18 + static int char_to_precedence_idx (const cob_pic_symbol *str, const cob_pic_symbol *current_sym, @@ -3018,27 +3032,30 @@ char_to_precedence_idx (const cob_pic_symbol *str, case 'X': return 16; - case 'S': + case 'L': return 17; - case 'V': + case 'S': return 18; + case 'V': + return 19; + case 'P': if (non_p_digits_seen && before_decimal_point) { - return 19; - } else { return 20; + } else { + return 21; } case '1': - return 21; + return 22; case 'N': - return 22; + return 23; case 'E': - return 23; + return 24; default: if (current_sym->symbol == current_program->currency_symbol) { @@ -3116,18 +3133,20 @@ get_char_type_description (const int idx) case 16: return _("A or X"); case 17: - return "S"; + return "L"; case 18: - return "V"; + return "S"; case 19: - return _("a P which is before the decimal point"); + return "V"; case 20: - return _("a P which is after the decimal point"); + return _("a P which is before the decimal point"); case 21: - return "1"; + return _("a P which is after the decimal point"); case 22: - return "N"; + return "1"; case 23: + return "N"; + case 24: return "E"; default: return NULL; @@ -3155,42 +3174,46 @@ emit_precedence_error (const int preceding_idx, const int following_idx) static int valid_char_order (const cob_pic_symbol *str, const int s_char_seen) { - static int precedence_table[24][24] = { + static int precedence_table[CB_PIC_CHAR_TYPES][CB_PIC_CHAR_TYPES] = { /* Refer to the standard's PICTURE clause precedence rules for complete explanation. + + The entries for character `L' are based on the GCOS7 reference + manual. */ - /* - B , . + + + CR cs cs Z Z + + cs cs 9 A S V P P 1 N E - 0 - - DB * * - - X - / - */ - /* B */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0 }, - /* , */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 0, 0 }, - /* . */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* + */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 }, - /* + */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* + */ { 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0 }, - /* C */ { 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0 }, - /* $ */ { 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* $ */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 1, 1, 1, 0, 0, 0 }, - /* Z */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* Z */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0 }, - /* + */ { 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* + */ { 1, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0 }, - /* $ */ { 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* $ */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0 }, - /* 9 */ { 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 0, 1, 0, 0, 1 }, - /* X */ { 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0 }, - /* S */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* V */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0 }, - /* P */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0 }, - /* P */ { 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0 }, - /* 1 */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 }, - /* N */ { 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 }, - /* E */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* + B , . + + + CR cs cs Z Z + + cs cs 9 A L S V P P 1 N E + 0 - - DB * * - - X + / + */ + /* B */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0 }, + /* , */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0 }, + /* . */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* + */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 }, + /* + */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* + */ { 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0 }, + /* C */ { 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0 }, + /* $ */ { 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* $ */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0 }, + /* Z */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* Z */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0 }, + /* + */ { 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* + */ { 1, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0 }, + /* $ */ { 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* $ */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0 }, + /* 9 */ { 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 0, 0, 1 }, + /* X */ { 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0 }, + /* L */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* S */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* V */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0 }, + /* P */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0 }, + /* P */ { 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0 }, + /* 1 */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 }, + /* N */ { 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 }, + /* E */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, }; - int error_emitted[24][24] = {{ 0 }}; - int chars_seen[24] = { 0 }; + int error_emitted[CB_PIC_CHAR_TYPES][CB_PIC_CHAR_TYPES] = {{ 0 }}; + int chars_seen[CB_PIC_CHAR_TYPES] = { 0 }; const cob_pic_symbol *first_floating_sym; const cob_pic_symbol *last_floating_sym; int before_decimal_point = 1; @@ -3201,7 +3224,7 @@ valid_char_order (const cob_pic_symbol *str, const int s_char_seen) int non_p_digits_seen = 0; int error_detected = 0; - chars_seen[17] = s_char_seen; + chars_seen[CB_PIC_S_CHAR_TYPE] = s_char_seen; find_floating_insertion_str (str, &first_floating_sym, &last_floating_sym); k=0; @@ -3217,7 +3240,8 @@ valid_char_order (const cob_pic_symbol *str, const int s_char_seen) non_p_digits_seen); if (idx == -1) { continue; - } else if (9 <= idx && idx <= 15) { + } else if (CB_FIRST_NON_P_DIGIT_CHAR_TYPE <= idx && + idx <= CB_LAST_NON_P_DIGIT_CHAR_TYPE) { non_p_digits_seen = 1; } @@ -3226,7 +3250,7 @@ valid_char_order (const cob_pic_symbol *str, const int s_char_seen) character it is not allowed to. Display an error once for each combination detected. */ - for (j = 0; j < 24; ++j) { + for (j = 0; j < CB_PIC_CHAR_TYPES; ++j) { if (chars_seen[j] && !precedence_table[idx][j] && !error_emitted[idx][j]) { @@ -3571,6 +3595,16 @@ cb_build_picture (const char *str) x_digits += n; break; + case 'L': + pic->variable_length = 1; + (void) cb_verify (cb_picture_l, + _("PICTURE string with 'L' character")); + if (idx != 0) { + cb_error (_("L must be at start of PICTURE string")); + error_detected = 1; + } + break; + case 'S': category |= PIC_NUMERIC; if (s_count <= 1) { @@ -4204,6 +4238,8 @@ cb_field_variable_size (const struct cb_field *f) for (fc = f->children; fc; fc = fc->sister) { if (fc->depending) { return fc; + } else if (fc->flag_picture_l) { + continue; } else if ((p = cb_field_variable_size (fc)) != NULL) { return p; } @@ -4220,7 +4256,8 @@ cb_field_variable_address (const struct cb_field *fld) f = fld; for (p = f->parent; p; f = f->parent, p = f->parent) { for (p = p->children; p != f; p = p->sister) { - if (p->depending || cb_field_variable_size (p)) { + if (p->depending || + (!p->flag_picture_l && cb_field_variable_size (p))) { return 1; } } @@ -5048,7 +5085,7 @@ finalize_file (struct cb_file *f, struct cb_field *records) } } } - + /* Validate and set max and min record size */ for (p = records; p; p = p->sister) { if (f->organization == COB_ORG_INDEXED diff --git a/cobc/tree.h b/cobc/tree.h index fc7abd3f6..a8493bb6a 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -797,6 +797,7 @@ struct cb_picture { cob_u32_t have_sign; /* Have 'S' */ unsigned int flag_is_calculated : 1; /* is calculated */ unsigned int flag_has_p : 1; /* Has PPs in PICTURE */ + unsigned int variable_length : 1; /* Starts with 'L' */ }; #define CB_PICTURE(x) (CB_TREE_CAST (CB_TAG_PICTURE, struct cb_picture, x)) @@ -993,7 +994,7 @@ struct cb_field { unsigned int flag_is_typedef : 1; /* TYPEDEF */ unsigned int flag_occurs_values: 1; /* OCCURS and multi VALUEs done */ - + unsigned int flag_picture_l : 1; /* Is USAGE PICTURE L */ }; #define CB_FIELD(x) (CB_TREE_CAST (CB_TAG_FIELD, struct cb_field, x)) diff --git a/cobc/typeck.c b/cobc/typeck.c index 67086252d..e01d56a8a 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2439,6 +2439,14 @@ cb_build_identifier (cb_tree x, const int subchk) for (p = f; p; p = p->children) { if (p->depending && p->depending != cb_error_node + /* Do not check length for implicit access + to a PIC L field (i.e, via enclosing + group), as those disregard the DEPENDING. + However, assuming the filler is never + explicitly accessed (p == f), check is + still done for explicit access to PIC L + field (p->parent == f). */ + && (p->parent == f || !p->parent->flag_picture_l) && !p->flag_unbounded) { e1 = cb_add_check_odo (p); if (e1 != NULL) { @@ -2970,7 +2978,7 @@ cb_build_length (cb_tree x) if (f->flag_any_length) { return cb_build_any_intrinsic (CB_LIST_INIT (x)); } - if (cb_field_variable_size (f) == NULL) { + if (f->flag_picture_l || cb_field_variable_size (f) == NULL) { sprintf (buff, FMT_LEN, cb_field_size (x)); return cb_build_numeric_literal (0, buff, 0); } @@ -4732,7 +4740,7 @@ cb_validate_program_data (struct cb_program *prog) /* Check ODO items */ for (l = cb_depend_check; l; l = CB_CHAIN (l)) { struct cb_field *depfld = NULL; - unsigned int odo_level = 0; + unsigned int odo_level = 0, parent_is_pic_l; cb_tree xerr = NULL; x = CB_VALUE (l); if (x == NULL || x == cb_error_node) { @@ -4754,12 +4762,17 @@ cb_validate_program_data (struct cb_program *prog) } } } + /* Direct parent being PIC L means we are checking an implicit + FILLER with ODO: this permits nested ODO and further sister + fields. */ + parent_is_pic_l = q->parent && q->parent->flag_picture_l; /* The data item that contains a OCCURS DEPENDING clause must be the last data item in the group */ for (p = q; ; p = p->parent) { if (p->depending) { if (odo_level > 0 - && !cb_odoslide) { + && !cb_odoslide + && !parent_is_pic_l) { xerr = x; cb_error_x (x, _("'%s' cannot have nested OCCURS DEPENDING"), @@ -4782,6 +4795,7 @@ cb_validate_program_data (struct cb_program *prog) if (!p->sister->redefines) { if (!cb_odoslide && !cb_complex_odo + && !parent_is_pic_l && x != xerr) { xerr = x; cb_error_x (x, @@ -7543,19 +7557,28 @@ emit_move_corresponding (cb_tree x1, cb_tree x2) found = 0; for (f1 = CB_FIELD_PTR (x1)->children; f1; f1 = f1->sister) { - if (!f1->redefines && !f1->flag_occurs) { - for (f2 = CB_FIELD_PTR (x2)->children; f2; f2 = f2->sister) { - if (!f2->redefines && !f2->flag_occurs) { - if (strcmp (f1->name, f2->name) == 0) { - t1 = cb_build_field_reference (f1, x1); - t2 = cb_build_field_reference (f2, x2); - if (f1->children && f2->children) { - found += emit_move_corresponding (t1, t2); - } else { - cb_emit (cb_build_move (t1, t2)); - found++; - } - } + if (f1->redefines || f1->flag_occurs) continue; + for (f2 = CB_FIELD_PTR (x2)->children; f2; f2 = f2->sister) { + if (f2->redefines || f2->flag_occurs) continue; + if (strcmp (f1->name, f2->name) == 0) { + t1 = cb_build_field_reference (f1, x1); + t2 = cb_build_field_reference (f2, x2); + /* GCOS 7: Contrary to the documentation, + handling of PIC L fields in MOVE + CORRESPONDING ignores the DEPENDING var for + both sending and receiving fields. */ + if (f1->flag_picture_l) { + CB_REFERENCE (t1)->length = cb_int (f1->size); + } + if (f2->flag_picture_l) { + CB_REFERENCE (t2)->length = cb_int (f2->size); + } + if (f1->children && !f1->flag_picture_l && + f2->children && !f2->flag_picture_l) { + found += emit_move_corresponding (t1, t2); + } else { + cb_emit (cb_build_move (t1, t2)); + found++; } } } @@ -9974,6 +9997,9 @@ cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value, && CB_REFERENCE_P (x) && CB_REFERENCE (x)->subs == NULL && CB_REFERENCE (x)->length == NULL) { + /* GCOS 7: Contrary to what the documentation states, + PIC L fields are initialized up to length indicated + by DEPENDING var. */ cb_tree temp; struct cb_field *f; temp = cb_build_index (cb_build_filler (), NULL, 0, NULL); diff --git a/config/ChangeLog b/config/ChangeLog index 51b56e6aa..2e203da39 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -21,6 +21,10 @@ * general: set defaultbyte to "none" for standard COBOL, 32 to " " +2022-07-12 Nicolas Berthier + + * general: add option picture-l + 2022-07-12 Simon Sobisch * ibm-strict.conf, mvs-strict.conf, gcos-strict.conf, bs2000-strict.conf: diff --git a/config/acu-strict.conf b/config/acu-strict.conf index 1708b7eeb..00e66489c 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -281,6 +281,7 @@ record-contains-depending-clause: unconformable align-record: 4 align-opt: no defaultbyte: " " +picture-l: unconformable # use fixed word list, synonyms and exceptions specified there reserved-words: ACU diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index 50e6f8792..68b0a191d 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -278,6 +278,7 @@ record-contains-depending-clause: unconformable align-record: 8 align-opt: no defaultbyte: 0 # not verified yet, but likely to be as IBM +picture-l: unconformable # use fixed word list, synonyms and exceptions specified there reserved-words: BS2000 diff --git a/config/cobol2002.conf b/config/cobol2002.conf index b8998266a..ecd06bb6f 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -276,6 +276,7 @@ record-contains-depending-clause: unconformable align-record: 0 align-opt: no defaultbyte: none # "undefined" +picture-l: unconformable # archaic in COBOL2002 and currently not available as dialect features: # 1: MOVE of alphanumeric figurative constants to numeric items diff --git a/config/cobol2014.conf b/config/cobol2014.conf index 88763ff8e..cdaefc8c4 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -276,6 +276,7 @@ record-contains-depending-clause: unconformable align-record: 0 align-opt: no defaultbyte: none # "undefined" +picture-l: unconformable # use fixed word list, synonyms and exceptions specified there reserved-words: COBOL2014 diff --git a/config/cobol85.conf b/config/cobol85.conf index c80328182..164916366 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -276,6 +276,7 @@ record-contains-depending-clause: unconformable align-record: 0 align-opt: no defaultbyte: none # "undefined" +picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: # 1: All literal with numeric or numeric edited item diff --git a/config/default.conf b/config/default.conf index 4117cee6a..a6d1c52b4 100644 --- a/config/default.conf +++ b/config/default.conf @@ -298,6 +298,7 @@ record-contains-depending-clause: unconformable align-record: 0 align-opt: no defaultbyte: init +picture-l: ok # use complete word list; synonyms and exceptions are specified below reserved-words: default diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 38e3cb776..fe7041b15 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -278,6 +278,7 @@ record-contains-depending-clause: obsolete align-record: 0 # TODO: verify align-opt: no # TODO: verify defaultbyte: 0 +picture-l: ok # use fixed word list, synonyms and exceptions specified there reserved-words: GCOS diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 7de96d8d2..be8d99075 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -275,6 +275,7 @@ record-contains-depending-clause: unconformable align-record: 8 align-opt: yes defaultbyte: 0 +picture-l: unconformable # use fixed word list, synonyms and exceptions specified there reserved-words: IBM diff --git a/config/lax.conf-inc b/config/lax.conf-inc index 96039f63c..7a781ce0b 100644 --- a/config/lax.conf-inc +++ b/config/lax.conf-inc @@ -138,6 +138,7 @@ assign-ext-dyn: ok assign-disk-from: ok vsam-status: +ignore self-call-recursive: skip +picture-l: +warning # use complete word list diff --git a/config/mf-strict.conf b/config/mf-strict.conf index 621e071ac..724f5328b 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -279,6 +279,7 @@ record-contains-depending-clause: unconformable align-record: 8 align-opt: yes defaultbyte: " " +picture-l: unconformable # use fixed word list, synonyms and exceptions specified there reserved-words: MF diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index 2519c6c35..080776816 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -275,6 +275,7 @@ record-contains-depending-clause: unconformable align-record: 8 align-opt: yes defaultbyte: 0 # not verified yet, but likely to be as IBM +picture-l: unconformable # use fixed word list, synonyms and exceptions specified there reserved-words: MVS diff --git a/config/realia-strict.conf b/config/realia-strict.conf index a5789d6a4..fba431901 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -281,6 +281,7 @@ record-contains-depending-clause: unconformable align-record: 0 align-opt: no defaultbyte: " " # not verified, but possibly like ACU/MF +picture-l: unconformable # use fixed word list, synonyms and exceptions specified there reserved-words: realia diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 47878c71a..af9bbe4fb 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -282,6 +282,7 @@ record-contains-depending-clause: unconformable align-record: 4 align-opt: no defaultbyte: " " # not verified, but possibly like ACU/MF +picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: # 1: All literal with numeric or numeric edited item diff --git a/config/xopen.conf b/config/xopen.conf index 0d450e97b..dd6439636 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -286,6 +286,7 @@ record-contains-depending-clause: obsolete align-record: 0 align-opt: no defaultbyte: none # "not specifically defined in Standard COBOL" +picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: # 1: All literal with numeric or numeric edited item diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index eece758a3..944bcda79 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -409,7 +409,7 @@ name: "Empty Conf" ]) # check if incomplete configuration result in error -AT_CHECK([$COMPILE_ONLY -conf=test.conf prog.cob], [97], [], +AT_CHECK([$COMPILE_ONLY -fmax-errors=132 -conf=test.conf prog.cob], [1], [], [configuration error: test.conf: missing definitions: no definition of 'reserved-words' @@ -540,9 +540,7 @@ test.conf: missing definitions: no definition of 'vsam-status' no definition of 'self-call-recursive' no definition of 'record-contains-depending-clause' -cobc: too many errors - -cobc: aborting + no definition of 'picture-l' ]) AT_CLEANUP diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index 28c788a1c..795a46921 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -5979,7 +5979,6 @@ Using PIC 9(4) COMP-5 AT_CLEANUP - AT_SETUP([GCOS floating-point usages]) AT_KEYWORDS([gcos]) @@ -6017,3 +6016,378 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], ], []) AT_CLEANUP + + +AT_SETUP([PICTURE L]) +AT_KEYWORDS([extensions gcos picture-l odo]) + +# Basic behaviors + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 W-DATA. + 2 X-DAT PICTURE LX(10) DEPENDING ON LGX. + 2 X-ALPHA PICTURE LA(10) DEPENDING ON LGX. + 2 Y-DAT PICTURE LX(9) DEPENDING ON LGY. + 2 Y-ALPHA PICTURE LA(9) DEPENDING ON LGY. + 1 W-NESTED. + 2 X-GRP. + 3 X-0 PICTURE X VALUE "0". + 3 X-V PICTURE LX(10) DEPENDING ON LGX. + 3 X-1 PICTURE X VALUE "1". + 1 W-LGS. + 2 LGX USAGE COMP-1 VALUE 10. + 2 LGY PIC 9 VALUE 9. + 1 W-LEN USAGE COMP-1. + PROCEDURE DIVISION. + MAIN. + MOVE SPACES TO W-DATA + MOVE SPACES TO X-V + IF X-DAT NOT EQUAL " " OR + X-ALPHA NOT EQUAL " " OR + Y-DAT NOT EQUAL " " OR + Y-ALPHA NOT EQUAL " " + DISPLAY "GROUP INITIALIZATION WITH SPACES FAILED" + PERFORM SHOW-VARS + END-IF + MOVE 5 TO LGX + MOVE 1 TO LGY + IF W-DATA NOT EQUAL " " + DISPLAY "GROUP COMPARISON FAILED (W-DATA)" + PERFORM SHOW-VARS + END-IF + IF W-NESTED NOT EQUAL "0 1" OR + X-GRP NOT EQUAL W-NESTED OR + X-V NOT EQUAL " " + DISPLAY "GROUP COMPARISON FAILED (W-NESTED)" + PERFORM SHOW-VARS + END-IF + MOVE ".........." TO X-DAT + MOVE "XXXXXXXXXX" TO X-ALPHA + MOVE "999999999" TO Y-DAT + MOVE "AAAAAAAAA" TO Y-ALPHA + IF X-DAT NOT EQUAL "....." OR + X-ALPHA NOT EQUAL "XXXXX" OR + Y-DAT NOT EQUAL "9" OR + Y-ALPHA NOT EQUAL "A" + DISPLAY "MOVES FROM LITERALS FAILED" + PERFORM SHOW-VARS + END-IF + MOVE X-DAT TO Y-DAT + MOVE Y-ALPHA TO X-ALPHA + IF X-DAT NOT EQUAL "....." OR + X-ALPHA NOT EQUAL "A " OR + Y-DAT NOT EQUAL "." OR + Y-ALPHA NOT EQUAL "A" + DISPLAY "MOVES FROM/TO VARS FAILED" + PERFORM SHOW-VARS + END-IF + MOVE "AAAAA" TO X-ALPHA + MOVE 1 TO LGX + INITIALIZE X-ALPHA + MOVE 10 TO LGX + IF X-ALPHA NOT EQUAL " AAAA " + DISPLAY "DIRECT VAR INITIALIZATION FAILED" + PERFORM SHOW-VARS + END-IF + MOVE 1 TO LGX + COMPUTE W-LEN = LENGTH OF X-DAT + IF W-LEN NOT EQUAL 10 + DISPLAY "UNEXPECTED RESULT FOR 'LENGTH OF X-DAT': " + W-LEN + PERFORM SHOW-VARS + END-IF + COMPUTE W-LEN = FUNCTION LENGTH (X-ALPHA) + IF W-LEN NOT EQUAL 1 + DISPLAY "UNEXPECTED RESULT FOR 'FUNCTION LENGTH " + "(X-ALPHA)': " W-LEN + PERFORM SHOW-VARS + END-IF + MOVE 9 TO LGY + MOVE ALL "A" TO Y-ALPHA + MOVE 5 TO LGY + INITIALIZE Y-ALPHA + MOVE 9 TO LGY + IF Y-ALPHA NOT EQUAL " AAAA" + DISPLAY "UNEXPECTED RESULT AFTER 'MOVE ALL/INITIALIZE': " + Y-ALPHA + PERFORM SHOW-VARS + END-IF + STOP RUN + . + SHOW-VARS. + DISPLAY W-DATA "*" + DISPLAY X-DAT "*" X-ALPHA "*" Y-DAT "*" Y-ALPHA "*" + DISPLAY W-NESTED "*" + DISPLAY X-GRP "*" + DISPLAY X-V "*" + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], []) +AT_CHECK([$COMPILE -fodoslide -o prog-x prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog-x], [0], []) + +# under/over shoot + +AT_DATA([under.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. under. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 X PICTURE LX(9) DEPENDING ON LGX. + 1 LGX PIC 9 VALUE 9. + PROCEDURE DIVISION. + MAIN. + MOVE 0 TO LGX + DISPLAY X + STOP RUN + . +]) +AT_CHECK([$COMPILE under.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./under], [1], [], +[libcob: under.cob:11: error: OCCURS DEPENDING ON 'LGX' out of bounds: 0 +note: minimum subscript for 'FILLER 1': 1 +]) +AT_CHECK([$COMPILE -fodoslide -o under-x under.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./under-x], [1], [], +[libcob: under.cob:11: error: OCCURS DEPENDING ON 'LGX' out of bounds: 0 +note: minimum subscript for 'FILLER 1': 1 +]) + +AT_DATA([over.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. over. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 X PICTURE LX(5) DEPENDING ON LGX. + 1 LGX PIC 9 VALUE 9. + PROCEDURE DIVISION. + MAIN. + DISPLAY X + STOP RUN + . +]) +AT_CHECK([$COMPILE over.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./over], [1], [], +[libcob: over.cob:10: error: OCCURS DEPENDING ON 'LGX' out of bounds: 9 +note: maximum subscript for 'FILLER 1': 5 +]) +AT_CHECK([$COMPILE -fodoslide -o over-x over.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./over-x], [1], [], +[libcob: over.cob:10: error: OCCURS DEPENDING ON 'LGX' out of bounds: 9 +note: maximum subscript for 'FILLER 1': 5 +]) + +# MOVE CORRESPONDING + +AT_DATA([corr.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. corr. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 W-DATA. + 2 GA. + 3 X PICTURE X VALUE "X". + 3 YZ PICTURE XX VALUE "YZ". + 3 X1 PICTURE LX(5) DEPENDING ON LGX. + 2 GB. + 3 X1 PICTURE LX(5) DEPENDING ON LGX. + 3 X PICTURE X VALUE SPACE. + 2 GC. + 3 X1 PICTURE X(5) VALUE "+++++". + 1 LGX USAGE COMP-1 VALUE 5. + 1 CNT USAGE COMP-1. + PROCEDURE DIVISION. + MAIN. + MOVE "AAAAA" TO X1 OF GA + MOVE "BBBBB" TO X1 OF GB + IF X1 OF GA NOT EQUAL "AAAAA" OR + X1 OF GB NOT EQUAL "BBBBB" + DISPLAY "GLOBAL INITIALIZATION FAILED" + PERFORM SHOW-VARS + END-IF + MOVE 2 TO LGX + IF W-DATA NOT EQUAL "XYZAAAAABBBBB +++++" + DISPLAY "GROUP COMPARISON FAILED" + DISPLAY GA + PERFORM SHOW-VARS + END-IF + * From basic to pic-l field: curr size should be ignored + MOVE CORRESPONDING GC TO GA + IF X1 OF GA NOT EQUAL "++" OR + GA NOT EQUAL "XYZ+++++" + DISPLAY "MOVE CORRESPONDING GC TO GA: FAILED" + PERFORM SHOW-VARS + END-IF + * From pic-l to basic field: curr. size is ignored + MOVE CORRESPONDING GB TO GC + INSPECT X1 OF GC TALLYING CNT FOR ALL "B" + IF X1 OF GC NOT EQUAL "BBBBB" OR + CNT NOT EQUAL 5 + DISPLAY "MOVE CORRESPONDING GB TO GC: FAILED" + PERFORM SHOW-VARS + END-IF + * From pic-l to pic-l: sizes are ignored + MOVE CORRESPONDING GA TO GB + MOVE 0 TO CNT + INSPECT X1 OF GB TALLYING CNT FOR ALL "+" + MOVE 5 TO LGX + IF X1 OF GB NOT EQUAL "+++++" OR + X OF GB NOT EQUAL "X" OR + CNT NOT EQUAL 2 + DISPLAY "MOVE CORRESPONDING GA TO GB: FAILED" + PERFORM SHOW-VARS + END-IF + STOP RUN + . + SHOW-VARS. + DISPLAY "LGX: " LGX + DISPLAY "W-DATA: *" W-DATA "*" + DISPLAY "CNT: " CNT + . +]) + +AT_CHECK([$COMPILE corr.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./corr], [0], []) +AT_CHECK([$COMPILE -fodoslide -o corr-x corr.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./corr-x], [0], []) + +# OCCURS ... PIC L ... + +AT_DATA([nested.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. nested. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 W-DATA. + 2 A OCCURS 4 + PICTURE LX(3) DEPENDING ON LGX. + 2 B OCCURS 1 TO 10 DEPENDING ON LGY + PICTURE LX(3) DEPENDING ON LGX. + 1 LGX USAGE COMP-1 VALUE 3. + 1 LGY USAGE COMP-1 VALUE 4. + PROCEDURE DIVISION. + MAIN. + MOVE "AAAAAAAAAAAABBBBBBBBBBBB" TO W-DATA + IF W-DATA NOT EQUAL "AAAAAAAAAAAABBBBBBBBBBBB" OR + A (1) NOT EQUAL "AAA" + DISPLAY "GLOBAL INITIALIZATION FAILED" + DISPLAY A (1) + PERFORM SHOW-VARS + END-IF + MOVE "CCC" TO A (4) + IF W-DATA NOT EQUAL "AAAAAAAAACCCBBBBBBBBBBBB" OR + A (4) NOT EQUAL "CCC" + DISPLAY "MOVE TO A (4) FAILED" + DISPLAY A (4) + PERFORM SHOW-VARS + END-IF + MOVE A (3) TO B (2) + IF W-DATA NOT EQUAL "AAAAAAAAACCCBBBAAABBBBBB" OR + B (2) NOT EQUAL "AAA" + DISPLAY "MOVE A (3) TO B (2) FAILED" + DISPLAY B (2) + PERFORM SHOW-VARS + END-IF + MOVE 6 TO LGY + MOVE 2 TO LGX + * Operand of 'INITIALIZE' may not have 'OCCURS DEPENDING ON': + * INITIALIZE B (5) + MOVE SPACES TO B (5) + * *> NO ODOSLIDE: W-DATA EQUAL "AAAAAAAAACCCBBBAAABBBBBB " + * *> ODOSLIDE: W-DATA EQUAL "AAAAAAAAACCCBBBAAABB" + IF A (3) NOT EQUAL "AA" OR + A (4) NOT EQUAL "CC" OR + B (4) NOT EQUAL "BB" OR + B (5) NOT EQUAL " " + DISPLAY "MOVE 2,6 TO LGX,Y; INITIALIZE B (5); FAILED" + PERFORM SHOW-VARS + END-IF + STOP RUN + . + SHOW-VARS. + DISPLAY "W-DATA: *" W-DATA "*" + DISPLAY "LGX: " LGX + DISPLAY "LGY: " LGY + . +]) + +AT_CHECK([$COMPILE nested.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./nested], [0], []) +AT_CHECK([$COMPILE -fodoslide -o nested-x nested.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./nested-x], [0], []) + +# REDEFINES + +AT_DATA([redefines.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. redefines. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 W-DATA. + 2 UNUSED-1 PIC X VALUE "?". + 2 X-DAT PICTURE X(10). + 2 Y1-DAT REDEFINES X-DAT PICTURE LX(5) DEPENDING ON LGY. + 2 Y2-DAT REDEFINES X-DAT PICTURE LX(5) DEPENDING ON LGY. + 2 UNUSED-2 PIC X VALUE "!". + 2 Z-DAT PICTURE LX(7) DEPENDING ON LGZ. + 2 T-DAT REDEFINES Z-DAT PICTURE LX(7) DEPENDING ON LGT. + 2 UNUSED-3 PIC X VALUE ".". + 1 W-LGS. + 2 LGX PIC 99 VALUE 10. + 2 LGY PIC 9 VALUE 5. + 2 LGZ PIC 9 VALUE 7. + 2 LGT PIC 9 VALUE 5. + PROCEDURE DIVISION. + MAIN. + MOVE "......." TO Z-DAT + MOVE 3 TO LGZ + MOVE "0123456789" TO X-DAT + IF Y1-DAT NOT EQUAL "01234" OR + Y2-DAT NOT EQUAL "01234" + DISPLAY "INITIAL MOVE FAILED" + PERFORM SHOW-VARS + END-IF + MOVE "0123456" TO Z-DAT. + IF T-DAT NOT EQUAL "012.." OR + Z-DAT NOT EQUAL "012" + DISPLAY "SECOND MOVE FAILED" + PERFORM SHOW-VARS + END-IF + * Initialize group containing PICTURE L field: curr. size should be ignored + MOVE 1 TO LGZ + INITIALIZE W-DATA + MOVE 7 TO LGT + IF T-DAT NOT EQUAL " " + DISPLAY "UNEXPECTED T-DAT AFTER 'INITIALIZE W-DATA': " + T-DAT + PERFORM SHOW-VARS + END-IF + * Initialize PICTURE L field: curr. size is ignored + MOVE "???????" TO T-DAT + INITIALIZE Z-DAT + MOVE 2 TO LGZ + IF T-DAT NOT EQUAL " ??????" OR + Z-DAT NOT EQUAL " ?" + DISPLAY "UNEXPECTED T-DAT/Z-DAT AFTER " + "'INITIALIZE Z-DAT': " T-DAT "/" Z-DAT "*" + PERFORM SHOW-VARS + END-IF + STOP RUN + . + SHOW-VARS. + DISPLAY X-DAT "*" Y1-DAT "*" Y2-DAT "*" T-DAT "*" Z-DAT "*" + . +]) + +AT_CHECK([$COMPILE redefines.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./redefines], [0], []) +AT_CHECK([$COMPILE -fodoslide -o redefines-x redefines.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./redefines-x], [0], []) + +AT_CLEANUP diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index d069a28f0..669e1a5ef 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -8862,3 +8862,96 @@ prog.cob:9: warning: DISPLAY statement in DEFAULT SECTION is not implemented AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) AT_CLEANUP + + +AT_SETUP([PICTURE L]) +AT_KEYWORDS([extensions gcos picture-l]) + +AT_DATA([prog_extraneous_depending.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog_extraneous_depending. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 L COMP-1. + 1 F-DAT PICTURE X(10) DEPENDING ON L. + PROCEDURE DIVISION. + MOVE SPACES TO F-DAT + STOP RUN. +]) +AT_CHECK([$COMPILE_ONLY prog_extraneous_depending.cob], [1], [], +[prog_extraneous_depending.cob:7: error: DEPENDING clause needs either an OCCURS clause or a variable-length PICTURE +]) + +AT_DATA([prog_missing_depending.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog_missing_depending. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 F-DAT PICTURE LX(10). + PROCEDURE DIVISION. + MOVE SPACES TO F-DAT + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog_missing_depending.cob], [1], [], +[prog_missing_depending.cob:6: error: variable-length PICTURE requires DEPENDING clause +]) + +AT_DATA([prog_value.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog_value. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 L COMP-1 VALUE 10. + 1 F-DAT PICTURE LX(10) DEPENDING ON L + VALUE "0123456789". + 1 F-DAT2 PICTURE LX(10) DEPENDING ON L + BLANK WHEN ZERO. + PROCEDURE DIVISION. + STOP RUN. +]) +AT_CHECK([$COMPILE_ONLY prog_value.cob], [1], [], +[prog_value.cob:7: error: variable-length PICTURE and VALUE are mutually exclusive +prog_value.cob:9: error: 'F-DAT2' cannot have BLANK WHEN ZERO clause +]) + +AT_DATA([prog_errs.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog_errs. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 W-LGS. + 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. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog_errs.cob], [1], [], +[prog_errs.cob:10: error: only USAGE DISPLAY may specify a variable-length PICTURE +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 +]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 LGS PICTURE X(10). + 1 L-DAT PICTURE LX(10) DEPENDING ON LGS. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY -fpicture-l=warning prog.cob], [0], [], +[prog.cob:7: warning: PICTURE string with 'L' character used +]) + +AT_CLEANUP