From 8a2a16ec35ef906a6359769c0b036cd0513c1ca7 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Sat, 11 Feb 2023 21:00:39 +0100 Subject: [PATCH 01/11] ATOS Patch rev 6 --- cobc/codegen.c | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/cobc/codegen.c b/cobc/codegen.c index 8c39850dd..c57ac028a 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -9682,6 +9682,21 @@ output_report_control (struct cb_report *p, int id, cb_tree ctl, cb_tree nx) if(nx) { output_report_control(p, id, nx, CB_CHAIN(nx)); } + bfound = 0; + for(i= p->num_lines-1; i >= 0; i--) { + if(p->line_ids[i]->report_control) { + struct cb_field *c = cb_code_field (p->line_ids[i]->report_control); + if(c == s) { + bfound = 1; + break; + } + } + } + if (!bfound) { + ctl = NULL; + p->controls = NULL; + return ; + } output_local("/* Report %s: CONTROL %s */\n",p->name,s->name); prvid = 0; for(i = 0; i < p->num_lines; i++) { From 2b3bd479d7936ec249d8a041eefcc4ed24052fb6 Mon Sep 17 00:00:00 2001 From: Nicolas Berthier Date: Thu, 27 Jan 2022 17:29:01 +0100 Subject: [PATCH 02/11] [GCOS] PR27 Support EBCDIC symbolic characters in alphanumeric literals (#8) * Support EBCDIC symbolic characters in alphanumeric literals * Do not error upon symbolic EBCDIC characters in literals for non-GCOS dialects * Decode EBCDIC character using machine character set [GCOS] fix EBCDIC symbolic-chars as ordinals (1..256 instead of 0..255) [GCOS] New test for EBCDIC symbolic-chars, and fix doc for related option [GCOS] Substitute `ebcdic-symbolic-characters` for `gcos-ebcdic-literals` Drop an unused warning in `cobc/scanner.l` [GCOS] Warn when EBCDIC symbolic character strings comprise extraneous separators Better test for symbolic EBCDIC characters; and fix ChangeLogs Honor -febcdic-table when decoding symbolic EBCDIC characters Fix in PR27 for new ebcdic-table options PR27 use symbolic enums --- cobc/ChangeLog | 8 ++ cobc/config.def | 3 + cobc/pplex.l | 4 +- cobc/scanner.l | 113 +++++++++++++++++++++++--- 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/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 | 1 + tests/testsuite.src/run_extensions.at | 71 ++++++++++++++++ 19 files changed, 200 insertions(+), 13 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 50606de37..f543a05c6 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -538,6 +538,14 @@ * typeck.c (validate_occurs): change level 01/77 check back to plain dialect verification fixing #854 +2022-10-05 Nicolas Berthier + + * scanner.l, config.def: Add support for EBCDIC symbolic characters in + alphanumeric literals, which is a GCOS-specific extension; add new + configuration option ebcdic-symbolic-characters + * scanner.l, pplex.l: detect and issue a warning when EBCDIC + symbolic character strings include extraneous separators + 2022-10-04 Nicolas Berthier * pplex.l, parser.y: fix AREACHECK in DEFAULT SECTION of CONTROL DIVISON diff --git a/cobc/config.def b/cobc/config.def index c69a68015..d4c9a3c5d 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -325,6 +325,9 @@ CB_CONFIG_SUPPORT (cb_hp_octal_literals, "hp-octal-literals", CB_CONFIG_SUPPORT (cb_acu_literals, "acu-literals", _("ACUCOBOL-GT literals (#B #O #H #X)")) +CB_CONFIG_BOOLEAN (cb_gcos_ebcdic_literals, "ebcdic-symbolic-characters", + _("EBCDIC symbolic characters in literals (\" \"135,151,151\"bar\"195, 194\"Z\" for \" foobarBAZ\")")) + CB_CONFIG_SUPPORT (cb_word_continuation, "word-continuation", _("continuation of COBOL words")) diff --git a/cobc/pplex.l b/cobc/pplex.l index a5ffd8c74..8d3796c84 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -190,7 +190,9 @@ static struct cb_text_list *pp_text_list_add (struct cb_text_list *, WORD [_0-9A-Z\x80-\xFF-]+ NUMRIC_LITERAL [+-]?[0-9,.]*[0-9] -ALNUM_LITERAL "\""[^""\n]*"\""|"\'"[^''\n]*"\'" +ALNUM_LITERAL_Q "\""([^""\n]|("\""[0-9][0-9, ]*"\""))*"\"" +ALNUM_LITERAL_A "\'"([^''\n]|("\'"[0-9][0-9, ]+"\'"))*"\'" +ALNUM_LITERAL {ALNUM_LITERAL_Q}|{ALNUM_LITERAL_A} SET_PAREN_LIT \([^()\n]*\) DEFNUM_LITERAL [+-]?[0-9]*[\.]*[0-9]+ diff --git a/cobc/scanner.l b/cobc/scanner.l index 2357ccc08..b2da3372d 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -141,6 +141,19 @@ struct cb_top_level_78 { struct cb_level_78 *lev_78_ptr; }; +enum cb_literal_type { + CB_LITERAL_DEFAULT, + CB_LITERAL_U, /* UTF-8, work-in-progress */ + CB_LITERAL_N, + CB_LITERAL_NC, +}; + +enum cb_sym_ebcdic_state { + CB_SYM_EBCDIC_INACTIVE, /* Outside */ + CB_SYM_EBCDIC_ACTIVE, /* Inside, before or after number */ + CB_SYM_EBCDIC_AFTER_SEP /* Inside, just after a separator */ +}; + /* Local variables */ static cb_tree last_yylval; static int last_token; @@ -160,7 +173,7 @@ static unsigned int inside_bracket = 0; static char err_msg[COB_MINI_BUFF]; /* Function declarations */ -static void read_literal (const char, const char *); +static void read_literal (const char, const enum cb_literal_type); static int scan_x (const char *, const char *); static int scan_z (const char *, const char *); static int scan_h (const char *, const char *); @@ -370,7 +383,7 @@ AREA_A \n"#AREA_A"\n [''""] { /* String literal */ cobc_force_literal = 0; - read_literal (yytext[0], ""); + read_literal (yytext[0], CB_LITERAL_DEFAULT); RETURN_TOK (LITERAL); } @@ -385,7 +398,7 @@ N[''""] { /* N national string literal */ cobc_force_literal = 0; /* TODO: national string - needs different handling */ - read_literal (yytext [1], "N"); + read_literal (yytext [1], CB_LITERAL_N); RETURN_TOK (LITERAL); } @@ -394,7 +407,7 @@ NC[''""] { same handling as COBOL 2002 national string literal) */ cobc_force_literal = 0; /* TODO: national string - needs different handling */ - read_literal (yytext [2], "NC"); + read_literal (yytext [2], CB_LITERAL_NC); RETURN_TOK (LITERAL); } @@ -409,7 +422,7 @@ U[''""] { /* N national string literal */ cobc_force_literal = 0; /* TODO: utf8 string - needs different handling */ - read_literal (yytext [1], "U"); + read_literal (yytext [1], CB_LITERAL_U); RETURN_TOK (LITERAL); } @@ -1303,12 +1316,51 @@ error_literal (const char *type, const char *literal, unsigned int literal_error cb_error ("%s", err_msg); } +/* Scans a symbolic EBCDIC character given as a sequence of decimal digits + starting with `c`, and returns the corresponding code as per the machine + character set (ASCII or EBCDIC). */ +static cob_u8_t +scan_ebcdic_char (int c) +{ + char buff[10]; /* Arbitrary limit, mostly for error-reporting */ +static cob_u8_t ebcdic_to_ascii[256] ; +static int ebcdic_to_ascii_initialized = 0 ; + + unsigned int j = 0; + do { + buff[j++] = c; + } while ((c = input ()) != EOF && '0' <= c && c <= '9' && j < 10); + unput (c); + buff[j++] = 0; + c = atoi (buff); + if (c < 1 || c >= 257) { + cb_error (_("symbolic character %s out of allowed EBCDIC range (1...256)"), + buff); + } + c--; // in ordinal, i.e. 1..256 -> 0..255 +#ifdef COB_EBCDIC_MACHINE + return (cob_u8_t) c; +#else + if( !ebcdic_to_ascii_initialized ){ + if (cob_load_collation (cb_ebcdic_table, + ebcdic_to_ascii, + NULL) < 0) { + cobc_err_exit (_("invalid parameter: %s"), "-febcdic-table"); + } + ebcdic_to_ascii_initialized = 1; + } + + return ebcdic_to_ascii[c]; +#endif +} + static void -read_literal (const char mark, const char *type) +read_literal (const char mark, const enum cb_literal_type type) { size_t i; int c; unsigned int literal_error = 0; + enum cb_sym_ebcdic_state ebcdic_flag = CB_SYM_EBCDIC_INACTIVE; i = 0; /* read until a not-escaped mark is found (see break) @@ -1328,11 +1380,47 @@ read_literal (const char mark, const char *type) } plex_buff[i] = (cob_u8_t)c; } + + if (ebcdic_flag != CB_SYM_EBCDIC_INACTIVE) { + /* While scanning symbolic EBCDIC character: */ + if (c == mark) { + if (ebcdic_flag == CB_SYM_EBCDIC_AFTER_SEP) { + cb_warning (COBC_WARN_FILLER, + _("extraneous separator at end " + "of symbolic EBCDIC characters")); + } + ebcdic_flag = CB_SYM_EBCDIC_INACTIVE; + } else if ('0' <= c && c <= '9') { + plex_buff[i++] = scan_ebcdic_char (c); + ebcdic_flag = CB_SYM_EBCDIC_ACTIVE; + } else if (c != ' ' && c != ',') { + cb_error (_("invalid character '%c' in sequence " + "of symbolic EBCDIC characters"), c); + ebcdic_flag = CB_SYM_EBCDIC_ACTIVE; + } else if (ebcdic_flag == CB_SYM_EBCDIC_AFTER_SEP) { + cb_warning (COBC_WARN_FILLER, + _("extraneous separator '%c' in sequence " + "of symbolic EBCDIC characters"), c); + ebcdic_flag = CB_SYM_EBCDIC_ACTIVE; + } else { + ebcdic_flag = CB_SYM_EBCDIC_AFTER_SEP; + } + continue; + } + if (c == mark && (c = input ()) != (int)mark) { if (c == '-') { /* Free format continuation ("a"- 'b'- ) */ /* Hack it as concatenation */ unput ('&'); + } else if (type == CB_LITERAL_DEFAULT && + cb_gcos_ebcdic_literals && + '0' <= c && c <= '9') { + /* GCOS 7: symbolic EBCDIC character in + literals */ + unput (c); + ebcdic_flag = CB_SYM_EBCDIC_ACTIVE; + continue; } else { if (c == EOF || c == 0) break; unput (c); @@ -1377,9 +1465,10 @@ read_literal (const char mark, const char *type) if (!i) { cb_verify (cb_zero_length_lit, _("zero-length literal")); cb_warning (COBC_WARN_FILLER, - type[0] == 'N' ? - _("national literal has zero length; a SPACE will be assumed") : - _("alphanumeric literal has zero length; a SPACE will be assumed")); + _("%s literal has zero length; a SPACE will be assumed"), + ( type == CB_LITERAL_N || type == CB_LITERAL_NC ) ? + _("national") : _("alphanumeric") + ); plex_buff[i++] = ' '; } else if (i > cb_lit_length) { i = cb_lit_length; @@ -1387,9 +1476,9 @@ read_literal (const char mark, const char *type) /* build literal with given size */ plex_buff[i] = 0; - if (type[0] != 'N') { + if ( type != CB_LITERAL_N && type != CB_LITERAL_NC ) { yylval = cb_build_alphanumeric_literal (plex_buff, i); - if (type[0] == 'U') { + if (type == CB_LITERAL_U) { CB_UNFINISHED (_("UTF-8 literal")); } } else { @@ -1407,7 +1496,7 @@ read_literal (const char mark, const char *type) plex_buff[i * 2] = 0; } i = new_size; - if (type[1] != 'C') { + if (type != CB_LITERAL_NC) { if (cb_verify (cb_national_literals, _("national literal"))) { CB_UNFINISHED (_("national literal")); } diff --git a/config/acu-strict.conf b/config/acu-strict.conf index 0b32e4854..8962823cb 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -242,6 +242,7 @@ national-character-literals: unconformable # TO-DO: Add separate config option for H"..." to be unsupported,numeric,non-numeric(acu) acu-literals: ok hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: ok not-exception-before-exception: unconformable accept-display-extensions: ok diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index f580a2396..1c15dd7dc 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -239,6 +239,7 @@ hexadecimal-national-literals: ok national-character-literals: unconformable acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: ok not-exception-before-exception: unconformable accept-display-extensions: unconformable diff --git a/config/cobol2002.conf b/config/cobol2002.conf index e3651b557..b95a49aef 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -238,6 +238,7 @@ hexadecimal-national-literals: ok national-character-literals: unconformable acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: archaic not-exception-before-exception: ok accept-display-extensions: unconformable diff --git a/config/cobol2014.conf b/config/cobol2014.conf index 392a992b4..16b21c899 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -240,6 +240,7 @@ national-character-literals: unconformable acu-literals: unconformable hp-octal-literals: unconformable word-continuation: archaic +ebcdic-symbolic-characters: no not-exception-before-exception: ok accept-display-extensions: unconformable renames-uncommon-levels: unconformable diff --git a/config/cobol85.conf b/config/cobol85.conf index f80f7a693..6111dcff1 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -238,6 +238,7 @@ hexadecimal-national-literals: unconformable national-character-literals: unconformable acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: ok not-exception-before-exception: unconformable accept-display-extensions: unconformable diff --git a/config/default.conf b/config/default.conf index cc91a1489..db6ffb1d4 100644 --- a/config/default.conf +++ b/config/default.conf @@ -259,6 +259,7 @@ national-character-literals: warning # TO-DO: Add separate config option for H"..." to be unsupported,numeric,non-numeric(acu) acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: warning not-exception-before-exception: ok accept-display-extensions: ok diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 8fa4b85b0..9b4e280e4 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -238,6 +238,7 @@ hexadecimal-national-literals: unconformable national-character-literals: unconformable acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: yes word-continuation: archaic not-exception-before-exception: unconformable accept-display-extensions: unconformable diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 1852798b5..10a565cf7 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -238,6 +238,7 @@ hexadecimal-national-literals: unconformable national-character-literals: unconformable acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: ok not-exception-before-exception: unconformable accept-display-extensions: unconformable diff --git a/config/mf-strict.conf b/config/mf-strict.conf index 4aaf8abbb..19583c424 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -241,6 +241,7 @@ national-character-literals: unconformable # TO-DO: Add separate config option for H"..." to be unsupported,numeric(rm/mf),non-numeric acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: ok not-exception-before-exception: unconformable accept-display-extensions: ok diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index ef18b7659..ea689341c 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -237,6 +237,7 @@ hexadecimal-national-literals: unconformable national-character-literals: unconformable acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: ok not-exception-before-exception: unconformable accept-display-extensions: unconformable diff --git a/config/realia-strict.conf b/config/realia-strict.conf index 061c1b05e..0da162868 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -242,6 +242,7 @@ national-character-literals: unconformable # TO-DO: Add separate config options for H"..." , Z"...", G"..." and N"..." to be ok acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: ok not-exception-before-exception: unconformable accept-display-extensions: ok diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 82cb46283..7c848573e 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -244,6 +244,7 @@ national-character-literals: unconformable # TO-DO: Add separate config option for H"..." to be unsupported,numeric(rm/mf),non-numeric acu-literals: unconformable hp-octal-literals: unconformable +ebcdic-symbolic-characters: no word-continuation: ok not-exception-before-exception: unconformable accept-display-extensions: ok diff --git a/config/xopen.conf b/config/xopen.conf index c60e14e8d..6fc8d4f78 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -258,6 +258,7 @@ national-character-literals: unconformable acu-literals: unconformable hp-octal-literals: unconformable word-continuation: obsolete # even for literals (as it added concatenation of literals by &)! +ebcdic-symbolic-characters: no not-exception-before-exception: unconformable accept-display-extensions: unconformable renames-uncommon-levels: unconformable diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index 1eafb6339..7f676c43d 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -499,6 +499,7 @@ test.conf: missing definitions: no definition of 'national-character-literals' no definition of 'hp-octal-literals' no definition of 'acu-literals' + no definition of 'ebcdic-symbolic-characters' no definition of 'word-continuation' no definition of 'not-exception-before-exception' no definition of 'accept-display-extensions' diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index f2c67e1d8..22c23cfe4 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -124,6 +124,77 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], AT_CLEANUP +AT_SETUP([GCOS literals with EBCDIC symbols]) +AT_KEYWORDS([extensions gcos ebcdic]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(11). + 01 T PIC 9. + 01 S USAGE COMP-1 VALUE ZERO. + PROCEDURE DIVISION. + MOVE 1 TO T + MOVE ""135,151,151"bar"195,194,234"" TO X + IF X NOT EQUAL "foobarBAZ" PERFORM SHOW. + + MOVE 2 TO T + MOVE " "135,151,151"bar"195 194"Z" TO X + IF X NOT EQUAL " foobarBAZ" PERFORM SHOW. + + MOVE 3 TO T + MOVE ' '135 151,151'bar'195,194'Z' TO X + IF X NOT EQUAL " foobarBAZ" PERFORM SHOW. + + *> GCOS7-specific: should give a ! in between square brackets: + *> note square brackets need to be doubled due to m4 preprocessing. + MOVE 4 TO T + MOVE ""75,80,91"" TO X + IF X NOT EQUAL "[[!]]" PERFORM SHOW. + + STOP RUN S. + SHOW. + DISPLAY "EBCDIC LIT " T " FAILED: X = """ X """" + MOVE 1 TO S. +]) + +AT_CHECK([$COMPILE -febcdic-symbolic-characters -febcdic-table=ebcdic500_latin1 prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], []) + +AT_CLEANUP + + +AT_SETUP([GCOS literals with EBCDIC symbols]) +AT_KEYWORDS([extensions gcos ebcdic]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + DISPLAY ""135,151,151"bar"195,194,0"" + DISPLAY ""135,257"" + DISPLAY ""135,x,194,1"" + DISPLAY " "135, 155,"" + DISPLAY " "135 155, " " + + STOP RUN. +]) + +AT_CHECK([$COMPILE -febcdic-symbolic-characters prog.cob], [1], [], +[prog.cob:5: error: symbolic character 0 out of allowed EBCDIC range (1...256) +prog.cob:6: error: symbolic character 257 out of allowed EBCDIC range (1...256) +prog.cob:7: error: invalid character 'x' in sequence of symbolic EBCDIC characters +prog.cob:8: warning: extraneous separator ' ' in sequence of symbolic EBCDIC characters +prog.cob:8: warning: extraneous separator at end of symbolic EBCDIC characters +prog.cob:9: warning: extraneous separator ' ' in sequence of symbolic EBCDIC characters +prog.cob:9: warning: extraneous separator ' ' in sequence of symbolic EBCDIC characters +]) + +AT_CLEANUP + + AT_SETUP([HP COBOL octal literals]) AT_KEYWORDS([extensions]) From 9f68d1e44309e0666a703ca7f7e309d048a27083 Mon Sep 17 00:00:00 2001 From: Nicolas Berthier Date: Tue, 21 Jun 2022 16:41:36 +0200 Subject: [PATCH 03/11] [GCOS] PR31 Allow paragraph names to redefine field and section names fix --- cobc/ChangeLog | 5 ++ cobc/config.def | 4 ++ cobc/error.c | 18 ++++++ cobc/tree.h | 1 + cobc/typeck.c | 11 +++- config/ChangeLog | 1 + 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/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 | 1 + tests/testsuite.src/syn_definition.at | 80 +++++++++++++++++++++++---- 21 files changed, 120 insertions(+), 14 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index f543a05c6..9c6877d54 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -957,6 +957,11 @@ Initial table values, then clear next, then propagate through remainder of the table +2022-02-04 David Declerck + + * config.def, typeck.c: allow paragraph names to redefine field + and section names; related to FR#260 + 2022-05-31 Simon Sobisch * cobc.c (cobc_check_string): replaced single string cache by an array diff --git a/cobc/config.def b/cobc/config.def index d4c9a3c5d..d7a65e7b4 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -433,3 +433,7 @@ CB_CONFIG_SUPPORT (cb_record_contains_depending_clause, "record-contains-dependi CB_CONFIG_SUPPORT (cb_picture_l, "picture-l", _("PICTURE string with 'L' character")) + +CB_CONFIG_SUPPORT (cb_non_unique_procedure_names, "non-unique-procedure-names", + _("allow paragraph names to redefine field and section names")) + diff --git a/cobc/error.c b/cobc/error.c index 42f9d3c07..635dbb31b 100644 --- a/cobc/error.c +++ b/cobc/error.c @@ -930,6 +930,24 @@ cb_verify (const enum cb_support tag, const char *feature) return cb_verify_x (&loc, tag, feature); } +/** + * tells whether the given compiler option is supported by the current std/configuration + * \return 1 = ok/warning/obsolete, 0 = skip/ignore/error/unconformable + */ +unsigned int +cb_is_supported (const enum cb_support tag) +{ + switch (tag) { + case CB_OK: + case CB_WARNING: + case CB_ARCHAIC: + case CB_OBSOLETE: + return 1; + default:; + } + return 0; +} + enum cb_warn_val redefinition_error (cb_tree x) { diff --git a/cobc/tree.h b/cobc/tree.h index c0645b3f8..d44927f7e 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2277,6 +2277,7 @@ extern unsigned int cb_syntax_check_x (cb_tree, const char *, ...) COB_A_FORMAT2 extern unsigned int cb_verify (const enum cb_support, const char *); extern unsigned int cb_verify_x (const cb_tree, const enum cb_support, const char *); +extern unsigned int cb_is_supported (const enum cb_support); #if 0 /* CHECKME: Is there any place other than "note" where we want to do listing suppression? */ extern void listprint_suppress (void); extern void listprint_restore (void); diff --git a/cobc/typeck.c b/cobc/typeck.c index dde5247cb..22f270594 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2156,8 +2156,15 @@ cb_build_section_name (cb_tree name, const int sect_or_para) if (!CB_LABEL_P (x) || sect_or_para == 0 || (sect_or_para && CB_LABEL_P (x) && CB_LABEL (x)->flag_section)) { - redefinition_error (name); - return cb_error_node; + if (cb_is_supported(cb_non_unique_procedure_names) && + (CB_FIELD_P (x) || + (CB_LABEL_P (x) && CB_LABEL (x)->flag_section))) { + /* To display the usual warning messages, if any */ + cb_verify(cb_non_unique_procedure_names, _("non-unique section or paragraph name")); + } else { + redefinition_error (name); + return cb_error_node; + } } } diff --git a/config/ChangeLog b/config/ChangeLog index b953ad3be..02e1776ba 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -128,6 +128,7 @@ * gcos-strict.conf, gcos.conf, gcos.words: added config files for GCOS 7 (Bull) dialect + * general: add a non-unique-paragraph-names option 2022-02-07 David Declerck diff --git a/config/acu-strict.conf b/config/acu-strict.conf index 8962823cb..d40e8b6b0 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -278,6 +278,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: " " picture-l: unconformable +non-unique-procedure-names: ok # 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 1c15dd7dc..c179460ef 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -275,6 +275,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: 0 # not verified yet, but likely to be as IBM picture-l: unconformable +non-unique-procedure-names: warning # Needs to be checked # use fixed word list, synonyms and exceptions specified there reserved-words: BS2000 diff --git a/config/cobol2002.conf b/config/cobol2002.conf index b95a49aef..6efddd690 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -274,6 +274,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: none # initial storage is undefined picture-l: unconformable +non-unique-procedure-names: error # 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 16b21c899..cf07f8220 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -274,6 +274,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: none # initial storage is undefined picture-l: unconformable +non-unique-procedure-names: error # use fixed word list, synonyms and exceptions specified there reserved-words: COBOL2014 diff --git a/config/cobol85.conf b/config/cobol85.conf index 6111dcff1..960ed3bb4 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -274,6 +274,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: none # initial storage is undefined picture-l: unconformable +non-unique-procedure-names: error # 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 db6ffb1d4..55773890f 100644 --- a/config/default.conf +++ b/config/default.conf @@ -296,6 +296,7 @@ record-contains-depending-clause: unconformable defaultbyte: init # GC inits as INITIALIZE ALL TO VALUE THEN TO DEFAULT, # with INDEXED BY variables initialized to 1 picture-l: ok +non-unique-procedure-names: warning # 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 9b4e280e4..39786e1d3 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -273,6 +273,7 @@ self-call-recursive: skip record-contains-depending-clause: obsolete defaultbyte: 0 picture-l: ok +non-unique-procedure-names: 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 10a565cf7..9cd043a0f 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -273,6 +273,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: 0 picture-l: unconformable +non-unique-procedure-names: warning # Needs to be checked # use fixed word list, synonyms and exceptions specified there reserved-words: IBM diff --git a/config/mf-strict.conf b/config/mf-strict.conf index 19583c424..a7099faf5 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -277,6 +277,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: " " picture-l: unconformable +non-unique-procedure-names: error # 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 ea689341c..a711015d8 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -273,6 +273,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: 0 # not verified yet, but likely to be as IBM picture-l: unconformable +non-unique-procedure-names: error # Needs to be checked # 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 0da162868..4ece96943 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -278,6 +278,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: 0 # not verified, but likely like IBM picture-l: unconformable +non-unique-procedure-names: error # Needs to be checked # 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 7c848573e..fe90fab22 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -280,6 +280,7 @@ self-call-recursive: skip record-contains-depending-clause: unconformable defaultbyte: " " # not verified, but possibly like ACU/MF picture-l: unconformable +non-unique-procedure-names: ok # 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 6fc8d4f78..fb589389b 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -293,6 +293,7 @@ self-call-recursive: skip record-contains-depending-clause: obsolete defaultbyte: none # "not specifically defined in Standard COBOL" picture-l: unconformable +non-unique-procedure-names: error # 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 7f676c43d..88d46b146 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -535,6 +535,7 @@ test.conf: missing definitions: no definition of 'self-call-recursive' no definition of 'record-contains-depending-clause' no definition of 'picture-l' + no definition of 'non-unique-procedure-names' ]) AT_CLEANUP diff --git a/tests/testsuite.src/syn_definition.at b/tests/testsuite.src/syn_definition.at index 88d645833..1c74bbf5e 100644 --- a/tests/testsuite.src/syn_definition.at +++ b/tests/testsuite.src/syn_definition.at @@ -601,7 +601,10 @@ AT_DATA([prog.cob], [ . ]) -AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], +[prog.cob:10: warning: non-unique section or paragraph name used +]) +AT_CHECK([$COMPILE_ONLY -fnon-unique-procedure-names=error prog.cob], [1], [], [prog.cob:10: error: redefinition of 'prog' prog.cob:7: note: 'prog' previously defined here ]) @@ -982,16 +985,16 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], +[prog.cob: in section 'L': +prog.cob:6: warning: non-unique section or paragraph name used +]) +AT_CHECK([$COMPILE_ONLY -fnon-unique-procedure-names=error prog.cob], [1], [], [prog.cob: in section 'L': prog.cob:6: error: redefinition of 'L' prog.cob:5: note: 'L' previously defined here ]) -# FIXME: as long as there is no direct reference to the section -# this should be not more than a warning, -# maybe depending on a compiler configuration - AT_CLEANUP @@ -1007,17 +1010,16 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], +[prog.cob: in section 'L': +prog.cob:6: warning: non-unique section or paragraph name used +]) +AT_CHECK([$COMPILE_ONLY -fnon-unique-procedure-names=error prog.cob], [1], [], [prog.cob: in section 'L': prog.cob:6: error: redefinition of 'L' prog.cob:5: note: 'L' previously defined here ]) -# FIXME: as long as there is no direct reference to -# the paragraph/section this should be not more -# than a warning, maybe depending on a compiler -# configuration - AT_CLEANUP @@ -1110,6 +1112,60 @@ prog.cob:8: note: 'L IN S-2' defined here AT_CLEANUP +AT_SETUP([Identical names for section/paragraph and data]) +AT_KEYWORDS([definition]) + +# FIXME: Identical data and section (or paragraph) names is not yet +# supported. +# See https://sourceforge.net/p/gnucobol/feature-requests/260/ + +AT_XFAIL_IF(true) + +AT_DATA([word.cob], [ + identification division. + program-id. word. + data division. + working-storage section. + *----------------------------------------------------------------- + 77 word pic 9. + 77 word2 pic x. + *----------------------------------------------------------------- + PROCEDURE DIVISION. + main section. + * + move 0 to word + perform word + display word + * + exit program. + *----------------------------------------------------------------- + word section. + * + add 1 to word + if word = 2 go to word2. + add 1 to word. + * + word2. + * + continue. + *----------------------------------------------------------------- +]) +AT_CHECK([$COMPILE_ONLY word.cob], [0], [], +[word.cob: in section 'main': +word.cob:19: warning: non-unique section or paragraph name used +word.cob: in section 'word': +word.cob:21: warning: non-unique section or paragraph name used +word.cob:7: note: 'word' defined here +word.cob:19: note: 'word' defined here +word.cob:25: warning: non-unique section or paragraph name used +]) +AT_CHECK([$COMPILE_ONLY -std=cobol2002 word.cob], [1], [], +[#TBD +]) + +AT_CLEANUP + + AT_SETUP([Non-matching level numbers (extension)]) AT_KEYWORDS([definition]) From 492be02619fae1bddf74f181e4a1f32d9719ca6e Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Sun, 15 Jan 2023 17:50:07 +0100 Subject: [PATCH 04/11] PR75 Fix COPY REPLACING and REPLACE Current implementation does not conform to standard (COPY REPLACING and REPLACE are supposed to be in two successive passes instead of applied together), and has various bugs. This version is probably less efficient, but better conforms to the standard. Limitations: * This first version only modify the replacements during preprocessing, not the ones during the listing printing. * Since REPLACE are interpreted *before* the COPY REPLACING, they cannot be modified by them. A conforming implementation would interpret REPLACE strictly after COPY REPLACING. --- cobc/ChangeLog | 10 + cobc/Makefile.am | 3 +- cobc/cobc.c | 58 ++- cobc/cobc.h | 5 + cobc/pplex.l | 271 ++----------- cobc/replace.c | 690 ++++++++++++++++++++++++++++++++ cobc/replace.h | 44 ++ tests/testsuite.src/syn_copy.at | 6 +- 8 files changed, 836 insertions(+), 251 deletions(-) create mode 100644 cobc/replace.c create mode 100644 cobc/replace.h diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 9c6877d54..5eeb9915a 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -126,6 +126,16 @@ * reserved.c (SEQUENCE): setting CB_CS_ALPHABET to allow code-name parsing * parser.y, reserved.c: changed reference from 202x to 2023 +2023-01-05 Fabrice Le Fessant + + * cobc.c.c: add `cobc_plex_stradd` and `cobc_plex_strsub` allocation + functions for the pplex phase. + * replace.c: new file containing the two-phase COPY-REPLACING and REPLACE + mechanism, conforming to COBOL standard. + * pplex.l: remove former `pplex_echo` and `pplex_replace` code. The + `alt_space` parameter is not used anymore, leading to different listing + code in some cases. + 2023-01-16 Simon Sobisch * parser.y (occurs_index): only set VALUE 1 for defaultbyte == INIT diff --git a/cobc/Makefile.am b/cobc/Makefile.am index 417af58aa..a96b7c3ab 100644 --- a/cobc/Makefile.am +++ b/cobc/Makefile.am @@ -22,7 +22,8 @@ bin_PROGRAMS = cobc cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.c parser.y scanner.c config.c \ reserved.c error.c tree.c tree.h field.c typeck.c codegen.c help.c \ - config.def flag.def warning.def codeoptim.def ppparse.def codeoptim.c + config.def flag.def warning.def codeoptim.def ppparse.def \ + codeoptim.c replace.h replace.c #cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.l parser.y scanner.l config.c diff --git a/cobc/cobc.c b/cobc/cobc.c index 0183804ce..7c90c10bc 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -985,8 +985,8 @@ cobc_strdup (const char *dupstr) return p; } -#if defined (_WIN32) || defined (__CYGWIN__) -static char * +#if defined (_WIN32) || defined (__CYGWIN__) +char * cobc_stradd_dup (const char *str1, const char *str2) { char *p; @@ -1315,6 +1315,59 @@ cobc_plex_strdup (const char *dupstr) return p; } +char * +cobc_plex_stradd (const char *str1, const char *str2) +{ + char *p; + size_t m, n; + + /* LCOV_EXCL_START */ + if (unlikely (!str1 || !str2)) { + cobc_err_msg (_("call to %s with NULL pointer"), + "cobc_plex_stradd"); + cobc_abort_terminate (1); + } + /* LCOV_EXCL_STOP */ + m = strlen (str1); + n = strlen (str2); + p = cobc_plex_malloc (m + n + 1); + memcpy (p, str1, m); + memcpy (p + m, str2, n); + return p; +} + +void * +cobc_plex_strsub (const char *s, const int len) +{ + void *p; + int n; + +#ifdef COB_TREE_DEBUG + /* LCOV_EXCL_START */ + if (unlikely (!s)) { + cobc_err_msg (_("call to %s with NULL pointer"), + "cobc_plex_strsub"); + cobc_abort_terminate (1); + } + /* LCOV_EXCL_STOP */ +#endif + n = strlen (s); + +#ifdef COB_TREE_DEBUG + /* LCOV_EXCL_START */ + if ( len>n ) { + cobc_err_msg (_("call to %s with bad argument len=%d>%d=strlen(s)"), + "cobc_plex_strsub", len, n); + cobc_abort_terminate (1); + } + /* LCOV_EXCL_STOP */ +#endif + + p = cobc_plex_malloc (len + 1); + memcpy (p, s, len); + return p; +} + /* variant of strcpy which copies max 'max_size' bytes from 'src' to 'dest', if the size of 'src' is too long only its last/last bytes are copied and an eliding "..." is placed in front or at end depending on 'elide_at_end' */ @@ -6011,6 +6064,7 @@ print_program_trailer (void) /* Print file/symbol tables if requested */ if (cb_listing_symbols) { + if (cb_listing_with_header) { set_listing_header_symbols (); } diff --git a/cobc/cobc.h b/cobc/cobc.h index 3e09f09db..38d5bc5dc 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -492,6 +492,8 @@ extern struct reserved_word_list *cob_user_res_list; extern void *cobc_malloc (const size_t); extern void cobc_free (void *); extern void *cobc_strdup (const char *); +extern char *cobc_stradd_dup (const char *str1, + const char *str2); extern void *cobc_realloc (void *, const size_t); extern void *cobc_main_malloc (const size_t); @@ -506,6 +508,9 @@ extern void cobc_parse_free (void *); extern void *cobc_plex_malloc (const size_t); extern void *cobc_plex_strdup (const char *); +extern void *cobc_plex_strsub (const char *, const int); +extern char *cobc_plex_stradd (const char *str1, + const char *str2); extern void *cobc_check_string (const char *); extern void cobc_err_msg (const char *, ...) COB_A_FORMAT12; diff --git a/cobc/pplex.l b/cobc/pplex.l index 8d3796c84..745f14996 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -92,6 +92,7 @@ static int ppwrap (void) { #include "cobc.h" #include "tree.h" #include "ppparse.h" +#include "replace.h" #ifdef _WIN32 #include /* for access */ @@ -106,6 +107,9 @@ static int ppwrap (void) { #define PLEX_COND_DEPTH 16 +// replace yytext by some simplified text in ppecho() +#define ALT_TEXT 1 + struct copy_info { struct copy_info *next; struct copy_info *prev; @@ -157,23 +161,14 @@ static int emit_area_a_tokens = 0; static char display_msg[PPLEX_BUFF_LEN]; -static struct cb_replace_list *current_replace_list = NULL; -static struct cb_replace_list *save_current_replace = NULL; -static struct cb_replace_list *base_replace_list = NULL; - -static struct cb_text_list *text_queue = NULL; -static size_t check_partial_match = 0; - static struct copy_info *copy_stack = NULL; static struct plex_stack plex_cond_stack[PLEX_COND_DEPTH]; /* Function declarations */ static int ppinput (char *, const size_t); -static void ppecho (const char *, const cob_u32_t, +static void ppecho (const char *, const int, const int); -static void ppecho_direct (const char *); -static int ppecho_replace (struct cb_replace_list *); static void switch_to_buffer (const int, const char *, const YY_BUFFER_STATE); static void check_listing (const char *, const unsigned int); @@ -183,9 +178,6 @@ static void display_finish (void); static void set_print_replace_list (struct cb_replace_list *); static void get_new_listing_file (void); -static struct cb_text_list *pp_text_list_add (struct cb_text_list *, - const char *, const size_t); - %} WORD [_0-9A-Z\x80-\xFF-]+ @@ -642,32 +634,32 @@ SUBSTITUTION_SECTION_STATE> } [,;]?\n { - ppecho ("\n", 0, 1); + ppecho ("\n", ALT_TEXT, 1); cb_source_line++; } [;]?[ ]+ { - ppecho (" ", 1U, 1); + ppecho (" ", ALT_TEXT, 1); } [,]?[ ]+ { if (inside_bracket) { - ppecho (", ", 0, 2); + ppecho (", ", ALT_TEXT, 2); } else { - ppecho (" ", 1U, 1); + ppecho (" ", ALT_TEXT, 1); } } "(" { - inside_bracket++; - ppecho ("(", 0, 1); + inside_bracket++; + ppecho (yytext, 0, (int)yyleng); } ")" { if (inside_bracket) { inside_bracket--; } - ppecho (")", 0, 1); + ppecho (yytext, 0, (int)yyleng); } {WORD} | @@ -1083,10 +1075,7 @@ ENDIF_DIRECTIVE_STATE>{ newline_count = 0; inside_bracket = 0; comment_allowed = 1; - current_replace_list = NULL; - base_replace_list = NULL; - save_current_replace = NULL; - text_queue = NULL; + free_replace (); copy_stack = NULL; quotation_mark = 0; consecutive_quotation = 0; @@ -1108,7 +1097,7 @@ ENDIF_DIRECTIVE_STATE>{ current_copy_info->buffer); /* Restore variables */ - current_replace_list = current_copy_info->replacing; + set_copy_replacing_list (current_copy_info->replacing); quotation_mark = current_copy_info->quotation_mark; cobc_set_source_format (current_copy_info->source_format); @@ -1125,26 +1114,8 @@ void pp_set_replace_list (struct cb_replace_list *list, const cob_u32_t is_pushpop) { /* Handle REPLACE verb */ - if (!list) { - /* REPLACE [LAST] OFF */ - if (!is_pushpop) { - base_replace_list = NULL; - return; - } - if (!base_replace_list) { - return; - } - base_replace_list = base_replace_list->prev; - return; - } - /* REPLACE [ALSO] ... */ - if (base_replace_list && is_pushpop) { - list->last->next = base_replace_list; - list->prev = base_replace_list; - } else { - list->prev = NULL; - } - base_replace_list = list; + + set_replace_list (list, is_pushpop); if (cb_src_list_file) { set_print_replace_list (list); } @@ -1174,6 +1145,7 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) struct copy_info *current_copy_info; char *dname; cb_tree x = NULL; + struct cb_replace_list *current_replace_list; if (ppin) { for (; newline_count > 0; newline_count--) { @@ -1275,7 +1247,9 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) cb_depend_list = pp_text_list_add (cb_depend_list, name, strlen (name)); } - /* Preserve the current buffer */ + current_replace_list = get_copy_replacing_list(); + + /* Preserve the current buffer */ current_copy_info = cobc_malloc (sizeof (struct copy_info)); current_copy_info->file = cb_source_file; current_copy_info->buffer = YY_CURRENT_BUFFER; @@ -1303,7 +1277,7 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) replacing_list->last->next = current_replace_list; replacing_list->last = current_replace_list->last; } - current_replace_list = replacing_list; + set_copy_replacing_list (replacing_list); if (cb_src_list_file) { set_print_replace_list (replacing_list); } @@ -2519,7 +2493,7 @@ start: return (int)gotcr; } -static struct cb_text_list * +struct cb_text_list * pp_text_list_add (struct cb_text_list *list, const char *text, const size_t size) { @@ -2540,201 +2514,11 @@ pp_text_list_add (struct cb_text_list *list, const char *text, } static void -ppecho (const char *text, const cob_u32_t alt_space, const int textlen) -{ - /* performance note (last verified with GnuCOBOL 2.2): - while this function used 5% (according to callgrind) - of the complete time spent in a sample run with - -fsyntax-only on 880 production code files (2,500,000 LOC), - 3.8% of this time is spent in fwrite, therefore not much potential - for optimization */ - - struct cb_replace_list *save_ptr; - const char *s; - struct cb_text_list *save_ptr_text_queue; - int status, save_status; - - /* ensure nothing is in the stream buffer */ - fflush (ppout); - - /* Check for replacement text before outputting */ - if (alt_space) { - s = yytext; - } else { - s = text; - } - - if (text_queue == NULL && (text[0] == ' ' || text[0] == '\n')) { - /* No replacement */ - fwrite (text, (size_t)textlen, (size_t)1, ppout); - /* TODO: instead of \n (empty line: set "needs source-loc" flag and - before first non-empty line output a #line directive, saving - quite some file io [keep 1 empty line]) */ - if (cb_listing_file) { - check_listing (s, 0); - } - return; - } - if (!current_replace_list && !base_replace_list) { - /* Output queue */ - for (; text_queue; text_queue = text_queue->next) { - fputs (text_queue->text, ppout); - } - fwrite (text, (size_t)textlen, (size_t)1, ppout); - if (cb_listing_file) { - check_listing (s, 0); - } - return; - } - if (!current_replace_list) { - current_replace_list = base_replace_list; - save_ptr = NULL; - } else { - current_replace_list->last->next = base_replace_list; - save_ptr = current_replace_list->last; - } - - /* Do replacement */ - text_queue = pp_text_list_add (text_queue, text, (size_t)textlen); - - save_ptr_text_queue = text_queue; - status = ppecho_replace (save_ptr); - /* Search another replacement when have a Partial Match in the last ppecho call */ - if (check_partial_match && status != -1) { - save_status = status; - text_queue = save_ptr_text_queue; - while (text_queue && check_partial_match) { - if (is_space_or_nl (text_queue->text[0])) { - ppecho_direct (text_queue->text); - text_queue = text_queue->next; - continue; - } - status = ppecho_replace (save_ptr); - if (status > save_status) { - save_status = status; - } - if (text_queue) { - /* Write text_queue if is not replaced */ - if (status != -1 && check_partial_match) { - ppecho_direct (text_queue->text); - } - text_queue = text_queue->next; - } - } - status = save_status; - } - /* Manage Partial Match */ - if (status == -1) { - check_partial_match = save_ptr_text_queue != NULL; - return; - } - if (!status) { - current_replace_list = NULL; - } else { - save_ptr->next = NULL; - } - - /* No match */ - for (; text_queue; text_queue = text_queue->next) { - ppecho_direct (text_queue->text); - } -} - -/* handle all kinds of COPY REPLACING and REPLACE */ -static int -ppecho_replace (struct cb_replace_list *save_ptr) +ppecho (const char *text, const int alt_space, const int textlen) { - char *temp_ptr; - size_t size; - size_t size2; - struct cb_text_list *queue; - struct cb_text_list *save_queue; - const struct cb_text_list *lno; - struct cb_replace_list *r; - - save_queue = NULL; - size = 0; - size2 = 0; - for (r = current_replace_list; r; r = r->next) { - queue = text_queue; - /* The LEADING/TRAILING code looks peculiar as we use */ - /* variables after breaking out of the loop BUT */ - /* ppparse.y guarantees that we have only one token */ - /* and therefore only one iteration of this loop */ - for (lno = r->src->text_list; lno; lno = lno->next) { - if (is_space_or_nl (lno->text[0])) { - continue; - } - while (queue && is_space_or_nl (queue->text[0])) { - queue = queue->next; - } - if (queue == NULL) { - /* Partial match */ - if (!save_ptr) { - current_replace_list = NULL; - } else { - save_ptr->next = NULL; - } - return -1; - } - if (r->src->lead_trail == CB_REPLACE_LEADING) { - /* Check leading text */ - size = strlen (lno->text); - if ((r->src->strict && strlen (queue->text) == size) - || strncasecmp (lno->text, queue->text, size)) { - /* No match */ - break; - } - save_queue = queue; - } else if (r->src->lead_trail == CB_REPLACE_TRAILING) { - /* Check trailing text */ - size = strlen (lno->text); - size2 = strlen (queue->text); - if (size2 < size - || (r->src->strict && size2 == size)) { - /* No match */ - break; - } - size2 -= size; - if (strncasecmp (lno->text, queue->text + size2, size)) { - /* No match */ - break; - } - save_queue = queue; - } else if (strcasecmp (lno->text, queue->text)) { - /* No match */ - break; - } - queue = queue->next; - } - if (lno == NULL) { - /* Match */ - if (r->src->lead_trail == CB_REPLACE_TRAILING - && save_queue /* <- silence warnings */) { - /* Non-matched part of original text */ - fprintf (ppout, "%*.*s", (int)size2, (int)size2, - save_queue->text); - if (cb_listing_file) { - temp_ptr = cobc_strdup (save_queue->text); - *(temp_ptr + size2) = 0; - check_listing (temp_ptr, 0); - cobc_free (temp_ptr); - } - } - for (lno = r->new_text; lno; lno = lno->next) { - ppecho_direct (lno->text); - } - if (r->src->lead_trail == CB_REPLACE_LEADING - && save_queue /* <- silence warnings */) { - /* Non-matched part of original text */ - ppecho_direct (save_queue->text + size); - } - check_partial_match = 0; - text_queue = queue; - continue; - } - } - return (save_ptr ? 1 : 0); + /* This new versoin does not use `alt_space`, so the output + will be different from the previous one. */ + ppecho_copy( text ); } static void @@ -2775,8 +2559,7 @@ display_finish (void) unput ('\n'); } -static void -ppecho_direct (const char *text) +void ppecho_direct (const char *text) { fputs (text, ppout); if (cb_listing_file) { diff --git a/cobc/replace.c b/cobc/replace.c new file mode 100644 index 000000000..3790ce484 --- /dev/null +++ b/cobc/replace.c @@ -0,0 +1,690 @@ +/* + Copyright (C) 2003-2022 Free Software Foundation, Inc. + Written by Fabrice Le Fessant + + This file is part of GnuCOBOL. + + The GnuCOBOL compiler is free software: you can redistribute it + and/or modify it under the terms of the GNU General Public License + as published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. + + GnuCOBOL is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GnuCOBOL. If not, see . +*/ + +#include "tarstamp.h" +#include "config.h" + +#include +#include +#include +#include +#include +#ifdef HAVE_STRINGS_H +#include +#endif +#include +#include +#include + + +#include "cobc.h" +#include "tree.h" +#include "replace.h" + +#define TRUE 1 +#define FALSE 0 + +// #define DEBUG_REPLACE_TRACE +// #define DEBUG_REPLACE + +#ifdef DEBUG_REPLACE_TRACE +#define DEBUG_REPLACE +#endif + +/* This is an implementation of the *two* phases of COPY-REPLACING and + REPLACE on a stream of token: the stream of tokens generated by the + pplex.l/parser.y goes first through COPY-REPLACING replacements, + and then through REPLACE replacements, as expected by the COBOL + standard. + + However, it does fully conform to the standard, as REPLACE are + parsed on the input stream *before* any COPY-REPLACING could have + been applied. + */ + + +/* types */ +enum cb_ppecho { + CB_PPECHO_DIRECT = 0, /* direct output */ + CB_PPECHO_REPLACE = 1, /* output to REPLACE */ +}; + +struct cb_replacement_state { + + /* The list of tokens that are currently being checked for + * replacements. Empty, unless a partial match occurred. */ + /* not const */ struct cb_text_list *token_queue ; + + /* We don't queue WORD tokens immediately, because + * preprocessing could create larger words. Instead, we buffer + * WORD tokens (and merge them) until another kind of token + * (SPACE,DELIM,etc.) is received. */ + const char *token_prequeue ; + + /* Current list of replacements specified in COPY-REPLACING or + * REPLACE */ + struct cb_replace_list *replace_list ; + + /* List of replacements after a partial match that still need + * to be tested. */ + const struct cb_replace_list *current_list ; + + /* The next pass to which generated tokens should be passed + * (either REPLACE pass or direct output */ + enum cb_ppecho ppecho ; + +#ifdef DEBUG_REPLACE + const char* name ; +#endif +}; + + +#ifdef DEBUG_REPLACE_TRACE + +#define WITH_DEPTH int depth, +#define INIT_DEPTH 1, +#define MORE_DEPTH depth+1, + +#define MAX_DEPTH 100 +char depth_buffer[MAX_DEPTH+1]; +#define DEPTH depth_buffer + ( MAX_DEPTH-depth ) + +#else // DEBUG_REPLACE_TRACE + +#define WITH_DEPTH +#define DEPTH +#define INIT_DEPTH +#define MORE_DEPTH + +#endif // DEBUG_REPLACE_TRACE + + +#ifdef DEBUG_REPLACE + +#define MAX_TEXT_LIST_STRING 10000 +char text_list_string[MAX_TEXT_LIST_STRING]; + +static +char * string_of_list(const struct cb_text_list *list) +{ + int pos = 1; + text_list_string[0] = '['; + + for(; list != NULL; list = list->next){ + int len = strlen(list->text); + text_list_string[pos++] = '"'; + memcpy( text_list_string + pos, list->text, len ); + pos += len; + text_list_string[pos++] = '"'; + text_list_string[pos++] = ','; + text_list_string[pos++] = ' '; + } + + text_list_string[pos] = ']'; + text_list_string[pos+1]=0; + return text_list_string; +} +#endif // DEBUG_REPLACE + +/* global state */ +static struct cb_replacement_state * replace_repls; +static struct cb_replacement_state * copy_repls; + +/* forward definitions */ +static void ppecho_replace (WITH_DEPTH const char *token); +static void do_replace (WITH_DEPTH struct cb_replacement_state* repls); +static void check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls); +static void check_replace_all (WITH_DEPTH struct cb_replacement_state *repls, + const struct cb_text_list *new_text, + struct cb_text_list *tokens, + const struct cb_text_list *src, + const struct cb_replace_list *replace_list); + +static COB_INLINE COB_A_INLINE int +is_space_or_nl (const char c) +{ + return c == ' ' || c == '\n'; +} + +/* This specific text_list_add function does a standard append on + list, without expecting `last` field to be correctly set. This is + important as `pp_text_list_add` only correctly works when always + adding on the same head, other `last` fields in the middle of the + list not being correctly updated... + */ +static +struct cb_text_list * +text_list_add (WITH_DEPTH struct cb_text_list *list, const char *text) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%stext_list_add(%s,'%s')\n", + DEPTH, string_of_list(list), text); +#endif + struct cb_text_list *p; + void *tp; + int size = strlen(text); + + tp = cobc_plex_malloc (size + 1); + memcpy (tp, text, size); + + p = cobc_plex_malloc (sizeof (struct cb_text_list)); + p->text = tp; + p->next = NULL; + + if (list==NULL) { + return p; + } else { + struct cb_text_list *cursor = list; + for(;cursor->next != NULL; cursor = cursor->next); + cursor->next = p; + return list; + } +} + + +static +const char* pop_token (WITH_DEPTH struct cb_replacement_state *repls) +{ + const struct cb_text_list *q = repls->token_queue ; + repls->token_queue = q->next ; +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%spop_token(%s) -> '%s'\n", + DEPTH, repls->name, q->text); +#endif + return q->text ; +} + +static +void ppecho_switch (WITH_DEPTH struct cb_replacement_state *repls, + const char* token) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sppecho_switch(%s, '%s')\n", + DEPTH, repls->name, token); +#endif + switch( repls->ppecho ){ + case CB_PPECHO_DIRECT: +#ifdef DEBUG_REPLACE + fprintf(stderr, "%s ppecho_direct('%s')\n", DEPTH, token); +#endif + return ppecho_direct (token); + case CB_PPECHO_REPLACE: + return ppecho_replace (MORE_DEPTH token); + } +} + +static +void ppecho_switch_list (WITH_DEPTH struct cb_replacement_state *repls, + const struct cb_text_list *p) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sppecho_switch_list(%s, %s)\n", + DEPTH, repls->name, string_of_list(p)); +#endif + + for (;p;p=p->next){ + ppecho_switch (MORE_DEPTH repls, p->text); + } +} + +static +int is_leading_or_trailing (WITH_DEPTH int leading, + const char* src_token, + const char* token, + int strict) +{ + + int src_len = strlen (src_token); + int token_len = strlen(token); + int result ; + if( token_len > src_len || ( !strict && token_len == src_len ) ){ + int pos = leading ? 0 : token_len - src_len ; + if( strncasecmp (src_token, token+pos, src_len) ){ + result = FALSE; + } else { + result = TRUE; + } + } else { + result = FALSE; + } +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, + "%sis_leading_or_trailing(%d, '%s', input='%s', %d) -> %d\n", + DEPTH, leading, src_token, token, strict, result); +#endif + return result; +} + +static +void ppecho_leading_or_trailing (WITH_DEPTH struct cb_replacement_state *repls, + int leading, + const char *src_token, + const char *token, + const struct cb_text_list * new_text) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, + "%sppecho_leading_or_trailing(%s, %d, '%s', input='%s', ...)\n", + DEPTH, repls->name, leading, src_token, token); +#endif + + int src_len = strlen (src_token); + int token_len = strlen (token); + + if (!leading && token_len > src_len) { + const char* remaining_token = + cobc_plex_strsub (token, + token_len - src_len); + ppecho_switch (MORE_DEPTH repls, remaining_token); + } + + ppecho_switch_list (MORE_DEPTH repls, new_text); + + if (leading && token_len > src_len) { + const char* remaining_token = + cobc_plex_strsub (token+src_len, + token_len - src_len); + ppecho_switch (MORE_DEPTH repls, remaining_token); + } +} + +static +void check_replace (WITH_DEPTH struct cb_replacement_state* repls, + const struct cb_replace_list *replace_list) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%scheck_replace(%s, ...)\n", DEPTH, + repls->name); +#endif + repls->current_list = replace_list; + + if (replace_list == NULL){ + + /* NO MATCH */ + const char* token = pop_token (MORE_DEPTH repls); + ppecho_switch (MORE_DEPTH repls, token); + check_replace_after_match (MORE_DEPTH repls); + + } else { + const struct cb_replace_src *src = replace_list->src; + const struct cb_text_list *new_text = replace_list->new_text; + replace_list = replace_list->next; + + if (src->lead_trail == CB_REPLACE_LEADING + || src->lead_trail == CB_REPLACE_TRAILING){ + int leading = (src->lead_trail == CB_REPLACE_LEADING); + unsigned int strict = src->strict; + const char *src_token = src->text_list->text; + const char *token = repls->token_queue->text; + + if (is_leading_or_trailing (MORE_DEPTH leading, + src_token,token,strict)){ + + /* MATCH */ + ppecho_leading_or_trailing (MORE_DEPTH repls, + leading, + src_token,token, + new_text) ; + pop_token (MORE_DEPTH repls); + check_replace_after_match (MORE_DEPTH repls); + } else { + check_replace (MORE_DEPTH repls,replace_list); + } + } else { + check_replace_all (MORE_DEPTH repls,new_text, + repls->token_queue, + src->text_list, + replace_list); + } + } +} + +static +void check_replace_all (WITH_DEPTH struct cb_replacement_state *repls, + const struct cb_text_list *new_text, + struct cb_text_list *tokens, + const struct cb_text_list *src, + const struct cb_replace_list *replace_list) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%scheck_replace_all(%s,", + DEPTH, repls->name); + fprintf(stderr, "%s new_text = %s,\n", DEPTH, + string_of_list(new_text)); + fprintf(stderr, "%s tokens = %s,\n", DEPTH, + string_of_list(tokens)); + fprintf(stderr, "%s src = %s,\n", DEPTH, + string_of_list(src)); + fprintf(stderr, "%s)\n", DEPTH); +#endif + + if (src==NULL){ + /* MATCH */ + ppecho_switch_list (MORE_DEPTH repls, new_text) ; + repls->token_queue = tokens ; + check_replace_after_match (MORE_DEPTH repls); + } else { + const char* src_token = src->text; + if ( is_space_or_nl(src_token[0]) ){ + check_replace_all (MORE_DEPTH repls,new_text,tokens, + src->next, replace_list); + } else { + if (tokens == NULL){ + /* PARTIAL MATCH, wait for next token */ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%s check_replace_all --> PARTIAL MATCH\n", DEPTH); +#endif + } else { + const char* token = tokens->text; + tokens = tokens->next; + if ( is_space_or_nl(token[0]) ){ + check_replace_all (MORE_DEPTH repls, + new_text, + tokens, src, + replace_list); + } else { + if (!strcasecmp(src_token,token)){ + + check_replace_all( + MORE_DEPTH repls, + new_text, + tokens,src->next, + replace_list); + } else { + check_replace ( + MORE_DEPTH repls, + replace_list); + } + } + } + } + } +} + +static +void check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%scheck_replace_after_match(%s)\n", + DEPTH, repls->name); +#endif + repls->current_list = NULL; + if (repls->token_queue != NULL){ + if( is_space_or_nl (repls->token_queue->text[0]) ){ + ppecho_switch (MORE_DEPTH repls, + repls->token_queue->text); + repls->token_queue = repls->token_queue->next; + check_replace_after_match (MORE_DEPTH repls); + } else { + do_replace (MORE_DEPTH repls); + } + } +} + +static +void do_replace (WITH_DEPTH struct cb_replacement_state* repls) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sdo_replace(%s)\n",DEPTH, repls->name); +#endif + if (repls->current_list == NULL){ + if (repls->replace_list == NULL){ + + /* Beware: this is incorrect if a REPLACE is + * withing the queue, as it has already been + * parsed before any COPY-REPLACING + * substitution. */ + ppecho_switch_list (MORE_DEPTH repls, + repls->token_queue); + repls->token_queue = NULL; + } else { + check_replace (MORE_DEPTH repls, repls->replace_list); + } + } else { + check_replace (MORE_DEPTH repls, repls->current_list); + } +} + +/* Whether a word matches the definition of WORD in pplex.l */ +static +int is_word (WITH_DEPTH const char* s){ + int i; + int len = strlen (s); + + + for( i = 0; i= '0' && c <= '9' ) + || ( c >= 'A' && c <= 'Z' ) + || ( c >= 'a' && c <= 'z' ) + || ( c >= 128 && c <= 255 ) + ){ + + } else { +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sis_word('%s') -> FALSE\n", DEPTH, s); +#endif + return FALSE; + } + } +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sis_word('%s') -> TRUE\n", DEPTH, s); +#endif + return TRUE; +} + +static void add_token_to_replace (WITH_DEPTH struct cb_replacement_state *repls, + int prequeue, + const char* token + ) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sadd_token_to_replace(%s%s, '%s')\n", DEPTH, + repls->name, prequeue ? ", PREQUEUE" : "", token); +#endif + if( prequeue ){ + + if( is_word (MORE_DEPTH token) ) { + + if( repls->token_prequeue == NULL ){ + repls->token_prequeue = + cobc_plex_strdup (token); + } else { + repls->token_prequeue = + cobc_plex_stradd (repls->token_prequeue, + token); + } + } else { + + if( repls->token_prequeue == NULL ){ + add_token_to_replace(MORE_DEPTH repls, FALSE, token); + } else { + const char* pretoken = repls->token_prequeue; + repls->token_prequeue = NULL; + add_token_to_replace(MORE_DEPTH repls, + FALSE, pretoken); + add_token_to_replace(MORE_DEPTH repls, + FALSE, token); + } + } + } + else { + if( repls->token_queue == NULL && + ( is_space_or_nl (token[0])) ) { + ppecho_switch (MORE_DEPTH repls, token); + } else { +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, + "%s add_token_to_replace() -> push_token()\n", + DEPTH); +#endif + repls->token_queue = + text_list_add(MORE_DEPTH repls->token_queue, + token); + + do_replace (MORE_DEPTH repls); + } + } +} + +static +struct cb_replacement_state * create_replacements( enum cb_ppecho ppecho ) +{ + struct cb_replacement_state * s; + + s = cobc_malloc (sizeof(struct cb_replacement_state)); + + s->token_prequeue = NULL; + s->token_queue = NULL; + s->replace_list = NULL ; + s->current_list = NULL ; + s->ppecho = ppecho; + +#ifdef DEBUG_REPLACE + if( ppecho == CB_PPECHO_REPLACE ){ + s->name = "COPY-REPLACING"; + } else { + s->name = "REPLACE"; + } +#endif + + return s; +} + +static void reset_replacements( struct cb_replacement_state * s ) +{ + s->token_prequeue = NULL; + s->token_queue = NULL; + s->replace_list = NULL ; + s->current_list = NULL ; +} + +static void ppecho_replace (WITH_DEPTH const char *token) +{ +#ifdef DEBUG_REPLACE + fprintf(stderr, "%sppecho_replace('%s')\n", DEPTH, token); +#endif + add_token_to_replace(MORE_DEPTH replace_repls, TRUE, token); +} + +void ppecho_copy (const char *token) +{ +#ifdef DEBUG_REPLACE + fprintf(stderr, "ppecho_copy('%s')\n", token); +#endif + add_token_to_replace(INIT_DEPTH copy_repls, FALSE, token); +} + +void init_replace( void ) +{ +#ifdef DEBUG_REPLACE_TRACE + for(int i=0; ireplace_list ; +} + +void set_copy_replacing_list (struct cb_replace_list *list) +{ + struct cb_replacement_state * repls = copy_repls ; + + repls->current_list = NULL; + repls->replace_list = list ; +#ifdef DEBUG_REPLACE + fprintf(stderr, "set_copy_replacing_list(\n"); + for(;list != NULL; list=list->next){ + fprintf(stderr, " repl = {\n"); + fprintf(stderr, " src = %s\n", + string_of_list(list->src->text_list)); + fprintf(stderr, " leading = %d\n", + list->src->lead_trail); + fprintf(stderr, " new_text = %s\n", + string_of_list(list->new_text)); + fprintf(stderr, " };\n"); + } + fprintf(stderr, " )\n"); +#endif +} + +void +set_replace_list (struct cb_replace_list *list, const int is_pushpop) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "set_replace_list(...)\n"); +#endif + struct cb_replacement_state * repls = replace_repls ; + /* Do not reset current candidates as the REPLACE is not yet active + repls->current_list = NULL; + */ + + /* We changed the former behavior of GnuCOBOL, because the + `return` statements used to return from + `pp_set_replace_list` before calling + `set_print_replace_list`, whereas this function is not + always called. */ + if (!list) { + /* REPLACE [LAST] OFF */ + if (!is_pushpop) { + repls->replace_list = NULL; + return; + } + if (!repls->replace_list) { + return; + } + repls->replace_list = repls->replace_list->prev; + return; + } + /* REPLACE [ALSO] ... */ + if (repls->replace_list && is_pushpop) { + list->last->next = repls->replace_list; + list->prev = repls->replace_list; + } else { + list->prev = NULL; + } + repls->replace_list = list; +} diff --git a/cobc/replace.h b/cobc/replace.h new file mode 100644 index 000000000..9ae41ffaa --- /dev/null +++ b/cobc/replace.h @@ -0,0 +1,44 @@ +/* + Copyright (C) 2023-2023 Free Software Foundation, Inc. + Written by Fabrice Le Fessant + + This file is part of GnuCOBOL. + + The GnuCOBOL compiler is free software: you can redistribute it + and/or modify it under the terms of the GNU General Public License + as published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. + + GnuCOBOL is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GnuCOBOL. If not, see . +*/ + +#ifndef CB_REPLACE_H +#define CB_REPLACE_H + +// defined in pplex.l +extern void ppecho_direct (const char *); +extern struct cb_text_list *pp_text_list_add (struct cb_text_list *, + const char *, const size_t); + +// defined in replace.c + +extern void init_replace (void); +extern void reset_replace (void); +extern void free_replace (void); +extern void ppecho_copy (const char *); + +/* For COPY-REPLACING */ +extern void set_copy_replacing_list (struct cb_replace_list *list); +extern struct cb_replace_list * get_copy_replacing_list (void); + +/* For REPLACE, called from yylex.l pp_set_replace_list */ +extern void +set_replace_list (struct cb_replace_list *list, const int is_pushpop); + +#endif // CB_REPLACE_H diff --git a/tests/testsuite.src/syn_copy.at b/tests/testsuite.src/syn_copy.at index 9fbb52f4c..750adf5a1 100644 --- a/tests/testsuite.src/syn_copy.at +++ b/tests/testsuite.src/syn_copy.at @@ -921,7 +921,7 @@ AT_CLEANUP AT_SETUP([COPY and REPLACE in same file]) -AT_KEYWORDS([copy]) +AT_KEYWORDS([copy replace]) # see Bug #868 # the issue with this example is that the outer REPLACE @@ -933,8 +933,6 @@ AT_KEYWORDS([copy]) # continue the loop with the - potential partially replaced - # new content. -AT_XFAIL_IF([true]) - AT_DATA([copy.inc], [ 01 VAR-:TEST: PIC X(2) VALUE "OK". ]) @@ -956,4 +954,4 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], []) -AT_CLEANUP \ No newline at end of file +AT_CLEANUP From fbc435daf7019ec81512d930368d7e817af89178 Mon Sep 17 00:00:00 2001 From: Nicolas Berthier Date: Thu, 25 Aug 2022 13:16:41 +0200 Subject: [PATCH 05/11] [GCOS] PR57 Add support for GCOS-specific SELECT --- cobc/ChangeLog | 16 ++++ cobc/codegen.c | 10 +++ cobc/config.def | 12 +++ cobc/parser.y | 118 ++++++++++++++++++++++++--- cobc/reserved.c | 30 +++++++ cobc/scanner.l | 40 +++++++++ cobc/tree.h | 5 ++ cobc/typeck.c | 64 +++++++++++++++ config/ChangeLog | 6 ++ config/acu-strict.conf | 7 ++ config/bs2000-strict.conf | 7 ++ config/cobol2002.conf | 7 ++ config/cobol2014.conf | 7 ++ config/cobol85.conf | 7 ++ config/default.conf | 7 ++ config/gcos-strict.conf | 7 ++ config/ibm-strict.conf | 7 ++ config/mf-strict.conf | 7 ++ config/mvs-strict.conf | 7 ++ config/realia-strict.conf | 7 ++ config/rm-strict.conf | 7 ++ config/xopen.conf | 7 ++ libcob/ChangeLog | 5 ++ libcob/common.h | 3 + libcob/fileio.c | 57 +++++++------ tests/testsuite.src/configuration.at | 4 + 26 files changed, 420 insertions(+), 41 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 5eeb9915a..ba4488dd9 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -722,6 +722,22 @@ * field.c (has_std_needed_screen_clause), typeck.c (validate_alphabet), codegen.c (output_initialize_one): minor refactorings +2022-08-02 David Declerck + + Support GCOS-specific SELECT + * config.def: add options interpret-assign-literal, select-external, + select-extra-organization-clauses, select-with + * tree.h, typeck.c (cb_build_interpreted_assignment_name, + is_valid_assign_filename): new functions to support tokenization and + parsing of interpreted literals in ASSIGN clause + * parser.y: add support for interpreted literals for ASSIGN clause in + SELECT, SELECT EXTERNAL, WITH clause (syntax only), and extra + organization clauses (syntax only) + * reserved.c, scanner.l: add reserved keywords for WITH and + organization clauses + * codegen.c (output_file_initialization): record default file + assignment + 2022-08-20 Simon Sobisch * pplex.l: match and ignore editor folding $REGION statement diff --git a/cobc/codegen.c b/cobc/codegen.c index c57ac028a..482620fa8 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -9135,6 +9135,16 @@ output_file_initialization (struct cb_file *f) output_param (f->assign, -1); output (";"); output_newline (); + + output_prefix (); + output ("%s%s->assign_default = ", CB_PREFIX_FILE, f->cname); + if (f->assign_default) { + output ("\"%s\";", f->assign_default); + } else { + output ("NULL;"); + } + output_newline (); + output_prefix (); output ("%s%s->record = ", CB_PREFIX_FILE, f->cname); output_param (CB_TREE (f->record), -1); diff --git a/cobc/config.def b/cobc/config.def index d7a65e7b4..4378ff8de 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -183,6 +183,9 @@ CB_CONFIG_BOOLEAN (cb_move_nonnumlit_to_numeric_is_zero, "move-non-numeric-lit-t CB_CONFIG_BOOLEAN (cb_implicit_assign_dynamic_var, "implicit-assign-dynamic-var", _("implicitly define a variable if an ASSIGN DYNAMIC does not match any data item")) +CB_CONFIG_BOOLEAN (cb_interpret_assign_literal, "interpret-assign-literal", + _("interpret literal arguments to ASSIGN clause in SELECT")) + CB_CONFIG_BOOLEAN (cb_device_mnemonics, "device-mnemonics", _("specifying device by mnemonic")) @@ -410,6 +413,15 @@ CB_CONFIG_SUPPORT (cb_continue_after, "continue-after", CB_CONFIG_SUPPORT (cb_goto_entry, "goto-entry", _("ENTRY FOR GO TO and GO TO ENTRY statements")) +CB_CONFIG_SUPPORT (cb_select_external, "select-external", + _("SELECT EXTERNAL")) + +CB_CONFIG_SUPPORT (cb_select_extra_oganization_clauses, "select-extra-organization-clauses", + _("extra ORGANIZATION clauses in SELECT")) + +CB_CONFIG_SUPPORT (cb_select_with, "select-with", + _("WITH clause in SELECT")) + CB_CONFIG_SUPPORT (cb_assign_variable, "assign-variable", _("ASSIGN [TO] variable in SELECT")) diff --git a/cobc/parser.y b/cobc/parser.y index acaeecdc5..de12d5db5 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -2378,6 +2378,7 @@ set_record_size (cb_tree min, cb_tree max) %token ALTER %token ALTERNATE %token AND +%token ANSI /* GCOS */ %token ANY %token APPLY %token ARE @@ -2387,6 +2388,7 @@ set_record_size (cb_tree min, cb_tree max) %token ARGUMENT_VALUE "ARGUMENT-VALUE" %token ARITHMETIC %token AS +%token ASA /* GCOS */ %token ASCENDING %token ASCII %token ASSIGN @@ -2441,6 +2443,7 @@ set_record_size (cb_tree min, cb_tree max) %token BOTTOM %token BOX %token BOXED +%token BSN /* GCOS */ %token BULK_ADDITION "BULK-ADDITION" %token BUSY %token BUTTONS @@ -2704,6 +2707,7 @@ set_record_size (cb_tree min, cb_tree max) %token FLOAT_LONG "FLOAT-LONG" %token FLOAT_SHORT "FLOAT-SHORT" %token FLOATING +%token FLR /* GCOS */ %token FONT %token FOOTING %token FOR @@ -2951,6 +2955,7 @@ set_record_size (cb_tree min, cb_tree max) %token OVERLAP_LEFT "OVERLAP-LEFT" %token OVERLAP_TOP "OVERLAP-TOP" %token OVERLINE +%token OVERRIDING /* GCOS */ %token PACKED_DECIMAL "PACKED-DECIMAL" %token PADDING %token PASCAL @@ -3007,6 +3012,7 @@ set_record_size (cb_tree min, cb_tree max) %token PUSH_BUTTON "PUSH-BUTTON" %token QUERY_INDEX "QUERY-INDEX" %token QUEUE +%token QUEUED /* GCOS */ %token QUOTE %token RADIO_BUTTON "RADIO-BUTTON" %token RAISE @@ -3084,6 +3090,7 @@ set_record_size (cb_tree min, cb_tree max) %token RUN %token S %token SAME +%token SARF /* GCOS */ %token SAVE_AS "SAVE-AS" %token SAVE_AS_NO_PROMPT "SAVE-AS-NO-PROMPT" %token SCREEN @@ -3139,6 +3146,7 @@ set_record_size (cb_tree min, cb_tree max) %token SPECIAL_NAMES "SPECIAL-NAMES" %token SPINNER %token SQUARE +%token SSF /* GCOS */ %token STANDARD %token STANDARD_1 "STANDARD-1" %token STANDARD_2 "STANDARD-2" @@ -3237,6 +3245,7 @@ set_record_size (cb_tree min, cb_tree max) %token TYPEDEF %token U %token UCS_4 "UCS-4" +%token UFF /* GCOS */ %token UNBOUNDED %token UNDERLINE %token UNFRAMED @@ -3285,6 +3294,7 @@ set_record_size (cb_tree min, cb_tree max) %token VERTICAL %token VERY_HEAVY "VERY-HEAVY" %token VIRTUAL_WIDTH "VIRTUAL-WIDTH" +%token VLR /* GCOS */ %token VOLATILE %token VPADDING %token VSCROLL @@ -5218,8 +5228,8 @@ _file_control_sequence: ; file_control_entry: - SELECT { check_non_area_a ($1); } - flag_optional undefined_word +SELECT { check_non_area_a ($1); } + flag_external flag_optional undefined_word { char buff[COB_MINI_BUFF]; @@ -5227,10 +5237,10 @@ file_control_entry: COBC_HD_INPUT_OUTPUT_SECTION, COBC_HD_FILE_CONTROL, 0); check_duplicate = 0; - if (CB_VALID_TREE ($4)) { + if (CB_VALID_TREE ($5)) { /* Build new file */ - current_file = build_file ($4); - current_file->optional = CB_INTEGER ($3)->val; + current_file = build_file ($5); + current_file->optional = CB_INTEGER ($4)->val; /* Add file to current program list */ CB_ADD_TO_CHAIN (CB_TREE (current_file), @@ -5245,6 +5255,12 @@ file_control_entry: } key_type = NO_KEY; + + if ($3 && cb_verify (cb_select_external, "SELECT EXTERNAL")) { + /* (GCOS extension) */ + current_file->flag_select_external = 1; + current_file->flag_external = 1; + } } _select_clauses_or_error { @@ -5303,6 +5319,10 @@ select_clause: | track_area_clause | track_limit_clause | encryption_clause +| with_clause + { + (void) cb_verify (cb_select_with, _("WITH clause in SELECT")); + } /* FXIME: disabled because of shift/reduce conflict (optional in [alternate] record key, could be moved here if the suppress_clause goes here too and both entries verify that @@ -5318,6 +5338,15 @@ select_clause: */ ; +with_clause: + ASA +| SSF +| SARF +| FLR +| VLR +| BSN +| OVERRIDING +; /* ASSIGN clause */ @@ -5332,10 +5361,17 @@ assign_clause: cb_error (_("EXTERNAL/DYNAMIC cannot be used with literals")); } - current_file->assign_type = CB_ASSIGN_EXT_FILE_NAME_REQUIRED; - current_file->assign = cb_build_assignment_name (current_file, $5); + if (cb_interpret_assign_literal) { + /* current_file->assign_type is set by _ext_clause */ + current_file->assign = + cb_build_interpreted_assignment_name (current_file, $5, + ¤t_file->assign_default); + } else { + current_file->assign_type = CB_ASSIGN_EXT_FILE_NAME_REQUIRED; + current_file->assign = cb_build_assignment_name (current_file, $5); + } } -| ASSIGN _to _ext_clause _assign_device_or_line_adv_file qualified_word +| ASSIGN _to _ext_clause _assign_device_or_line_adv_file qualified_word _literal { check_repeated ("ASSIGN", SYN_CLAUSE_1, &check_duplicate); @@ -5343,7 +5379,18 @@ assign_clause: if (!ext_dyn_specified) { current_file->flag_assign_no_keyword = 1; } - current_file->assign = cb_build_assignment_name (current_file, $5); + + if (cb_interpret_assign_literal) { + current_file->assign = + cb_build_assignment_name (current_file, $5); + current_file->assign_default = + $6 ? (char *)CB_LITERAL ($6)->data : NULL; + } else { + current_file->assign = cb_build_assignment_name (current_file, $5); + if( $6 != NULL ){ + cb_error (_("ASSIGN TO ... literal is forbidden here")); + } + } } | ASSIGN _to _ext_clause _assign_device_or_line_adv_file using_or_varying qualified_word { @@ -5504,6 +5551,11 @@ assignment_name: | qualified_word ; +_literal: + /* empty */ { $$ = NULL; } +| LITERAL { $$ = $1; } +; + /* ACCESS MODE clause */ access_mode_clause: @@ -5810,19 +5862,19 @@ organization_clause: ; organization: - INDEXED + org_indexed { check_repeated ("ORGANIZATION", SYN_CLAUSE_6, &check_duplicate); error_if_record_delimiter_incompatible (COB_ORG_INDEXED, "INDEXED"); current_file->organization = COB_ORG_INDEXED; } -| _record _binary SEQUENTIAL +| org_sequential { check_repeated ("ORGANIZATION", SYN_CLAUSE_6, &check_duplicate); error_if_record_delimiter_incompatible (COB_ORG_SEQUENTIAL, "SEQUENTIAL"); current_file->organization = COB_ORG_SEQUENTIAL; } -| RELATIVE +| org_relative { check_repeated ("ORGANIZATION", SYN_CLAUSE_6, &check_duplicate); error_if_record_delimiter_incompatible (COB_ORG_RELATIVE, "RELATIVE"); @@ -5837,6 +5889,39 @@ organization: } ; +org_indexed: + INDEXED +| UFF INDEXED + { + (void) cb_verify (cb_select_extra_oganization_clauses, + _("ORGANIZATION UFF INDEXED in SELECT")); + } +; + +org_sequential: + _record _binary SEQUENTIAL +| select_extra_org_clause _record _binary SEQUENTIAL + { + (void) cb_verify (cb_select_extra_oganization_clauses, + _("ORGANIZATION UFF/ANSI/QUEUED in SELECT")); + } +; + +org_relative: + RELATIVE +| UFF RELATIVE + { + (void) cb_verify (cb_select_extra_oganization_clauses, + _("ORGANIZATION UFF RELATIVE in SELECT")); + } +; + +select_extra_org_clause: + UFF +| ANSI +| QUEUED +; + /* PADDING CHARACTER clause */ @@ -6407,6 +6492,10 @@ file_description_clause: cb_error (_("%s and %s are mutually exclusive"), "EXTERNAL", "GLOBAL"); } #endif + if (current_file->flag_select_external) { + cb_error (_("EXTERNAL clause can not be used both in the file " + "descriptor and the file control entry")); + } current_file->flag_external = 1; } | _is GLOBAL @@ -19819,6 +19908,11 @@ flag_optional: | NOT OPTIONAL { $$ = cb_int0; } ; +flag_external: + /* empty */ { $$ = NULL; } +| EXTERNAL { $$ = cb_true; } +; + flag_rounded: /* empty */ { diff --git a/cobc/reserved.c b/cobc/reserved.c index b034431e2..47de9f719 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -334,6 +334,9 @@ static struct cobc_reserved default_reserved_words[] = { { "AND", 0, 0, AND, /* 2002 */ 0, 0 }, + { "ANSI", 0, 1, ANSI, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "ANY", 0, 0, ANY, /* 2002 */ 0, 0 }, @@ -367,6 +370,9 @@ static struct cobc_reserved default_reserved_words[] = { { "AS", 0, 0, AS, /* 2002 */ 0, 0 }, + { "ASA", 0, 1, ASA, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "ASCENDING", 0, 0, ASCENDING, /* 2002 */ 0, 0 }, @@ -530,6 +536,9 @@ static struct cobc_reserved default_reserved_words[] = { { "BULK-ADDITION", 0, 1, BULK_ADDITION, /* ACU extension */ 0, CB_CS_OPEN }, + { "BSN", 0, 1, BSN, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "BUSY", 0, 1, BUSY, /* ACU extension */ 0, CB_CS_GRAPHICAL_CONTROL | CB_CS_INQUIRE_MODIFY }, @@ -1390,6 +1399,9 @@ static struct cobc_reserved default_reserved_words[] = { { "FLOATING", 0, 0, FLOATING, /* ACU extension */ 0, CB_CS_DISPLAY }, + { "FLR", 0, 1, FLR, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "FONT", 0, 0, FONT, /* ACU extension */ 0, 0 /* Checkme: likely context sensitive */ }, @@ -2122,6 +2134,9 @@ static struct cobc_reserved default_reserved_words[] = { { "OVERRIDE", 0, 0, -1, /* 2002 */ 0, 0 }, + { "OVERRIDING", 0, 1, OVERRIDING, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "PACKED-DECIMAL", 0, 0, PACKED_DECIMAL, /* 2002 */ 0, 0 }, @@ -2293,6 +2308,9 @@ static struct cobc_reserved default_reserved_words[] = { { "QUEUE", 0, 0, QUEUE, /* Communication Section */ 0, 0 }, + { "QUEUED", 0, 1, QUEUED, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "QUOTE", 0, 0, QUOTE, /* 2002 */ 0, 0 }, @@ -2525,6 +2543,9 @@ static struct cobc_reserved default_reserved_words[] = { { "SAME", 0, 0, SAME, /* 2002 */ 0, 0 }, + { "SARF", 0, 1, SARF, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "SAVE-AS", 0, 1, SAVE_AS, /* ACU extension */ 0, CB_CS_GRAPHICAL_CONTROL | CB_CS_INQUIRE_MODIFY }, @@ -2694,6 +2715,9 @@ static struct cobc_reserved default_reserved_words[] = { { "SQUARE", 0, 1, SQUARE, /* ACU extension */ 0, CB_CS_GRAPHICAL_CONTROL | CB_CS_INQUIRE_MODIFY }, + { "SSF", 0, 1, SSF, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "STACK", 0, 1, -1, /* 2023 (C/S) */ 0, CB_CS_MODULE_NAME }, @@ -2949,6 +2973,9 @@ static struct cobc_reserved default_reserved_words[] = { { "UCS-4", 0, 1, UCS_4, /* 2002 (C/S) */ 0, CB_CS_ALPHABET }, + { "UFF", 0, 1, UFF, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "UNBOUNDED", 0, 1, UNBOUNDED, /* IBM V5 */ 0, CB_CS_OCCURS }, @@ -3081,6 +3108,9 @@ static struct cobc_reserved default_reserved_words[] = { { "VOLATILE", 0, 0, VOLATILE, /* IBM Extension */ 0, 0 }, + { "VLR", 0, 1, VLR, /* GCOS extension */ + 0, CB_CS_SELECT + }, { "VPADDING", 0, 1, VPADDING, /* ACU extension */ 0, CB_CS_GRAPHICAL_CONTROL | CB_CS_INQUIRE_MODIFY }, diff --git a/cobc/scanner.l b/cobc/scanner.l index b2da3372d..c16345419 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -848,6 +848,46 @@ H#[0-9A-Za-z]+ { RETURN_TOK (DATA); } +"WITH"[ ,;\n]+"ASA"/[ .,;\n] { + count_lines (yytext); + RETURN_TOK (ASA); +} + +"WITH"[ ,;\n]+"SSF"/[ .,;\n] { + count_lines (yytext); + RETURN_TOK (SSF); +} + +"WITH"[ ,;\n]+"SARF"/[ .,;\n] { + count_lines (yytext); + RETURN_TOK (SARF); +} + +"WITH"[ ,;\n]+"FLR"/[ .,;\n] { + count_lines (yytext); + RETURN_TOK (FLR); +} + +"WITH"[ ,;\n]+"VLR"/[ .,;\n] { + count_lines (yytext); + RETURN_TOK (VLR); +} + +"NO"[ ,;\n]+"BSN"/[ .,;\n] { + count_lines (yytext); + RETURN_TOK (BSN); +} + +"WITH"[ ,;\n]+("NO"[ ,;\n]+)?"BSN"/[ .,;\n] { + count_lines (yytext); + RETURN_TOK (BSN); +} + +"WITH"[ ,;\n]+"OVERRIDING"/[ .,;\n] { + count_lines (yytext); + RETURN_TOK (OVERRIDING); +} + "UPON"[ ,;\n]+"ENVIRONMENT-NAME"/[ .,;\n] { count_lines (yytext); RETURN_TOK (UPON_ENVIRONMENT_NAME); diff --git a/cobc/tree.h b/cobc/tree.h index d44927f7e..83455e703 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1098,6 +1098,7 @@ struct cb_file { char *cname; /* Name used in C */ /* SELECT */ cb_tree assign; /* ASSIGN */ + char *assign_default; /* [GCOS] Filename to use if file mapping fails */ cb_tree file_status; /* FILE STATUS */ cb_tree sharing; /* SHARING */ cb_tree key; /* Primary RECORD KEY */ @@ -1148,6 +1149,7 @@ struct cb_file { /* Whether the file's ASSIGN is like "ASSIGN word", not "ASSIGN EXTERNAL/DYNAMIC/USING/... word" */ unsigned int flag_assign_no_keyword : 1; + unsigned int flag_select_external : 1; /* [GCOS] EXTERNAL on SELECT */ /* Exceptions enabled for file */ struct cb_exception *exception_table; }; @@ -2343,6 +2345,9 @@ extern cb_tree cb_define_switch_name (cb_tree, cb_tree, const int); extern void cb_check_word_length (unsigned int, const char *); extern cb_tree cb_build_section_name (cb_tree, const int); extern cb_tree cb_build_assignment_name (struct cb_file *, cb_tree); +extern cb_tree cb_build_interpreted_assignment_name (struct cb_file * const, + const cb_tree, + char ** const); extern cb_tree cb_build_index (cb_tree, cb_tree, const unsigned int, struct cb_field *); extern cb_tree cb_build_identifier (cb_tree, const int); diff --git a/cobc/typeck.c b/cobc/typeck.c index 22f270594..254799de1 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2242,6 +2242,70 @@ cb_build_assignment_name (struct cb_file *cfile, cb_tree name) } } +static int +is_valid_assign_filename (const char *fn) +{ /* GCOS rules for ASSIGN filename */ + while (*fn && (isalnum (*fn) || *fn == '_' || *fn == '-' || *fn == '.')) + fn++; + return *fn == '\0'; +} + + +/* Tries to interpret GCOS literal-1 to `SELECT x ASSIGN TO y literal-1` + where `literal-1` is a string containing zero, one or two positional arguments + (i.e. simple words) and additional non-positional arguments (i.e. `key=value`). + Returns the filename and also set the assign_default if not NULL. +*/ +cb_tree +cb_build_interpreted_assignment_name (struct cb_file * const cfile, + const cb_tree name, + char ** const assign_default) +{ + /* assign_default == NULL => only one positional is allowed */ + cb_tree res = NULL; + char *data, *n, *d, *filename; + + if (!name || name == cb_error_node || + !(CB_LITERAL_P (name) || CB_REFERENCE_P (name))) { + return cb_error_node; + } + + data = cob_strdup (CB_LITERAL_P (name) + ? (char *)(CB_LITERAL (name)->data) + : CB_NAME (name)); + n = strtok (data, " \t,"); + if (n && strchr (n, '=') == NULL ) { /* get out if non-positional */ + d = strtok (NULL, " \t,"); + if (d && strchr (d, '=') == NULL) { /* get out if non-positional */ + /* two positionals: n is an internal-file-name, d is + the file-name */ + if (!assign_default) { + cb_error_x (name, + _("expected at most one " + "positional parameter in '%s'"), + data); + } + filename = d; + } else { + /* only one positional: n is the file-name */ + filename = n; + } + res = cb_build_alphanumeric_literal (filename, + strlen (filename)); + if (assign_default) { + /* record filename */ + *assign_default = strdup (filename); + } + } + cob_free (data); + + if (res && !is_valid_assign_filename ((char *)(CB_LITERAL (res)->data))) { + cb_error_x (name, _("invalid filename in ASSIGN literal")); + } + + return res; +} + cb_tree cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by, struct cb_field *qual) diff --git a/config/ChangeLog b/config/ChangeLog index 02e1776ba..7b9ef29c5 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -69,6 +69,12 @@ * general: do not reserve EXAMINE keyword by default, only in lax configurations +2022-08-02 David Declerck + + * general: add options interpret-assign-literal, select-external, + select-extra-organization-clauses, select-with, to support + GCOS-style SELECT + 2022-08-17 Simon Sobisch * general: add xml-parse-xmlss, note: explicit NOT enabled diff --git a/config/acu-strict.conf b/config/acu-strict.conf index d40e8b6b0..cbbd47daf 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -184,6 +184,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: no @@ -269,6 +273,9 @@ zero-length-literals: unconformable # not verified yet xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: ok assign-using-variable: unconformable assign-ext-dyn: ok diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index c179460ef..b503e0ad5 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -182,6 +182,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: no @@ -266,6 +270,9 @@ zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: unconformable assign-using-variable: ok assign-ext-dyn: unconformable diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 6efddd690..e5065259d 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -181,6 +181,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: no @@ -265,6 +269,9 @@ zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: unconformable assign-using-variable: ok assign-ext-dyn: unconformable diff --git a/config/cobol2014.conf b/config/cobol2014.conf index cf07f8220..63cba1c7f 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -181,6 +181,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: no @@ -265,6 +269,9 @@ zero-length-literals: ok xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: unconformable assign-using-variable: ok assign-ext-dyn: unconformable diff --git a/config/cobol85.conf b/config/cobol85.conf index 960ed3bb4..6780c0a98 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -181,6 +181,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: no @@ -265,6 +269,9 @@ zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: unconformable diff --git a/config/default.conf b/config/default.conf index 55773890f..f2a76bb99 100644 --- a/config/default.conf +++ b/config/default.conf @@ -201,6 +201,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: no @@ -286,6 +290,9 @@ zero-length-literals: ok xml-generate-extra-phrases: ok continue-after: ok goto-entry: warning +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: ok assign-using-variable: ok assign-ext-dyn: ok diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 39786e1d3..33d1e0a57 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -180,6 +180,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: yes + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: yes @@ -264,6 +268,9 @@ zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: ok +select-extra-organization-clauses: ok +select-with: ok assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: unconformable diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 9cd043a0f..9343608a3 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -180,6 +180,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: yes @@ -264,6 +268,9 @@ zero-length-literals: unconformable xml-generate-extra-phrases: ok continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: unconformable diff --git a/config/mf-strict.conf b/config/mf-strict.conf index a7099faf5..a3961f621 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -183,6 +183,10 @@ move-non-numeric-lit-to-numeric-is-zero: yes # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: yes @@ -268,6 +272,9 @@ zero-length-literals: unconformable xml-generate-extra-phrases: ok continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: ok diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index a711015d8..1ae611fe1 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -180,6 +180,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: yes @@ -264,6 +268,9 @@ zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: unconformable diff --git a/config/realia-strict.conf b/config/realia-strict.conf index 4ece96943..86dd101e3 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -184,6 +184,10 @@ move-non-numeric-lit-to-numeric-is-zero: yes # match an existing data item. implicit-assign-dynamic-var: no +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: no @@ -269,6 +273,9 @@ zero-length-literals: unconformable # not verified yet xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: unconformable assign-using-variable: ok assign-ext-dyn: unconformable diff --git a/config/rm-strict.conf b/config/rm-strict.conf index fe90fab22..b148f599e 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -186,6 +186,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # not verified yet # match an existing data item. implicit-assign-dynamic-var: no +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: no @@ -271,6 +275,9 @@ zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: unconformable +select-extra-organization-clauses: unconformable +select-with: unconformable assign-variable: ok assign-using-variable: unconformable assign-ext-dyn: unconformable diff --git a/config/xopen.conf b/config/xopen.conf index fb589389b..ae688727c 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -194,6 +194,10 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, interpret literal arguments to ASSIGN clause in SELECT as a +# list of positional and key-value parameters (GCOS extension) +interpret-assign-literal: no + # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics device-mnemonics: no @@ -284,6 +288,9 @@ zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable +select-external: unconformable # not checked yet +select-extra-organization-clauses: unconformable # not checked yet +select-with: unconformable # not checked yet assign-variable: ok assign-using-variable: unconformable assign-ext-dyn: unconformable diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 8e537f7a7..572ef070b 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -545,6 +545,11 @@ on mouse-move * common.c (cob_sys_exit_proc): fix compiler warning +2022-08-02 David Declerck + + * common.h (cob_file), fileio.c (cob_chk_file_mapping): support ASSIGN + fallback (GCOS extension) + 2022-08-19 Simon Sobisch * mlio.c, common.h: added XML PARSE stub including minimal diff --git a/libcob/common.h b/libcob/common.h index 7fe2b1008..ab6c31856 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1383,6 +1383,9 @@ typedef struct __cob_file { const unsigned char* code_set_read; /* CODE-SET conversion for READs */ size_t nconvert_fields; /* Number of logical fields to convert */ cob_field *convert_field; /* logical fields to convert for CODE-SET */ + + const char *assign_default; /* [GCOS] External filename to use if file mapping fails */ + } cob_file; diff --git a/libcob/fileio.c b/libcob/fileio.c index 42990029a..3cb49b674 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -1032,7 +1032,7 @@ cob_chk_file_env (const char *src) /* checks if 'src' containes a / or \ */ static int -has_directory_separator (char *src) +has_directory_separator (const char *src) { for (; *src; src++) { if (*src == '/' || *src == '\\') { @@ -1044,7 +1044,7 @@ has_directory_separator (char *src) /* checks if 'src' looks like starting with name */ static int -looks_absolute (char *src) +looks_absolute (const char * const src) { /* no file path adjustment if filename is absolute because it begins with a slash (or win-disk-drive) */ @@ -1076,26 +1076,20 @@ has_acu_hyphen (char *src) static void do_acu_hyphen_translation (char *src) { - size_t len; /* maybe store device type to "adjust locking rules" */ /* find first non-space and return it in the original storage */ for (src = src + 3; *src && isspace ((cob_u8_t)*src); src++); - len = strlen (src); - if (len >= COB_FILE_MAX) { - len = COB_FILE_MAX; - } - memcpy (file_open_buff, src, len); - file_open_buff[len + 1] = 0; - + strncpy (file_open_buff, src, (size_t)COB_FILE_MAX); + file_open_buff[COB_FILE_MAX] = 0; strncpy (file_open_name, file_open_buff, (size_t)COB_FILE_MAX); } static void -cob_chk_file_mapping (void) +cob_chk_file_mapping (cob_file *f) { - char *p; - char *src; + const char *p; + const char *src; char *dst; char *saveptr; char *orig; @@ -1125,7 +1119,10 @@ cob_chk_file_mapping (void) /* Check for DD_xx, dd_xx, xx environment variables */ /* Note: ACU and Fujitsu would only check for xx */ /* If not found, use as is, possibly including the dollar character */ - if ((p = cob_chk_file_env (src)) != NULL) { + if (((p = cob_chk_file_env (src)) != NULL) + /* ASSIGN fallback: use the default name if not found via + environment variables (GCOS extension) */ + || (f && (p = f->assign_default) != NULL)) { strncpy (file_open_name, p, (size_t)COB_FILE_MAX); /* Note: ACU specifies: "repeated until variable can't be resolved" we don't apply this and will not in the future @@ -1154,6 +1151,8 @@ cob_chk_file_mapping (void) /* Complex */ /* Note: ACU and Fujitsu would return the value back and stop here */ + /* Note: on GCOS, we should not reach this point (no separator in + internal filename) */ /* Isolate first element (everything before the slash) */ /* If it starts with a $, mark and skip over the $ */ @@ -1795,7 +1794,7 @@ cob_file_open (cob_file *f, char *filename, ret = extfh_seqra_locate (f, filename); switch (ret) { case COB_NOT_CONFIGURED: - cob_chk_file_mapping (); + cob_chk_file_mapping (f); errno = 0; if (access (filename, F_OK) && errno == ENOENT) { if (mode != COB_OPEN_OUTPUT && f->flag_optional == 0) { @@ -1835,7 +1834,7 @@ cob_file_open (cob_file *f, char *filename, /* Note filename points to file_open_name */ /* cob_chk_file_mapping manipulates file_open_name directly */ - cob_chk_file_mapping (); + cob_chk_file_mapping (f); nonexistent = 0; errno = 0; @@ -4128,7 +4127,7 @@ indexed_open (cob_file *f, char *filename, ret = extfh_indexed_locate (f, filename); switch (ret) { case COB_NOT_CONFIGURED: - cob_chk_file_mapping (); + cob_chk_file_mapping (f); errno = 0; if (access (filename, F_OK) && errno == ENOENT) { if (mode != COB_OPEN_OUTPUT && f->flag_optional == 0) { @@ -4174,7 +4173,7 @@ indexed_open (cob_file *f, char *filename, COB_UNUSED (sharing); - cob_chk_file_mapping (); + cob_chk_file_mapping (f); if (mode == COB_OPEN_INPUT) { checkvalue = R_OK; @@ -4419,7 +4418,7 @@ indexed_open (cob_file *f, char *filename, #endif } } - cob_chk_file_mapping (); + cob_chk_file_mapping (f); #if 0 /* RXWRXW - Access check BDB Human */ if (mode == COB_OPEN_INPUT) { @@ -6861,7 +6860,7 @@ cob_delete_file (cob_file *f, cob_field *fnstatus) /* Obtain the file name */ cob_field_to_string (f->assign, file_open_name, (size_t)COB_FILE_MAX); - cob_chk_file_mapping (); + cob_chk_file_mapping (f); if (f->organization != COB_ORG_INDEXED) { #ifdef WITH_SEQRA_EXTFH @@ -7040,7 +7039,7 @@ open_cbl_file (unsigned char *file_name, unsigned char *file_access, cob_free (fn); } - cob_chk_file_mapping (); + cob_chk_file_mapping (NULL); fd = open (file_open_name, flag, COB_FILE_MODE); if (fd < 0) { @@ -7246,7 +7245,7 @@ cob_sys_delete_file (unsigned char *file_name) file_open_name[COB_FILE_MAX] = 0; cob_free (fn); } - cob_chk_file_mapping (); + cob_chk_file_mapping (NULL); ret = unlink (file_open_name); if (ret) { @@ -7283,7 +7282,7 @@ cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) file_open_name[COB_FILE_MAX] = 0; cob_free (fn); } - cob_chk_file_mapping (); + cob_chk_file_mapping (NULL); flag |= O_RDONLY; fd1 = open (file_open_name, flag, 0); @@ -7297,7 +7296,7 @@ cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) file_open_name[COB_FILE_MAX] = 0; cob_free (fn); } - cob_chk_file_mapping (); + cob_chk_file_mapping (NULL); flag &= ~O_RDONLY; flag |= O_CREAT | O_TRUNC | O_WRONLY; @@ -7352,7 +7351,7 @@ cob_sys_check_file_exist (unsigned char *file_name, unsigned char *file_info) strncpy (file_open_name, fn, (size_t)COB_FILE_MAX); cob_free (fn); } - cob_chk_file_mapping (); + cob_chk_file_mapping (NULL); if (stat (file_open_name, &st) < 0) { return 35; @@ -7412,7 +7411,7 @@ cob_sys_rename_file (unsigned char *fname1, unsigned char *fname2) file_open_name[COB_FILE_MAX] = 0; cob_free (fn); } - cob_chk_file_mapping (); + cob_chk_file_mapping (NULL); strncpy (localbuff, file_open_name, (size_t)COB_FILE_MAX); localbuff[COB_FILE_MAX] = 0; @@ -7422,7 +7421,7 @@ cob_sys_rename_file (unsigned char *fname1, unsigned char *fname2) file_open_name[COB_FILE_MAX] = 0; cob_free (fn); } - cob_chk_file_mapping (); + cob_chk_file_mapping (NULL); ret = rename (localbuff, file_open_name); if (ret) { @@ -8437,7 +8436,7 @@ cob_get_filename_print (cob_file* file, const int show_resolved_name) if (show_resolved_name) { strncpy (file_open_name, file_open_env, (size_t)COB_FILE_MAX); file_open_name[COB_FILE_MAX] = 0; - cob_chk_file_mapping (); + cob_chk_file_mapping (file); } len = strlen (file->select_name); @@ -10020,7 +10019,7 @@ EXTFH3 (unsigned char *opcode, FCD3 *fcd) f->record_min = LDCOMPX4 (fcd->minRecLen); f->record_max = LDCOMPX4 (fcd->maxRecLen); } - cob_chk_file_mapping (); + cob_chk_file_mapping (f); #if 0 /* GC 4.x+ only */ f->organization = COB_ORG_MAX; /* To Force file.dd to be processed */ sts = cob_read_dict (f, fname, 1); diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index 88d46b146..fe2636059 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -455,6 +455,7 @@ test.conf: missing definitions: no definition of 'numeric-pointer' no definition of 'move-non-numeric-lit-to-numeric-is-zero' no definition of 'implicit-assign-dynamic-var' + no definition of 'interpret-assign-literal' no definition of 'device-mnemonics' no definition of 'xml-parse-xmlss' no definition of 'areacheck' @@ -527,6 +528,9 @@ test.conf: missing definitions: no definition of 'xml-generate-extra-phrases' no definition of 'continue-after' no definition of 'goto-entry' + no definition of 'select-external' + no definition of 'select-extra-organization-clauses' + no definition of 'select-with' no definition of 'assign-variable' no definition of 'assign-using-variable' no definition of 'assign-ext-dyn' From 47611325a2cb861e8e813b76d74b66e17bab4867 Mon Sep 17 00:00:00 2001 From: Nicolas Berthier Date: Thu, 25 Aug 2022 15:32:08 +0200 Subject: [PATCH 06/11] [GCOS] PR58 Add support for ASSIGN statement --- NEWS | 2 + cobc/ChangeLog | 5 ++ cobc/config.def | 3 + cobc/parser.y | 53 ++++++++++++ cobc/reserved.c | 3 + cobc/tree.h | 3 + cobc/typeck.c | 119 +++++++++++++++++++++++++-- config/ChangeLog | 1 + 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/mf-strict.conf | 1 + config/mvs-strict.conf | 1 + config/realia-strict.conf | 1 + config/rm-strict.conf | 1 + config/xopen.conf | 1 + libcob/ChangeLog | 3 + libcob/common.h | 13 ++- libcob/fileio.c | 102 ++++++++++++++++++++++- libcob/statement.def | 2 + tests/testsuite.src/configuration.at | 1 + 26 files changed, 313 insertions(+), 10 deletions(-) diff --git a/NEWS b/NEWS index 91ba976d2..9ea3b901a 100644 --- a/NEWS +++ b/NEWS @@ -41,6 +41,8 @@ NEWS - user visible changes -*- outline -*- * PICTURE strings with L character (variable length fields) * CONTROL DIVISION with SUBSTITUTION SECTION (full support) and DEFAULT SECTION (partial support) + * GCOS-specific handling of ASSIGN clause in SELECT, and ASSIGN + statement (support for ASSIGN TO MEMBER is partial) ** Multiple sequential files may be concatenated by specifying multiple files with a separator in its ASSIGN name (either directly or via diff --git a/cobc/ChangeLog b/cobc/ChangeLog index ba4488dd9..62542ee30 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -725,6 +725,7 @@ 2022-08-02 David Declerck Support GCOS-specific SELECT + Support ASSIGN statements (GCOS extension) * config.def: add options interpret-assign-literal, select-external, select-extra-organization-clauses, select-with * tree.h, typeck.c (cb_build_interpreted_assignment_name, @@ -737,6 +738,10 @@ organization clauses * codegen.c (output_file_initialization): record default file assignment + * config.def: add option assign-statement + * reserved.c: reserved MEMBER keyword + * typeck.c (cb_emit_assign_to_file, cb_emit_assign_to_member), + tree.h, parser.y: support ASSIGN statements 2022-08-20 Simon Sobisch diff --git a/cobc/config.def b/cobc/config.def index 4378ff8de..0e69da749 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -434,6 +434,9 @@ CB_CONFIG_SUPPORT (cb_assign_ext_dyn, "assign-ext-dyn", CB_CONFIG_SUPPORT (cb_assign_disk_from, "assign-disk-from", _("ASSIGN DISK FROM variable in SELECT")) +CB_CONFIG_SUPPORT (cb_assign_statement, "assign-statement", + _("ASSIGN statement")) + CB_CONFIG_SUPPORT (cb_vsam_status, "vsam-status", _("VSAM status in FILE STATUS")) diff --git a/cobc/parser.y b/cobc/parser.y index de12d5db5..2943e13dc 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -2857,6 +2857,7 @@ set_record_size (cb_tree min, cb_tree max) %token MAX_PROGRESS "MAX-PROGRESS" %token MAX_TEXT "MAX-TEXT" %token MAX_VAL "MAX-VAL" +%token MEMBER %token MEMORY %token MEDIUM_FONT "MEDIUM-FONT" %token MENU @@ -3341,6 +3342,7 @@ set_record_size (cb_tree min, cb_tree max) %nonassoc ADD %nonassoc ALLOCATE %nonassoc ALTER +%nonassoc ASSIGN %nonassoc CALL %nonassoc CANCEL %nonassoc CLOSE @@ -11552,6 +11554,7 @@ statement: | add_statement | allocate_statement | alter_statement +| assign_statement | call_statement | cancel_statement | close_statement @@ -12380,6 +12383,56 @@ alter_entry: _proceed_to: | PROCEED TO ; +/* ASSIGN statement */ + +assign_statement: + ASSIGN + { + begin_statement (STMT_ASSIGN, TERM_NONE); + cb_verify (cb_assign_statement, _("ASSIGN statement")); + } + assign_body +; + +assign_body: + file_name TO TOK_FILE id_or_lit_or_file_name + { + cb_emit_assign_to_file ($1, $4); + } + +| file_name TO MEMBER assign_op id_or_lit_or_actual + { + cb_emit_assign_to_member ($1, $4, $5); + } +; + +assign_op: + eq { $$ = cb_int (COB_EQ); } +| not_equal_op { $$ = cb_int (COB_NE); } +| _flag_not gt { $$ = cb_int ($1 ? COB_LE : COB_GT); } +| _flag_not lt { $$ = cb_int ($1 ? COB_GE : COB_LT); } +| _flag_not ge { $$ = cb_int ($1 ? COB_LT : COB_GE); } +| _flag_not le { $$ = cb_int ($1 ? COB_GT : COB_LE); } +; + +id_or_lit_or_actual: + identifier + { + $$ = check_not_88_level ($1); + } +| LITERAL +| ACTUAL +; + +id_or_lit_or_file_name: + identifier_or_file_name + { + $$ = check_not_88_level ($1); + } +| LITERAL +; + + /* CALL statement */ call_statement: diff --git a/cobc/reserved.c b/cobc/reserved.c index 47de9f719..14ec15cff 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -1861,6 +1861,9 @@ static struct cobc_reserved default_reserved_words[] = { { "MEDIUM-FONT", 0, 0, MEDIUM_FONT, /* ACU extension */ 0, 0 /* Checkme: likely context sensitive */ }, + { "MEMBER", 0, 0, MEMBER, /* GCOS extension */ + 0, 0 + }, { "MEMORY", 0, 1, MEMORY, /* 85 */ 0, CB_CS_OBJECT_COMPUTER }, diff --git a/cobc/tree.h b/cobc/tree.h index 83455e703..2a08289aa 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2412,6 +2412,9 @@ extern void cb_emit_allocate_characters (cb_tree, cb_tree, cb_tree); extern void cb_emit_alter (cb_tree, cb_tree); extern void cb_emit_free (cb_tree); +extern void cb_emit_assign_to_file (cb_tree, cb_tree); +extern void cb_emit_assign_to_member (cb_tree, cb_tree, cb_tree); + extern void cb_emit_call (cb_tree, cb_tree, cb_tree, cb_tree, cb_tree, cb_tree, cb_tree, cb_tree, int); diff --git a/cobc/typeck.c b/cobc/typeck.c index 254799de1..51225657a 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2270,9 +2270,9 @@ cb_build_interpreted_assignment_name (struct cb_file * const cfile, return cb_error_node; } - data = cob_strdup (CB_LITERAL_P (name) - ? (char *)(CB_LITERAL (name)->data) - : CB_NAME (name)); + data = cobc_strdup (CB_LITERAL_P (name) + ? (char *)(CB_LITERAL (name)->data) + : CB_NAME (name)); n = strtok (data, " \t,"); if (n && strchr (n, '=') == NULL ) { /* get out if non-positional */ d = strtok (NULL, " \t,"); @@ -2294,10 +2294,10 @@ cb_build_interpreted_assignment_name (struct cb_file * const cfile, strlen (filename)); if (assign_default) { /* record filename */ - *assign_default = strdup (filename); + *assign_default = cobc_strdup (filename); } } - cob_free (data); + cobc_free (data); if (res && !is_valid_assign_filename ((char *)(CB_LITERAL (res)->data))) { cb_error_x (name, _("invalid filename in ASSIGN literal")); @@ -8528,6 +8528,115 @@ cb_emit_alter (cb_tree source, cb_tree target) cb_emit (cb_build_alter (source, target)); } +/* ASSIGN statement */ + +void +cb_emit_assign_to_file (cb_tree file, cb_tree target) +{ + struct cb_file *f; + int target_is_file = 0; + + file = cb_ref (file); + if (file == cb_error_node) { + return; + } + + f = CB_FILE (file); + if (f->assign_default == NULL) { + cb_error_x (CB_TREE (current_statement), + _("ASSIGN can only be used on files whose description " + "specify a file literal in their ASSIGN clause")); + return; + } + + if (CB_INVALID_TREE(target)) { + return; + } + + if (CB_LITERAL_P (target)) { + // Literal is a file-literal (may be followed by params) + struct cb_literal *l = CB_LITERAL (target); + if (CB_NUMERIC_LITERAL_P (l)) { + cb_error_x (CB_TREE (current_statement), + _("literal must be non-numeric in ASSIGN")); + return; + } + } else { + cb_tree x = cb_ref (target); + if (CB_FIELD_P (x)) { + // Field contains a file-literal (may be followed by params) + if (CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHANUMERIC) { + cb_error_x (CB_TREE (current_statement), + _("field must be alphanumeric in ASSIGN")); + return; + } + } else if (CB_FILE_P (x)) { + target_is_file = 1; + } else { + return; + } + } + + if (target_is_file == 0) { + cb_emit (CB_BUILD_FUNCALL_3 ("cob_assign_to_file", file, target, NULL)); + } else { + cb_emit (CB_BUILD_FUNCALL_3 ("cob_assign_to_file", file, NULL, target)); + } +} + +void +cb_emit_assign_to_member (cb_tree file, cb_tree op, cb_tree target) +{ + struct cb_file *f; + + file = cb_ref (file); + if (file == cb_error_node) { + return; + } + + f = CB_FILE (file); + if (f->assign_default == NULL) { + cb_error_x (CB_TREE (current_statement), + _("ASSIGN can only be used on files whose description " + "specify a file literal in their ASSIGN clause")); + return; + } + + if (CB_INVALID_TREE (op) || !CB_INTEGER_P (op)) { + return; + } + + if (target && CB_INVALID_TREE (target)) { + return; + } + + if (target == NULL) { + // ACTUAL + } else if (CB_LITERAL_P (target)) { + // Literal is a file-literal (may be followed by params) + struct cb_literal *l = CB_LITERAL (target); + if (CB_NUMERIC_LITERAL_P (l)) { + cb_error_x (CB_TREE (current_statement), + _("literal must be non-numeric in ASSIGN")); + return; + } + } else { + cb_tree x = cb_ref (target); + if (CB_FIELD_P (x)) { + // Field contains a file-literal (may be followed by params) + if (CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHANUMERIC) { + cb_error_x (CB_TREE (current_statement), + _("field must be alphanumeric in ASSIGN")); + return; + } + } else { + return; + } + } + + CB_PENDING ("TO MEMBER phrase in ASSIGN statement"); +} + /* CALL statement */ static const char * diff --git a/config/ChangeLog b/config/ChangeLog index 7b9ef29c5..673353088 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -74,6 +74,7 @@ * general: add options interpret-assign-literal, select-external, select-extra-organization-clauses, select-with, to support GCOS-style SELECT + * general: add option assign-statement 2022-08-17 Simon Sobisch diff --git a/config/acu-strict.conf b/config/acu-strict.conf index cbbd47daf..7523449de 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -280,6 +280,7 @@ assign-variable: ok assign-using-variable: unconformable assign-ext-dyn: ok assign-disk-from: unconformable +assign-statement: unconformable vsam-status: ignore self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index b503e0ad5..f3e2b1e28 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -277,6 +277,7 @@ assign-variable: unconformable assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: unconformable vsam-status: ok self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/cobol2002.conf b/config/cobol2002.conf index e5065259d..2a2969cbf 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -276,6 +276,7 @@ assign-variable: unconformable assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/cobol2014.conf b/config/cobol2014.conf index 63cba1c7f..786657968 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -276,6 +276,7 @@ assign-variable: unconformable assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/cobol85.conf b/config/cobol85.conf index 6780c0a98..ff0d3b1eb 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -276,6 +276,7 @@ assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/default.conf b/config/default.conf index f2a76bb99..e2a4c735f 100644 --- a/config/default.conf +++ b/config/default.conf @@ -297,6 +297,7 @@ assign-variable: ok assign-using-variable: ok assign-ext-dyn: ok assign-disk-from: ok +assign-statement: warning #CHECKME vsam-status: ignore self-call-recursive: warning record-contains-depending-clause: unconformable diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 33d1e0a57..f2f7eb00a 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -275,6 +275,7 @@ assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: ok vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: obsolete diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 9343608a3..5069eadee 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -275,6 +275,7 @@ assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: unconformable vsam-status: ok self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/mf-strict.conf b/config/mf-strict.conf index a3961f621..77c624392 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -279,6 +279,7 @@ assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: ok assign-disk-from: ok +assign-statement: unconformable vsam-status: ignore self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index 1ae611fe1..d9dc19a38 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -275,6 +275,7 @@ assign-variable: unconformable assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: unconformable vsam-status: ok self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/realia-strict.conf b/config/realia-strict.conf index 86dd101e3..4c66d18f8 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -280,6 +280,7 @@ assign-variable: unconformable assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: unconformable vsam-status: ok self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/rm-strict.conf b/config/rm-strict.conf index b148f599e..f0f9dd96d 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -282,6 +282,7 @@ assign-variable: ok assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: unconformable diff --git a/config/xopen.conf b/config/xopen.conf index ae688727c..c3460d2fb 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -295,6 +295,7 @@ assign-variable: ok assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable +assign-statement: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: obsolete diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 572ef070b..329706b9c 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -549,6 +549,9 @@ * common.h (cob_file), fileio.c (cob_chk_file_mapping): support ASSIGN fallback (GCOS extension) + * common.h (cob_assign_status, cob_file), fileio.c + (cob_chk_file_mapping_raw, cob_chk_file_mapping, cob_assign_to_file): + support ASSIGN statements (GCOS extension) 2022-08-19 Simon Sobisch diff --git a/libcob/common.h b/libcob/common.h index ab6c31856..25979ddea 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1329,6 +1329,14 @@ typedef struct __cob_file_key { /* File structure */ +/* Assignment status, checked and set by ASSIGN statements */ +enum cob_assign_status { + COB_ASSIGN_UNASSIGNED = 0, + COB_ASSIGN_FAILED, + COB_ASSIGN_ASSIGNED, + COB_ASSIGN_RESOLVED, +}; + /*NOTE: *** Add new fields to end *** * cob_file is now allocated by cob_file_malloc in common.c * so as long as you add new fields to the end there should be no @@ -1385,7 +1393,8 @@ typedef struct __cob_file { cob_field *convert_field; /* logical fields to convert for CODE-SET */ const char *assign_default; /* [GCOS] External filename to use if file mapping fails */ - + const char *assign_current; /* [GCOS] Currently assigned external filename */ + enum cob_assign_status assign_status; /* [GCOS] Current assignment status */ } cob_file; @@ -2543,6 +2552,8 @@ COB_EXPIMP void cob_unlock_file (cob_file *, cob_field *); COB_EXPIMP void cob_commit (void); COB_EXPIMP void cob_rollback (void); +COB_EXPIMP void cob_assign_to_file (cob_file *, cob_field *, cob_file *); + /* functions in fileio.c for the MF style EXTFH interface */ COB_EXPIMP int EXTFH (unsigned char *opcode, FCD3 *fcd); diff --git a/libcob/fileio.c b/libcob/fileio.c index 3cb49b674..f86f18134 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -1086,7 +1086,7 @@ do_acu_hyphen_translation (char *src) } static void -cob_chk_file_mapping (cob_file *f) +cob_chk_file_mapping_raw (cob_file *f) { const char *p; const char *src; @@ -1243,6 +1243,44 @@ cob_chk_file_mapping (cob_file *f) } +static void +cob_chk_file_mapping (cob_file *f) +{ + /* If there was no previous assignment, we perform regular file + mapping */ + if (!f || f->assign_status == COB_ASSIGN_UNASSIGNED) { + cob_chk_file_mapping_raw (f); + } else { /* Otherwise, there was a previous assignment [GCOS] */ + + /* If it failed, we return an invalid name */ + if (f->assign_status == COB_ASSIGN_FAILED) { + file_open_name[0] = 0; + + /* If it succeeded, we prepend the file path, if needed */ + } else if ((f->assign_status == COB_ASSIGN_ASSIGNED) && + !looks_absolute (file_open_name) && + cobsetptr->cob_file_path != NULL) { + snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s%c%s", + cobsetptr->cob_file_path, SLASH_CHAR, file_open_name); + file_open_buff[COB_FILE_MAX] = 0; + strncpy (file_open_name, file_open_buff, (size_t)COB_FILE_MAX); + } + + /* If the path was assigned, mark it resolved */ + if (f->assign_status == COB_ASSIGN_ASSIGNED) { + f->assign_status = COB_ASSIGN_RESOLVED; + } + + /* If the path is resolved and differs from the one + stored in the file structure, update it */ + if ((f->assign_status == COB_ASSIGN_RESOLVED) && + (strcmp (f->assign_current, file_open_name) != 0)) { + cob_free((char *)f->assign_current); + f->assign_current = cob_strdup(file_open_name); + } + } +} + static void cob_sync (cob_file *f) { @@ -6085,9 +6123,10 @@ cob_pre_open (cob_file *f) break; } } - } else - if (f->assign != NULL - && f->assign->data != NULL) { + } else if (f->assign_current != NULL) { + strncpy (file_open_name, f->assign_current, (size_t)COB_FILE_MAX); + } else if (f->assign != NULL + && f->assign->data != NULL) { cob_field_to_string (f->assign, file_open_name, (size_t)COB_FILE_MAX); } } @@ -6944,6 +6983,61 @@ cob_savekey (cob_file *f, int idx, unsigned char *data) return len; } +void +cob_assign_to_file (cob_file *f, cob_field *tfield, cob_file *tfile) +{ + cob_field *fnstatus = NULL; + + /* Must de-assign first, according to GCOS docs */ + if (f->assign_current != NULL) { + cob_free ((char *)f->assign_current); + f->assign_current = NULL; + } + f->assign_status = COB_ASSIGN_UNASSIGNED; + + /* File is already open */ + if (f->open_mode != COB_OPEN_CLOSED) { + save_status (f, fnstatus, COB_STATUS_41_ALREADY_OPEN); + f->assign_status = COB_ASSIGN_FAILED; + return; + } + + /* Target file is already open */ + if ((tfile != NULL) && (tfile->open_mode != COB_OPEN_CLOSED)) { + save_status (tfile, fnstatus, COB_STATUS_41_ALREADY_OPEN); + f->assign_status = COB_ASSIGN_FAILED; + return; + } + + + if (tfield != NULL) { + char fn[(size_t)COB_FILE_MAX]; + cob_field_to_string (tfield, fn, (size_t)COB_FILE_MAX); + f->assign_current = cob_strdup (fn); + /* TODO: should check the file literal is valid and fail if it + is not */ + f->assign_status = COB_ASSIGN_ASSIGNED; + + } else if (tfile != NULL) { + if (tfile->assign_status == COB_ASSIGN_UNASSIGNED) { + if (tfile->assign != NULL && tfile->assign->data != NULL) { + cob_field_to_string (tfile->assign, file_open_name, + (size_t)COB_FILE_MAX); + cob_chk_file_mapping_raw (f); /* we use f instead of tfile */ + f->assign_current = cob_strdup (file_open_name); + f->assign_status = COB_ASSIGN_ASSIGNED; + } else { + f->assign_status = COB_ASSIGN_FAILED; + } + } else if (tfile->assign_status == COB_ASSIGN_FAILED) { + f->assign_status = COB_ASSIGN_FAILED; + } else { + f->assign_current = cob_strdup (tfile->assign_current); + f->assign_status = tfile->assign_status; + } + } +} + /* System routines */ /* stores the field's rtrimmed string content into a fresh allocated diff --git a/libcob/statement.def b/libcob/statement.def index 3d43f5e3d..6b3d062fe 100644 --- a/libcob/statement.def +++ b/libcob/statement.def @@ -166,5 +166,7 @@ COB_STATEMENT (STMT_JSON_PARSE, "JSON GENERATE") COB_STATEMENT (STMT_XML_GENERATE, "XML GENERATE") COB_STATEMENT (STMT_XML_PARSE, "XML GENERATE") +COB_STATEMENT (STMT_ASSIGN, "ASSIGN") /* GCOS specific */ + /* codegen intern only */ COB_STATEMENT (STMT_INIT_STORAGE, "INIT STORAGE") diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index fe2636059..b71cc4112 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -535,6 +535,7 @@ test.conf: missing definitions: no definition of 'assign-using-variable' no definition of 'assign-ext-dyn' no definition of 'assign-disk-from' + no definition of 'assign-statement' no definition of 'vsam-status' no definition of 'self-call-recursive' no definition of 'record-contains-depending-clause' From 8bde67897a5ebda43144ddccf335818b2b2d8337 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Wed, 15 Feb 2023 12:45:09 +0100 Subject: [PATCH 07/11] [GCOS] remove alias VALUES=VALUE --- config/gcos.words | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config/gcos.words b/config/gcos.words index 69357a9fa..80347e766 100644 --- a/config/gcos.words +++ b/config/gcos.words @@ -490,7 +490,7 @@ reserved: USAGE reserved: USE reserved: USING reserved: VALUE -reserved: VALUES=VALUE +reserved: VALUES reserved: VARYING reserved: VIA reserved: VIRTUAL From 9ae800fcdb50e97fa4f44fc668924f7b4aa69e0b Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Wed, 15 Feb 2023 12:46:31 +0100 Subject: [PATCH 08/11] Add option `-fdisplay-context` to print source lines around warning/error --- cobc/error.c | 44 ++++++++++++++++++++++++++++++++++++++++++++ cobc/flag.def | 3 +++ 2 files changed, 47 insertions(+) diff --git a/cobc/error.c b/cobc/error.c index 635dbb31b..91a7e779b 100644 --- a/cobc/error.c +++ b/cobc/error.c @@ -63,6 +63,49 @@ print_error_prefix (const char *file, int line, const char *prefix) } } +static void +print_error_context (const char *file, int line) +{ + if ( cb_display_context && file != NULL && line ){ + FILE* fd = fopen(file, "r"); + char buffer[74]; + int line_pos = 1; + int char_pos = 0; + int printed = 0; /* nothing printed */ + while(1){ + int c = fgetc (fd); + if ( c == EOF ){ + if (printed) fprintf(stderr, "\n"); + fclose(fd); return ; } + buffer[char_pos] = c ; + if( c == '\n' || char_pos == 73 ){ + buffer[char_pos] = 0; + if (line_pos > line-3 && line_pos < line+3){ + if (line_pos == line-2) fprintf(stderr, "\n"); + printed = 1; + fprintf (stderr, " %04d %c %s%s\n", + line_pos, + line == line_pos ? '>' : ' ', + c == '\n' ? "" : ".." , + buffer); + if (line_pos == line+2){ + fprintf(stderr, "\n"); + fclose(fd); return; + } + } + while ( c != '\n' ){ /* skip end of line too long */ + c = fgetc (fd); + if( c == EOF ) { fclose(fd); return ; } + } + line_pos++; + char_pos=0; + } else { + char_pos++; + } + } + } +} + static void print_error (const char *file, int line, const char *prefix, const char *fmt, va_list ap, const char *diagnostic_option) @@ -119,6 +162,7 @@ print_error (const char *file, int line, const char *prefix, } cb_add_error_to_listing (file, line, prefix, errmsg); } + print_error_context (file, line); } static void diff --git a/cobc/flag.def b/cobc/flag.def index 478c6bb4b..67fb6810e 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -235,3 +235,6 @@ CB_FLAG (cb_listing_cmd, 1, "tcmd", CB_FLAG_ON (cb_diagnostic_show_option, 1, "diagnostics-show-option", _(" -fno-diagnostics-show-option\tsuppress output of option that directly\n" " controls the diagnostic")) + +CB_FLAG (cb_display_context, 1, "display-context", + _(" -fdisplay-context display source lines on warning/error")) From aad4861cf92e80396c79efe0d85bc2e18a04cc6a Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 16 Feb 2023 13:50:55 +0100 Subject: [PATCH 09/11] [GCOS] COMMUNICATION SECTION and DECLARATIVES --- cobc/flag.def | 2 +- cobc/parser.y | 58 ++++++++++++++++++++++----------- tests/testsuite.src/syn_file.at | 4 +-- 3 files changed, 42 insertions(+), 22 deletions(-) diff --git a/cobc/flag.def b/cobc/flag.def index 67fb6810e..90e4c8673 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -237,4 +237,4 @@ CB_FLAG_ON (cb_diagnostic_show_option, 1, "diagnostics-show-option", " controls the diagnostic")) CB_FLAG (cb_display_context, 1, "display-context", - _(" -fdisplay-context display source lines on warning/error")) + _(" -fdisplay-context display source lines on warning/error")) diff --git a/cobc/parser.y b/cobc/parser.y index 2943e13dc..3e3f18fc9 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -6383,13 +6383,21 @@ _data_division: current_storage = CB_STORAGE_WORKING; } _working_storage_section - _communication_section - _local_storage_section - _linkage_section + _data_division_sections _report_section _screen_section ; +data_division_section: + communication_section +| local_storage_section +| linkage_section +; + +_data_division_sections: +| data_division_section _data_division_sections +; + _data_division_header: | data_division_header ; @@ -6834,9 +6842,12 @@ rep_name_list: /* COMMUNICATION SECTION */ communication: COMMUNICATION { check_area_a_of ("COMMUNICATION SECTION"); }; -_communication_section: -| communication SECTION _dot +communication_section: + communication SECTION _dot { + if( header_check & COBC_HD_COMMUNICATION_SECTION ){ + cb_error (_("Duplicate COMMUNICATION SECTION")); + } current_storage = CB_STORAGE_COMMUNICATION; check_headers_present (COBC_HD_DATA_DIVISION, 0, 0, 0); header_check |= COBC_HD_COMMUNICATION_SECTION; @@ -6919,17 +6930,17 @@ named_input_cd_clauses: ; named_input_cd_clause: - _symbolic QUEUE _is identifier -| _symbolic SUB_QUEUE_1 _is identifier -| _symbolic SUB_QUEUE_2 _is identifier -| _symbolic SUB_QUEUE_3 _is identifier -| MESSAGE DATE _is identifier -| MESSAGE TIME _is identifier -| _symbolic SOURCE _is identifier -| TEXT LENGTH _is identifier -| END KEY _is identifier -| STATUS KEY _is identifier -| _message COUNT _is identifier + _symbolic QUEUE _is identifier_1 +| _symbolic SUB_QUEUE_1 _is identifier_1 +| _symbolic SUB_QUEUE_2 _is identifier_1 +| _symbolic SUB_QUEUE_3 _is identifier_1 +| MESSAGE DATE _is identifier_1 +| MESSAGE TIME _is identifier_1 +| _symbolic SOURCE _is identifier_1 +| TEXT LENGTH _is identifier_1 +| END KEY _is identifier_1 +| STATUS KEY _is identifier_1 +| _message COUNT _is identifier_1 ; unnamed_input_cd_clauses: @@ -8967,9 +8978,12 @@ identified_by_clause: /* LOCAL-STORAGE SECTION */ local_storage: LOCAL_STORAGE { check_area_a_of ("LOCAL-STORAGE SECTION"); }; -_local_storage_section: -| local_storage SECTION _dot +local_storage_section: + local_storage SECTION _dot { + if( header_check & COBC_HD_LOCAL_STORAGE_SECTION ){ + cb_error (_("Duplicate LOCAL STORAGE SECTION")); + } check_headers_present (COBC_HD_DATA_DIVISION, 0, 0, 0); header_check |= COBC_HD_LOCAL_STORAGE_SECTION; current_storage = CB_STORAGE_LOCAL; @@ -8994,8 +9008,14 @@ _local_storage_section: linkage: LINKAGE { check_area_a_of ("LINKAGE SECTION"); }; _linkage_section: -| linkage SECTION _dot +| linkage_section +; +linkage_section: + linkage SECTION _dot { + if( header_check & COBC_HD_LINKAGE_SECTION ){ + cb_error (_("Duplicate LINKAGE SECTION")); + } check_headers_present (COBC_HD_DATA_DIVISION, 0, 0, 0); header_check |= COBC_HD_LINKAGE_SECTION; current_storage = CB_STORAGE_LINKAGE; diff --git a/tests/testsuite.src/syn_file.at b/tests/testsuite.src/syn_file.at index 42af0b05e..6a80e9a88 100644 --- a/tests/testsuite.src/syn_file.at +++ b/tests/testsuite.src/syn_file.at @@ -908,7 +908,7 @@ AT_CLEANUP AT_SETUP([DECLARATIVES invalid procedure reference (1)]) -AT_KEYWORDS([file GOTO GO PERFORM]) +AT_KEYWORDS([file GOTO GO PERFORM DECLARATIVES]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -997,7 +997,7 @@ AT_CLEANUP AT_SETUP([DECLARATIVES invalid procedure reference (2)]) -AT_KEYWORDS([file]) +AT_KEYWORDS([file DECLARATIVES]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. From f147ddaa739d41cb0a46738b4f16df476c409cfd Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 16 Feb 2023 18:19:05 +0100 Subject: [PATCH 10/11] Fix invalid conditional expression 0106 MOVE CLE(1) TO CLE(2) 0107 CALL "FLXDBO" USING LECSG ERREUR DEC(2) PDF-DBO-ART 0108 > IF ERREUR-NIV ZERO AND CLE2-4(1) = "PDF" 0109 MOVE PDF-DBO-INF(1:LGR-PDF) TO PDF 0110 IF COD-PDF = PDF-NUMERO-ETAT --- cobc/typeck.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/cobc/typeck.c b/cobc/typeck.c index 51225657a..07895d6b1 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -5925,6 +5925,9 @@ cb_build_expr (cb_tree list) default: v = CB_VALUE (l); if (op == 'x') { + if( has_var && v == cb_zero ){ + has_rel = 1; + } has_var = 1; if (CB_TREE_TAG (v) == CB_TAG_BINARY_OP) { has_rel = 1; @@ -5932,7 +5935,7 @@ cb_build_expr (cb_tree list) if (CB_TREE_TAG (v) == CB_TAG_FUNCALL) { has_rel = 1; } else - if (CB_REF_OR_FIELD_P (v)) { + if (CB_REF_OR_FIELD_P (v)) { f = CB_FIELD_PTR (v); if (f->level == 88) { has_rel = 1; From 9b91497e56ce87de390d2acd095ec2c2f59709c5 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Fri, 17 Feb 2023 00:49:25 +0100 Subject: [PATCH 11/11] Allow REPLACE in CONTROL SECTION --- cobc/pplex.l | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/cobc/pplex.l b/cobc/pplex.l index 745f14996..803d9a40d 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -525,11 +525,14 @@ MAYBE_AREA_A [ ]?#? } } -{ +{ "REPLACE" { yy_push_state (COPY_STATE); return REPLACE; } +} +{ \. { /* Intercept dots within the SUBSTITUTION SECTION */ return DOT;