From 0f469c67c858fa5baf7387130ecef9000003e4db Mon Sep 17 00:00:00 2001 From: David Declerck Date: Fri, 12 Jul 2024 16:17:55 +0200 Subject: [PATCH] Merge SVN 4721 --- tests/ChangeLog | 6 +- tests/testsuite.src/run_extensions.at | 222 ++++++++++++++++++++++++++ tests/testsuite.src/run_misc.at | 149 +---------------- 3 files changed, 227 insertions(+), 150 deletions(-) diff --git a/tests/ChangeLog b/tests/ChangeLog index 882c037bd..ff68f5671 100644 --- a/tests/ChangeLog +++ b/tests/ChangeLog @@ -33,8 +33,10 @@ 2022-09-30 Simon Sobisch - * testsuite.src/run_extensions.at, testsuite.src/run_file.at: - moved LINE SEQUNTIAL related tests to run_file.at + * testsuite.src/run_extensions.at, testsuite.src/run_file.at: moved + LINE SEQUNTIAL related tests to run_file.at + * testsuite.src/run_misc.at, testsuite.src/run_extensions.at: moved + INSPECT ... TRAILING and EXAMINE related tests to run_extensions.at 2022-09-21 Simon Sobisch diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index 67e800bf9..78ef3a25c 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -6275,3 +6275,225 @@ AT_CHECK([$COMPILE -fodoslide -o redefines-x redefines.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./redefines-x], [0], []) AT_CLEANUP + + +AT_SETUP([INSPECT TRAILING]) # Note: TRAILING is an extension +AT_KEYWORDS([extensions]) + +AT_DATA([prog.cob], [ + identification division. + program-id. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + 01 W01-STRING PIC X(20) VALUE '0123456789'. + 01 W01-INDEX PIC 9(04) BINARY. + + PROCEDURE DIVISION. + *> + MOVE 0 TO W01-INDEX. + INSPECT W01-STRING + TALLYING W01-INDEX FOR TRAILING SPACE. + IF W01-INDEX NOT = 10 + THEN + DISPLAY 'Bad Result for Inspect Trailing Case 1' + END-IF. + *> + INSPECT W01-STRING REPLACING TRAILING SPACE BY 'A'. + IF W01-STRING NOT = '0123456789AAAAAAAAAA' + THEN + DISPLAY 'Bad Result for Inspect Trailing Case 2' + END-IF. + *> + MOVE 0 TO W01-INDEX. + INSPECT W01-STRING + TALLYING W01-INDEX FOR TRAILING SPACE + REPLACING TRAILING 'A' BY 'B'. + *> + IF W01-STRING NOT = '0123456789BBBBBBBBBB' + THEN + DISPLAY 'Bad Result for Inspect Trailing Case 3' + END-IF. + *> + MOVE 0 TO W01-INDEX. + MOVE SPACES TO W01-STRING. + INSPECT W01-STRING + TALLYING W01-INDEX FOR TRAILING 'A'. + *> + IF W01-INDEX NOT = 0 + THEN + DISPLAY 'Bad Result for Inspect Trailing Case 4' + W01-INDEX + END-IF. + *> + MOVE 0 TO W01-INDEX. + MOVE SPACES TO W01-STRING. + INSPECT W01-STRING + TALLYING W01-INDEX FOR TRAILING SPACES. + *> + IF W01-INDEX NOT = 20 + THEN + DISPLAY 'Bad Result for Inspect Trailing Case 5' + W01-INDEX + END-IF. + *> + GOBACK. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([INSPECT REPLACING TRAILING ZEROS BY SPACES]) +AT_KEYWORDS([runmisc figurative constant]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "1000". + PROCEDURE DIVISION. + INSPECT X REPLACING TRAILING ZEROS BY SPACES. + IF X NOT = "1 " + DISPLAY X. + STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([INSPECT REPLACING complex]) +AT_KEYWORDS([runmisc CHARACTERS TRAILING]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(12) VALUE "AZABBCDCCECC". + PROCEDURE DIVISION. + INSPECT X REPLACING + ALL "A" BY "Z" + "B" BY "Y" + "Z" BY "0" + TRAILING "C" BY "X" + IF X NOT = "Z0ZYYCDCCEXX" + DISPLAY "1 - " X. + + INSPECT X REPLACING + CHARACTERS BY SPACES + BEFORE "C" AFTER "0" + CHARACTERS BY ZEROES + BEFORE "E" AFTER "C" + IF X NOT = "Z0 C000EXX" + DISPLAY "2 - " X. + + STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +AT_CLEANUP + + +# Note: EXAMINE was dropped with COBOL85, but some dialects +# still support that + +AT_SETUP([EXAMINE TALLYING]) +AT_KEYWORDS([runmisc]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(8) VALUE "AABABCAB". + 01 N PIC S9(5)V9(2) VALUE -11122.55. + 01 T PIC X(10) VALUE " 8 ". + PROCEDURE DIVISION. + EXAMINE X TALLYING ALL "A" + IF TALLY NOT = 4 + DISPLAY "Should be 4 but is " TALLY. + EXAMINE X TALLYING LEADING "A" + IF TALLY NOT = 2 + DISPLAY "Should be 2 but is " TALLY. + EXAMINE X TALLYING UNTIL FIRST "C" + IF TALLY NOT = 5 + DISPLAY "Should be 5 but is " TALLY. + EXAMINE X TALLYING ALL "A" REPLACING BY "Z" + IF TALLY NOT = 4 + DISPLAY "Should be 4 but is " TALLY. + IF X NOT = "ZZBZBCZB" + DISPLAY "Should be ZZBZBCZB but is " X. + EXAMINE X TALLYING LEADING "Z" REPLACING BY "A" + IF TALLY NOT = 2 + DISPLAY "Should be 2 but is " TALLY. + IF X NOT = "AABZBCZB" + DISPLAY "Should be AABZBCZB but is " X. + EXAMINE X TALLYING UNTIL FIRST "C" REPLACING BY "X" + IF TALLY NOT = 5 + DISPLAY "Should be 5 but is " TALLY. + IF X NOT = "XXXXXCZB" + DISPLAY "Should be XXXXXCZB but is " X. + EXAMINE X TALLYING UNTIL FIRST "Y" REPLACING BY "Y" + IF TALLY NOT = 8 + DISPLAY "Should be 8 but is " TALLY. + IF X NOT = "YYYYYYYY" + DISPLAY "Should be YYYYYYYY but is " X. + EXAMINE N TALLYING UNTIL FIRST 5 REPLACING BY 8 + IF N NOT = -88888.55 + DISPLAY "Should be -88888.55 but is " N. + * Re-mod is forbidden here (at least on GCOS): + * EXAMINE N TALLYING LEADING T (5:1) + * IF TALLY NOT = 5 + * DISPLAY "Should be 5 but is " TALLY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -freserved=EXAMINE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([EXAMINE REPLACING]) +AT_KEYWORDS([runmisc]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(8) VALUE "AABABCAB". + 01 Y PIC X VALUE "Y". + 01 N PIC S9(5) VALUE -11122. + PROCEDURE DIVISION. + EXAMINE X REPLACING ALL "A" BY "X" + IF X NOT = "XXBXBCXB" + DISPLAY "Should be XXBXBCXB but is " X. + EXAMINE X REPLACING LEADING "X" BY "Y" + IF X NOT = "YYBXBCXB" + DISPLAY "Should be YYBXBCXB but is " X. + EXAMINE X REPLACING FIRST "B" BY "C" + IF X NOT = "YYCXBCXB" + DISPLAY "Should be YYCXBCXB but is " X. + EXAMINE X REPLACING UNTIL FIRST "B" BY "Z" + IF X NOT = "ZZZZBCXB" + DISPLAY "Should be ZZZZBCXB but is " X. + EXAMINE N REPLACING ALL 1 BY 3 + IF N NOT = -33322 + DISPLAY "Should be -33322 but is " N. + STOP RUN. +]) + +AT_CHECK([$COMPILE -freserved=EXAMINE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index eaf704af5..ba6864cc2 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -2115,154 +2115,7 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP - -AT_SETUP([INSPECT REPLACING TRAILING ZEROS BY SPACES]) -AT_KEYWORDS([runmisc]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 X PIC X(4) VALUE "1000". - PROCEDURE DIVISION. - INSPECT X REPLACING TRAILING ZEROS BY SPACES. - IF X NOT = "1 " - DISPLAY X. - STOP RUN. -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([INSPECT REPLACING complex]) -AT_KEYWORDS([runmisc CHARACTERS]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 X PIC X(12) VALUE "AZABBCDCCECC". - PROCEDURE DIVISION. - INSPECT X REPLACING - ALL "A" BY "Z" - "B" BY "Y" - "Z" BY "0" - TRAILING "C" BY "X" - IF X NOT = "Z0ZYYCDCCEXX" - DISPLAY "1 - " X. - - INSPECT X REPLACING - CHARACTERS BY SPACES - BEFORE "C" AFTER "0" - CHARACTERS BY ZEROES - BEFORE "E" AFTER "C" - IF X NOT = "Z0 C000EXX" - DISPLAY "2 - " X. - - STOP RUN. -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) -AT_CLEANUP - - -AT_SETUP([EXAMINE TALLYING]) -AT_KEYWORDS([runmisc]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 X PIC X(8) VALUE "AABABCAB". - 01 N PIC S9(5)V9(2) VALUE -11122.55. - 01 T PIC X(10) VALUE " 8 ". - PROCEDURE DIVISION. - EXAMINE X TALLYING ALL "A" - IF TALLY NOT = 4 - DISPLAY "Should be 4 but is " TALLY. - EXAMINE X TALLYING LEADING "A" - IF TALLY NOT = 2 - DISPLAY "Should be 2 but is " TALLY. - EXAMINE X TALLYING UNTIL FIRST "C" - IF TALLY NOT = 5 - DISPLAY "Should be 5 but is " TALLY. - EXAMINE X TALLYING ALL "A" REPLACING BY "Z" - IF TALLY NOT = 4 - DISPLAY "Should be 4 but is " TALLY. - IF X NOT = "ZZBZBCZB" - DISPLAY "Should be ZZBZBCZB but is " X. - EXAMINE X TALLYING LEADING "Z" REPLACING BY "A" - IF TALLY NOT = 2 - DISPLAY "Should be 2 but is " TALLY. - IF X NOT = "AABZBCZB" - DISPLAY "Should be AABZBCZB but is " X. - EXAMINE X TALLYING UNTIL FIRST "C" REPLACING BY "X" - IF TALLY NOT = 5 - DISPLAY "Should be 5 but is " TALLY. - IF X NOT = "XXXXXCZB" - DISPLAY "Should be XXXXXCZB but is " X. - EXAMINE X TALLYING UNTIL FIRST "Y" REPLACING BY "Y" - IF TALLY NOT = 8 - DISPLAY "Should be 8 but is " TALLY. - IF X NOT = "YYYYYYYY" - DISPLAY "Should be YYYYYYYY but is " X. - EXAMINE N TALLYING UNTIL FIRST 5 REPLACING BY 8 - IF N NOT = -88888.55 - DISPLAY "Should be -88888.55 but is " N. - * Re-mod is forbidden here (at least on GCOS): - * EXAMINE N TALLYING LEADING T (5:1) - * IF TALLY NOT = 5 - * DISPLAY "Should be 5 but is " TALLY. - STOP RUN. -]) - -AT_CHECK([$COMPILE -freserved=EXAMINE prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([EXAMINE REPLACING]) -AT_KEYWORDS([runmisc]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 X PIC X(8) VALUE "AABABCAB". - 01 Y PIC X VALUE "Y". - 01 N PIC S9(5) VALUE -11122. - PROCEDURE DIVISION. - EXAMINE X REPLACING ALL "A" BY "X" - IF X NOT = "XXBXBCXB" - DISPLAY "Should be XXBXBCXB but is " X. - EXAMINE X REPLACING LEADING "X" BY "Y" - IF X NOT = "YYBXBCXB" - DISPLAY "Should be YYBXBCXB but is " X. - EXAMINE X REPLACING FIRST "B" BY "C" - IF X NOT = "YYCXBCXB" - DISPLAY "Should be YYCXBCXB but is " X. - EXAMINE X REPLACING UNTIL FIRST "B" BY "Z" - IF X NOT = "ZZZZBCXB" - DISPLAY "Should be ZZZZBCXB but is " X. - EXAMINE N REPLACING ALL 1 BY 3 - IF N NOT = -33322 - DISPLAY "Should be -33322 but is " N. - STOP RUN. -]) - -AT_CHECK([$COMPILE -freserved=EXAMINE prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP +# Note: more INSPECT for "TRAILING" and EXAMINE in run_extensions.at AT_SETUP([SWITCHES (environment COB_SWITCH_n and SET)])