Skip to content

Commit

Permalink
Merge SVN 4721
Browse files Browse the repository at this point in the history
  • Loading branch information
@ddeclerck
ddeclerck committed Jul 12, 2024
1 parent e864344 commit 0f469c6
Show file tree
Hide file tree
Showing 3 changed files with 227 additions and 150 deletions.
6 changes: 4 additions & 2 deletions tests/ChangeLog
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,8 +33,10 @@

2022-09-30 Simon Sobisch <[email protected]>

* 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 <[email protected]>

Expand Down
222 changes: 222 additions & 0 deletions tests/testsuite.src/run_extensions.at
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
149 changes: 1 addition & 148 deletions tests/testsuite.src/run_misc.at
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)])
Expand Down

0 comments on commit 0f469c6

Please sign in to comment.