From 1df283ac6c3ddd84ae5bcedb3038e2c6e6a4b5be Mon Sep 17 00:00:00 2001 From: David Declerck Date: Sun, 28 Jul 2024 23:40:56 +0200 Subject: [PATCH] Merge SVN 4849 --- cobc/ChangeLog | 4 ++ cobc/field.c | 6 ++ tests/testsuite.src/syn_redefines.at | 96 ++++++++++++++++++++++------ 3 files changed, 85 insertions(+), 21 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index d941bc3a1..31961e801 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -43,6 +43,10 @@ * codegen.c: Verify that EXTERNAL variables have 'ename' * field.c (copy_into_field): If EXTERNAL set 'ename' +2022-12-06 Simon Sobisch + + * field.c (validate_redefines): check for target not to have ANY LENGTH + 2022-12-03 Simon Sobisch * cobc.c: check SOURCE_DATE_EPOCH once, if set parse via libcob diff --git a/cobc/field.c b/cobc/field.c index af4d74197..d2adfb3bf 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -1341,6 +1341,12 @@ validate_redefines (const struct cb_field * const f) _("the original definition '%s' should not have an OCCURS clause"), f->redefines->name); } + /* Check ANY LENGTH */ + if (f->redefines->flag_any_length) { + cb_error_x (x, + _("the original definition '%s' should not have an ANY LENGTH clause"), + f->redefines->name); + } /* Check definition */ for (p = f->redefines->sister; p && p != f; p = p->sister) { diff --git a/tests/testsuite.src/syn_redefines.at b/tests/testsuite.src/syn_redefines.at index 337133066..d2a9abc4a 100644 --- a/tests/testsuite.src/syn_redefines.at +++ b/tests/testsuite.src/syn_redefines.at @@ -18,9 +18,9 @@ ### GnuCOBOL Test Suite -### ISO+IEC+1989-2002 13.16.42 REDEFINES clause +### ISO+IEC+1989-2022 13.18.44 REDEFINES clause -## 13.16.42.2 Syntax rules +## 13.18.44.3 Syntax rules # 1) DONE @@ -139,10 +139,9 @@ AT_CLEANUP # 3) TODO -# 4) TODO +# check vs. FORMAT clause - -# 5) DONE +# 4) DONE AT_SETUP([REDEFINES: lower level number]) AT_KEYWORDS([redefines]) @@ -168,7 +167,7 @@ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], AT_CLEANUP -# 6) DONE +# 5) DONE AT_SETUP([REDEFINES: with OCCURS]) AT_KEYWORDS([redefines]) @@ -185,12 +184,15 @@ AT_DATA([prog.cob], [ STOP RUN. ]) +# TODO: should be a dialect option, currntly it is _always_ a warning + AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [prog.cob:8: warning: the original definition 'X' should not have an OCCURS clause ]) AT_CLEANUP + AT_SETUP([REDEFINES: with subscript]) AT_KEYWORDS([redefines]) @@ -213,6 +215,7 @@ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], AT_CLEANUP + AT_SETUP([REDEFINES: with variable occurrence]) AT_KEYWORDS([redefines]) @@ -246,7 +249,7 @@ prog.cob:16: error: the original definition 'X' cannot be variable length AT_CLEANUP -# 7) DONE +# 6) DONE AT_SETUP([REDEFINES: with qualification]) AT_KEYWORDS([redefines]) @@ -272,7 +275,7 @@ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], AT_CLEANUP -# 8) DONE +# 7) DONE AT_SETUP([REDEFINES: multiple redefinition]) AT_KEYWORDS([redefines]) @@ -300,7 +303,7 @@ AT_CHECK([$COMPILE_ONLY -std=mvs prog.cob], [0], [], []) AT_CLEANUP -# 9) DONE +# 8) DONE AT_SETUP([REDEFINES: size exceeds]) AT_KEYWORDS([redefines]) @@ -337,7 +340,7 @@ prog.cob:13: note: size of 'EXT-X-REDEF' larger than size of 'EXT-X' [-Wdialect] prog.cob:17: warning: size of 'FILLER 1' larger than size of 'WRK-X2' [-Wlarger-01-redefines] ]]) -# of course, other dialects ignore the rules... +# of course, other dialects ignore the rules, implicit adding a FILLER to the original item... AT_CHECK([$COBC -std=mf prog.cob], [0], [], []) AT_CHECK([$COBC -flarger-redefines=warning prog.cob], [0], [], [[prog.cob:8: warning: larger REDEFINES used [-Wdialect] @@ -351,7 +354,7 @@ prog.cob:13: note: size of 'EXT-X-REDEF' larger than size of 'EXT-X' [-Wdialect] AT_CLEANUP -# 10) DONE +# 9) DONE AT_SETUP([REDEFINES: with VALUE]) AT_KEYWORDS([redefines]) @@ -368,6 +371,7 @@ AT_DATA([prog.cob], [ 01 Y REDEFINES X PIC X. 88 C VALUE "A". PROCEDURE DIVISION. + INITIALIZE G ALL TO VALUE *> the reason that this extension is useful STOP RUN. ]) @@ -383,7 +387,7 @@ AT_CHECK([$COMPILE -frelax-syntax-checks prog.cob], [0], [], []) AT_CLEANUP -# 11) DONE +# 10) DONE AT_SETUP([REDEFINES: with intervention]) AT_KEYWORDS([redefines]) @@ -409,10 +413,13 @@ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], prog.cob:12: error: REDEFINES must follow the original definition ]) +# TODO: several implementations allow to specify those anywhere - add +# dialect option, configure accordingly and test here + AT_CLEANUP -# 12) DONE +# 11) DONE AT_SETUP([REDEFINES: within REDEFINES]) AT_KEYWORDS([redefines]) @@ -435,6 +442,61 @@ AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], []) AT_CLEANUP +# 12) TODO + +# not _with_ class pointer, object, ... + + +# 13) TODO + +# no redefinition of CONSTANT RECORD + + +# 14) TODO + +# not _for_ class pointer, object, ... + + +# 15) TODO + +# matchin alignment + + +# 16) DONE + +AT_SETUP([REDEFINES: for ANY LENGTH item]) +AT_KEYWORDS([redefines]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + LINKAGE SECTION. + 01 X PIC X ANY LENGTH. + 01 Y REDEFINES X PIC X. + 01 N PIC 9 ANY NUMERIC. + 01 M REDEFINES N PIC 9. + PROCEDURE DIVISION USING X N. + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +[prog.cob:7: error: the original definition 'X' should not have an ANY LENGTH clause +prog.cob:9: error: the original definition 'N' should not have an ANY LENGTH clause +]) + +AT_CLEANUP + + +# 17) TODO + +# no redefinition of variable-length group or dynamic length item, +# but allowed below that + + +## additional syntax tests for REDEFINES + + AT_SETUP([REDEFINES: non-referenced ambiguous item]) AT_KEYWORDS([redefines extensions]) @@ -461,11 +523,3 @@ prog.cob:6: note: 'X' previously defined here AT_CLEANUP - -# 13) TODO - -# 14) TODO - -# 15) TODO - -# 16) TODO