diff options
Diffstat (limited to 'gcc/testsuite/cobol.dg')
282 files changed, 9329 insertions, 0 deletions
diff --git a/gcc/testsuite/cobol.dg/data1.cob b/gcc/testsuite/cobol.dg/data1.cob new file mode 100644 index 0000000..5830195 --- /dev/null +++ b/gcc/testsuite/cobol.dg/data1.cob @@ -0,0 +1,14 @@ +*> { dg-do run } +*> { dg-output {1.2345678E\+07(\n|\r\n|\r)} } +*> { dg-output {1.2345678E\+07(\n|\r\n|\r)} } + IDENTIFICATION DIVISION. + PROGRAM-ID. data1. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FLOATLONG FLOAT-LONG VALUE 12345678. + 01 FLOATEXT FLOAT-EXTENDED VALUE 12345678. + PROCEDURE DIVISION. + DISPLAY FLOATLONG + DISPLAY FLOATEXT + GOBACK. + END PROGRAM data1. diff --git a/gcc/testsuite/cobol.dg/group2/ACCEPT_DATE___DAY_and_intrinsic_functions__1_.cob b/gcc/testsuite/cobol.dg/group2/ACCEPT_DATE___DAY_and_intrinsic_functions__1_.cob new file mode 100644 index 0000000..69eb283 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ACCEPT_DATE___DAY_and_intrinsic_functions__1_.cob @@ -0,0 +1,30 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + *> one byte longer to make sure there is no garbage in + 01 WS-YYYYMMDD PIC 9(9). + 01 WS-YYYYDDD PIC 9(8). + PROCEDURE DIVISION. + ACCEPT WS-YYYYMMDD FROM DATE YYYYMMDD + END-ACCEPT + ACCEPT WS-YYYYDDD FROM DAY YYYYDDD + END-ACCEPT + IF FUNCTION INTEGER-OF-DATE (WS-YYYYMMDD) + NOT = FUNCTION INTEGER-OF-DAY (WS-YYYYDDD) + DISPLAY "DIFFERENCES FOUND!" + END-DISPLAY + DISPLAY "YYYYMMDD = " WS-YYYYMMDD ", " + "YYYYDDD = " WS-YYYYDDD + END-DISPLAY + DISPLAY "INTEGER-OF-DATE = " + FUNCTION INTEGER-OF-DATE (WS-YYYYMMDD) ", " + "INTEGER-OF-DAY = " + FUNCTION INTEGER-OF-DAY (WS-YYYYDDD) + END-DISPLAY + MOVE 1 TO RETURN-CODE + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ACCEPT_DATE___DAY_and_intrinsic_functions__2_.cob b/gcc/testsuite/cobol.dg/group2/ACCEPT_DATE___DAY_and_intrinsic_functions__2_.cob new file mode 100644 index 0000000..7a404fd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ACCEPT_DATE___DAY_and_intrinsic_functions__2_.cob @@ -0,0 +1,31 @@ + *> { dg-do run } + *> { dg-set-target-env-var COB_CURRENT_DATE "2020/06/12 18:45:22" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + *> one byte longer to make sure there is no garbage in + 01 WS-YYYYMMDD PIC 9(9). + 01 WS-YYYYDDD PIC 9(8). + PROCEDURE DIVISION. + ACCEPT WS-YYYYMMDD FROM DATE YYYYMMDD + END-ACCEPT + ACCEPT WS-YYYYDDD FROM DAY YYYYDDD + END-ACCEPT + IF FUNCTION INTEGER-OF-DATE (WS-YYYYMMDD) + NOT = FUNCTION INTEGER-OF-DAY (WS-YYYYDDD) + DISPLAY "DIFFERENCES FOUND!" + END-DISPLAY + DISPLAY "YYYYMMDD = " WS-YYYYMMDD ", " + "YYYYDDD = " WS-YYYYDDD + END-DISPLAY + DISPLAY "INTEGER-OF-DATE = " + FUNCTION INTEGER-OF-DATE (WS-YYYYMMDD) ", " + "INTEGER-OF-DAY = " + FUNCTION INTEGER-OF-DAY (WS-YYYYDDD) + END-DISPLAY + MOVE 1 TO RETURN-CODE + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__1_.cob b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__1_.cob new file mode 100644 index 0000000..6c1e479 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__1_.cob @@ -0,0 +1,58 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + *> one byte longer to make sure there is no garbage in + 01 X PIC X(9). + PROCEDURE DIVISION. + ACCEPT X FROM TIME + END-ACCEPT + IF X (1:2) >= "00" AND <= "23" AND + X (3:2) >= "00" AND <= "59" AND + X (5:2) >= "00" AND <= "60" AND + X (7:2) >= "00" AND <= "99" AND + X (9: ) = SPACE + CONTINUE + ELSE + DISPLAY "TIME " X "!" + END-DISPLAY + END-IF + ACCEPT X FROM DATE + END-ACCEPT + INSPECT X CONVERTING "012345678" TO "999999999" + IF X NOT = "999999" + DISPLAY "DATE " X "!" + END-DISPLAY + END-IF + ACCEPT X FROM DATE YYYYMMDD + END-ACCEPT + INSPECT X CONVERTING "012345678" TO "999999999" + IF X NOT = "99999999" + DISPLAY "YYYYMMDD " X "!" + END-DISPLAY + END-IF + ACCEPT X FROM DAY + END-ACCEPT + INSPECT X CONVERTING "012345678" TO "999999999" + IF X NOT = "99999" + DISPLAY "DAY " X "!" + END-DISPLAY + END-IF + ACCEPT X FROM DAY YYYYDDD + END-ACCEPT + INSPECT X CONVERTING "012345678" TO "999999999" + IF X NOT = "9999999" + DISPLAY "YYYYDDD " X "!" + END-DISPLAY + END-IF + ACCEPT X FROM DAY-OF-WEEK + END-ACCEPT + INSPECT X CONVERTING "1234567" TO "9999999" + IF X NOT = "9" + DISPLAY "DAY-OF-WEEK " X "!" + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__2_.cob b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__2_.cob new file mode 100644 index 0000000..6014220 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__2_.cob @@ -0,0 +1,74 @@ + *> { dg-do run } + *> { dg-set-target-env-var COB_CURRENT_DATE "2015/04/05 18:45:22" } + *> { dg-output-file "group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + *> one byte longer to make sure there is no garbage in + 01 WS-YYYYMMDD PIC X(9). + 01 WS-YYYYDDD PIC X(8). + 01 WS-DAYOFWEEK PIC X(2). + 01 WS-DATE-TODAY. + 05 WS-TODAYS-YY PIC 9(02) VALUE 0. + 05 WS-TODAYS-MM PIC 9(02) VALUE 0. + 05 WS-TODAYS-DD PIC 9(02) VALUE 0. + + 01 WS-DATE. + 05 WS-DATE-MM PIC 9(02) VALUE 0. + 05 FILLER PIC X(01) VALUE '/'. + 05 WS-DATE-DD PIC 9(02) VALUE 0. + 05 FILLER PIC X(01) VALUE '/'. + 05 WS-DATE-YY PIC 9(02) VALUE 0. + + 01 WS-TIME-NOW. + 05 WS-NOW-HH PIC 9(02) VALUE 0. + 05 WS-NOW-MM PIC 9(02) VALUE 0. + 05 WS-NOW-SS PIC 9(02) VALUE 0. + 05 WS-NOW-HS PIC 9(02) VALUE 0. + + 01 WS-TIME. + 05 WS-TIME-HH PIC 9(02) VALUE 0. + 05 FILLER PIC X(01) VALUE ':'. + 05 WS-TIME-MM PIC 9(02) VALUE 0. + 05 FILLER PIC X(01) VALUE ':'. + 05 WS-TIME-SS PIC 9(02) VALUE 0. + + PROCEDURE DIVISION. + ACCEPT WS-DATE-TODAY FROM DATE + ACCEPT WS-TIME-NOW FROM TIME + MOVE WS-TODAYS-YY TO WS-DATE-YY + MOVE WS-TODAYS-MM TO WS-DATE-MM + MOVE WS-TODAYS-DD TO WS-DATE-DD + MOVE WS-NOW-HH TO WS-TIME-HH + MOVE WS-NOW-MM TO WS-TIME-MM + MOVE WS-NOW-SS TO WS-TIME-SS + DISPLAY 'PROCESS DATE/TIME : ' WS-DATE SPACE WS-TIME + END-DISPLAY + ACCEPT WS-YYYYMMDD FROM DATE YYYYMMDD + DISPLAY WS-YYYYMMDD(1:8) + IF WS-YYYYMMDD not = "20150405" + DISPLAY 'Wrong date DATE YYYYMMDD: ' WS-YYYYMMDD + ' expected: 20150405' + UPON STDERR + END-DISPLAY + END-IF + ACCEPT WS-YYYYDDD FROM DAY YYYYDDD + DISPLAY WS-YYYYDDD(1:7) + IF WS-YYYYDDD not = "2015095" + DISPLAY 'Wrong date YYYYDDD: ' WS-YYYYDDD + ' expected: 2015095' + UPON STDERR + END-DISPLAY + END-IF + ACCEPT WS-DAYOFWEEK FROM DAY-OF-WEEK + DISPLAY WS-DAYOFWEEK(1:1) + IF WS-DAYOFWEEK not = "7" + DISPLAY 'Wrong date DAYOFWEEK: ' WS-DAYOFWEEK + ' expected: 7' + UPON STDERR + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__2_.out b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__2_.out new file mode 100644 index 0000000..a6ac8c4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__2_.out @@ -0,0 +1,5 @@ +PROCESS DATE/TIME : 04/05/15 18:45:22 +20150405 +2015095 +7 + diff --git a/gcc/testsuite/cobol.dg/group2/COMP-6_arithmetic.cob b/gcc/testsuite/cobol.dg/group2/COMP-6_arithmetic.cob new file mode 100644 index 0000000..6e8dc5c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMP-6_arithmetic.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/COMP-6_arithmetic.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-99 PIC 99 USAGE COMP-6. + 01 X-999 PIC 999 USAGE COMP-6. + 01 B-99 USAGE BINARY-LONG UNSIGNED. + 01 B-999 USAGE BINARY-LONG UNSIGNED. + PROCEDURE DIVISION. + MOVE 99 TO B-99 + MOVE B-99 TO X-99 + MOVE 123 TO B-999 + MOVE B-999 TO X-999 + ADD X-99 X-999 GIVING B-99 + END-ADD + DISPLAY B-99 + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/COMP-6_arithmetic.out b/gcc/testsuite/cobol.dg/group2/COMP-6_arithmetic.out new file mode 100644 index 0000000..fce98b0 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMP-6_arithmetic.out @@ -0,0 +1,2 @@ +0000000222 + diff --git a/gcc/testsuite/cobol.dg/group2/COMP-6_numeric_test.cob b/gcc/testsuite/cobol.dg/group2/COMP-6_numeric_test.cob new file mode 100644 index 0000000..3628628 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMP-6_numeric_test.cob @@ -0,0 +1,75 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/COMP-6_numeric_test.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X-2 PIC X(2). + 02 N-3 REDEFINES X-2 PIC 999 USAGE COMP-6. + 02 N-4 REDEFINES X-2 PIC 9999 USAGE COMP-6. + PROCEDURE DIVISION. + MOVE X"0000" TO X-2. + IF N-3 IS NUMERIC + DISPLAY "OK" + END-DISPLAY + ELSE + DISPLAY "1 NG" + END-DISPLAY + END-IF. + IF N-4 IS NUMERIC + DISPLAY "OK" + END-DISPLAY + ELSE + DISPLAY "2 NG" + END-DISPLAY + END-IF. + MOVE X"000c" TO X-2. + IF N-3 IS NUMERIC + DISPLAY "3 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + IF N-4 IS NUMERIC + DISPLAY "4 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + MOVE X"1234" TO X-2. + IF N-3 IS NUMERIC + DISPLAY "5 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + IF N-4 IS NUMERIC + DISPLAY "OK" + END-DISPLAY + ELSE + DISPLAY "6 NG" + END-DISPLAY + END-IF. + MOVE X"ffff" TO X-2. + IF N-3 IS NUMERIC + DISPLAY "7 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + IF N-4 IS NUMERIC + DISPLAY "7 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/COMP-6_numeric_test.out b/gcc/testsuite/cobol.dg/group2/COMP-6_numeric_test.out new file mode 100644 index 0000000..09117b6 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMP-6_numeric_test.out @@ -0,0 +1,9 @@ +OK +OK +OK +OK +OK +OK +OK +OK + diff --git a/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_DISPLAY.cob b/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_DISPLAY.cob new file mode 100644 index 0000000..33d048e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_DISPLAY.cob @@ -0,0 +1,25 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/COMP-6_used_with_DISPLAY.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-99 PIC 99 USAGE COMP-6. + 01 X-999 PIC 999 USAGE COMP-6. + PROCEDURE DIVISION. + MOVE 0 TO X-99. + DISPLAY X-99 + END-DISPLAY. + MOVE 99 TO X-99. + DISPLAY X-99 + END-DISPLAY. + MOVE 0 TO X-999. + DISPLAY X-999 + END-DISPLAY. + MOVE 123 TO X-999. + DISPLAY X-999 + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_DISPLAY.out b/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_DISPLAY.out new file mode 100644 index 0000000..901408e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_DISPLAY.out @@ -0,0 +1,5 @@ +00 +99 +000 +123 + diff --git a/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_MOVE.cob b/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_MOVE.cob new file mode 100644 index 0000000..9f319fa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_MOVE.cob @@ -0,0 +1,34 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/COMP-6_used_with_MOVE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-99 PIC 99 USAGE COMP-6. + 01 X-999 PIC 999 USAGE COMP-6. + 01 B-99 USAGE BINARY-LONG. + 01 B-999 USAGE BINARY-LONG. + PROCEDURE DIVISION. + MOVE 0 TO B-99. + MOVE B-99 TO X-99. + DISPLAY X-99 + END-DISPLAY. + MOVE 99 TO B-99. + MOVE B-99 TO X-99. + DISPLAY X-99 + END-DISPLAY. + MOVE 0 TO B-999. + MOVE B-999 TO X-999. + DISPLAY X-999 + END-DISPLAY. + MOVE 123 TO B-999. + MOVE B-999 TO X-999. + DISPLAY X-999 + END-DISPLAY. + MOVE B-999 TO X-99. + DISPLAY X-99 + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_MOVE.out b/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_MOVE.out new file mode 100644 index 0000000..19f3704 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMP-6_used_with_MOVE.out @@ -0,0 +1,6 @@ +00 +99 +000 +123 +23 + diff --git a/gcc/testsuite/cobol.dg/group2/COMPUTE_multiplication_to_FIX4.cob b/gcc/testsuite/cobol.dg/group2/COMPUTE_multiplication_to_FIX4.cob new file mode 100644 index 0000000..4ea8b35 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMPUTE_multiplication_to_FIX4.cob @@ -0,0 +1,154 @@ + *> { dg-do run } + *> { dg-output-file "group2/COMPUTE_multiplication_to_FIX4.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. onsize. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FIX4DISPLAY PIC 9(4) DISPLAY. + 01 FIX8DISPLAY PIC 9(8) DISPLAY VALUE 12345678. + 01 FIX8BINARY PIC 9(8) BINARY VALUE 12345678. + 01 FIX8PACKED PIC 9(8) PACKED-DECIMAL VALUE 12345678. + 01 FIX8NUMEDT PIC 9(8).0 VALUE 12345678. + 01 FLOATSHORT FLOAT-SHORT VALUE 12345678. + 01 FLOATLONG FLOAT-LONG VALUE 12345678. + 01 FLOATEXT FLOAT-EXTENDED VALUE 12345678. + + PROCEDURE DIVISION. + + *> FIX8DISPLAY + DISPLAY "COMPUTE FIX4DISPLAY = FIX8DISPLAY without SIZE ERROR" + MOVE 9876 TO FIX4DISPLAY + COMPUTE FIX4DISPLAY = FIX8DISPLAY + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 5678" + DISPLAY "." + + DISPLAY "COMPUTE FIX4DISPLAY = FIX8DISPLAY with SIZE ERROR" + COMPUTE FIX4DISPLAY = FIX8DISPLAY + MOVE 9876 TO FIX4DISPLAY + COMPUTE FIX4DISPLAY = FIX8DISPLAY + ON SIZE ERROR Display "Proper size error" + NOT ON SIZE ERROR Display "Improper no error" + END-COMPUTE + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 9876" + DISPLAY "." + + *> FIX8BINARY + + DISPLAY "COMPUTE FIX4DISPLAY = FIX8BINARY without SIZE ERROR" + COMPUTE FIX4DISPLAY = FIX8BINARY + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 5678" + DISPLAY "." + + DISPLAY "COMPUTE FIX4DISPLAY = FIX8BINARY with SIZE ERROR" + COMPUTE FIX4DISPLAY = FIX8BINARY + MOVE 9876 TO FIX4DISPLAY + COMPUTE FIX4DISPLAY = FIX8BINARY + ON SIZE ERROR Display "Proper size error" + NOT ON SIZE ERROR Display "Improper no error" + END-COMPUTE + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 9876" + DISPLAY "." + + *> FIX8PACKED + + DISPLAY "COMPUTE FIX4DISPLAY = FIX8PACKED without SIZE ERROR" + COMPUTE FIX4DISPLAY = FIX8PACKED + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 5678" + DISPLAY "." + + DISPLAY "COMPUTE FIX4DISPLAY = FIX8PACKED with SIZE ERROR" + COMPUTE FIX4DISPLAY = FIX8PACKED + MOVE 9876 TO FIX4DISPLAY + COMPUTE FIX4DISPLAY = FIX8PACKED + ON SIZE ERROR Display "Proper size error" + NOT ON SIZE ERROR Display "Improper no error" + END-COMPUTE + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 9876" + DISPLAY "." + + *> FIX8NUMEDT + + DISPLAY "COMPUTE FIX4DISPLAY = FIX8NUMEDT without SIZE ERROR" + COMPUTE FIX4DISPLAY = FIX8NUMEDT + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 5678" + DISPLAY "." + + DISPLAY "COMPUTE FIX4DISPLAY = FIX8NUMEDT with SIZE ERROR" + COMPUTE FIX4DISPLAY = FIX8NUMEDT + MOVE 9876 TO FIX4DISPLAY + COMPUTE FIX4DISPLAY = FIX8NUMEDT + ON SIZE ERROR Display "Proper size error" + NOT ON SIZE ERROR Display "Improper no error" + END-COMPUTE + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 9876" + DISPLAY "." + + *> FLOATSHORT + + DISPLAY "COMPUTE FIX4DISPLAY = FLOATSHORT without SIZE ERROR" + COMPUTE FIX4DISPLAY = FLOATSHORT + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 5678" + DISPLAY "." + + DISPLAY "COMPUTE FIX4DISPLAY = FLOATSHORT with SIZE ERROR" + COMPUTE FIX4DISPLAY = FLOATSHORT + MOVE 9876 TO FIX4DISPLAY + COMPUTE FIX4DISPLAY = FLOATSHORT + ON SIZE ERROR Display "Proper size error" + NOT ON SIZE ERROR Display "Improper no error" + END-COMPUTE + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 9876" + DISPLAY "." + + *> FLOATLONG + + DISPLAY "COMPUTE FIX4DISPLAY = FLOATLONG without SIZE ERROR" + COMPUTE FIX4DISPLAY = FLOATLONG + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 5678" + DISPLAY "." + + DISPLAY "COMPUTE FIX4DISPLAY = FLOATLONG with SIZE ERROR" + COMPUTE FIX4DISPLAY = FLOATLONG + MOVE 9876 TO FIX4DISPLAY + COMPUTE FIX4DISPLAY = FLOATLONG + ON SIZE ERROR Display "Proper size error" + NOT ON SIZE ERROR Display "Improper no error" + END-COMPUTE + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 9876" + DISPLAY "." + + *> FLOATEXT + + DISPLAY "COMPUTE FIX4DISPLAY = FLOATEXT without SIZE ERROR" + COMPUTE FIX4DISPLAY = FLOATEXT + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 5678" + DISPLAY "." + + DISPLAY "COMPUTE FIX4DISPLAY = FLOATEXT with SIZE ERROR" + COMPUTE FIX4DISPLAY = FLOATEXT + MOVE 9876 TO FIX4DISPLAY + COMPUTE FIX4DISPLAY = FLOATEXT + ON SIZE ERROR Display "Proper size error" + NOT ON SIZE ERROR Display "Improper no error" + END-COMPUTE + DISPLAY "FIX4DISPLAY is " FIX4DISPLAY + DISPLAY "Should be 9876" + DISPLAY ".". + + STOP RUN. + END PROGRAM onsize. + diff --git a/gcc/testsuite/cobol.dg/group2/COMPUTE_multiplication_to_FIX4.out b/gcc/testsuite/cobol.dg/group2/COMPUTE_multiplication_to_FIX4.out new file mode 100644 index 0000000..8970a6c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/COMPUTE_multiplication_to_FIX4.out @@ -0,0 +1,64 @@ +COMPUTE FIX4DISPLAY = FIX8DISPLAY without SIZE ERROR +FIX4DISPLAY is 5678 +Should be 5678 +. +COMPUTE FIX4DISPLAY = FIX8DISPLAY with SIZE ERROR +Proper size error +FIX4DISPLAY is 9876 +Should be 9876 +. +COMPUTE FIX4DISPLAY = FIX8BINARY without SIZE ERROR +FIX4DISPLAY is 5678 +Should be 5678 +. +COMPUTE FIX4DISPLAY = FIX8BINARY with SIZE ERROR +Proper size error +FIX4DISPLAY is 9876 +Should be 9876 +. +COMPUTE FIX4DISPLAY = FIX8PACKED without SIZE ERROR +FIX4DISPLAY is 5678 +Should be 5678 +. +COMPUTE FIX4DISPLAY = FIX8PACKED with SIZE ERROR +Proper size error +FIX4DISPLAY is 9876 +Should be 9876 +. +COMPUTE FIX4DISPLAY = FIX8NUMEDT without SIZE ERROR +FIX4DISPLAY is 5678 +Should be 5678 +. +COMPUTE FIX4DISPLAY = FIX8NUMEDT with SIZE ERROR +Proper size error +FIX4DISPLAY is 9876 +Should be 9876 +. +COMPUTE FIX4DISPLAY = FLOATSHORT without SIZE ERROR +FIX4DISPLAY is 5678 +Should be 5678 +. +COMPUTE FIX4DISPLAY = FLOATSHORT with SIZE ERROR +Proper size error +FIX4DISPLAY is 9876 +Should be 9876 +. +COMPUTE FIX4DISPLAY = FLOATLONG without SIZE ERROR +FIX4DISPLAY is 5678 +Should be 5678 +. +COMPUTE FIX4DISPLAY = FLOATLONG with SIZE ERROR +Proper size error +FIX4DISPLAY is 9876 +Should be 9876 +. +COMPUTE FIX4DISPLAY = FLOATEXT without SIZE ERROR +FIX4DISPLAY is 5678 +Should be 5678 +. +COMPUTE FIX4DISPLAY = FLOATEXT with SIZE ERROR +Proper size error +FIX4DISPLAY is 9876 +Should be 9876 +. + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.cob b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.cob new file mode 100644 index 0000000..a070d16 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.cob @@ -0,0 +1,46 @@ + *> { dg-do run } + *> { dg-output-file "group2/Complex_EVALUATE__1_.out" } + + identification division. + function-id. bumper. + data division. + working-storage section. + 77 bump pic 9999 value zero. + linkage section. + 77 bumped pic 9999. + procedure division returning bumped. + add 1 to bump. + move bump to bumped. + goback. + end function bumper. + + identification division. + program-id. prog. + environment division. + configuration section. + repository. + function bumper. + data division. + working-storage section. + 77 bump pic 9999 value zero. + 77 bump1 pic 9999 value zero. + 77 bump2 pic 9999 value zero. + 77 bump3 pic 9999 value zero. + procedure division. + move function bumper to bump + display bump + move function bumper to bump + display bump + move function bumper to bump + display bump + evaluate function bumper also function bumper also function bumper + when 4 also 5 also 6 + display "properly 4 also 5 also 6" + when 7 also 8 also 9 + display "IMPROPERLY 6 then 7 then 8" + when other + display "we don't know what's going on" + end-evaluate + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.out b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.out new file mode 100644 index 0000000..d634a79 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.out @@ -0,0 +1,5 @@ +0001 +0002 +0003 +properly 4 also 5 also 6 + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.cob b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.cob new file mode 100644 index 0000000..0e88d74 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.cob @@ -0,0 +1,52 @@ + *> { dg-do run } + *> { dg-output-file "group2/Complex_EVALUATE__2_.out" } + + identification division. + function-id. bumper. + data division. + working-storage section. + 77 bump pic 9999 value zero. + linkage section. + 77 bumped pic 9999. + procedure division returning bumped. + add 1 to bump. + move bump to bumped. + display " bumper is returning " bumped + goback. + end function bumper. + + identification division. + program-id. prog. + environment division. + configuration section. + repository. + function bumper. + data division. + working-storage section. + 77 bump pic 9999 value zero. + procedure division. + display " Prime the pump with three calls to bumper" + move function bumper to bump + move function bumper to bump + move function bumper to bump + display " Three calls to BUMPER should follow" + evaluate function bumper also function bumper also function bumper + when 4 also 5 also 6 + display "properly 4 also 5 also 6" + when 7 also 8 also 9 + display "IMPROPERLY 7 also 8 also 9" + when other + display "IMPROPERLY we don't know what's going on" + end-evaluate + display " Three more calls to BUMPER should follow" + evaluate function bumper also function bumper also function bumper + when 4 also 5 also 6 + display "IMPROPERLY 4 also 5 also 6" + when 7 also 8 also 9 + display "properly 7 also 8 also 9" + when other + display "IMPROPERLY we don't know what's going on" + end-evaluate + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.out b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.out new file mode 100644 index 0000000..b0e9bdb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.out @@ -0,0 +1,15 @@ + Prime the pump with three calls to bumper + bumper is returning 0001 + bumper is returning 0002 + bumper is returning 0003 + Three calls to BUMPER should follow + bumper is returning 0004 + bumper is returning 0005 + bumper is returning 0006 +properly 4 also 5 also 6 + Three more calls to BUMPER should follow + bumper is returning 0007 + bumper is returning 0008 + bumper is returning 0009 +properly 7 also 8 also 9 + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.cob b/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.cob new file mode 100644 index 0000000..6225c20 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.cob @@ -0,0 +1,40 @@ + *> { dg-do run } + *> { dg-output-file "group2/DISPLAY__Sign_ASCII.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X(5). + 02 X-9 REDEFINES X PIC 9(4). + 02 X-S9 REDEFINES X PIC S9(4). + 02 X-S9-L REDEFINES X PIC S9(4) LEADING. + 02 X-S9-LS REDEFINES X PIC S9(4) LEADING SEPARATE. + 02 X-S9-T REDEFINES X PIC S9(4) TRAILING. + 02 X-S9-TS REDEFINES X PIC S9(4) TRAILING SEPARATE. + PROCEDURE DIVISION. + MOVE ZERO TO X. MOVE 1234 TO X-9. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE 1234 TO X-S9. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE -1234 TO X-S9. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE 1234 TO X-S9-L. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE -1234 TO X-S9-L. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE 1234 TO X-S9-LS. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE -1234 TO X-S9-LS. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE 1234 TO X-S9-T. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE -1234 TO X-S9-T. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE 1234 TO X-S9-TS. DISPLAY X + END-DISPLAY. + MOVE ZERO TO X. MOVE -1234 TO X-S9-TS. DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.out b/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.out new file mode 100644 index 0000000..bda63c7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.out @@ -0,0 +1,12 @@ +12340 +12340 +123t0 +12340 +q2340 ++1234 +-1234 +12340 +123t0 +1234+ +1234- + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII__2_.cob b/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII__2_.cob new file mode 100644 index 0000000..585e60c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII__2_.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + *> { dg-output-file "group2/DISPLAY__Sign_ASCII__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X(10). + 02 X-S99 REDEFINES X PIC S99. + 02 X-S9 REDEFINES X PIC S9 OCCURS 10. + PROCEDURE DIVISION. + MOVE 0 TO X-S9(1). + MOVE 1 TO X-S9(2). + MOVE 2 TO X-S9(3). + MOVE 3 TO X-S9(4). + MOVE 4 TO X-S9(5). + MOVE 5 TO X-S9(6). + MOVE 6 TO X-S9(7). + MOVE 7 TO X-S9(8). + MOVE 8 TO X-S9(9). + MOVE 9 TO X-S9(10). + DISPLAY X NO ADVANCING + END-DISPLAY. + MOVE -10 TO X-S99. MOVE X(2:1) TO X(1:1). + MOVE -1 TO X-S9(2). + MOVE -2 TO X-S9(3). + MOVE -3 TO X-S9(4). + MOVE -4 TO X-S9(5). + MOVE -5 TO X-S9(6). + MOVE -6 TO X-S9(7). + MOVE -7 TO X-S9(8). + MOVE -8 TO X-S9(9). + MOVE -9 TO X-S9(10). + DISPLAY X NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII__2_.out b/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII__2_.out new file mode 100644 index 0000000..6717b6e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII__2_.out @@ -0,0 +1 @@ +0123456789pqrstuvwxy diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.cob b/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.cob new file mode 100644 index 0000000..798f18b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/EVALUATE_WHEN_NEGATIVE.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + 77 num pic s9. + procedure division. + move -1 to num + evaluate num + when negative + display "negative" + end-evaluate. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.out b/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.out new file mode 100644 index 0000000..126adb7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.out @@ -0,0 +1,2 @@ +negative + diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.cob b/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.cob new file mode 100644 index 0000000..84bc885 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + *> { dg-output-file "group2/EVALUATE_condition__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 XVAL PIC X VALUE '_'. + 88 UNDERSCORE VALUE '_'. + PROCEDURE DIVISION. + DISPLAY 'Next line should be "UNDERSCORE evaluates to TRUE"' + EVALUATE TRUE + WHEN NOT UNDERSCORE + DISPLAY + "***IMPROPERLY*** NOT UNDERSCORE evaluates to TRUE" + END-DISPLAY + END-EVALUATE. + EVALUATE TRUE + WHEN UNDERSCORE + DISPLAY "UNDERSCORE evaluates to TRUE" + END-DISPLAY + END-EVALUATE. + + DISPLAY + 'Next line should be "NOT UNDERSCORE evaluates to FALSE"' + EVALUATE FALSE + WHEN NOT UNDERSCORE + DISPLAY "NOT UNDERSCORE evaluates to FALSE" + END-DISPLAY + END-EVALUATE. + EVALUATE FALSE + WHEN UNDERSCORE + DISPLAY + "***IMPROPERLY*** UNDERSCORE evaluates to FALSE" + END-DISPLAY + END-EVALUATE. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.out b/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.out new file mode 100644 index 0000000..adff5ca --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.out @@ -0,0 +1,5 @@ +Next line should be "UNDERSCORE evaluates to TRUE" +UNDERSCORE evaluates to TRUE +Next line should be "NOT UNDERSCORE evaluates to FALSE" +NOT UNDERSCORE evaluates to FALSE + diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.cob b/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.cob new file mode 100644 index 0000000..50ff958 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.cob @@ -0,0 +1,30 @@ + *> { dg-do run } + *> { dg-output-file "group2/EVALUATE_doubled_WHEN.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + 77 eval pic x(4). + procedure division. + move "open" to eval + display "about to EVALUATE eval " """" eval """" + evaluate true + when eval = 'open' + when eval = 'OPEN' + display "Good: We got us an " """" eval """" + when other + display "BAD!!! It shoulda been " """" eval """" + end-evaluate + move "OPEN" to eval + display "about to EVALUATE eval " """" eval """" + evaluate true + when eval = 'open' + when eval = 'OPEN' + display "Good: We got us an " """" eval """" + when other + display "BAD!!! It shoulda been " """" eval """" + end-evaluate + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.out b/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.out new file mode 100644 index 0000000..c4fa148 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.out @@ -0,0 +1,5 @@ +about to EVALUATE eval "open" +Good: We got us an "open" +about to EVALUATE eval "OPEN" +Good: We got us an "OPEN" + diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.cob b/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.cob new file mode 100644 index 0000000..ed4c89a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/EVALUATE_with_WHEN_using_condition-1.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 var-1 PIC 99V9. + 88 var-1-big VALUE 20 THRU 40. + 88 var-1-huge VALUE 40 THRU 99. + PROCEDURE DIVISION. + EVALUATE TRUE *> not: var-1 + WHEN var-1-big DISPLAY "big" + WHEN var-1-huge DISPLAY "huge" + WHEN OTHER DISPLAY "not" + END-EVALUATE. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.out b/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.out new file mode 100644 index 0000000..3043bcc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.out @@ -0,0 +1,2 @@ +not + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ABS.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_ABS.cob new file mode 100644 index 0000000..3f4049b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ABS.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_ABS.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC S9(4)V9(4) VALUE -1.2345. + PROCEDURE DIVISION. + COMPUTE X = FUNCTION ABS( X ) + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ABS.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_ABS.out new file mode 100644 index 0000000..ab39cfe --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ABS.out @@ -0,0 +1,2 @@ ++0001.2345 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ACOS.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_ACOS.cob new file mode 100644 index 0000000..73e192f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ACOS.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC S9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION ACOS ( -0.2345 ) TO Z. + IF Z NOT = 1.807500521108243435101500438523210 + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ALL_INTRINSIC_simple_test.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_ALL_INTRINSIC_simple_test.cob new file mode 100644 index 0000000..276c33f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ALL_INTRINSIC_simple_test.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_ALL_INTRINSIC_simple_test.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. phase0. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + REPOSITORY. + FUNCTION ALL INTRINSIC. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 work-string pic X(80) VALUE " ABC ". + PROCEDURE DIVISION. + DISPLAY """" TRIM(work-string) """" + goback. + end program phase0. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ALL_INTRINSIC_simple_test.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_ALL_INTRINSIC_simple_test.out new file mode 100644 index 0000000..7b9bc93 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ALL_INTRINSIC_simple_test.out @@ -0,0 +1,2 @@ +"ABC" + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ANNUITY.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_ANNUITY.cob new file mode 100644 index 0000000..29049dd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ANNUITY.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC S9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION ANNUITY ( 3, 5 ) TO Z. + IF Z NOT = 3.002932551319648093841642228739003 + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ASIN.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_ASIN.cob new file mode 100644 index 0000000..b364a40 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ASIN.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION ASIN ( -0.2345 ) TO Y. + IF Y NOT = -0.236704194313346815870178746883458 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ATAN.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_ATAN.cob new file mode 100644 index 0000000..1f884ce --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ATAN.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION ATAN ( 1 ) TO Y. + IF Y NOT = 0.785398163397448309615660845819875 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER.cob new file mode 100644 index 0000000..70b40ba --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER.cob @@ -0,0 +1,40 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + *> { dg-output-file "group2/FUNCTION_BIGGER-POINTER.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 N PIC S9(8) COMP-5 value 0. + 01 P REDEFINES N POINTER. + 01 FILLER. + 05 X PIC A(4) VALUE "ABC". + 05 E REDEFINES X PIC A(1) OCCURS 4. + LINKAGE SECTION. + 77 B PIC A. + + PROCEDURE DIVISION. + set P to address of E(1). + + display FUNCTION trim(x) '.' + + set address of B to p. + perform until B = SPACE + display B no advancing + set p up by 1 + set address of B to p + end-perform + display '.' + + set P to address of E(1) + set address of B to p + perform until B = SPACES + display B no advancing + add 1 to N + set address of B to p + end-perform + display '.' + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER.out new file mode 100644 index 0000000..d31e83b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER.out @@ -0,0 +1,4 @@ +ABC. +ABC. +ABC. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER__2_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER__2_.cob new file mode 100644 index 0000000..d6d04d1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER__2_.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + *> { dg-output-file "group2/FUNCTION_BIGGER-POINTER__2_.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + 01 n4 pic s9(8) comp-5 value 0. + 01 p4 redefines n4 pointer. + 01 n8 pic s9(16) comp-5 value 0. + 01 p8 redefines n8 pointer. + procedure division. + move -1 to n8 + set p4 to p8 + display "P4 and P8 before: " p4 space p8 + display "Increment N4 and N8" + add 1 to n4 n8 + display "P4 and P8 after: " p4 space p8 + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER__2_.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER__2_.out new file mode 100644 index 0000000..b15a754 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_BIGGER-POINTER__2_.out @@ -0,0 +1,4 @@ +P4 and P8 before: 0xffffffffffffffff 0xffffffffffffffff +Increment N4 and N8 +P4 and P8 after: 0x0000000000000000 0x0000000000000000 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_BYTE-LENGTH.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_BYTE-LENGTH.cob new file mode 100644 index 0000000..9a5f384 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_BYTE-LENGTH.cob @@ -0,0 +1,20 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_BYTE-LENGTH.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4). + 01 TEST-FLD PIC S9(04)V9(08). + PROCEDURE DIVISION. + MOVE FUNCTION BYTE-LENGTH ( TEST-FLD ) TO TEST-FLD. + DISPLAY "BYTE-LENGTH of PIC S9(04)V9(08) is " TEST-FLD + MOVE FUNCTION BYTE-LENGTH ( X ) TO TEST-FLD. + DISPLAY "BYTE-LENGTH of PIC X(4) is " TEST-FLD + MOVE FUNCTION BYTE-LENGTH ( '00128' ) TO TEST-FLD + DISPLAY "BYTE-LENGTH of PIC '00128' is " TEST-FLD + MOVE FUNCTION BYTE-LENGTH ( x'a0' ) TO TEST-FLD + DISPLAY "BYTE-LENGTH of PIC x'a0' is " TEST-FLD + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_BYTE-LENGTH.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_BYTE-LENGTH.out new file mode 100644 index 0000000..64ad515 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_BYTE-LENGTH.out @@ -0,0 +1,5 @@ +BYTE-LENGTH of PIC S9(04)V9(08) is +0012.00000000 +BYTE-LENGTH of PIC X(4) is +0004.00000000 +BYTE-LENGTH of PIC '00128' is +0005.00000000 +BYTE-LENGTH of PIC x'a0' is +0001.00000000 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_CHAR.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_CHAR.cob new file mode 100644 index 0000000..955cc51 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_CHAR.cob @@ -0,0 +1,29 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC S9(4)V9(4) VALUE 108. + 01 TEST-FLD. + 05 TEST-DATA PIC X(01). + 88 VALID-DATA VALUE 'k'. + 05 TEST-UNSET PIC X VALUE '_'. + 88 VALID-UNSET VALUE '_'. + PROCEDURE DIVISION. + STRING FUNCTION CHAR ( X ) + DELIMITED BY SIZE + INTO TEST-FLD + END-STRING. + EVALUATE TRUE + WHEN NOT VALID-UNSET + DISPLAY "FUNCTION result too long" + END-DISPLAY + WHEN VALID-DATA + CONTINUE + WHEN OTHER + DISPLAY TEST-DATA + END-DISPLAY + END-EVALUATE. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_COMBINED-DATETIME.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_COMBINED-DATETIME.cob new file mode 100644 index 0000000..3f9c6e1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_COMBINED-DATETIME.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(04)V9(08). + PROCEDURE DIVISION. + MOVE FUNCTION COMBINED-DATETIME ( 987, 345.6 ) + TO TEST-FLD. + IF TEST-FLD NOT = 987.003456 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_CONCAT___CONCATENATE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_CONCAT___CONCATENATE.cob new file mode 100644 index 0000000..d982432 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_CONCAT___CONCATENATE.cob @@ -0,0 +1,36 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC X(4). + 01 TEST-FLD. + 05 TEST-DATA PIC X(14). + 88 VALID-DATA VALUE 'defxabczz55666'. + 05 TEST-UNSET PIC X VALUE '_'. + 88 VALID-UNSET VALUE '_'. + PROCEDURE DIVISION. + MOVE "defx" TO Y. + STRING FUNCTION CONCAT ( Y "abc" "zz" "55" "666" ) + DELIMITED BY SIZE + INTO TEST-FLD + END-STRING. + EVALUATE TRUE + WHEN NOT VALID-UNSET + DISPLAY "FUNCTION result too long" + END-DISPLAY + WHEN TEST-DATA + <> FUNCTION CONCAT ( Y "abc" "zz" "55" "666" ) + DISPLAY "CONCAT issue, '" TEST-DATA + "' vs. '" + FUNCTION CONCAT ( Y "abc" "zz" "55" "666" ) "'" + END-DISPLAY + WHEN VALID-DATA + CONTINUE + WHEN OTHER + DISPLAY TEST-DATA + END-DISPLAY + END-EVALUATE. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_CONCAT_with_reference_modding.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_CONCAT_with_reference_modding.cob new file mode 100644 index 0000000..98f21c3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_CONCAT_with_reference_modding.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC X(4). + 01 TEST-FLD PIC X(9) VALUE SPACES. + PROCEDURE DIVISION. + MOVE 'defx' TO Y. + MOVE FUNCTION CONCAT + ( Y "abc" "zz" "55" "666" ) (2 : 9) + TO TEST-FLD. + IF TEST-FLD NOT = 'efxabczz5' + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_COS.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_COS.cob new file mode 100644 index 0000000..6651b9d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_COS.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION COS ( -0.2345 ) TO Y. + IF Y NOT = 0.972630641256258184713416962414561 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_CURRENT-DATE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_CURRENT-DATE.cob new file mode 100644 index 0000000..429f247 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_CURRENT-DATE.cob @@ -0,0 +1,62 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD. + 02 WS-YEAR PIC 9(04). + 88 VALID-YEAR VALUE 1980 THRU 9999. + 02 WS-MONTH PIC 9(02). + 88 VALID-MONTH VALUE 01 THRU 12. + 02 WS-DAY PIC 9(02). + 88 VALID-DAY VALUE 01 THRU 31. + 02 WS-HOUR PIC 9(02). + 88 VALID-HOUR VALUE 00 THRU 23. + 02 WS-MIN PIC 9(02). + 88 VALID-MIN VALUE 00 THRU 59. + 02 WS-SEVALIDD PIC 9(02). + 88 VALID-SEC VALUE 00 THRU 59. + 02 WS-HUNDSEC PIC 9(02). + 88 VALID-HUNDSEC VALUE 00 THRU 99. + 02 WS-GREENW PIC X. + 88 VALID-GREENW VALUE "-", "+", "0". + 88 ZERO-GREENW VALUE "0". + 02 WS-OFFSET PIC 9(02). + 88 VALID-OFFSET VALUE 00 THRU 13. + 88 ZERO-OFFSET VALUE 00. + 02 WS-OFFSET2 PIC 9(02). + 88 VALID-OFFSET2 VALUE 00 THRU 59. + 88 ZERO-OFFSET2 VALUE 00. + 02 WS-UNSET PIC X VALUE '_'. + 88 VALID-UNSET VALUE '_'. + PROCEDURE DIVISION. + STRING FUNCTION CURRENT-DATE + DELIMITED BY SIZE + INTO TEST-FLD + END-STRING. + EVALUATE TRUE + WHEN NOT VALID-UNSET + DISPLAY "FUNCTION result too long" + END-DISPLAY + WHEN VALID-YEAR AND + VALID-MONTH AND + VALID-DAY AND + VALID-HOUR AND + VALID-MIN AND + VALID-SEC AND + VALID-HUNDSEC AND + VALID-GREENW AND + VALID-OFFSET AND + VALID-OFFSET2 AND + VALID-UNSET AND + ((NOT ZERO-GREENW) OR (ZERO-OFFSET AND ZERO-OFFSET2)) + CONTINUE + WHEN OTHER + DISPLAY "CURRENT-DATE with wrong format: " + TEST-FLD (01:21) + END-DISPLAY + END-EVALUATE. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE-OF-INTEGER.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE-OF-INTEGER.cob new file mode 100644 index 0000000..708aa96 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE-OF-INTEGER.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(09)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION DATE-OF-INTEGER ( 146000 ) + TO TEST-FLD. + IF TEST-FLD NOT = 20000925 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE-TO-YYYYMMDD.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE-TO-YYYYMMDD.cob new file mode 100644 index 0000000..5b2bd43 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE-TO-YYYYMMDD.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(09)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION DATE-TO-YYYYMMDD ( 981002, -10, 1994 ) + TO TEST-FLD. + IF TEST-FLD NOT = 018981002 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob new file mode 100644 index 0000000..bb48bb0 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob @@ -0,0 +1,334 @@ + *> { dg-do run } + + identification division. + program-id. test. + *> Tests all the DATE and TIME functions + *> + *> The various functions are used to test each other. + *> + *> COMBINED-DATETIME OK + *> CURRENT_DATE OK + *> DATE-OF-INTEGER OK + *> DATE-TO-YYYYMMDD OK + *> DAY-OF-INTEGER OK + *> DAY-TO-YYYYDDD OK + *> FORMATTED-CURRENT-DATE OK + *> FORMATTED-DATE OK + *> FORMATTED-DATETIME OK + *> FORMATTED-TIME OK + *> INTEGER-OF-DATE OK + *> INTEGER-OF-DAY OK + *> INTEGER-OF-FORMATTED-DATE OK + *> SECONDS-FROM-FORMATTED-TIME OK + *> SECONDS-PAST-MIDNIGHT OK + *> TEST-DATE-YYYYMMDD OK + *> TEST-DAY-YYYYDDD OK + *> TEST-FORMATTED-DATETIME OK + *> + data division. + working-storage section. + + 01 checking pic x(80). + 01 should-be pic x(32). + 01 but-is pic x(32). + 01 but-is-n redefines but-is pic 99999999.999999. + 01 but-is-integer_part pic 99999. + + 01 jd1601 pic 9(7). + 01 jd9999 pic 9(7). + 01 jd pic s9(7). + + 01 integer-date pic s9(7). + 01 integer-result pic 99. + 01 standard-date-form pic 9(8). + 01 julian-date-form PIC 9(8). + + 01 date1. + 02 YYYY pic 9999. + 02 MM pic 99. + 02 DD pic 99. + 01 date2. + 02 YYYY pic 9999. + 02 filler pic x value "-". + 02 MM pic 99. + 02 filler pic x value "-". + 02 DD pic 99. + 01 date3. + 02 YYYY pic 9999. + 02 DDD pic 999. + 01 date4. + 02 YYYY pic 9999. + 02 filler pic x value "-". + 02 DDD pic 999. + 01 date5. + 02 YYYY pic 9999. + 02 filler pic x value "W". + 02 ww pic 99. + 02 d pic 9. + 01 date6. + 02 YYYY pic 9999. + 02 filler pic xx value "-W". + 02 ww pic 99. + 02 filler pic x value "-". + 02 d pic 9. + + 01 yymmdd. + 02 YY pic 99. + 02 MM pic 99. + 02 DD pic 99. + + 01 minus10 pic s99 value -10. + + 01 forced_date_n pic X(64) VALUE Z"COB_CURRENT_DATE". + 01 forced_date_v pic X(64) VALUE Z"1945/06/01 12:34:56". + + procedure division. + CALL "setenv" using forced_date_n, forced_date_v + + move "SECONDS-PAST-MIDNIGHT" to checking + move "45296" to should-be + MOVE FUNCTION SECONDS-PAST-MIDNIGHT to but-is-integer_part + move but-is-integer_part to but-is + perform checkit + + *> Establish the initial date integer + move "integer-of-date" to checking + move function integer-of-date(19000101) to jd1601 + move "integer-of-date(19000101)" to checking + move 0109208 to should-be + move jd1601 to but-is + perform checkit + + *> Establish the final date integer + move "integer-of-date" to checking + move function integer-of-date(21011231) to jd9999 + move "integer-of-date(21001231)" to checking + move 0182986 to should-be + move jd9999 to but-is + perform checkit + + *> We are going to do the following tests over all valid dates: + perform varying jd from jd1601 by 1 until jd > jd9999 + + *> Convert JD to all six DATE types: + move FUNCTION FORMATTED-DATE("YYYYMMDD" jd) TO date1 + move FUNCTION FORMATTED-DATE("YYYY-MM-DD" jd) TO date2 + move FUNCTION FORMATTED-DATE("YYYYDDD" jd) TO date3 + move FUNCTION FORMATTED-DATE("YYYY-DDD" jd) TO date4 + move FUNCTION FORMATTED-DATE("YYYYWwwD" jd) TO date5 + move FUNCTION FORMATTED-DATE("YYYY-Www-D" jd) TO date6 + + *> Test the routines that check DATE types + move zero to should-be + move FUNCTION TEST-FORMATTED-DATETIME("YYYYMMDD" date1) TO but-is + move "TEST-FORMATTED-DATETIME(""YYYYMMDD"" date1)" to checking + perform checkit + move FUNCTION TEST-FORMATTED-DATETIME("YYYY-MM-DD" date2) TO but-is + move "TEST-FORMATTED-DATETIME(""YYYY-MM-DD"" date2)" to checking + perform checkit + move FUNCTION TEST-FORMATTED-DATETIME("YYYYDDD" date3) TO but-is + move "TEST-FORMATTED-DATETIME(""YYYYDDD"" date3)" to checking + perform checkit + move FUNCTION TEST-FORMATTED-DATETIME("YYYY-DDD" date4) TO but-is + move "TEST-FORMATTED-DATETIME(""YYYY-DDD"" date4)" to checking + perform checkit + move FUNCTION TEST-FORMATTED-DATETIME("YYYYWwwD" date5) TO but-is + move "TEST-FORMATTED-DATETIME(""YYYYWwwD"" date5)" to checking + perform checkit + move FUNCTION TEST-FORMATTED-DATETIME("YYYY-Www-D" date6) TO but-is + move "TEST-FORMATTED-DATETIME(""YYYY-Www-D"" date6)" to checking + perform checkit + + *> Test the routines that extract the integer date + + move function INTEGER-OF-FORMATTED-DATE("YYYYMMDD" date1) TO integer-date + move "INTEGER-OF-FORMATTED-DATE(""YYYYMMDD"" date1)" to checking + move jd to should-be + move integer-date to but-is + perform checkit + + move function INTEGER-OF-FORMATTED-DATE("YYYY-MM-DD" date2) TO integer-date + move "INTEGER-OF-FORMATTED-DATE(""YYYY-MM-DD"" date2)" to checking + move jd to should-be + move integer-date to but-is + perform checkit + + move function INTEGER-OF-FORMATTED-DATE("YYYYDDD" date3) TO integer-date + move "INTEGER-OF-FORMATTED-DATE(""YYYYDDD"" date3)" to checking + move jd to should-be + move integer-date to but-is + perform checkit + + move function INTEGER-OF-FORMATTED-DATE("YYYY-DDD" date4) TO integer-date + move "INTEGER-OF-FORMATTED-DATE(""YYYY-DDD"" date4)" to checking + move jd to should-be + move integer-date to but-is + perform checkit + + move function INTEGER-OF-FORMATTED-DATE("YYYYWwwD" date5) TO integer-date + move "INTEGER-OF-FORMATTED-DATE(""YYYYWwwD"" date5)" to checking + move jd to should-be + move integer-date to but-is + perform checkit + + move function INTEGER-OF-FORMATTED-DATE("YYYY-Www-D" date6) TO integer-date + move "INTEGER-OF-FORMATTED-DATE(""YYYY-Www-D"" date6)" to checking + move jd to should-be + move integer-date to but-is + perform checkit + + move function DATE-OF-INTEGER(jd) to standard-date-form + move function INTEGER-OF-DATE(standard-date-form) to integer-date + move "DATE-OF-INTEGER and INTEGER-OF-DATE" to checking + move jd to should-be + move integer-date to but-is + perform checkit + + move function TEST-DATE-YYYYMMDD(standard-date-form) to integer-result + move "TEST-DATE-YYYYMMDD" to checking + move zero to should-be + move integer-result to but-is + perform checkit + + move function DAY-OF-INTEGER(jd) to julian-date-form + move function INTEGER-OF-DAY(julian-date-form) to integer-date + move "DAY-OF-INTEGER and INTEGER-OF-DAY" to checking + move jd to should-be + move integer-date to but-is + perform checkit + + move function TEST-DAY-YYYYDDD(julian-date-form) to integer-result + move "TEST-DAY-YYYYDDD" to checking + move zero to should-be + move integer-result to but-is + perform checkit + end-perform. + + move function integer-of-date(19980101) to jd1601 + move function integer-of-date(19981231) to jd9999 + perform varying jd from jd1601 by 1 until jd > jd9999 + move FUNCTION FORMATTED-DATE("YYYYMMDD" jd) TO date1 + move FUNCTION FORMATTED-DATE("YYYYDDD" jd) TO date3 + + move FUNCTION MOD( YYYY of date1 100) to yy of yymmdd + move MM of date1 to MM of yymmdd + move DD of date1 to DD of yymmdd + + move FUNCTION DATE-TO-YYYYMMDD(yymmdd, minus10, 1994) + to standard-date-form + move "DATE-TO-YYYYMMDD" to checking + move "18" to date1(1:2) + move date1 to should-be + move standard-date-form to but-is + perform checkit + end-perform. + + move "DAY-TO-YYYYDDD" to checking + MOVE 1910004 to should-be + MOVE FUNCTION DAY-TO-YYYYDDD(10004 -20 2002) TO but-is + perform checkit + MOVE 1810004 to should-be + MOVE FUNCTION DAY-TO-YYYYDDD(10004 -120 2002) TO but-is + perform checkit + MOVE 2010004 to should-be + MOVE FUNCTION DAY-TO-YYYYDDD(10004 20 2002) TO but-is + perform checkit + MOVE 1995005 to should-be + MOVE FUNCTION DAY-TO-YYYYDDD(95005 -10 2013) TO but-is + perform checkit + + move "COMBINED-DATETIME" to checking + MOVE "19450601.123456" TO should-be + MOVE FUNCTION COMBINED-DATETIME(19450601 123456) TO but-is-n + perform checkit + + move "CURRENT_DATE" to checking + MOVE "1945060112345600+0000" TO should-be + MOVE FUNCTION CURRENT-DATE TO but-is + move "+0000" to but-is(17:5) + perform checkit + + move "FORMATTED-CURRENT-DATE (1)" to checking + MOVE "1945-06-01T12:34:56" TO should-be + MOVE FUNCTION FORMATTED-CURRENT-DATE("YYYY-MM-DDThh:mm:ss") TO but-is + perform blot-zulu + perform checkit + + move "FORMATTED-CURRENT-DATE (2)" to checking + MOVE "1945-06-01T12:34:56Z" TO should-be + MOVE FUNCTION FORMATTED-CURRENT-DATE("YYYY-MM-DDThh:mm:ssZ") TO but-is + perform blot-zulu + perform checkit + + move "FORMATTED-CURRENT-DATE (3)" to checking + MOVE "1945-06-01T12:34:56-05:00" TO should-be + MOVE FUNCTION FORMATTED-CURRENT-DATE("YYYY-MM-DDThh:mm:ss+hh:mm") TO but-is + perform blot-zulu + perform checkit + + move "formatted-time" to checking + move "01:12:34Z" to should-be + MOVE FUNCTION formatted-time("hh:mm:ssZ" 754 -60 ) to but-is + perform checkit. + + move "00:12:34Z" to should-be + MOVE FUNCTION formatted-time("hh:mm:ssZ" 754 0 ) to but-is + perform checkit. + + move "23:12:34Z" to should-be + MOVE FUNCTION formatted-time("hh:mm:ssZ" 754 60 ) to but-is + perform checkit. + + move "formatted-datetime" to checking + MOVE "1900-01-01T00:00:00-01:00" TO SHOULD-BE + MOVE FUNCTION formatted-datetime("YYYY-MM-DDThh:mm:ss+hh:mm" 0109208 0 -60 ) TO but-is + perform checkit. + + MOVE "1900-01-01T00:00:00+00:00" TO SHOULD-BE + MOVE FUNCTION formatted-datetime("YYYY-MM-DDThh:mm:ss+hh:mm" 0109208 0 -0 ) TO but-is + perform checkit. + + MOVE "1900-01-01T00:00:00+01:00" TO SHOULD-BE + MOVE FUNCTION formatted-datetime("YYYY-MM-DDThh:mm:ss+hh:mm" 0109208 0 +60 ) TO but-is + perform checkit. + + move "SECONDS-FROM-FORMATTED-TIME" to checking + MOVE "00043200.000000" TO SHOULD-BE + MOVE SPACE TO but-is + MOVE FUNCTION SECONDS-FROM-FORMATTED-TIME("hh:mm:ss" "12:00:00") TO but-is-n + perform checkit. + + stop run. + + checkit. + *> display "checkit " """" should-be """" space """" but-is """" + if FUNCTION TRIM(should-be) IS NUMERIC AND FUNCTION TRIM(but-is) IS NUMERIC + if FUNCTION NUMVAL(should-be) + not equal to FUNCTION NUMVAL(but-is) + and should-be not equal to but-is + then + display function trim (checking) ":" + " should be " """" function trim (should-be) """" + " but is " """" function trim (but-is) """" + move 1 to return-code + end-if + else + if should-be not equal to but-is + and should-be not equal to but-is + then + display function trim (checking) ":" + " should be " """" function trim (should-be) """" + " but is " """" function trim (but-is) """" + move 1 to return-code + end-if + . + blot-zulu. + move "hh:mm" TO but-is(12:5) + move "hh:mm" TO should-be(12:5) + if but-is(21:1) not equal to space + move "+hh:mm" TO but-is(20:6) + move "+hh:mm" TO should-be(20:6) + end-if + . + end program test. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_DAY-OF-INTEGER.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_DAY-OF-INTEGER.cob new file mode 100644 index 0000000..df70a82 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_DAY-OF-INTEGER.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(09)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION DAY-OF-INTEGER ( 146000 ) + TO TEST-FLD. + IF TEST-FLD NOT = 2000269 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_DAY-TO-YYYYDDD.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_DAY-TO-YYYYDDD.cob new file mode 100644 index 0000000..5316a70 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_DAY-TO-YYYYDDD.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(09)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION DAY-TO-YYYYDDD ( 95005, -10, 2013 ) + TO TEST-FLD. + IF TEST-FLD NOT = 001995005 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_E.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_E.cob new file mode 100644 index 0000000..e07edf0 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_E.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC 9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION E TO Y. + IF Y NOT = 2.718281828459045235360287471352662 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-FILE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-FILE.cob new file mode 100644 index 0000000..e822708 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-FILE.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_EXCEPTION-FILE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT TEST-FILE ASSIGN "NOTEXIST" + FILE STATUS IS TEST-STATUS. + DATA DIVISION. + FILE SECTION. + FD TEST-FILE. + 01 TEST-REC PIC X(4). + WORKING-STORAGE SECTION. + 01 TEST-STATUS PIC XX. + PROCEDURE DIVISION. + DISPLAY FUNCTION EXCEPTION-FILE '|' + NO ADVANCING + END-DISPLAY. + OPEN INPUT TEST-FILE. + DISPLAY FUNCTION EXCEPTION-FILE + NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-FILE.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-FILE.out new file mode 100644 index 0000000..ece5467 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-FILE.out @@ -0,0 +1 @@ +00|35TEST-FILE diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATEMENT.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATEMENT.cob new file mode 100644 index 0000000..d68261d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATEMENT.cob @@ -0,0 +1,24 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_EXCEPTION-STATEMENT.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT TEST-FILE ASSIGN "NOTEXIST" + FILE STATUS IS TEST-STATUS. + DATA DIVISION. + FILE SECTION. + FD TEST-FILE. + 01 TEST-REC PIC X(4). + WORKING-STORAGE SECTION. + 01 TEST-STATUS PIC XX. + PROCEDURE DIVISION. + DISPLAY "EXCEPTION-STATEMENT before bad OPEN: " + """" FUNCTION EXCEPTION-STATEMENT """" + OPEN INPUT TEST-FILE. + DISPLAY "EXCEPTION-STATEMENT after bad OPEN: " + """" FUNCTION EXCEPTION-STATEMENT """" + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATEMENT.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATEMENT.out new file mode 100644 index 0000000..5656102 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATEMENT.out @@ -0,0 +1,3 @@ +EXCEPTION-STATEMENT before bad OPEN: " " +EXCEPTION-STATEMENT after bad OPEN: "OPEN" + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATUS.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATUS.cob new file mode 100644 index 0000000..1ffa366 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATUS.cob @@ -0,0 +1,24 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_EXCEPTION-STATUS.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT TEST-FILE ASSIGN "NOTEXIST" + FILE STATUS IS TEST-STATUS. + DATA DIVISION. + FILE SECTION. + FD TEST-FILE. + 01 TEST-REC PIC X(4). + WORKING-STORAGE SECTION. + 01 TEST-STATUS PIC XX. + PROCEDURE DIVISION. + DISPLAY "EXCEPTION STATUS before bad open: " + """" FUNCTION EXCEPTION-STATUS """" + OPEN INPUT TEST-FILE. + DISPLAY "EXCEPTION STATUS after bad open: " + """" FUNCTION EXCEPTION-STATUS """" + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATUS.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATUS.out new file mode 100644 index 0000000..02b4f84 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXCEPTION-STATUS.out @@ -0,0 +1,3 @@ +EXCEPTION STATUS before bad open: " " +EXCEPTION STATUS after bad open: "EC-I-O-PERMANENT-ERROR" + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_EXP.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXP.cob new file mode 100644 index 0000000..756612c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXP.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S99V9(31). + PROCEDURE DIVISION. + MOVE FUNCTION EXP ( 3 ) TO Y. + IF Y NOT = 20.0855369231876677409285296545817 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_EXP10.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXP10.cob new file mode 100644 index 0000000..a76fcfb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_EXP10.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(09)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION EXP10 ( 4 ) + TO TEST-FLD. + IF TEST-FLD NOT = 000010000 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FACTORIAL.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_FACTORIAL.cob new file mode 100644 index 0000000..969663c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FACTORIAL.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(09)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION FACTORIAL ( 6 ) + TO TEST-FLD. + IF TEST-FLD NOT = 000000720 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE.cob new file mode 100644 index 0000000..cde5644 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE.cob @@ -0,0 +1,54 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(10). + PROCEDURE DIVISION. + *> Test normal inputs. + MOVE FUNCTION FORMATTED-DATE ( "YYYYMMDD", 1 ) TO str + IF str <> "16010101" + DISPLAY "Test 1 failed: " str END-DISPLAY + END-IF + + MOVE FUNCTION FORMATTED-DATE ( "YYYY-MM-DD", 1 ) TO str + IF str <> "1601-01-01" + DISPLAY "Test 2 failed: " str END-DISPLAY + END-IF + + MOVE FUNCTION FORMATTED-DATE ( "YYYYDDD", 1 ) TO str + IF str <> "1601001" + DISPLAY "Test 3 failed: " str END-DISPLAY + END-IF + + MOVE FUNCTION FORMATTED-DATE ( "YYYY-DDD", 1 ) TO str + IF str <> "1601-001" + DISPLAY "Test 4 failed: " str END-DISPLAY + END-IF + + MOVE FUNCTION FORMATTED-DATE ( "YYYYWwwD", 1 ) TO str + IF str <> "1601W011" + DISPLAY "Test 5 failed: " str END-DISPLAY + END-IF + + MOVE FUNCTION FORMATTED-DATE ( "YYYY-Www-D", 1 ) TO str + IF str <> "1601-W01-1" + DISPLAY "Test 6 failed: " str END-DISPLAY + END-IF + + *> Test week number edge cases. + *> For 2012-01-01. + MOVE FUNCTION FORMATTED-DATE ( "YYYYWwwD", 150115 ) TO str + IF str <> "2011W527" + DISPLAY "Test 7 failed: " str END-DISPLAY + END-IF + + *> and for 2013-12-30. + MOVE FUNCTION FORMATTED-DATE ( "YYYYWwwD", 150844 ) TO str + IF str <> "2014W011" + DISPLAY "Test 8 failed: " str END-DISPLAY + END-IF + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATETIME.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATETIME.cob new file mode 100644 index 0000000..47654cb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATETIME.cob @@ -0,0 +1,48 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(40). + PROCEDURE DIVISION. + *> Test normal inputs. + MOVE FUNCTION FORMATTED-DATETIME + ("YYYYMMDDThhmmss", 1, 45296) + TO str + IF str <> "16010101T123456" + DISPLAY "Test 1 failed: " str END-DISPLAY + END-IF + + MOVE FUNCTION FORMATTED-DATETIME + ("YYYY-MM-DDThh:mm:ss", 1, 45296) + TO str + IF str <> "1601-01-01T12:34:56" + DISPLAY "Test 2 failed: " str END-DISPLAY + END-IF + + MOVE FUNCTION FORMATTED-DATETIME + ("YYYYDDDThhmmss+hhmm", 1, 45296, -754) + TO str + IF str <> "1601001T123456-1234" + DISPLAY "Test 3 failed: " str END-DISPLAY + END-IF + + MOVE FUNCTION FORMATTED-DATETIME + ("YYYYDDDThhmmss+hhmm", 1, 45296) + TO str + IF str <> "1601001T123456+0000" + DISPLAY "Test 4 failed: " str END-DISPLAY + END-IF + + *> Test underflow to next day due to offset + MOVE FUNCTION FORMATTED-DATETIME + ("YYYYDDDThhmmss.sssssssssZ", 150846, 0, + 1) + TO str + IF str <> "2013365T235900.000000000Z" + DISPLAY "Test 5 failed: " str END-DISPLAY + END-IF + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATETIME_with_ref_modding.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATETIME_with_ref_modding.cob new file mode 100644 index 0000000..c440755 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATETIME_with_ref_modding.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(04). + PROCEDURE DIVISION. + MOVE FUNCTION FORMATTED-DATETIME + ("YYYYMMDDThhmmss", 1, 1) (3:4) + TO STR + IF STR NOT = '0101' + DISPLAY STR + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE_TIME_DATETIME.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE_TIME_DATETIME.cob new file mode 100644 index 0000000..c495e0d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE_TIME_DATETIME.cob @@ -0,0 +1,69 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_FORMATTED-DATE_TIME_DATETIME.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. datetime. + PROCEDURE DIVISION. + DISPLAY "FUNCTION FORMATTED-DATETIME - valid format strings" + DISPLAY " FORMATTED-DATE Basic" + DISPLAY FUNCTION FORMATTED-DATE("YYYYMMDD" 128623). + DISPLAY FUNCTION FORMATTED-DATE("YYYYDDD" 128623). + DISPLAY FUNCTION FORMATTED-DATE("YYYYWwwD" 128623). + DISPLAY " FORMATTED-DATE Extended" + DISPLAY FUNCTION FORMATTED-DATE("YYYY-MM-DD" 128623). + DISPLAY FUNCTION FORMATTED-DATE("YYYY-DDD" 128623). + DISPLAY FUNCTION FORMATTED-DATE("YYYY-Www-D" 128623). + DISPLAY " FORMATTED-TIME Basic" + DISPLAY FUNCTION FORMATTED-TIME("hhmmss" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hhmmss+hhmm" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hhmmss.ssss" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hhmmss.ssss+hhmm" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hhmmss.ssssZ" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hhmmssZ" 45296.987654321 -300). + DISPLAY " FORMATTED-TIME Extended" + DISPLAY FUNCTION FORMATTED-TIME("hh:mm:ss" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hh:mm:ss+hh:mm" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hh:mm:ss.ssss" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hh:mm:ss.ssss+hh:mm" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hh:mm:ss.ssssZ" 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-TIME("hh:mm:ssZ" 45296.987654321 -300). + DISPLAY " FORMATTED-DATETIME Basic" + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYMMDDThhmmss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYMMDDThhmmss+hhmm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYMMDDThhmmss.ssss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYMMDDThhmmss.ssss+hhmm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYMMDDThhmmss.ssssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYMMDDThhmmssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYDDDThhmmss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYDDDThhmmss+hhmm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYDDDThhmmss.ssss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYDDDThhmmss.ssss+hhmm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYDDDThhmmss.ssssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYDDDThhmmssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYWwwDThhmmss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYWwwDThhmmss+hhmm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYWwwDThhmmss.ssss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYWwwDThhmmss.ssss+hhmm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYWwwDThhmmss.ssssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYYWwwDThhmmssZ" 128623 45296.987654321 -300). + DISPLAY " FORMATTED-DATETIME Extended" + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-MM-DDThh:mm:ss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-MM-DDThh:mm:ss+hh:mm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-MM-DDThh:mm:ss.ssss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-MM-DDThh:mm:ss.ssss+hh:mm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-MM-DDThh:mm:ss.ssssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-MM-DDThh:mm:ssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-DDDThh:mm:ss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-DDDThh:mm:ss+hh:mm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-DDDThh:mm:ss.ssss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-DDDThh:mm:ss.ssss+hh:mm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-DDDThh:mm:ss.ssssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-DDDThh:mm:ssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-Www-DThh:mm:ss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-Www-DThh:mm:ss+hh:mm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-Www-DThh:mm:ss.ssss" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-Www-DThh:mm:ss.ssss+hh:mm" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-Www-DThh:mm:ss.ssssZ" 128623 45296.987654321 -300). + DISPLAY FUNCTION FORMATTED-DATETIME("YYYY-Www-DThh:mm:ssZ" 128623 45296.987654321 -300). + END PROGRAM datetime. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE_TIME_DATETIME.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE_TIME_DATETIME.out new file mode 100644 index 0000000..5395f4e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE_TIME_DATETIME.out @@ -0,0 +1,62 @@ +FUNCTION FORMATTED-DATETIME - valid format strings + FORMATTED-DATE Basic +19530227 +1953058 +1953W095 + FORMATTED-DATE Extended +1953-02-27 +1953-058 +1953-W09-5 + FORMATTED-TIME Basic +123456 +123456-0500 +123456.9876 +123456.9876-0500 +173456.0000Z +173456Z + FORMATTED-TIME Extended +12:34:56 +12:34:56-05:00 +12:34:56.9876 +12:34:56.9876-05:00 +17:34:56.0000Z +17:34:56Z + FORMATTED-DATETIME Basic +19530227T123456 +19530227T123456-0500 +19530227T123456.9876 +19530227T123456.9876-0500 +19530227T173456.0000Z +19530227T173456Z +1953058T123456 +1953058T123456-0500 +1953058T123456.9876 +1953058T123456.9876-0500 +1953058T173456.0000Z +1953058T173456Z +1953W095T123456 +1953W095T123456-0500 +1953W095T123456.9876 +1953W095T123456.9876-0500 +1953W095T173456.0000Z +1953W095T173456Z + FORMATTED-DATETIME Extended +1953-02-27T12:34:56 +1953-02-27T12:34:56-05:00 +1953-02-27T12:34:56.9876 +1953-02-27T12:34:56.9876-05:00 +1953-02-27T17:34:56.0000Z +1953-02-27T17:34:56Z +1953-058T12:34:56 +1953-058T12:34:56-05:00 +1953-058T12:34:56.9876 +1953-058T12:34:56.9876-05:00 +1953-058T17:34:56.0000Z +1953-058T17:34:56Z +1953-W09-5T12:34:56 +1953-W09-5T12:34:56-05:00 +1953-W09-5T12:34:56.9876 +1953-W09-5T12:34:56.9876-05:00 +1953-W09-5T17:34:56.0000Z +1953-W09-5T17:34:56Z + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE_with_ref_modding.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE_with_ref_modding.cob new file mode 100644 index 0000000..ac5c828 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-DATE_with_ref_modding.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(04). + PROCEDURE DIVISION. + MOVE FUNCTION FORMATTED-DATE ("YYYYMMDD", 1) (3:4) + TO STR + IF STR NOT = '0101' + DISPLAY STR + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-TIME_DP.COMMA.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-TIME_DP.COMMA.cob new file mode 100644 index 0000000..1abd625 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-TIME_DP.COMMA.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(11). + + PROCEDURE DIVISION. + MOVE FUNCTION FORMATTED-TIME ("hh:mm:ss,ss", 45296) TO str + IF str <> "12:34:56,00" + DISPLAY "Test 1 failed: " str END-DISPLAY + END-IF + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-TIME_with_ref_modding.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-TIME_with_ref_modding.cob new file mode 100644 index 0000000..cfcf0c7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FORMATTED-TIME_with_ref_modding.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(04). + PROCEDURE DIVISION. + MOVE FUNCTION FORMATTED-TIME ("hhmmss", 45296) (3:4) + TO STR + IF STR NOT = '3456' + DISPLAY STR + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_FRACTION-PART.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_FRACTION-PART.cob new file mode 100644 index 0000000..65f341b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_FRACTION-PART.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(04)V9(04). + PROCEDURE DIVISION. + MOVE FUNCTION FRACTION-PART ( 3.12345 ) + TO TEST-FLD. + IF TEST-FLD NOT = +0000.1234 + DISPLAY 'FRACTION-PART ( +3.12345 ) wrong: ' TEST-FLD + END-DISPLAY + END-IF. + MOVE FUNCTION FRACTION-PART ( -3.12345 ) + TO TEST-FLD. + IF TEST-FLD NOT = -0000.1234 + DISPLAY 'FRACTION-PART ( -3.12345 ) wrong: ' TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_HEX-OF.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_HEX-OF.cob new file mode 100644 index 0000000..ed31eb6 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_HEX-OF.cob @@ -0,0 +1,13 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_HEX-OF.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 PAC PIC 9(5) COMP-3 VALUE 12345. + PROCEDURE DIVISION. + DISPLAY FUNCTION HEX-OF('Hello, world!') + DISPLAY FUNCTION HEX-OF(PAC). + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_HEX-OF.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_HEX-OF.out new file mode 100644 index 0000000..40892ac --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_HEX-OF.out @@ -0,0 +1,3 @@ +48656C6C6F2C20776F726C6421 +12345F + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_HIGHEST-ALGEBRAIC.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_HIGHEST-ALGEBRAIC.cob new file mode 100644 index 0000000..2e59df3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_HIGHEST-ALGEBRAIC.cob @@ -0,0 +1,76 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 F1 PIC S999. + 01 F2 PIC S9(4) BINARY. + 01 F3 PIC 99V9(3). + 01 F4 PIC $**,**9.99BCR. + 01 F5 PIC $**,**9.99. + 01 F6 USAGE BINARY-CHAR SIGNED. + 01 F7 USAGE BINARY-CHAR UNSIGNED. + 01 F8 PIC 999PPP. + 01 F9 PIC P99. + 01 TEST-FLD PIC S9(08)V9(04). + PROCEDURE DIVISION. + MOVE FUNCTION HIGHEST-ALGEBRAIC (F1) + TO TEST-FLD. + IF TEST-FLD NOT = 999 + DISPLAY "Test 1 fail: " TEST-FLD + END-DISPLAY + END-IF. + MOVE FUNCTION HIGHEST-ALGEBRAIC (F2) + TO TEST-FLD. + IF TEST-FLD NOT = 9999 + DISPLAY "Test 2 fail: " TEST-FLD + END-DISPLAY + END-IF. + MOVE FUNCTION HIGHEST-ALGEBRAIC (F3) + TO TEST-FLD. + IF TEST-FLD NOT = 99.999 + DISPLAY "Test 3 fail: " TEST-FLD + END-DISPLAY + END-IF. + MOVE FUNCTION HIGHEST-ALGEBRAIC (F4) + TO TEST-FLD. + IF TEST-FLD NOT = 99999.99 + DISPLAY "Test 4 fail: " TEST-FLD + END-DISPLAY + END-IF. + MOVE FUNCTION HIGHEST-ALGEBRAIC (F5) + TO TEST-FLD. + IF TEST-FLD NOT = 99999.99 + DISPLAY "Test 5 fail: " TEST-FLD + END-DISPLAY + END-IF. + MOVE FUNCTION HIGHEST-ALGEBRAIC (F6) + TO TEST-FLD. + IF TEST-FLD NOT = 127 + DISPLAY "Test 6 fail: " TEST-FLD + END-DISPLAY + END-IF. + MOVE FUNCTION HIGHEST-ALGEBRAIC (F7) + TO TEST-FLD. + IF TEST-FLD NOT = 255 + DISPLAY "Test 7 fail: " TEST-FLD + END-DISPLAY + END-IF. + + MOVE FUNCTION HIGHEST-ALGEBRAIC (F8) + TO TEST-FLD. + IF TEST-FLD NOT = 999000 + DISPLAY "Test 7 fail: " TEST-FLD + END-DISPLAY + END-IF. + + MOVE FUNCTION HIGHEST-ALGEBRAIC (F9) + TO TEST-FLD. + IF TEST-FLD NOT = 0.099 + DISPLAY "Test 7 fail: " TEST-FLD + END-DISPLAY + END-IF. + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-OF-DATE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-OF-DATE.cob new file mode 100644 index 0000000..4632864 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-OF-DATE.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(09)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION INTEGER-OF-DATE ( 20000925 ) + TO TEST-FLD. + IF TEST-FLD NOT = 000146000 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-OF-DAY.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-OF-DAY.cob new file mode 100644 index 0000000..38162bf --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-OF-DAY.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-FLD PIC S9(09)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION INTEGER-OF-DAY ( 2000269 ) + TO TEST-FLD. + IF TEST-FLD NOT = 000146000 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-OF-FORMATTED-DATE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-OF-FORMATTED-DATE.cob new file mode 100644 index 0000000..d580ea8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-OF-FORMATTED-DATE.cob @@ -0,0 +1,41 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 day-int PIC 9(9). + + PROCEDURE DIVISION. + *> The date 2013-12-30 is used as it can also be used to + *> check the conversion of dates in week form. + MOVE FUNCTION INTEGER-OF-FORMATTED-DATE + ("YYYY-MM-DD", "2013-12-30") + TO day-int + IF day-int <> 150844 + DISPLAY "Test 1 failed: " day-int END-DISPLAY + END-IF + + MOVE FUNCTION INTEGER-OF-FORMATTED-DATE + ("YYYY-DDD", "2013-364") + TO day-int + IF day-int <> 150844 + DISPLAY "Test 2 failed: " day-int END-DISPLAY + END-IF + + MOVE FUNCTION INTEGER-OF-FORMATTED-DATE + ("YYYY-Www-D", "2014-W01-1") + TO day-int + IF day-int <> 150844 + DISPLAY "Test 3 failed: " day-int END-DISPLAY + END-IF + + MOVE FUNCTION INTEGER-OF-FORMATTED-DATE + ("YYYY-MM-DDThh:mm:ss", "2013-12-30T12:34:56") + TO day-int + IF day-int <> 150844 + DISPLAY "Test 4 failed: " day-int END-DISPLAY + END-IF + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-PART.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-PART.cob new file mode 100644 index 0000000..cc97765 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER-PART.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC S9(4)V9(4) VALUE -1.5. + 01 TEST-FLD PIC S9(04)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION INTEGER-PART ( X ) + TO TEST-FLD. + IF TEST-FLD NOT = -1 + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER.cob new file mode 100644 index 0000000..d43dd08 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_INTEGER.cob @@ -0,0 +1,24 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC S9(4)V9(4) VALUE -1.5. + 01 Y PIC 9(12) VALUE 600851475143. + 01 TEST-FLD PIC S9(14)V9(08). + PROCEDURE DIVISION. + MOVE FUNCTION INTEGER ( X ) + TO TEST-FLD. + IF TEST-FLD NOT = -2 + DISPLAY 'INTEGER ( X ) wrong: ' TEST-FLD + END-DISPLAY + END-IF. + MOVE FUNCTION INTEGER ( Y / 71 ) + TO TEST-FLD. + IF TEST-FLD NOT = 8462696833 + DISPLAY 'INTEGER ( Y / 71 ) wrong: ' TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LENGTH__1_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LENGTH__1_.cob new file mode 100644 index 0000000..8bbf689 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LENGTH__1_.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC S9(4)V9(4) VALUE -1.5. + 01 TEST-FLD PIC S9(04)V9(02). + PROCEDURE DIVISION. + MOVE FUNCTION LENGTH ( X ) TO TEST-FLD + IF TEST-FLD NOT = 8 + DISPLAY 'LENGTH "00128" wrong: ' TEST-FLD + END-DISPLAY + END-IF + + MOVE FUNCTION LENGTH ( '00128' ) + TO TEST-FLD + IF TEST-FLD NOT = 5 + DISPLAY 'LENGTH "00128" wrong: ' TEST-FLD + END-DISPLAY + END-IF + + MOVE FUNCTION LENGTH ( x'a0' ) + TO TEST-FLD + IF TEST-FLD NOT = 1 + DISPLAY 'LENGTH x"a0" wrong: ' TEST-FLD + END-DISPLAY + END-IF + + MOVE FUNCTION LENGTH ( z'a0' ) + TO TEST-FLD + IF TEST-FLD NOT = 3 + DISPLAY 'LENGTH z"a0" wrong: ' TEST-FLD + END-DISPLAY + END-IF + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LENGTH__2_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LENGTH__2_.cob new file mode 100644 index 0000000..9416ca0 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LENGTH__2_.cob @@ -0,0 +1,139 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + *> { dg-output-file "group2/FUNCTION_LENGTH__2_.out" } + program-id. prog. + data division. + working-storage section. + 01 desc1. + 05 desc1-entry pic x(5) occurs 10. + + 01 desc2. + 05 desc2-table occurs 10 times. + 10 desc2-entry pic x(5). + + 01 desc3. + 05 desc3-outer occurs 1 to 5 times depending on desc3-lim. + 10 desc3-outer-txt pic x(7). + 10 desc3-inner occurs 11 times. + 15 desc3-inner-text pic x(13). + 77 desc3-lim binary-long. + + 77 msg pic x(64). + 77 should-be pic zzzz9. + 77 but-is pic zzzz9. + + procedure division. + + display "using FUNCTION LENGTH" + + move "function length(desc1)" to msg + move 50 to should-be + move function length(desc1) to but-is + perform result-is + + move "function length(desc1-entry)" to msg + move 50 to should-be + move function length(desc1-entry) to but-is + perform result-is + + move "function length(desc1-entry(1))" to msg + move 5 to should-be + move function length(desc1-entry(1)) to but-is + perform result-is + + move "function length(desc2)" to msg + move 50 to should-be + move function length(desc2) to but-is + perform result-is + + move "function length(desc2-table)" to msg + move 50 to should-be + move function length(desc2-table) to but-is + perform result-is + + move "function length(desc2-entry)" to msg + move 5 to should-be + move function length(desc2-entry) to but-is + perform result-is + + move "function length(desc2-entry(1))" to msg + move 5 to should-be + move function length(desc2-entry(1)) to but-is + perform result-is + + move 5 to desc3-lim + + move "function length(desc3)" to msg + move 750 to should-be + move function length(desc3) to but-is + perform result-is + + move "function length(desc3-outer)" to msg + move 750 to should-be + move function length(desc3-outer) to but-is + perform result-is + + move "function length(desc3-outer(1))" to msg + move 150 to should-be + move function length(desc3-outer(1)) to but-is + perform result-is + + move "function length(desc3-outer-txt)" to msg + move 7 to should-be + move function length(desc3-outer-txt) to but-is + perform result-is + + move "function length(desc3-inner)" to msg + move 143 to should-be + move function length(desc3-inner) to but-is + perform result-is + + move "function length(desc3-inner(1))" to msg + move 13 to should-be + move function length(desc3-inner(1)) to but-is + perform result-is + + display "After changing desc3-lim from 5 to 3..." + move 3 to desc3-lim + + move "function length(desc3)" to msg + move 450 to should-be + move function length(desc3) to but-is + perform result-is + + move "function length(desc3-outer)" to msg + move 450 to should-be + move function length(desc3-outer) to but-is + perform result-is + + move "function length(desc3-outer(1))" to msg + move 150 to should-be + move function length(desc3-outer(1)) to but-is + perform result-is + + move "function length(desc3-outer-txt)" to msg + move 7 to should-be + move function length(desc3-outer-txt) to but-is + perform result-is + + move "function length(desc3-inner)" to msg + move 143 to should-be + move function length(desc3-inner) to but-is + perform result-is + + move "function length(desc3-inner(1))" to msg + move 13 to should-be + move function length(desc3-inner(1)) to but-is + perform result-is + + goback. + result-is. + display function trim(msg) ": " with no advancing + if but-is equal to should-be + display function trim(but-is) + else + display "should be " function trim(should-be) + " but is " function trim(but-is) + end-if. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LENGTH__2_.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_LENGTH__2_.out new file mode 100644 index 0000000..9d90261 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LENGTH__2_.out @@ -0,0 +1,22 @@ +using FUNCTION LENGTH +function length(desc1): 50 +function length(desc1-entry): 50 +function length(desc1-entry(1)): 5 +function length(desc2): 50 +function length(desc2-table): 50 +function length(desc2-entry): 5 +function length(desc2-entry(1)): 5 +function length(desc3): 750 +function length(desc3-outer): 750 +function length(desc3-outer(1)): 150 +function length(desc3-outer-txt): 7 +function length(desc3-inner): 143 +function length(desc3-inner(1)): 13 +After changing desc3-lim from 5 to 3... +function length(desc3): 450 +function length(desc3-outer): 450 +function length(desc3-outer(1)): 150 +function length(desc3-outer-txt): 7 +function length(desc3-inner): 143 +function length(desc3-inner(1)): 13 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-COMPARE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-COMPARE.cob new file mode 100644 index 0000000..cb6d783 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-COMPARE.cob @@ -0,0 +1,21 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + IF FUNCTION LOCALE-COMPARE ("A", "B") NOT = "<" + DISPLAY "Test 1 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOCALE-COMPARE ("B", "A") NOT = ">" + DISPLAY "Test 2 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOCALE-COMPARE ("A", "A") NOT = "=" + DISPLAY "Test 3 fail" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-DATE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-DATE.cob new file mode 100644 index 0000000..35e0729 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-DATE.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_LOCALE-DATE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(32) VALUE SPACES. + PROCEDURE DIVISION. + MOVE FUNCTION LOCALE-DATE ( "19630302" ) TO X. + IF X NOT = SPACES + DISPLAY "OK" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-DATE.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-DATE.out new file mode 100644 index 0000000..885fd66 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-DATE.out @@ -0,0 +1,2 @@ +OK + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME-FROM-SECONDS.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME-FROM-SECONDS.cob new file mode 100644 index 0000000..d04e7a9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME-FROM-SECONDS.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_LOCALE-TIME-FROM-SECONDS.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(32) VALUE SPACES. + PROCEDURE DIVISION. + MOVE FUNCTION LOCALE-TIME-FROM-SECONDS ( 33012 ) TO X. + IF X NOT = SPACES + DISPLAY "OK" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME-FROM-SECONDS.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME-FROM-SECONDS.out new file mode 100644 index 0000000..885fd66 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME-FROM-SECONDS.out @@ -0,0 +1,2 @@ +OK + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME.cob new file mode 100644 index 0000000..aeba184 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_LOCALE-TIME.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(32) VALUE SPACES. + PROCEDURE DIVISION. + MOVE FUNCTION LOCALE-TIME ( "233012" ) TO X. + IF X NOT = SPACES + DISPLAY "OK" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME.out new file mode 100644 index 0000000..885fd66 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOCALE-TIME.out @@ -0,0 +1,2 @@ +OK + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOG.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOG.cob new file mode 100644 index 0000000..f0ab0e7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOG.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION LOG ( 1.5 ) TO Y. + IF Y NOT = 0.405465108108164381978013115464349 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOG10.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOG10.cob new file mode 100644 index 0000000..e37210b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOG10.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION LOG10 ( 1.5 ) TO Y. + IF Y NOT = 0.176091259055681242081289008530622 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOWER-CASE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOWER-CASE.cob new file mode 100644 index 0000000..4cf24d5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOWER-CASE.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(10) VALUE "A#B.C%D+E$". + 01 TEST-FLD PIC X(12) VALUE ALL '_'. + PROCEDURE DIVISION. + STRING FUNCTION LOWER-CASE ( X ) + DELIMITED BY SIZE + INTO TEST-FLD + END-STRING + IF TEST-FLD NOT = 'a#b.c%d+e$__' + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOWER-CASE_with_reference_modding.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOWER-CASE_with_reference_modding.cob new file mode 100644 index 0000000..eb53ca4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOWER-CASE_with_reference_modding.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(10) VALUE "A#B.C%D+E$". + 01 TEST-FLD PIC X(03). + PROCEDURE DIVISION. + MOVE FUNCTION LOWER-CASE ( X ) (1 : 3) + TO TEST-FLD + IF TEST-FLD NOT = 'a#b' + DISPLAY TEST-FLD + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_LOWEST-ALGEBRAIC.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOWEST-ALGEBRAIC.cob new file mode 100644 index 0000000..4750c7e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_LOWEST-ALGEBRAIC.cob @@ -0,0 +1,55 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 F1 PIC S999. + 01 F2 PIC S9(4) BINARY. + 01 F3 PIC 99V9(3). + 01 F4 PIC $**,**9.99BCR. + 01 F5 PIC $**,**9.99. + 01 F6 USAGE BINARY-CHAR SIGNED. + 01 F7 USAGE BINARY-CHAR UNSIGNED. + 01 F8 PIC S999PPP. + 01 F9 PIC SP99. + PROCEDURE DIVISION. + IF FUNCTION LOWEST-ALGEBRAIC (F1) NOT = -999 + DISPLAY "Test 1 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOWEST-ALGEBRAIC (F2) NOT = -9999 + DISPLAY "Test 2 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOWEST-ALGEBRAIC (F3) NOT = 0 + DISPLAY "Test 3 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOWEST-ALGEBRAIC (F4) NOT = -99999.99 + DISPLAY "Test 4 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOWEST-ALGEBRAIC (F5) NOT = 0 + DISPLAY "Test 5 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOWEST-ALGEBRAIC (F6) NOT = -128 + DISPLAY "Test 6 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOWEST-ALGEBRAIC (F7) NOT = 0 + DISPLAY "Test 7 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOWEST-ALGEBRAIC (F8) NOT = -999000 + DISPLAY "Test 8 fail" + END-DISPLAY + END-IF. + IF FUNCTION LOWEST-ALGEBRAIC (F9) NOT = -0.099 + DISPLAY "Test 9 fail" + END-DISPLAY + END-IF. + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MAX.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_MAX.cob new file mode 100644 index 0000000..99971a9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MAX.cob @@ -0,0 +1,12 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_MAX.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY FUNCTION MAX ( 3 -14 0 8 -3 ) + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MAX.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_MAX.out new file mode 100644 index 0000000..2f95459 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MAX.out @@ -0,0 +1,2 @@ +8 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MEAN.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_MEAN.cob new file mode 100644 index 0000000..007f235 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MEAN.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_MEAN.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 result PIC S999V999. + PROCEDURE DIVISION. + COMPUTE result = FUNCTION MEAN ( 3 -14 0 8 -3 ) + DISPLAY result + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MEAN.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_MEAN.out new file mode 100644 index 0000000..7f05c89 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MEAN.out @@ -0,0 +1,2 @@ +-001.200 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MEDIAN.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_MEDIAN.cob new file mode 100644 index 0000000..ac2515d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MEDIAN.cob @@ -0,0 +1,12 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_MEDIAN.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY FUNCTION MEDIAN ( 3 -14 0 8 -3 ) + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MEDIAN.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_MEDIAN.out new file mode 100644 index 0000000..77ac542 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MEDIAN.out @@ -0,0 +1,2 @@ +0 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MIDRANGE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_MIDRANGE.cob new file mode 100644 index 0000000..601cbc7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MIDRANGE.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_MIDRANGE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 RESULT PIC S999V999. + PROCEDURE DIVISION. + COMPUTE RESULT = FUNCTION MIDRANGE ( 3 -14 0 8 -3 ) + DISPLAY RESULT + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MIDRANGE.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_MIDRANGE.out new file mode 100644 index 0000000..6945d25 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MIDRANGE.out @@ -0,0 +1,2 @@ +-003.000 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MIN.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_MIN.cob new file mode 100644 index 0000000..85ef141 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MIN.cob @@ -0,0 +1,12 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_MIN.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY FUNCTION MIN ( 3 -14 0 8 -3 ) + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MIN.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_MIN.out new file mode 100644 index 0000000..1bd872a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MIN.out @@ -0,0 +1,2 @@ +-14 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MODULE-NAME.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_MODULE-NAME.cob new file mode 100644 index 0000000..cbb445f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MODULE-NAME.cob @@ -0,0 +1,110 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_MODULE-NAME.out" } + + identification division. + program-id. level-1. + data division. + working-storage section. + procedure division. + display "From level-1:" + perform reportt. + call "level-2" + goback. + reportt. + display " " "top-level: " """" function module-name(top-level) """" + display " " "current: " """" function module-name(current) """" + display " " "activating: " """" function module-name(activating) """" + display " " "nested: " """" function module-name(nested) """" + display " " "stack: " """" function module-name(stack) """" + continue. + end program level-1. + + identification division. + program-id. level-2. + data division. + working-storage section. + procedure division. + display "From level-2:" + perform reportt. + call "level-3" + goback. + reportt. + display " " "top-level: " """" function module-name(top-level) """" + display " " "current: " """" function module-name(current) """" + display " " "activating: " """" function module-name(activating) """" + display " " "nested: " """" function module-name(nested) """" + display " " "stack: " """" function module-name(stack) """" + continue. + end program level-2. + + identification division. + program-id. level-3. + data division. + working-storage section. + procedure division. + display "From level-3:" + perform reportt. + call "level-3a" + goback. + reportt. + display " " "top-level: " """" function module-name(top-level) """" + display " " "current: " """" function module-name(current) """" + display " " "activating: " """" function module-name(activating) """" + display " " "nested: " """" function module-name(nested) """" + display " " "stack: " """" function module-name(stack) """" + continue. + + identification division. + program-id. level-3a. + data division. + working-storage section. + procedure division. + display "From level-3a:" + perform reportt. + call "level-3b" + goback. + reportt. + display " " "top-level: " """" function module-name(top-level) """" + display " " "current: " """" function module-name(current) """" + display " " "activating: " """" function module-name(activating) """" + display " " "nested: " """" function module-name(nested) """" + display " " "stack: " """" function module-name(stack) """" + continue. + + identification division. + program-id. level-3b. + data division. + working-storage section. + procedure division. + display "From level-3b:" + perform reportt. + call "level-3c" + goback. + reportt. + display " " "top-level: " """" function module-name(top-level) """" + display " " "current: " """" function module-name(current) """" + display " " "activating: " """" function module-name(activating) """" + display " " "nested: " """" function module-name(nested) """" + display " " "stack: " """" function module-name(stack) """" + continue. + + identification division. + program-id. level-3c. + data division. + working-storage section. + procedure division. + display "From level-3c:" + perform reportt. + goback. + reportt. + display " " "top-level: " """" function module-name(top-level) """" + display " " "current: " """" function module-name(current) """" + display " " "activating: " """" function module-name(activating) """" + display " " "nested: " """" function module-name(nested) """" + display " " "stack: " """" function module-name(stack) """" + continue. + end program level-3c. + end program level-3b. + end program level-3a. + end program level-3. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MODULE-NAME.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_MODULE-NAME.out new file mode 100644 index 0000000..7be80f0 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MODULE-NAME.out @@ -0,0 +1,37 @@ +From level-1: + top-level: "level-1" + current: "level-1" + activating: " " + nested: "level-1" + stack: "level-1; " +From level-2: + top-level: "level-1" + current: "level-2" + activating: "level-1" + nested: "level-2" + stack: "level-2;level-1; " +From level-3: + top-level: "level-1" + current: "level-3" + activating: "level-2" + nested: "level-3" + stack: "level-3;level-2;level-1; " +From level-3a: + top-level: "level-1" + current: "level-3" + activating: "level-3" + nested: "level-3a" + stack: "level-3a;level-3;level-2;level-1; " +From level-3b: + top-level: "level-1" + current: "level-3" + activating: "level-3a" + nested: "level-3b" + stack: "level-3b;level-3a;level-3;level-2;level-1; " +From level-3c: + top-level: "level-1" + current: "level-3" + activating: "level-3b" + nested: "level-3c" + stack: "level-3c;level-3b;level-3a;level-3;level-2;level-1; " + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MOD__invalid_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_MOD__invalid_.cob new file mode 100644 index 0000000..56ecbcd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MOD__invalid_.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC 9 VALUE 0. + 01 R PIC S9(4)V9(4) VALUE 1. + PROCEDURE DIVISION. + MOVE FUNCTION MOD ( -11 Z ) TO R + IF FUNCTION EXCEPTION-STATUS + NOT = 'EC-ARGUMENT-FUNCTION' + DISPLAY 'Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + IF R NOT = 0 + DISPLAY 'result is not zero: ' R + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_MOD__valid_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_MOD__valid_.cob new file mode 100644 index 0000000..0db8679 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_MOD__valid_.cob @@ -0,0 +1,21 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC 9(12) VALUE 600851475143. + 01 R PIC S9(4)V9(4) VALUE 0. + PROCEDURE DIVISION. + MOVE FUNCTION MOD ( -11 5 ) TO R + IF R NOT = 4 + DISPLAY 'first one wrong: ' R + END-DISPLAY + END-IF + MOVE FUNCTION MOD ( Y, 71 ) TO R + IF R NOT = 0 + DISPLAY 'second one wrong: ' R + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-C.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-C.cob new file mode 100644 index 0000000..2eb8eb9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-C.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X1 PIC X(14) VALUE " -% 9876.1234 ". + 01 X2 PIC X(20) VALUE " % 19,876.1234 DB". + 01 N PIC s9(5)v9(5). + PROCEDURE DIVISION. + MOVE FUNCTION NUMVAL-C ( X1 , "%" ) TO N + IF N NOT = -9876.1234 + DISPLAY N + END-DISPLAY + END-IF + MOVE FUNCTION NUMVAL-C ( X2 , "%" ) TO N + IF N NOT = -19876.1234 + DISPLAY N + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-C_DP.COMMA.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-C_DP.COMMA.cob new file mode 100644 index 0000000..bd57463 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-C_DP.COMMA.cob @@ -0,0 +1,21 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA + . + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X1 PIC X(20) VALUE " % 19.876,1234 DB". + 01 N PIC s9(5)v9(5). + PROCEDURE DIVISION. + MOVE FUNCTION NUMVAL-C ( X1 , "%" ) TO N + IF N NOT = -19876,1234 + DISPLAY N + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-F.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-F.cob new file mode 100644 index 0000000..522f810 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-F.cob @@ -0,0 +1,30 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_NUMVAL-F.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 result PIC S9(8)V9(9) COMP-5. + 01 vector. + 05 vd. + 10 FILLER PIC X(32) VALUE " - 123.456 E + 2 ". + 10 FILLER PIC X(32) VALUE "123". + 10 FILLER PIC X(32) VALUE ".456". + 10 FILLER PIC X(32) VALUE "123.456". + 10 FILLER PIC X(32) VALUE "-123.456". + 10 FILLER PIC X(32) VALUE "123.456E2". + 10 FILLER PIC X(32) VALUE "-123.456E-2". + 10 FILLER PIC X(32) VALUE "DONE". + 10 FILLER PIC X(32) OCCURS 100 TIMES. + 05 datat REDEFINES vd PIC X(32) OCCURS 100 TIMES INDEXED BY I. + PROCEDURE DIVISION. + SET I TO 1 + PERFORM UNTIL datat(I) EQUALS "DONE" + DISPLAY """"datat(I)"""" SPACE WITH NO ADVANCING + MOVE FUNCTION NUMVAL-F(datat(I)) TO result + DISPLAY result + ADD 1 TO I + END-PERFORM. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-F.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-F.out new file mode 100644 index 0000000..6d27dd2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL-F.out @@ -0,0 +1,8 @@ +" - 123.456 E + 2 " -00012345.600000000 +"123 " +00000123.000000000 +".456 " +00000000.456000000 +"123.456 " +00000123.456000000 +"-123.456 " -00000123.456000000 +"123.456E2 " +00012345.600000000 +"-123.456E-2 " -00000001.234560000 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL.cob new file mode 100644 index 0000000..9288331 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_NUMVAL.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X1 PIC X(12) VALUE " -9876.1234 ". + 01 X2 PIC X(18) VALUE " 19876.1234 CR". + 01 N PIC s9(5)v9(5). + PROCEDURE DIVISION. + MOVE FUNCTION NUMVAL ( X1 ) TO N + IF N NOT = -9876.1234 + DISPLAY N + END-DISPLAY + END-IF + MOVE FUNCTION NUMVAL ( X2 ) TO N + IF N NOT = -19876.1234 + DISPLAY N + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MAX.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MAX.cob new file mode 100644 index 0000000..0dd1053 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MAX.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_ORD-MAX.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 RESULT PIC 999. + PROCEDURE DIVISION. + MOVE FUNCTION ORD-MAX ( 3 -14 0 8 -3 ) TO RESULT + DISPLAY RESULT + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MAX.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MAX.out new file mode 100644 index 0000000..c9ce4ea --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MAX.out @@ -0,0 +1,2 @@ +004 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MIN.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MIN.cob new file mode 100644 index 0000000..fd55396 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MIN.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_ORD-MIN.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 RESULT PIC 999. + PROCEDURE DIVISION. + MOVE FUNCTION ORD-MIN ( 3 -14 0 8 -3 ) TO RESULT + DISPLAY RESULT + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MIN.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MIN.out new file mode 100644 index 0000000..4119821 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD-MIN.out @@ -0,0 +1,2 @@ +002 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD.cob new file mode 100644 index 0000000..fe5e290 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_ORD.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 RESULT PIC 999. + PROCEDURE DIVISION. + MOVE FUNCTION ORD ( "k" ) TO RESULT + DISPLAY RESULT + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD.out new file mode 100644 index 0000000..e55677a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_ORD.out @@ -0,0 +1,2 @@ +108 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_PI.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_PI.cob new file mode 100644 index 0000000..9792e03 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_PI.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC 9V9(32). + PROCEDURE DIVISION. + MOVE FUNCTION PI TO Y. + IF Y NOT = 3.14159265358979323846264338327950 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_PRESENT-VALUE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_PRESENT-VALUE.cob new file mode 100644 index 0000000..5883abd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_PRESENT-VALUE.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_PRESENT-VALUE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 RESULT PIC 9(5)V9(4). + PROCEDURE DIVISION. + MOVE FUNCTION PRESENT-VALUE ( 3 2 1 ) TO RESULT + DISPLAY RESULT + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_PRESENT-VALUE.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_PRESENT-VALUE.out new file mode 100644 index 0000000..52ce840 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_PRESENT-VALUE.out @@ -0,0 +1,2 @@ +00000.5625 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_RANDOM.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_RANDOM.cob new file mode 100644 index 0000000..0a3e151 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_RANDOM.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S99V99 COMP VALUE -1.0. + PROCEDURE DIVISION. + MOVE FUNCTION RANDOM ( ) TO Y. + IF Y < 0 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_RANGE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_RANGE.cob new file mode 100644 index 0000000..48a9511 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_RANGE.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC S9(4)V9(4) COMP-5. + PROCEDURE DIVISION. + MOVE FUNCTION RANGE ( 3 -14 0 8 -3 ) TO Z. + IF Z NOT = 22 + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_REM__invalid_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_REM__invalid_.cob new file mode 100644 index 0000000..38298a8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_REM__invalid_.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 R PIC S9(4)V9(4) COMP-5 VALUE 4.1. + 01 Z PIC 9 COMP-5 VALUE 0. + PROCEDURE DIVISION. + MOVE FUNCTION REM ( -11 Z ) TO R + IF FUNCTION EXCEPTION-STATUS + NOT = 'EC-ARGUMENT-FUNCTION' + DISPLAY 'Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + IF R NOT = 0 + DISPLAY 'result is not zero: ' R + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_REM__valid_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_REM__valid_.cob new file mode 100644 index 0000000..7ace4a2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_REM__valid_.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 R PIC S9(4)V9(4) COMP-5 VALUE 0. + PROCEDURE DIVISION. + MOVE FUNCTION REM ( -11 5 ) TO R + IF R NOT = -1 + DISPLAY R END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_REVERSE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_REVERSE.cob new file mode 100644 index 0000000..b1b1690 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_REVERSE.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(10) VALUE "A#B.C%D+E$". + 01 Z PIC X(10). + PROCEDURE DIVISION. + MOVE FUNCTION REVERSE ( X ) TO Z. + IF Z NOT = "$E+D%C.B#A" + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_REVERSE_with_reference_modding.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_REVERSE_with_reference_modding.cob new file mode 100644 index 0000000..98c28ad --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_REVERSE_with_reference_modding.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(10) VALUE "A#B.C%D+E$". + 01 Z PIC X(10). + PROCEDURE DIVISION. + MOVE FUNCTION REVERSE ( X ) (1 : 4) TO Z. + IF Z NOT = "$E+D " + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SECONDS-FROM-FORMATTED-TIME.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SECONDS-FROM-FORMATTED-TIME.cob new file mode 100644 index 0000000..2641e08 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SECONDS-FROM-FORMATTED-TIME.cob @@ -0,0 +1,58 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 result PIC 9(8)V9(9) COMP-5. + PROCEDURE DIVISION. + MOVE FUNCTION SECONDS-FROM-FORMATTED-TIME + ("hhmmss", "010203") + TO result. + IF result NOT = 3723 + DISPLAY "Test 1 failed: " result + END-DISPLAY + END-IF. + + MOVE FUNCTION SECONDS-FROM-FORMATTED-TIME + ("hh:mm:ss", "01:02:03") + TO result. + IF result NOT = 3723 + DISPLAY "Test 2 failed: " result + END-DISPLAY + END-IF. + + MOVE FUNCTION SECONDS-FROM-FORMATTED-TIME + ("hhmmss.ssssssss", "010203.04050607") + TO result. + IF result NOT = 3723.04050607 + DISPLAY "Test 3 failed: " result + END-DISPLAY + END-IF. + + MOVE FUNCTION SECONDS-FROM-FORMATTED-TIME + ("hhmmssZ", "010203Z") + TO result. + IF result NOT = 3723 + DISPLAY "Test 4 failed: " result + END-DISPLAY + END-IF. + + MOVE FUNCTION SECONDS-FROM-FORMATTED-TIME + ("hhmmss+hhmm", "010203+0405") + TO result. + IF result NOT = 3723 + DISPLAY "Test 5 failed: " result + END-DISPLAY + END-IF. + + MOVE FUNCTION SECONDS-FROM-FORMATTED-TIME + ("YYYYMMDDThhmmss", "16010101T010203") + TO result. + IF result NOT = 3723 + DISPLAY "Test 6 failed: " result + END-DISPLAY + END-IF. + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SECONDS-PAST-MIDNIGHT.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SECONDS-PAST-MIDNIGHT.cob new file mode 100644 index 0000000..b229ac3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SECONDS-PAST-MIDNIGHT.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC 9(8) COMP-5. + PROCEDURE DIVISION. + MOVE FUNCTION SECONDS-PAST-MIDNIGHT TO Y. + IF Y NOT < 86402 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SIGN.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SIGN.cob new file mode 100644 index 0000000..f698d97 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SIGN.cob @@ -0,0 +1,30 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z USAGE BINARY-LONG SIGNED. + PROCEDURE DIVISION. + MOVE FUNCTION SIGN ( 3.12345 ) TO Z. + IF Z NOT = 1 + DISPLAY "Sign 1 " Z + END-DISPLAY + END-IF. + MOVE FUNCTION SIGN ( -0.0 ) TO Z. + IF Z NOT = 0 + DISPLAY "Sign 2 " Z + END-DISPLAY + END-IF. + MOVE FUNCTION SIGN ( 0.0 ) TO Z. + IF Z NOT = 0 + DISPLAY "Sign 3 " Z + END-DISPLAY + END-IF. + MOVE FUNCTION SIGN ( -3.12345 ) TO Z. + IF Z NOT = -1 + DISPLAY "Sign 4 " Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SIN.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SIN.cob new file mode 100644 index 0000000..a72df35 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SIN.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION SIN ( 1.5 ) TO Y. + IF Y NOT = 0.997494986604054430941723371141487 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SQRT.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SQRT.cob new file mode 100644 index 0000000..ddf36da --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SQRT.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S9V9(33). + PROCEDURE DIVISION. + MOVE FUNCTION SQRT ( 1.5 ) TO Y. + IF Y NOT = 1.224744871391589049098642037352945 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_STANDARD-DEVIATION.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_STANDARD-DEVIATION.cob new file mode 100644 index 0000000..8deadc7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_STANDARD-DEVIATION.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S9V9(32). + PROCEDURE DIVISION. + MOVE FUNCTION STANDARD-DEVIATION ( 3 -14 0 8 -3 ) TO Y. + IF Y NOT = 7.35934779718963954877237043574538 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE-CASE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE-CASE.cob new file mode 100644 index 0000000..850f1da --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE-CASE.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC X(20). + 01 Z PIC X(20). + PROCEDURE DIVISION. + MOVE "ABC111444555defxxabc" TO Y. + MOVE FUNCTION SUBSTITUTE (Y anycase "abc" "zz" + anycase "55" "666") + TO Z. + IF Z NOT = "zz1114446665defxxzz" + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE-CASE_with_reference_mod.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE-CASE_with_reference_mod.cob new file mode 100644 index 0000000..24ed1b8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE-CASE_with_reference_mod.cob @@ -0,0 +1,20 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC X(20). + 01 Z PIC X(20). + PROCEDURE DIVISION. + MOVE "abc111444555defxxabc" TO Y. + MOVE FUNCTION SUBSTITUTE + ( Y anycase "ABC" "zz" + anycase "55" "666" ) (2 : 9) + TO Z. + IF Z NOT = "z11144466" + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE.cob new file mode 100644 index 0000000..072c159 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE.cob @@ -0,0 +1,24 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_SUBSTITUTE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC X(24). + PROCEDURE DIVISION. + MOVE "abc111444555defxxabc" TO Y + DISPLAY FUNCTION TRIM (FUNCTION SUBSTITUTE ( Y "abc" "zz" "55" "666" )) + + MOVE "bobBobjimJimbobBobjimJim" TO Y + DISPLAY FUNCTION SUBSTITUTE ( Y "bob" "FILLER" "jim" "Z") + + MOVE "bobBobjimJimbobBobjimJim" TO Y + DISPLAY FUNCTION SUBSTITUTE ( Y FIRST "bob" "FILLER" "jim" "Z") + + MOVE "bobBobjimJimbobBobjimJim" TO Y + DISPLAY FUNCTION SUBSTITUTE ( Y LAST "bob" "FILLER" "jim" "Z") + + MOVE "bobBobjimJimbobBobjimJim" TO Y + DISPLAY FUNCTION SUBSTITUTE ( Y ANYCASE "bob" "FILLER" ANYCASE "jim" "Z") + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE.out new file mode 100644 index 0000000..4f5f7a0 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE.out @@ -0,0 +1,6 @@ +zz1114446665defxxzz +FILLERBobZJimFILLERBobZJim +FILLERBobZJimbobBobZJim +bobBobZJimFILLERBobZJim +FILLERFILLERZZFILLERFILLERZZ + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE_with_reference_modding.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE_with_reference_modding.cob new file mode 100644 index 0000000..7894915 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUBSTITUTE_with_reference_modding.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC X(20). + 01 Z PIC X(20). + PROCEDURE DIVISION. + MOVE "abc111444555defxxabc" TO Y. + MOVE FUNCTION SUBSTITUTE + ( Y "abc" "zz" "55" "666" ) (2 : 9) + TO Z. + IF Z NOT = "z11144466" + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SUM.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUM.cob new file mode 100644 index 0000000..228e996 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SUM.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z USAGE BINARY-LONG. + PROCEDURE DIVISION. + MOVE FUNCTION SUM ( 3 -14 0 8 -3 ) TO Z. + IF Z NOT = -6 + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TAN.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TAN.cob new file mode 100644 index 0000000..f932157 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TAN.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Y PIC S99V9(31). + PROCEDURE DIVISION. + MOVE FUNCTION TAN ( 1.5 ) TO Y. + IF Y NOT = 14.1014199471717193876460836519877 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DATE-YYYYMMDD.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DATE-YYYYMMDD.cob new file mode 100644 index 0000000..8841f5a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DATE-YYYYMMDD.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_TEST-DATE-YYYYMMDD.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 RESULT PIC 999. + PROCEDURE DIVISION. + MOVE FUNCTION TEST-DATE-YYYYMMDD ( 20020231 ) TO RESULT + DISPLAY RESULT + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DATE-YYYYMMDD.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DATE-YYYYMMDD.out new file mode 100644 index 0000000..56fa706 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DATE-YYYYMMDD.out @@ -0,0 +1,2 @@ +003 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__1_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__1_.cob new file mode 100644 index 0000000..71fbdb9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__1_.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_TEST-DAY-YYYYDDD__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 RESULT PIC 999. + PROCEDURE DIVISION. + MOVE FUNCTION TEST-DAY-YYYYDDD ( 2002400 ) TO RESULT + DISPLAY RESULT + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__1_.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__1_.out new file mode 100644 index 0000000..4119821 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__1_.out @@ -0,0 +1,2 @@ +002 + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__2_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__2_.cob new file mode 100644 index 0000000..24893ab --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__2_.cob @@ -0,0 +1,170 @@ + *> { dg-do run } + + identification division. + program-id. test. + data division. + working-storage section. + 01 datev pic 99999999. + 01 should_be pic 9999. + 01 result pic 9999. + procedure division. + move function test-day-yyyyddd(1945123) to result + move zero to should_be + if result not equal to should_be then + display "test-day-yyyyddd(1945123) should have been " + should_be " but was " result + move 1 to return-code + end-if. + move function test-day-yyyyddd(10000000) to result + move 1 to should_be + if result not equal to should_be then + display "test-day-yyyyddd(100000000) should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1601000 to datev + move 2 to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1601001 to datev + move zero to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1601364 to datev + move zero to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1601365 to datev + move zero to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1601366 to datev + move 2 to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1601367 to datev + move 2 to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 2000365 to datev + move zero to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 2000366 to datev + move zero to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 2000367 to datev + move 2 to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 2100365 to datev + move zero to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 2100366 to datev + move 2 to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 2100367 to datev + move 2 to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1988365 to datev + move zero to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1988366 to datev + move zero to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1988367 to datev + move 2 to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1989365 to datev + move zero to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1989366 to datev + move 2 to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1989367 to datev + move 2 to should_be + move function test-day-yyyyddd(datev) to result + if result not equal to should_be then + display "test-day-yyyyddd(" datev ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + end program test. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_DP.COMMA.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_DP.COMMA.cob new file mode 100644 index 0000000..b825198 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_DP.COMMA.cob @@ -0,0 +1,32 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss,ss", "000000,00") <> 0 + DISPLAY "Test 1 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDDThhmmss,ss", "16010101T000000,00") <> 0 + DISPLAY "Test 2 failed" END-DISPLAY + END-IF + + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss,ss", "000000.00") <> 7 + DISPLAY "Test 3 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDDThhmmss,ss", "16010101T000000.00") <> 16 + DISPLAY "Test 4 failed" END-DISPLAY + END-IF + + STOP RUN + . + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_additional.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_additional.cob new file mode 100644 index 0000000..e782647 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_additional.cob @@ -0,0 +1,173 @@ + *> { dg-do run } + + identification division. + program-id. test. + data division. + working-storage section. + 01 datev pic 99999999. + 01 should_be pic 9999. + 01 result pic 9999. + 01 date-integer PIC 999999. + 01 i PIC 999. + 01 datex PIC X(8). + 01 xone PIC X. + 01 yyyydddv . + 02 yyyy PIC 9999. + 02 filler PIC X VALUE "-". + 02 ddd PIC 999. + procedure division. + *> TESTING YYYYMMDD + move "19000229" to datex + move function TEST-FORMATTED-DATETIME("YYYYMMDD", datex) to RESULT + move 8 to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYMMDD""" + ", " + function trim(datex) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + *> Test an entire year of YYYYMMDD: + move function integer-of-date(19880101) to date-integer + perform until date-integer >= function integer-of-date(19890101) + move function date-of-integer(date-integer) to datev + move function TEST-FORMATTED-DATETIME("YYYYMMDD", datev) to RESULT + move zero to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYMMDD""" + ", " + datev + ") should have been " + should_be " but was " result + move 1 to return-code + end-if + add 1 to date-integer + end-perform. + *> Make sure foreign characters trigger the correct gazinga in YYYYMMDD + move "19530227" to datex + perform varying i from 1 by 1 until i > 8 + move datex(i:1) to xone + move 'X' to datex(i:1) + move function TEST-FORMATTED-DATETIME("YYYYMMDD", datex) to RESULT + move i to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYMMDD""" + ", " + function trim(datex) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if + move xone to datex(i:1) + end-perform. + move "19000229" to datex + move function TEST-FORMATTED-DATETIME("YYYYMMDD", datex) to RESULT + move 8 to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYMMDD""" + ", " + function trim(datex) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move "20000229" to datex + move function TEST-FORMATTED-DATETIME("YYYYMMDD", datex) to RESULT + move 0 to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYMMDD""" + ", " + function trim(datex) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move "20007029" to datex + move function TEST-FORMATTED-DATETIME("YYYYMMDD", datex) to RESULT + move 5 to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYMMDD""" + ", " + function trim(datex) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + *> TESTING YYYY-DDD + move "1988" to yyyy of yyyydddv + move "000" to ddd of yyyydddv + move function TEST-FORMATTED-DATETIME("YYYY-DDD", yyyydddv) to RESULT + move 8 to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYDDD""" + ", " + function trim(yyyydddv) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move "1988" to yyyy of yyyydddv + move "367" to ddd of yyyydddv + move function TEST-FORMATTED-DATETIME("YYYY-DDD", yyyydddv) to RESULT + move 8 to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYDDD""" + ", " + function trim(yyyydddv) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move "1988" to yyyy of yyyydddv + move "399" to ddd of yyyydddv + move function TEST-FORMATTED-DATETIME("YYYY-DDD", yyyydddv) to RESULT + move 7 to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYDDD""" + ", " + function trim(yyyydddv) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1988 to yyyy of yyyydddv + move 400 to ddd of yyyydddv + move function TEST-FORMATTED-DATETIME("YYYY-DDD", yyyydddv) to RESULT + move 6 to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYYDDD""" + ", " + function trim(yyyydddv) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if. + move 1988 to yyyy of yyyydddv + perform varying i from 1 by 1 until i > 366 + move i to ddd of yyyydddv + move function TEST-FORMATTED-DATETIME("YYYY-DDD", yyyydddv) to RESULT + move zero to should_be + if result not equal to should_be then + display "TEST-FORMATTED-DATETIME(" + """YYYY-DDD""" + ", " + function trim(yyyydddv) + ") should have been " + should_be " but was " result + move 1 to return-code + end-if + add 1 to date-integer + end-perform. + end program test. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_with_dates.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_with_dates.cob new file mode 100644 index 0000000..1b571f9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_with_dates.cob @@ -0,0 +1,118 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "16010101") <> 0 + DISPLAY "Test 1 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYY-MM-DD", "1601-01-01") <> 0 + DISPLAY "Test 2 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYDDD", "1601001") <> 0 + DISPLAY "Test 3 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYY-DDD", "1601-001") <> 0 + DISPLAY "Test 4 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYWwwD", "1601W011") <> 0 + DISPLAY "Test 5 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYY-Www-D", "1601-W01-1") <> 0 + DISPLAY "Test 6 failed" END-DISPLAY + END-IF + + + *> How will this work with zero-length items? + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "1") <> 2 + DISPLAY "Test 7 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "160A0101") <> 4 + DISPLAY "Test 8 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "00000101") <> 1 + DISPLAY "Test 9 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "16000101") <> 4 + DISPLAY "Test 10 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "16010001") <> 6 + DISPLAY "Test 11 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "16011301") <> 6 + DISPLAY "Test 12 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "16010190") <> 7 + DISPLAY "Test 13 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "18000229") <> 8 + DISPLAY "Test 14 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYY-MM-DD", "1601 01 01") <> 5 + DISPLAY "Test 15 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "160101010") <> 9 + DISPLAY "Test 16 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYWwwD", "1601A011") <> 5 + DISPLAY "Test 17 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYWwwD", "1601W531") <> 7 + DISPLAY "Test 18 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYWwwD", "1601W601") <> 6 + DISPLAY "Test 19 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYWwwD", "2009W531") <> 0 + DISPLAY "Test 20 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYWwwD", "1601W018") <> 8 + DISPLAY "Test 21 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYDDD", "1601366") <> 7 + DISPLAY "Test 22 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYDDD", "1601370") <> 6 + DISPLAY "Test 23 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYDDD", "1601400") <> 5 + DISPLAY "Test 24 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "01") <> 1 + DISPLAY "Test 25 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDD", "1601010") <> 8 + DISPLAY "Test 26 failed" END-DISPLAY + END-IF + + STOP RUN + . + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_with_datetimes.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_with_datetimes.cob new file mode 100644 index 0000000..5591fbb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_with_datetimes.cob @@ -0,0 +1,44 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 RESULT PIC 9(02). + PROCEDURE DIVISION. + MOVE FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDDThhmmss", "16010101T000000") + TO RESULT + IF RESULT <> 0 + DISPLAY "Test 1 failed: " RESULT END-DISPLAY + END-IF + MOVE FUNCTION TEST-FORMATTED-DATETIME + ("YYYY-MM-DDThh:mm:ss.sssssssss+hh:mm", + "1601-01-01T00:00:00.000000000+00:00") + TO RESULT + IF RESULT <> 0 + DISPLAY "Test 2 failed: " RESULT END-DISPLAY + END-IF + + MOVE FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDDThhmmss", "16010101 000000") + TO RESULT + IF RESULT <> 9 + DISPLAY "Test 3 failed: " RESULT END-DISPLAY + END-IF + MOVE FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDDThhmmss", SPACE) + TO RESULT + IF RESULT <> 1 + DISPLAY "Test 4 failed: " RESULT END-DISPLAY + END-IF + MOVE FUNCTION TEST-FORMATTED-DATETIME + ("YYYYMMDDThhmmss", "16010101T ") + TO RESULT + IF RESULT <> 10 + DISPLAY "Test 5 failed: " RESULT END-DISPLAY + END-IF + + STOP RUN + . + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_with_times.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_with_times.cob new file mode 100644 index 0000000..ded9551 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_with_times.cob @@ -0,0 +1,72 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss.sssssssssZ", "000000.000000000Z") <> 0 + DISPLAY "Test 1 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hh:mm:ss.sssssssssZ", "00:00:00.000000000Z") <> 0 + DISPLAY "Test 2 failed" END-DISPLAY + END-IF + *> 0 instead of +/- valid in sending fields with offset of zero. + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss.sssssssss+hhmm", "000000.00000000000000") + <> 0 + DISPLAY "Test 3 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hh:mm:ss.sssssssss+hh:mm", + "00:00:00.000000000+00:00") + <> 0 + DISPLAY "Test 4 failed" END-DISPLAY + END-IF + + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss", "300000") <> 1 + DISPLAY "Test 5 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss", "250000") <> 2 + DISPLAY "Test 6 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss", "006000") <> 3 + DISPLAY "Test 7 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss", "000060") <> 5 + DISPLAY "Test 8 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hh:mm:ss", "00-00-00") <> 3 + DISPLAY "Test 9 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss.ss", "000000,00") <> 7 + DISPLAY "Test 10 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss+hhmm", "000000 0000") <> 7 + DISPLAY "Test 11 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss+hhmm", "00000000001") <> 11 + DISPLAY "Test 12 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmssZ", "000000A") <> 7 + DISPLAY "Test 13 failed" END-DISPLAY + END-IF + IF FUNCTION TEST-FORMATTED-DATETIME + ("hhmmss", SPACE) <> 1 + DISPLAY "Test 14 failed" END-DISPLAY + END-IF + + STOP RUN + . + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-NUMVAL-C.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-NUMVAL-C.cob new file mode 100644 index 0000000..e458f4a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-NUMVAL-C.cob @@ -0,0 +1,89 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + IF FUNCTION TEST-NUMVAL-C ("+ 1") NOT = 0 + DISPLAY "Test 1 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C (" + 1") NOT = 0 + DISPLAY "Test 2 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("- 1") NOT = 0 + DISPLAY "Test 3 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C (" - 1") NOT = 0 + DISPLAY "Test 4 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("+- 1") NOT = 2 + DISPLAY "Test 5 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("1 +") NOT = 0 + DISPLAY "Test 6 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("1 -") NOT = 0 + DISPLAY "Test 7 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("1 +-") NOT = 4 + DISPLAY "Test 8 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("1 -+") NOT = 4 + DISPLAY "Test 9 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("+ 1.1") NOT = 0 + DISPLAY "Test 10 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("- 1.1") NOT = 0 + DISPLAY "Test 11 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("1.1 +") NOT = 0 + DISPLAY "Test 12 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("1.1 -") NOT = 0 + DISPLAY "Test 13 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("1.1 CR") NOT = 0 + DISPLAY "Test 14 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("1.1 DB") NOT = 0 + DISPLAY "Test 15 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("1.1 -CR") NOT = 6 + DISPLAY "Test 16 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("+ $1.1 ") NOT = 0 + DISPLAY "Test 17 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("- $1.1 ") NOT = 0 + DISPLAY "Test 18 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("+ X1.1 ", "X") NOT = 0 + DISPLAY "Test 19 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-C ("- X1.1 ", "X") NOT = 0 + DISPLAY "Test 20 fail" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-NUMVAL-F.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-NUMVAL-F.cob new file mode 100644 index 0000000..3fcec0e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-NUMVAL-F.cob @@ -0,0 +1,89 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + IF FUNCTION TEST-NUMVAL-F ("+ 1") NOT = 0 + DISPLAY "Test 1 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F (" + 1") NOT = 0 + DISPLAY "Test 2 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("- 1") NOT = 0 + DISPLAY "Test 3 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F (" - 1") NOT = 0 + DISPLAY "Test 4 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("+- 1") NOT = 2 + DISPLAY "Test 5 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1 +") NOT = 3 + DISPLAY "Test 6 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1 -") NOT = 3 + DISPLAY "Test 7 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1 +-") NOT = 3 + DISPLAY "Test 8 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1 -+") NOT = 3 + DISPLAY "Test 9 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("+ 1.1") NOT = 0 + DISPLAY "Test 10 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("- 1.1") NOT = 0 + DISPLAY "Test 11 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1.1 +") NOT = 5 + DISPLAY "Test 12 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1.1 -") NOT = 5 + DISPLAY "Test 13 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1.1 ") NOT = 0 + DISPLAY "Test 14 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1.1 ") NOT = 0 + DISPLAY "Test 15 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1.1 -CR") NOT = 5 + DISPLAY "Test 16 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1.1 E+1") NOT = 0 + DISPLAY "Test 17 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1.1 E -1") NOT = 0 + DISPLAY "Test 18 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("1.1 EE") NOT = 6 + DISPLAY "Test 19 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL-F ("+1.1 E+01") NOT = 0 + DISPLAY "Test 20 fail" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-NUMVAL.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-NUMVAL.cob new file mode 100644 index 0000000..bc38b4e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TEST-NUMVAL.cob @@ -0,0 +1,89 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + IF FUNCTION TEST-NUMVAL ("+ 1") NOT = 0 + DISPLAY "Test 1 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL (" + 1") NOT = 0 + DISPLAY "Test 2 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("- 1") NOT = 0 + DISPLAY "Test 3 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL (" - 1") NOT = 0 + DISPLAY "Test 4 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("+- 1") NOT = 2 + DISPLAY "Test 5 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1 +") NOT = 0 + DISPLAY "Test 6 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1 -") NOT = 0 + DISPLAY "Test 7 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1 +-") NOT = 4 + DISPLAY "Test 8 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1 -+") NOT = 4 + DISPLAY "Test 9 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("+ 1.1") NOT = 0 + DISPLAY "Test 10 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("- 1.1") NOT = 0 + DISPLAY "Test 11 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1.1 +") NOT = 0 + DISPLAY "Test 12 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1.1 -") NOT = 0 + DISPLAY "Test 13 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1.1 CR") NOT = 0 + DISPLAY "Test 14 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1.1 DB") NOT = 0 + DISPLAY "Test 15 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1.1 -CR") NOT = 6 + DISPLAY "Test 16 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1.1 +DB") NOT = 6 + DISPLAY "Test 17 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("1.1 CDB") NOT = 6 + DISPLAY "Test 18 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("+1.1 CR") NOT = 6 + DISPLAY "Test 19 fail" + END-DISPLAY + END-IF. + IF FUNCTION TEST-NUMVAL ("+ ") NOT = 8 + DISPLAY "Test 20 fail" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM.cob new file mode 100644 index 0000000..054b14a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_TRIM.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(12) VALUE " a#b.c%d+e$ ". + PROCEDURE DIVISION. + DISPLAY FUNCTION TRIM ( X ) + END-DISPLAY. + DISPLAY FUNCTION TRIM ( X TRAILING ) + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM.out new file mode 100644 index 0000000..b0e4a72 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM.out @@ -0,0 +1,3 @@ +a#b.c%d+e$ + a#b.c%d+e$ + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_reference_modding.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_reference_modding.cob new file mode 100644 index 0000000..f14f0fa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_reference_modding.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_TRIM_with_reference_modding.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(12) VALUE " a#b.c%d+e$ ". + PROCEDURE DIVISION. + DISPLAY FUNCTION TRIM ( X ) (2 : 3) + END-DISPLAY. + DISPLAY FUNCTION TRIM ( X TRAILING ) (2 : 3) + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_reference_modding.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_reference_modding.out new file mode 100644 index 0000000..f716581 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_reference_modding.out @@ -0,0 +1,3 @@ +#b. +a#b + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_zero_length.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_zero_length.cob new file mode 100644 index 0000000..d92a490 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_zero_length.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_TRIM_zero_length.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 A2 PIC X(2) VALUE " ". + 01 A3 PIC X(3) VALUE " ". + 01 X PIC X(4) VALUE "NOOK". + PROCEDURE DIVISION. + MOVE FUNCTION TRIM ( A2 ) TO X. + DISPLAY ">" X "<" + END-DISPLAY. + DISPLAY ">" FUNCTION TRIM ( A3 ) "<" + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_zero_length.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_zero_length.out new file mode 100644 index 0000000..9aa7900 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_zero_length.out @@ -0,0 +1,3 @@ +> < +>< + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_UPPER-CASE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_UPPER-CASE.cob new file mode 100644 index 0000000..9bf6a6b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_UPPER-CASE.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(10) VALUE "a#b.c%d+e$". + 01 Z PIC X(10). + PROCEDURE DIVISION. + MOVE FUNCTION UPPER-CASE ( X ) TO Z. + IF Z NOT = "A#B.C%D+E$" + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_UPPER-CASE_with_reference_modding.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_UPPER-CASE_with_reference_modding.cob new file mode 100644 index 0000000..2f96446 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_UPPER-CASE_with_reference_modding.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(10) VALUE "a#b.c%d+e$". + 01 Z PIC X(4). + PROCEDURE DIVISION. + MOVE FUNCTION UPPER-CASE ( X ) (1 : 3) TO Z. + IF Z NOT = "A#B " + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_VARIANCE.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_VARIANCE.cob new file mode 100644 index 0000000..0a08f5a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_VARIANCE.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC S9(4)V9(4) COMP-5. + PROCEDURE DIVISION. + MOVE FUNCTION VARIANCE ( 3 -14 0 8 -3 ) TO Z. + IF Z NOT = 54.16 + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_WHEN-COMPILED.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_WHEN-COMPILED.cob new file mode 100644 index 0000000..d47967b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_WHEN-COMPILED.cob @@ -0,0 +1,45 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 compiled-datetime. + 03 compiled-date. + 05 millennium PIC X. + 05 FILLER PIC X(15). + 03 timezone PIC X(5). + PROCEDURE DIVISION. + *> Check millennium. + MOVE FUNCTION WHEN-COMPILED TO compiled-datetime. + IF millennium NOT = "2" + DISPLAY "Millennium NOT OK: " millennium + END-DISPLAY + END-IF. + + *> Check timezone. + IF timezone NOT = FUNCTION CURRENT-DATE (17:5) + DISPLAY "Timezone NOT OK: " timezone + END-DISPLAY + END-IF. + + *> Check date format. + INSPECT compiled-date CONVERTING "0123456789" + TO "9999999999". + IF compiled-date NOT = ALL "9" + DISPLAY "Date format NOT OK: " compiled-date + END-DISPLAY + END-IF. + + *> Check timezone format. + IF timezone NOT = "00000" + INSPECT timezone CONVERTING "0123456789" + TO "9999999999" + IF timezone NOT = "+9999" AND "-9999" + DISPLAY "Timezone format NOT OK: " timezone + END-DISPLAY + END-IF + END-IF. + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_YEAR-TO-YYYY.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_YEAR-TO-YYYY.cob new file mode 100644 index 0000000..ece8151 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_YEAR-TO-YYYY.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z USAGE BINARY-LONG. + PROCEDURE DIVISION. + MOVE FUNCTION YEAR-TO-YYYY ( 50 ) TO Z. + IF Z NOT = 2050 + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.cob new file mode 100644 index 0000000..e25ac8b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_as_CALL_parameter_BY_CONTENT.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + PROCEDURE DIVISION. + PROG-MAIN. + CALL "subprog" USING BY CONTENT + FUNCTION CONCAT("Abc" "D") + STOP RUN. + + *> ***************************** + IDENTIFICATION DIVISION. + PROGRAM-ID. subprog. + + DATA DIVISION. + LINKAGE SECTION. + 01 TESTING PIC X ANY LENGTH. + + PROCEDURE DIVISION USING TESTING. + SUBPROG-MAIN. + DISPLAY TESTING + GOBACK. + END PROGRAM subprog. + END PROGRAM prog. *> bzzt + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.out new file mode 100644 index 0000000..11f0477 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.out @@ -0,0 +1,2 @@ +AbcD + diff --git a/gcc/testsuite/cobol.dg/group2/Floating_continuation_indicator__1_.cob b/gcc/testsuite/cobol.dg/group2/Floating_continuation_indicator__1_.cob new file mode 100644 index 0000000..53211b2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Floating_continuation_indicator__1_.cob @@ -0,0 +1,21 @@ + *> { dg-do run } + *> { dg-options "-ffixed-form" } + *> { dg-output-file "group2/Floating_continuation_indicator__1_.out" } + IDENTIFICATION DIVISION. + * testing floating continuation literals ("'-" and '"-') + PROGRAM-ID. FF2. + PROCEDURE DIVISION. + DISPLAY "hello "- + "world.". + DISPLAY 'hello '- + 'world.'. + DISPLAY "hello "- + * non-interrupting comment + "world.". + DISPLAY 'hello '- + *> non-interrupting comment + + 'world.'. + EXIT PROGRAM. + + diff --git a/gcc/testsuite/cobol.dg/group2/Floating_continuation_indicator__1_.out b/gcc/testsuite/cobol.dg/group2/Floating_continuation_indicator__1_.out new file mode 100644 index 0000000..fe031c3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Floating_continuation_indicator__1_.out @@ -0,0 +1,5 @@ +hello world. +hello world. +hello world. +hello world. + diff --git a/gcc/testsuite/cobol.dg/group2/IBM_dialect_COMP_redefined_by_POINTER_as_64-bit.cob b/gcc/testsuite/cobol.dg/group2/IBM_dialect_COMP_redefined_by_POINTER_as_64-bit.cob new file mode 100644 index 0000000..071b88a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/IBM_dialect_COMP_redefined_by_POINTER_as_64-bit.cob @@ -0,0 +1,34 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + *> { dg-output-file "group2/IBM_dialect_COMP_redefined_by_POINTER_as_64-bit.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + *> This is a test of the "-dialect ibm" special interpretation of a common + *> construction in IBM mainframe code. That machine is a 32-bit + *> big-endian architecture. We are assuming a 64-bit little-endian + *> x86_64 architecture. So, the COMP PIC S8(8) would usually be an 32-bit + *> big-endian value. But "-dialect ibm" means that the following + *> REDEFINES USAGE POINTER causes the prior "COMP" to actually be defined + *> as a 64-bit little-endian binary value. + 77 pointer-value COMP PIC S9(8) VALUE ZERO. + 77 point-at REDEFINES pointer-value USAGE POINTER. + procedure division. + *> The following value is 0x123456789 + move 4886718345 to pointer-value + display point-at " should be 0x0000000123456789" + set point-at down by 4886718345 + display point-at " should be 0x0000000000000000" + set point-at down by 4886718345 + display point-at " should be 0xfffffffedcba9877" + set point-at up by 4886718345 + display point-at " should be 0x0000000000000000" + subtract 1 from pointer-value + display point-at " should be 0xffffffffffffffff" + add 1 to pointer-value + display point-at " should be 0x0000000000000000" + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/IBM_dialect_COMP_redefined_by_POINTER_as_64-bit.out b/gcc/testsuite/cobol.dg/group2/IBM_dialect_COMP_redefined_by_POINTER_as_64-bit.out new file mode 100644 index 0000000..cd7fa5b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/IBM_dialect_COMP_redefined_by_POINTER_as_64-bit.out @@ -0,0 +1,7 @@ +0x0000000123456789 should be 0x0000000123456789 +0x0000000000000000 should be 0x0000000000000000 +0xfffffffedcba9877 should be 0xfffffffedcba9877 +0x0000000000000000 should be 0x0000000000000000 +0xffffffffffffffff should be 0xffffffffffffffff +0x0000000000000000 should be 0x0000000000000000 + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_LEADING.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_LEADING.cob new file mode 100644 index 0000000..bfe4b67 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_LEADING.cob @@ -0,0 +1,43 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_BACKWARD_REPLACING_LEADING.out" } + identification division. + program-id. caller. + data division. + working-storage section. + 77 str pic x(19) value "AAAAsomeABthingBBBB". + procedure division. + display "Starting with " """" str """" "..." + + initialize str all value. + inspect str replacing all "A" by "X" + display "After inspect replacing ALL A by X: " """" str """" + + initialize str all value. + inspect str replacing leading "A" by "X" + display "After inspect replacing LEADING A by X: " """" str """" + + initialize str all value. + inspect backward str replacing all "A" by "X" + display "After inspect backward replacing ALL A by X: " """" str """" + + initialize str all value. + inspect backward str replacing leading "A" by "X" + display "After inspect backward replacing LEADING A by X: " """" str """" + + initialize str all value. + inspect str replacing all "B" by "X" + display "After inspect replacing ALL B by X: " """" str """" + + initialize str all value. + inspect str replacing leading "B" by "X" + display "After inspect replacing LEADING B by X: " """" str """" + + initialize str all value. + inspect backward str replacing all "B" by "X" + display "After inspect backward replacing ALL B by X: " """" str """" + + initialize str all value. + inspect backward str replacing leading "B" by "X" + display "After inspect backward replacing LEADING B by X: " """" str """" + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_LEADING.out b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_LEADING.out new file mode 100644 index 0000000..3e9c3c3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_LEADING.out @@ -0,0 +1,10 @@ +Starting with "AAAAsomeABthingBBBB"... +After inspect replacing ALL A by X: "XXXXsomeXBthingBBBB" +After inspect replacing LEADING A by X: "XXXXsomeABthingBBBB" +After inspect backward replacing ALL A by X: "XXXXsomeXBthingBBBB" +After inspect backward replacing LEADING A by X: "AAAAsomeABthingBBBB" +After inspect replacing ALL B by X: "AAAAsomeAXthingXXXX" +After inspect replacing LEADING B by X: "AAAAsomeABthingBBBB" +After inspect backward replacing ALL B by X: "AAAAsomeAXthingXXXX" +After inspect backward replacing LEADING B by X: "AAAAsomeABthingXXXX" + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_TRAILING.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_TRAILING.cob new file mode 100644 index 0000000..c2e6a09 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_TRAILING.cob @@ -0,0 +1,44 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/INSPECT_BACKWARD_REPLACING_TRAILING.out" } + identification division. + program-id. caller. + data division. + working-storage section. + 77 str pic x(19) value "AAAAsomeABthingBBBB". + procedure division. + display "Starting with " """" str """" "..." + + initialize str all value. + inspect str replacing all "A" by "X" + display "After inspect replacing ALL A by X: " """" str """" + + initialize str all value. + inspect str replacing trailing "A" by "X" + display "After inspect replacing TRAILING A by X: " """" str """" + + initialize str all value. + inspect backward str replacing all "A" by "X" + display "After inspect backward replacing ALL A by X: " """" str """" + + initialize str all value. + inspect backward str replacing trailing "A" by "X" + display "After inspect backward replacing TRAILING A by X: " """" str """" + + initialize str all value. + inspect str replacing all "B" by "X" + display "After inspect replacing ALL B by X: " """" str """" + + initialize str all value. + inspect str replacing trailing "B" by "X" + display "After inspect replacing TRAILING B by X: " """" str """" + + initialize str all value. + inspect backward str replacing all "B" by "X" + display "After inspect backward replacing ALL B by X: " """" str """" + + initialize str all value. + inspect backward str replacing trailing "B" by "X" + display "After inspect backward replacing TRAILING B by X: " """" str """" + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_TRAILING.out b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_TRAILING.out new file mode 100644 index 0000000..c8f492d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_REPLACING_TRAILING.out @@ -0,0 +1,10 @@ +Starting with "AAAAsomeABthingBBBB"... +After inspect replacing ALL A by X: "XXXXsomeXBthingBBBB" +After inspect replacing TRAILING A by X: "AAAAsomeABthingBBBB" +After inspect backward replacing ALL A by X: "XXXXsomeXBthingBBBB" +After inspect backward replacing TRAILING A by X: "XXXXsomeABthingBBBB" +After inspect replacing ALL B by X: "AAAAsomeAXthingXXXX" +After inspect replacing TRAILING B by X: "AAAAsomeABthingXXXX" +After inspect backward replacing ALL B by X: "AAAAsomeAXthingXXXX" +After inspect backward replacing TRAILING B by X: "AAAAsomeABthingBBBB" + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_CONVERTING.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_CONVERTING.cob new file mode 100644 index 0000000..fbf9e09d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_CONVERTING.cob @@ -0,0 +1,105 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/INSPECT_BACKWARD_simple_CONVERTING.out" } + + program-id. prog. + data division. + working-storage section. + 01 item pic x(64). + 01 should-be pic x(64). + procedure division. + display "Forward:" + move "the quick brown fox jumps over the lazy dog" to item + inspect item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + move "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" before "jumps" + move "THE QUICK BROWN FOX jumps over the lazy dog" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" before "nothing" + move "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" after "fox" + move "the quick brown fox JUMPS OVER THE LAZY DOG" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" after "fox" before "over" + move "the quick brown fox JUMPS over the lazy dog" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" after "fox" before "xyzzy" + move "the quick brown fox JUMPS OVER THE LAZY DOG" to should-be + perform reportt + + display "Reverse:" + + move "the quick brown fox jumps over the lazy dog" to item + inspect backward item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + move "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect backward item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" before "jumps" + move "the quick brown fox jumps OVER THE LAZY DOG" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect backward item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" before "nothing" + move "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect backward item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" after "fox" + move "THE QUICK BROWN fox jumps over the lazy dog" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect backward item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" before "fox" after "over" + move "the quick brown fox JUMPS over the lazy dog" to should-be + perform reportt + + move "the quick brown fox jumps over the lazy dog" to item + inspect backward item converting + "abcdefghijklmnopqrstuvwxyz" + TO "ABCDEFGHIJKLMNOPQRSTUVWXYZ" before "xyzzy" after "over" + move "THE QUICK BROWN FOX JUMPS over the lazy dog" to should-be + perform reportt + + goback. + reportt. + display " " function trim(item) + if item not equal to should-be + display "should have been " function trim(should-be) + end-if. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_CONVERTING.out b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_CONVERTING.out new file mode 100644 index 0000000..0675c63 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_CONVERTING.out @@ -0,0 +1,15 @@ +Forward: + THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG + THE QUICK BROWN FOX jumps over the lazy dog + THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG + the quick brown fox JUMPS OVER THE LAZY DOG + the quick brown fox JUMPS over the lazy dog + the quick brown fox JUMPS OVER THE LAZY DOG +Reverse: + THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG + the quick brown fox jumps OVER THE LAZY DOG + THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG + THE QUICK BROWN fox jumps over the lazy dog + the quick brown fox JUMPS over the lazy dog + THE QUICK BROWN FOX JUMPS over the lazy dog + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_REPLACING.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_REPLACING.cob new file mode 100644 index 0000000..4714e5e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_REPLACING.cob @@ -0,0 +1,29 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/INSPECT_BACKWARD_simple_REPLACING.out" } + + program-id. prog. + data division. + working-storage section. + 01 item pic x(64). + procedure division. + + move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbcZAbcAbcAbcAbcAbc" to item + display function trim(item) + inspect backward item replacing all "Abc" by "Qrs" + display function trim(item) + + move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbcZAbcAbcAbcAbcAbc" to item + display function trim(item) + inspect backward item replacing trailing "Abc" by "Qrs" + display function trim(item) + + move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbcZAbcAbcAbcAbcAbc" to item + display function trim(item) + inspect backward item replacing all "Abc" by "Qrs" + after "Z" before "Y" + display function trim(item) + + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_REPLACING.out b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_REPLACING.out new file mode 100644 index 0000000..230ab91 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_REPLACING.out @@ -0,0 +1,7 @@ +AbcAbcXAbcAbcAbcYAbcAbcAbcAbcZAbcAbcAbcAbcAbc +QrsQrsXQrsQrsQrsYQrsQrsQrsQrsZQrsQrsQrsQrsQrs +AbcAbcXAbcAbcAbcYAbcAbcAbcAbcZAbcAbcAbcAbcAbc +QrsQrsXAbcAbcAbcYAbcAbcAbcAbcZAbcAbcAbcAbcAbc +AbcAbcXAbcAbcAbcYAbcAbcAbcAbcZAbcAbcAbcAbcAbc +AbcAbcXAbcAbcAbcYQrsQrsQrsQrsZAbcAbcAbcAbcAbc + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_TALLYING.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_TALLYING.cob new file mode 100644 index 0000000..7cd284f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_TALLYING.cob @@ -0,0 +1,78 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/INSPECT_BACKWARD_simple_TALLYING.out" } + + program-id. prog. + data division. + working-storage section. + 01 item pic x(64). + 01 counter pic 999. + procedure division. + + move "AAXAAAYAAAAZAAAAA" to item + display function trim(item) + display "Forward:" + + move zero to counter + inspect item tallying + counter for all "A" + display "FOR ALL A " counter + + move zero to counter + move "AAXAAAYAAAAZAAAAA" to item + inspect item tallying + counter for all "A" after "X" + display "FOR ALL A after X " counter + + move zero to counter + move "AAXAAAYAAAAZAAAAA" to item + inspect item tallying + counter for all "A" before "Z" + display "FOR ALL A before Z " counter + + move zero to counter + move "AAXAAAYAAAAZAAAAA" to item + inspect item tallying + counter for all "A" after "X" before "Z" + display "FOR ALL A after X before Z " counter + + move zero to counter + move "AAXAAAYAAAAZAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" to item + inspect item tallying + counter for trailing "A" + display "FOR TRAILING A " counter + + + display "Backward:" + move zero to counter + inspect backward item tallying + counter for all "A" + display "FOR ALL A " counter + + move zero to counter + move "AAXAAAYAAAAZAAAAA" to item + inspect backward item tallying + counter for all "A" after "X" + display "FOR ALL A after X " counter + + move zero to counter + move "AAXAAAYAAAAZAAAAA" to item + inspect backward item tallying + counter for all "A" before "Z" + display "FOR ALL A before Z " counter + + move zero to counter + move "AAXAAAYAAAAZAAAAA" to item + inspect backward item tallying + counter for all "A" after "Z" before "X" + display "FOR ALL A after Z before X " counter + + move zero to counter + move "AAXAAAYAAAAZAAAAA" to item + inspect backward item tallying + counter for trailing "A" + display "FOR TRAILING A " counter + + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_TALLYING.out b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_TALLYING.out new file mode 100644 index 0000000..73d9006 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_BACKWARD_simple_TALLYING.out @@ -0,0 +1,14 @@ +AAXAAAYAAAAZAAAAA +Forward: +FOR ALL A 014 +FOR ALL A after X 012 +FOR ALL A before Z 009 +FOR ALL A after X before Z 007 +FOR TRAILING A 052 +Backward: +FOR ALL A 061 +FOR ALL A after X 002 +FOR ALL A before Z 005 +FOR ALL A after Z before X 007 +FOR TRAILING A 002 + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_NULL.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_NULL.cob new file mode 100644 index 0000000..26a760c1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_NULL.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(3) VALUE LOW-VALUES. + PROCEDURE DIVISION. + INSPECT X CONVERTING NULL TO "A". + IF X NOT = "AAA" + DISPLAY X NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constant.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constant.cob new file mode 100644 index 0000000..fe1605e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constant.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(3) VALUE "BCA". + PROCEDURE DIVISION. + INSPECT X CONVERTING "ABC" TO SPACES. + IF X NOT = SPACES + DISPLAY X NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constants.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constants.cob new file mode 100644 index 0000000..2983cce --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constants.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_CONVERTING_TO_figurative_constants.out" } + + identification division. + program-id. clouseau. + data division. + working-storage section. + 01 item pic x(12). + procedure division. + move all "abcd" to item + inspect item converting "abcd" to low-values + display "low-values " space """" item """" + move all "abcd" to item + inspect item converting "abcd" to spaces + display "spaces " space """" item """" + move all "abcd" to item + inspect item converting "abcd" to zeros + display "zeros " space """" item """" + move all "abcd" to item + inspect item converting "abcd" to quotes + display "quotes " space """" item """" + move all "abcd" to item + inspect item converting "abcd" to high-values + display "high-values" space """" item """" + goback. + end program clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constants.out b/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constants.out new file mode 100644 index 0000000..7de6e48 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constants.out @@ -0,0 +1,6 @@ +low-values "" +spaces " " +zeros "000000000000" +quotes """""""""""""" +high-values "ÿÿÿÿÿÿÿÿÿÿÿÿ" + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_1.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_1.cob new file mode 100644 index 0000000..1bbdea4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_1.cob @@ -0,0 +1,83 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_ISO_Example_1.out" } + Identification Division. + Program-Id. Clouseau. + Data Division. + Working-Storage Section. + 01 rows pic 99 value 3. + 01 counts pic 99 value 5. + + 01 rowlim pic 99. + 01 ncount pic 99. + + 01 inputs. + 05 row occurs 6 times indexed by counter. + 10 star PIC X. + 10 input PIC X(20). + 10 count PIC 99 occurs 5 times. + 10 output PIC X(20). + 77 len PIC 9(8). + Procedure Division. + *> Odd-numbered rows are "read only" and contain the inputs and expected + *> outputs. + *> Even-numbered rows are modified by the INSPECT statements and contain + *> the observed outputs + Move ' EFABDBCGABEFGG 0301010005TUXYXVWRXYZZPZ' to row(1). + Move ' BABABC 0200000101SXYXYZ' to row(3). + Move ' BBBC 0001000200SSVW' to row(5). +` + compute rowlim = 2*rows - 1 + + Display ' INPUT C0 C1 C2 C3 C4 OUTPUT' + Display ' -------------------- -- -- -- -- -- ----------------' + Perform Example-1 with test after + varying counter from 1 by 2 until counter >= rowlim. + + Goback. + + Inspection Section. + Example-1. + Move row(counter) to row(counter + 1) + + perform varying ncount from 1 by 1 until ncount > counts + Move Zero to count(counter + 1 ncount) + end-perform + + Move function length( function trim(input(counter)) ) to len. + MOVE INPUT(COUNTER) TO OUTPUT(COUNTER + 1) + INSPECT INPUT(COUNTER)(1:len) TALLYING + COUNT(counter + 1 1) FOR ALL "AB", ALL "D" + COUNT(counter + 1 2) FOR ALL "BC" + COUNT(counter + 1 3) FOR LEADING "EF" + COUNT(counter + 1 4) FOR LEADING "B" + COUNT(counter + 1 5) FOR CHARACTERS + INSPECT OUTPUT(COUNTER + 1)(1:len) REPLACING + ALL "AB" BY "XY", "D" BY "X" + ALL "BC" BY "VW" + LEADING "EF" BY "TU" + LEADING "B" BY "S" + FIRST "G" BY "R" + FIRST "G" BY "P" + CHARACTERS BY "Z" + + If row(counter) = row(counter + 1) then + Move '*' to star(counter + 1) + Else + Move '!' to star(counter + 1). + + Display star(counter) ' ' + input(counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(counter ncount) ' ' with no advancing + end-perform + display function trim (output(counter)) + + Display star(1 + counter) ' ' + input(1 + counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(1 + counter ncount) ' ' with no advancing + end-perform + display function trim (output(1 + counter)) + continue. + end program Clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_1.out b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_1.out new file mode 100644 index 0000000..b3b354c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_1.out @@ -0,0 +1,9 @@ + INPUT C0 C1 C2 C3 C4 OUTPUT + -------------------- -- -- -- -- -- ---------------- + EFABDBCGABEFGG 03 01 01 00 05 TUXYXVWRXYZZPZ +* EFABDBCGABEFGG 03 01 01 00 05 TUXYXVWRXYZZPZ + BABABC 02 00 00 01 01 SXYXYZ +* BABABC 02 00 00 01 01 SXYXYZ + BBBC 00 01 00 02 00 SSVW +* BBBC 00 01 00 02 00 SSVW + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_2.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_2.cob new file mode 100644 index 0000000..a464101 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_2.cob @@ -0,0 +1,75 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_ISO_Example_2.out" } + + Identification Division. + Program-Id. Clouseau. + Data Division. + Working-Storage Section. + 01 rows pic 99 value 2. + 01 counts pic 99 value 2. + + 01 rowlim pic 99. + 01 ncount pic 99. + + 01 inputs. + 05 row occurs 4 times indexed by counter. + 10 star PIC X. + 10 input PIC X(20). + 10 count PIC 99 occurs 2 times. + 10 output PIC X(20). + 77 len PIC 9(8). + Procedure Division. + *> Odd-numbered rows are "read only" and contain the inputs and expected + *> outputs. + *> Even-numbered rows are modified by the INSPECT statements and contain + *> the observed outputs + Move ' BBB 0300ZZZ' to row(1). + Move ' ABA 0300ZZZ' to row(3). +` + compute rowlim = 2*rows - 1 + + Display ' INPUT C0 C1 OUTPUT' + Display ' -------------------- -- -- ----------------' + Perform Example-1 with test after + varying counter from 1 by 2 until counter >= rowlim. + + Goback. + + Inspection Section. + Example-1. + Move row(counter) to row(counter + 1) + + perform varying ncount from 1 by 1 until ncount > counts + Move Zero to count(counter + 1 ncount) + end-perform + + Move function length( function trim(input(counter)) ) to len. + MOVE INPUT(COUNTER) TO OUTPUT(COUNTER + 1) + INSPECT INPUT(COUNTER)(1:len) TALLYING + COUNT(counter + 1 1) FOR CHARACTERS + COUNT(counter + 1 2) FOR ALL "A"; + INSPECT OUTPUT(COUNTER + 1)(1:len) REPLACING + CHARACTERS BY "Z" + ALL "A" BY "X" + + If row(counter) = row(counter + 1) then + Move '*' to star(counter + 1) + Else + Move '!' to star(counter + 1). + + Display star(counter) ' ' + input(counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(counter ncount) ' ' with no advancing + end-perform + display function trim(output(counter)) + + Display star(1 + counter) ' ' + input(1 + counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(1 + counter ncount) ' ' with no advancing + end-perform + display function trim(output(1 + counter)) + continue. + end program Clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_2.out b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_2.out new file mode 100644 index 0000000..65eb71c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_2.out @@ -0,0 +1,7 @@ + INPUT C0 C1 OUTPUT + -------------------- -- -- ---------------- + BBB 03 00 ZZZ +* BBB 03 00 ZZZ + ABA 03 00 ZZZ +* ABA 03 00 ZZZ + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_3.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_3.cob new file mode 100644 index 0000000..7111e9c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_3.cob @@ -0,0 +1,68 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_ISO_Example_3.out" } + + Identification Division. + Program-Id. Clouseau. + Data Division. + Working-Storage Section. + 01 inputs. + 05 row occurs 10 times indexed by counter. + 10 star PIC X. + 10 input PIC X(20). + 10 count PIC 99 occurs 3 times. + 10 output PIC X(20). + 77 len PIC 9(8). + + Procedure Division. + Move ' BBEABDABABBCABE 030002BBEXYZXYXYZCABV' to row(1). + Move ' ADDDDC 000004AZZZZC' to row(3). + Move ' ADDDDA 000005AZZZZZ' to row(5). + Move ' CDDDDC 000000CDDDDC' to row(7). + Move ' BDBBBDB 000300BDWWWDB' to row(9). +` + Display ' INPUT C0 C1 C2 OUTPUT' + Display ' -------------------- -- -- -- --------------------' + Perform Example-3 with test after + varying counter from 1 by 2 until counter = 9. + + Goback. + + Inspection Section. + Example-3. + Move row(counter) to row(counter + 1) + Move input(counter) to output(counter) + Move Zero to count(counter 1) + Move Zero to count(counter 2) + Move Zero to count(counter 3) + + Move function length( function trim(input(counter)) ) to len. + INSPECT OUTPUT(COUNTER)(1:len) TALLYING + COUNT(counter 1) FOR ALL "AB" BEFORE "BC" + COUNT(counter 2) FOR LEADING "B" AFTER "D" + COUNT(counter 3) FOR CHARACTERS AFTER "A" BEFORE "C"; + INSPECT OUTPUT(COUNTER)(1:len) REPLACING + ALL "AB" BY "XY" BEFORE "BC" + LEADING "B" BY "W" AFTER "D" + FIRST "E" BY "V" AFTER "D" + CHARACTERS BY "Z" AFTER "A" BEFORE "C" + + If row(counter) = row(counter + 1) then + Move '*' to star(counter + 1) + Else + Move '!' to star(counter + 1). + + Display star(counter) ' ' + input(counter) ' ' + count(counter 1) ' ' + count(counter 2) ' ' + count(counter 3) ' ' + function trim(output(counter)) + Display star(1 + counter) ' ' + input(1 + counter) ' ' + count(1 + counter 1) ' ' + count(1 + counter 2) ' ' + count(1 + counter 3) ' ' + function trim(output(1 + counter)) + continue. + end program Clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_3.out b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_3.out new file mode 100644 index 0000000..268fa3e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_3.out @@ -0,0 +1,13 @@ + INPUT C0 C1 C2 OUTPUT + -------------------- -- -- -- -------------------- + BBEABDABABBCABE 03 00 02 BBEXYZXYXYZCABV +* BBEABDABABBCABE 03 00 02 BBEXYZXYXYZCABV + ADDDDC 00 00 04 AZZZZC +* ADDDDC 00 00 04 AZZZZC + ADDDDA 00 00 05 AZZZZZ +* ADDDDA 00 00 05 AZZZZZ + CDDDDC 00 00 00 CDDDDC +* CDDDDC 00 00 00 CDDDDC + BDBBBDB 00 03 00 BDWWWDB +* BDBBBDB 00 03 00 BDWWWDB + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_4.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_4.cob new file mode 100644 index 0000000..192e1a8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_4.cob @@ -0,0 +1,71 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_ISO_Example_4.out" } + + Identification Division. + Program-Id. Clouseau. + Data Division. + Working-Storage Section. + 01 rows pic 99 value 1. + 01 counts pic 99 value 1. + + 01 rowlim pic 99. + 01 ncount pic 99. + + 01 inputs. + 05 row occurs 2 times indexed by counter. + 10 star PIC X. + 10 input PIC X(20). + 10 count PIC 99 occurs 1 times. + 10 output PIC X(20). + 77 len PIC 9(8). + Procedure Division. + *> Odd-numbered rows are "read only" and contain the inputs and expected + *> outputs. + *> Even-numbered rows are modified by the INSPECT statements and contain + *> the observed outputs + Move ' ABABABABC 01ABABXYABC' to row(1). +` + compute rowlim = 2*rows - 1 + + Display ' INPUT C0 C1 OUTPUT' + Display ' -------------------- -- -- ----------------' + Perform Example-1 with test after + varying counter from 1 by 2 until counter >= rowlim. + + Goback. + + Inspection Section. + Example-1. + Move row(counter) to row(counter + 1) + + perform varying ncount from 1 by 1 until ncount > counts + Move Zero to count(counter + 1 ncount) + end-perform + + Move function length( function trim(input(counter)) ) to len. + MOVE INPUT(COUNTER) TO OUTPUT(COUNTER + 1) + INSPECT INPUT(COUNTER)(1:len) TALLYING + COUNT(counter + 1 1) FOR ALL "AB" AFTER "BA" BEFORE "BC"; + INSPECT OUTPUT(COUNTER + 1)(1:len) REPLACING + ALL "AB" BY "XY" AFTER "BA" BEFORE "BC" + If row(counter) = row(counter + 1) then + Move '*' to star(counter + 1) + Else + Move '!' to star(counter + 1). + + Display star(counter) ' ' + input(counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(counter ncount) ' ' with no advancing + end-perform + display function trim(output(counter)) + + Display star(1 + counter) ' ' + input(1 + counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(1 + counter ncount) ' ' with no advancing + end-perform + display function trim(output(1 + counter)) + continue. + end program Clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_4.out b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_4.out new file mode 100644 index 0000000..a2ae6e5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_4.out @@ -0,0 +1,5 @@ + INPUT C0 C1 OUTPUT + -------------------- -- -- ---------------- + ABABABABC 01 ABABXYABC +* ABABABABC 01 ABABXYABC + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-f.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-f.cob new file mode 100644 index 0000000..0923720 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-f.cob @@ -0,0 +1,81 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_ISO_Example_5-f.out" } + + Identification Division. + Program-Id. Clouseau. + *> Note: Although modeled on Example-5 in Appendix D of the ISO 2023 + *> specification, all three of the samples are incorrect. This code + *> modifies the problem to make it somewhat more interesting, and, of + *> course, changes the answers so that they are correct for the problem. + Data Division. + Working-Storage Section. + 01 rows pic 99 value 3. + 01 counts pic 99 value 3. + + 01 rowlim pic 99. + 01 ncount pic 99. + + 01 inputs. + 05 row occurs 6 times indexed by counter. + 10 star PIC X. + 10 input PIC X(20). + 10 count PIC 99 occurs 3 times. + 10 output PIC X(20). + 77 len PIC 9(8). + Procedure Division. + *> Odd-numbered rows are "read only" and contain the inputs and expected + *> outputs. + *> Even-numbered rows are modified by the INSPECT statements and contain + *> the observed outputs + Move ' ABABBCAB 000106ABABBCXY' to row(1). + Move ' ABDBABC 000001AVDBABC' to row(3). + Move ' BCABCABD 010000BCABCAVD' to row(5). +` + compute rowlim = 2*rows - 1 + + Display ' INPUT C0 C1 C2 OUTPUT' + Display ' -------------------- -- -- -- ----------------' + Perform Example-1 with test after + varying counter from 1 by 2 until counter >= rowlim. + + Goback. + + Inspection Section. + Example-1. + Move row(counter) to row(counter + 1) + + perform varying ncount from 1 by 1 until ncount > counts + Move Zero to count(counter + 1 ncount) + end-perform + + Move function length( function trim(input(counter)) ) to len. + MOVE INPUT(COUNTER) TO OUTPUT(COUNTER + 1) + INSPECT BACKWARD INPUT(COUNTER)(1:len) TALLYING + COUNT(counter + 1 1) FOR ALL "AB" BEFORE "BC" + COUNT(counter + 1 2) FOR LEADING "B" + COUNT(counter + 1 3) FOR CHARACTERS AFTER "A" BEFORE "D" + INSPECT BACKWARD OUTPUT(COUNTER + 1)(1:len) REPLACING + ALL "AB" BY "XY" BEFORE "BC" + LEADING "B" BY "V" AFTER "D" + + If row(counter) = row(counter + 1) then + Move '*' to star(counter + 1) + Else + Move '!' to star(counter + 1). + + Display star(counter) ' ' + input(counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(counter ncount) ' ' with no advancing + end-perform + display function trim(output(counter)) + + Display star(1 + counter) ' ' + input(1 + counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(1 + counter ncount) ' ' with no advancing + end-perform + display function trim(output(1 + counter)) + continue. + end program Clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-f.out b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-f.out new file mode 100644 index 0000000..dbfef10 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-f.out @@ -0,0 +1,9 @@ + INPUT C0 C1 C2 OUTPUT + -------------------- -- -- -- ---------------- + ABABBCAB 00 01 06 ABABBCXY +* ABABBCAB 00 01 06 ABABBCXY + ABDBABC 00 00 01 AVDBABC +* ABDBABC 00 00 01 AVDBABC + BCABCABD 01 00 00 BCABCAVD +* BCABCABD 01 00 00 BCABCAVD + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-r.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-r.cob new file mode 100644 index 0000000..bf9299a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-r.cob @@ -0,0 +1,77 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_ISO_Example_5-r.out" } + + Identification Division. + Program-Id. Clouseau. + Data Division. + Working-Storage Section. + 01 rows pic 99 value 3. + 01 counts pic 99 value 3. + + 01 rowlim pic 99. + 01 ncount pic 99. + + 01 inputs. + 05 row occurs 6 times indexed by counter. + 10 star PIC X. + 10 input PIC X(20). + 10 count PIC 99 occurs 3 times. + 10 output PIC X(20). + 77 len PIC 9(8). + Procedure Division. + *> Odd-numbered rows are "read only" and contain the inputs and expected + *> outputs. + *> Even-numbered rows are modified by the INSPECT statements and contain + *> the observed outputs + Move ' BACBBABA 000004BACBBXYA' to row(1). + Move ' CBABDBA 000005CBAVDBA' to row(3). + Move ' DBACBACB 000100DBACBACB' to row(5). + + compute rowlim = 2*rows - 1 + + Display ' INPUT C0 C1 C2 C3 C4 OUTPUT' + Display ' -------------------- -- -- -- -- -- ----------------' + Perform Example-1 with test after + varying counter from 1 by 2 until counter >= rowlim. + + Goback. + + Inspection Section. + Example-1. + Move row(counter) to row(counter + 1) + + perform varying ncount from 1 by 1 until ncount > counts + Move Zero to count(counter + 1 ncount) + end-perform + + Move function length( function trim(input(counter)) ) to len. + MOVE INPUT(COUNTER) TO OUTPUT(COUNTER + 1) + INSPECT BACKWARD INPUT(COUNTER)(1:len) TALLYING + COUNT(counter + 1 1) FOR ALL "AB" BEFORE "BC" + COUNT(counter + 1 2) FOR LEADING "B" + COUNT(counter + 1 3) FOR CHARACTERS AFTER "A" BEFORE "C" + INSPECT BACKWARD OUTPUT(COUNTER + 1)(1:len) REPLACING + ALL "AB" BY "XY" BEFORE "BC" + LEADING "B" BY "V" AFTER "D" + + If row(counter) = row(counter + 1) then + Move '*' to star(counter + 1) + Else + Move '!' to star(counter + 1). + + Display star(counter) ' ' + input(counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(counter ncount) ' ' with no advancing + end-perform + display function trim(output(counter)) + + Display star(1 + counter) ' ' + input(1 + counter) ' ' with no advancing + perform varying ncount from 1 by 1 until ncount > counts + Display count(1 + counter ncount) ' ' with no advancing + end-perform + display function trim(output(1 + counter)) + continue. + end program Clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-r.out b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-r.out new file mode 100644 index 0000000..02e8d67 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5-r.out @@ -0,0 +1,9 @@ + INPUT C0 C1 C2 C3 C4 OUTPUT + -------------------- -- -- -- -- -- ---------------- + BACBBABA 00 00 04 BACBBXYA +* BACBBABA 00 00 04 BACBBXYA + CBABDBA 00 00 05 CBAVDBA +* CBABDBA 00 00 05 CBAVDBA + DBACBACB 00 01 00 DBACBACB +* DBACBACB 00 01 00 DBACBACB + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5.cob new file mode 100644 index 0000000..016777b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5.cob @@ -0,0 +1,90 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_ISO_Example_5.out" } + Identification Division. + Program-Id. Clouseau. + *> Note: Although modeled on Example-5 in Appendix D of the ISO 2023 + *> specification, all six of the samples are incorrect. + *> This code executes the examples as written, and the test suite checks + *> For the answers believed to be correct + Data Division. + Working-Storage Section. + 01 item-1 pic x(8) value "ABABBCAB". + 01 item-2 pic x(7) value "ABDBABC". + 01 item-3 pic x(8) value "BCABCABD". + 01 count-0 pic 9 value zero. + 01 count-1 pic 9 value zero. + 01 count-2 pic 9 value zero. + Procedure Division. + + initialize item-1 item-2 item-3 count-0 count-1 count-2 all value + display item-1 " " with no advancing + INSPECT BACKWARD ITEM-1 TALLYING + COUNT-0 FOR ALL "AB" BEFORE "BC" + COUNT-1 FOR LEADING "B" + COUNT-2 FOR CHARACTERS AFTER "A" BEFORE "C" + INSPECT BACKWARD ITEM-1 REPLACING + ALL "AB" BY "XY" BEFORE "BC" + LEADING "B" BY "V" AFTER "D" + display count-0 space count-1 space count-2 space item-1 + + initialize item-1 item-2 item-3 count-0 count-1 count-2 all value + display item-2 " " with no advancing + INSPECT BACKWARD ITEM-2 TALLYING + COUNT-0 FOR ALL "AB" BEFORE "BC" + COUNT-1 FOR LEADING "B" + COUNT-2 FOR CHARACTERS AFTER "A" BEFORE "C" + INSPECT BACKWARD ITEM-2 REPLACING + ALL "AB" BY "XY" BEFORE "BC" + LEADING "B" BY "V" AFTER "D" + display count-0 space count-1 space count-2 space item-2 + + initialize item-1 item-2 item-3 count-0 count-1 count-2 all value + display item-3 " " with no advancing + INSPECT BACKWARD ITEM-3 TALLYING + COUNT-0 FOR ALL "AB" BEFORE "BC" + COUNT-1 FOR LEADING "B" + COUNT-2 FOR CHARACTERS AFTER "A" BEFORE "C" + INSPECT BACKWARD ITEM-3 REPLACING + ALL "AB" BY "XY" BEFORE "BC" + LEADING "B" BY "V" AFTER "D" + display count-0 space count-1 space count-2 space item-3 + + initialize item-1 item-2 item-3 count-0 count-1 count-2 all value + MOVE FUNCTION REVERSE (ITEM-1) TO ITEM-1 + display item-1 " " with no advancing + INSPECT ITEM-1 TALLYING + COUNT-0 FOR ALL "AB" BEFORE "BC" + COUNT-1 FOR LEADING "B" + COUNT-2 FOR CHARACTERS AFTER "A" BEFORE "C" + INSPECT BACKWARD ITEM-1 REPLACING + ALL "AB" BY "XY" BEFORE "BC" + LEADING "B" BY "V" AFTER "D" + display count-0 space count-1 space count-2 space item-1 + + initialize item-1 item-2 item-3 count-0 count-1 count-2 all value + MOVE FUNCTION REVERSE (ITEM-2) TO ITEM-2 + display item-2 " " with no advancing + INSPECT ITEM-2 TALLYING + COUNT-0 FOR ALL "AB" BEFORE "BC" + COUNT-1 FOR LEADING "B" + COUNT-2 FOR CHARACTERS AFTER "A" BEFORE "C" + INSPECT BACKWARD ITEM-2 REPLACING + ALL "AB" BY "XY" BEFORE "BC" + LEADING "B" BY "V" AFTER "D" + display count-0 space count-1 space count-2 space item-2 + + initialize item-1 item-2 item-3 count-0 count-1 count-2 all value + MOVE FUNCTION REVERSE (ITEM-3) TO ITEM-3 + display item-3 " " with no advancing + INSPECT ITEM-3 TALLYING + COUNT-0 FOR ALL "AB" BEFORE "BC" + COUNT-1 FOR LEADING "B" + COUNT-2 FOR CHARACTERS AFTER "A" BEFORE "C" + INSPECT BACKWARD ITEM-3 REPLACING + ALL "AB" BY "XY" BEFORE "BC" + LEADING "B" BY "V" AFTER "D" + display count-0 space count-1 space count-2 space item-3 + + goback. + end program Clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5.out b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5.out new file mode 100644 index 0000000..afcfb72 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_5.out @@ -0,0 +1,7 @@ +ABABBCAB 0 1 0 ABABBCXY +ABDBABC 0 0 0 AVDBABC +BCABCABD 1 0 0 BCABCAVD +BACBBABA 1 1 0 BACBBXYA +CBABDBA 1 0 0 CBAVDBA +DBACBACB 0 0 0 DBACBACB + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_6.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_6.cob new file mode 100644 index 0000000..75917a2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_6.cob @@ -0,0 +1,58 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_ISO_Example_6.out" } + + Identification Division. + Program-Id. Clouseau. + Data Division. + Working-Storage Section. + 01 rows pic 99 value 1. + + 01 rowlim pic 99. + 01 ncount pic 99. + + 01 inputs. + 05 row occurs 6 times indexed by counter. + 10 star PIC X. + 10 input PIC X(20). + 10 output PIC X(20). + 77 len PIC 9(8). + Procedure Division. + *> Odd-numbered rows are "read only" and contain the inputs and expected + *> outputs. + *> Even-numbered rows are modified by the INSPECT statements and contain + *> the observed outputs + Move ' AC"AEBDFBCD#AB"D AC"XEYXFYZX#AB"D' to row(1). +` + compute rowlim = 2*rows - 1 + + Display ' INPUT OUTPUT' + Display ' -------------------- ----------------' + Perform Example-1 with test after + varying counter from 1 by 2 until counter >= rowlim. + + Goback. + + Inspection Section. + Example-1. + Move row(counter) to row(counter + 1) + + Move function length( function trim(input(counter)) ) to len. + MOVE INPUT(COUNTER) TO OUTPUT(COUNTER + 1) + INSPECT OUTPUT(COUNTER + 1)(1:len) CONVERTING + "ABCD" TO "XYZX" AFTER QUOTE BEFORE "#". + + If row(counter) = row(counter + 1) then + Move '*' to star(counter + 1) + Else + Move '!' to star(counter + 1). + + Display star(counter) ' ' + input(counter) ' ' with no advancing + display function trim(output(counter)) + + Display star(1 + counter) ' ' + input(1 + counter) ' ' with no advancing + display function trim(output(1 + counter)) + continue. + end program Clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_6.out b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_6.out new file mode 100644 index 0000000..dfe5f4b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_6.out @@ -0,0 +1,5 @@ + INPUT OUTPUT + -------------------- ---------------- + AC"AEBDFBCD#AB"D AC"XEYXFYZX#AB"D +* AC"AEBDFBCD#AB"D AC"XEYXFYZX#AB"D + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_7.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_7.cob new file mode 100644 index 0000000..ca2ae71 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_7.cob @@ -0,0 +1,65 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_ISO_Example_7.out" } + Identification Division. + Program-Id. Clouseau. + Data Division. + Working-Storage Section. + 01 rows pic 99 value 3. + + 01 rowlim pic 99. + 01 ncount pic 99. + + 01 inputs. + 05 row occurs 6 times indexed by counter. + 10 star PIC X. + 10 input PIC X(20). + 10 output PIC X(20). + 77 len PIC 9(8). + + Linkage Section. + 77 result PIC 9(8) Value 0. + + Procedure Division returning result. + *> Odd-numbered rows are "read only" and contain the inputs and expected + *> outputs. + *> Even-numbered rows are modified by the INSPECT statements and contain + *> the observed outputs + Move ' 415-245-1212 415-245-1212' to row(1). + Move ' 415-CH5-1212 415-??5-1212' to row(3). + Move ' 20%Numeric 20%???????' to row(5). +` + compute rowlim = 2*rows - 1 + + Display ' INPUT OUTPUT' + Display ' -------------------- ----------------' + Perform Example-1 with test after + varying counter from 1 by 2 until counter >= rowlim. + + Goback. + + Inspection Section. + Example-1. + Move row(counter) to row(counter + 1) + + Move function length( function trim(input(counter)) ) to len. + MOVE INPUT(COUNTER) TO OUTPUT(COUNTER + 1) + INSPECT OUTPUT(COUNTER + 1)(1:len) CONVERTING + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" + TO ALL "?" + + If row(counter) = row(counter + 1) then + Move '*' to star(counter + 1) + Else + Move 1 to result + Move '!' to star(counter + 1). + + Display star(counter) ' ' + input(counter) ' ' with no advancing + display function trim(output(counter)) + + Display star(1 + counter) ' ' + input(1 + counter) ' ' with no advancing + display function trim(output(1 + counter)) + continue. + end program Clouseau. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_7.out b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_7.out new file mode 100644 index 0000000..2418c36 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_ISO_Example_7.out @@ -0,0 +1,9 @@ + INPUT OUTPUT + -------------------- ---------------- + 415-245-1212 415-245-1212 +* 415-245-1212 415-245-1212 + 415-CH5-1212 415-??5-1212 +* 415-CH5-1212 415-??5-1212 + 20%Numeric 20%??????? +* 20%Numeric 20%??????? + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_No_repeat_conversion_check.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_No_repeat_conversion_check.cob new file mode 100644 index 0000000..358a1da --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_No_repeat_conversion_check.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(3) VALUE "BCA". + 01 Y PIC X(6) VALUE " BCA". + PROCEDURE DIVISION. + INSPECT X CONVERTING "ABC" TO "BCD". + IF X NOT = "CDB" + DISPLAY "X: " X. + INSPECT Y CONVERTING "ABC" TO "BCD". + IF Y NOT = " CDB" + DISPLAY "Y: " Y. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_REPLACING_LEADING_ZEROS_BY_SPACES.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_REPLACING_LEADING_ZEROS_BY_SPACES.cob new file mode 100644 index 0000000..d710292 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_REPLACING_LEADING_ZEROS_BY_SPACES.cob @@ -0,0 +1,13 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "0001". + PROCEDURE DIVISION. + INSPECT X REPLACING LEADING ZEROS BY SPACES. + IF X NOT = " 1" + DISPLAY "Should be ' 1' but is '" X "'". + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_REPLACING_figurative_constant.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_REPLACING_figurative_constant.cob new file mode 100644 index 0000000..5d706eb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_REPLACING_figurative_constant.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(3) VALUE "BCA". + PROCEDURE DIVISION. + INSPECT X REPLACING ALL "BC" BY SPACE. + IF X NOT = " A" + DISPLAY X NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_AFTER.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_AFTER.cob new file mode 100644 index 0000000..c8cd95e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_AFTER.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "ABC ". + 01 TAL PIC 999 VALUE 0. + PROCEDURE DIVISION. + MOVE 0 TO TAL. + INSPECT X TALLYING TAL FOR CHARACTERS + AFTER INITIAL " ". + IF TAL NOT = 0 + DISPLAY TAL NO ADVANCING + END-DISPLAY + END-IF. + MOVE 0 TO TAL. + MOVE " ABC" TO X. + INSPECT X TALLYING TAL FOR CHARACTERS + AFTER INITIAL " ". + IF TAL NOT = 3 + DISPLAY TAL NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_BEFORE.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_BEFORE.cob new file mode 100644 index 0000000..5640ff5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_BEFORE.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "ABC ". + 01 TAL PIC 999 VALUE 0. + PROCEDURE DIVISION. + MOVE 0 TO TAL. + INSPECT X TALLYING TAL FOR CHARACTERS + BEFORE INITIAL " ". + IF TAL NOT = 3 + DISPLAY TAL NO ADVANCING + END-DISPLAY + END-IF. + MOVE 0 TO TAL. + MOVE " ABC" TO X. + INSPECT X TALLYING TAL FOR CHARACTERS + BEFORE INITIAL " ". + IF TAL NOT = 0 + DISPLAY TAL NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_REPLACING_ISO_Example.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_REPLACING_ISO_Example.cob new file mode 100644 index 0000000..ab1a4118 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_REPLACING_ISO_Example.cob @@ -0,0 +1,142 @@ + *> { dg-do run } + *> { dg-output-file "group2/INSPECT_TALLYING_REPLACING_ISO_Example.out" } + + *> Example from ISO/IEC 2023 page 1151 + IDENTIFICATION DIVISION. + PROGRAM-ID. tests. + PROCEDURE DIVISION. + CALL "test1" + CALL "test2" + CALL "test3" + goback. + end program tests. + + IDENTIFICATION DIVISION. + PROGRAM-ID. test1. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 ITEM PIC X(14) VALUE "EFABDBCGABEFGG". + 01 COUNT-0 PIC 99 VALUE 0. + 01 COUNT-1 PIC 99 VALUE 0. + 01 COUNT-2 PIC 99 VALUE 0. + 01 COUNT-3 PIC 99 VALUE 0. + 01 COUNT-4 PIC 99 VALUE 0. + PROCEDURE DIVISION. + INSPECT ITEM TALLYING + COUNT-0 FOR ALL "AB", ALL "D" + COUNT-1 FOR ALL "BC" + COUNT-2 FOR LEADING "EF" + COUNT-3 FOR LEADING "B" + COUNT-4 FOR CHARACTERS; + INSPECT ITEM REPLACING + ALL "AB" BY "XY", "D" BY "X" + ALL "BC" BY "VW" + LEADING "EF" BY "TU" + LEADING "B" BY "S" + FIRST "G" BY "R" + FIRST "G" BY "P" + CHARACTERS BY "Z" + DISPLAY "Counts are: " + COUNT-0 SPACE + COUNT-1 SPACE + COUNT-2 SPACE + COUNT-3 SPACE + COUNT-4 + DISPLAY "Should be: " + "03" SPACE + "01" SPACE + "01" SPACE + "00" SPACE + "05" + DISPLAY "Result is " """" ITEM """" + MOVE "TUXYXVWRXYZZPZ" TO ITEM + DISPLAY "Should be " """" ITEM """" + GOBACK. + END PROGRAM test1. + + IDENTIFICATION DIVISION. + PROGRAM-ID. test2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 ITEM PIC X(6) VALUE "BABABC". + 01 COUNT-0 PIC 99 VALUE 0. + 01 COUNT-1 PIC 99 VALUE 0. + 01 COUNT-2 PIC 99 VALUE 0. + 01 COUNT-3 PIC 99 VALUE 0. + 01 COUNT-4 PIC 99 VALUE 0. + PROCEDURE DIVISION. + INSPECT ITEM TALLYING + COUNT-0 FOR ALL "AB", ALL "D" + COUNT-1 FOR ALL "BC" + COUNT-2 FOR LEADING "EF" + COUNT-3 FOR LEADING "B" + COUNT-4 FOR CHARACTERS; + INSPECT ITEM REPLACING + ALL "AB" BY "XY", "D" BY "X" + ALL "BC" BY "VW" + LEADING "EF" BY "TU" + LEADING "B" BY "S" + FIRST "G" BY "R" + FIRST "G" BY "P" + CHARACTERS BY "Z" + DISPLAY "Counts are: " + COUNT-0 SPACE + COUNT-1 SPACE + COUNT-2 SPACE + COUNT-3 SPACE + COUNT-4 + DISPLAY "Should be: " + "02" SPACE + "00" SPACE + "00" SPACE + "01" SPACE + "01" + DISPLAY "Result is " """" ITEM """" + MOVE "SXYXYZ" TO ITEM + DISPLAY "Should be " """" ITEM """" + GOBACK. + END PROGRAM test2. + + IDENTIFICATION DIVISION. + PROGRAM-ID. test3. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 ITEM PIC X(4) VALUE "BBBC". + 01 COUNT-0 PIC 99 VALUE 0. + 01 COUNT-1 PIC 99 VALUE 0. + 01 COUNT-2 PIC 99 VALUE 0. + 01 COUNT-3 PIC 99 VALUE 0. + 01 COUNT-4 PIC 99 VALUE 0. + PROCEDURE DIVISION. + INSPECT ITEM TALLYING + COUNT-0 FOR ALL "AB", ALL "D" + COUNT-1 FOR ALL "BC" + COUNT-2 FOR LEADING "EF" + COUNT-3 FOR LEADING "B" + COUNT-4 FOR CHARACTERS; + INSPECT ITEM REPLACING + ALL "AB" BY "XY", "D" BY "X" + ALL "BC" BY "VW" + LEADING "EF" BY "TU" + LEADING "B" BY "S" + FIRST "G" BY "R" + FIRST "G" BY "P" + CHARACTERS BY "Z" + DISPLAY "Counts are: " + COUNT-0 SPACE + COUNT-1 SPACE + COUNT-2 SPACE + COUNT-3 SPACE + COUNT-4 + DISPLAY "Should be: " + "00" SPACE + "01" SPACE + "00" SPACE + "02" SPACE + "00" + DISPLAY "Result is " """" ITEM """" + MOVE "SSVW" TO ITEM + DISPLAY "Should be " """" ITEM """" + GOBACK. + END PROGRAM test3. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_REPLACING_ISO_Example.out b/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_REPLACING_ISO_Example.out new file mode 100644 index 0000000..58f40fe --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_TALLYING_REPLACING_ISO_Example.out @@ -0,0 +1,13 @@ +Counts are: 03 01 01 00 05 +Should be: 03 01 01 00 05 +Result is "TUXYXVWRXYZZPZ" +Should be "TUXYXVWRXYZZPZ" +Counts are: 02 00 00 01 01 +Should be: 02 00 00 01 01 +Result is "SXYXYZ" +Should be "SXYXYZ" +Counts are: 00 01 00 02 00 +Should be: 00 01 00 02 00 +Result is "SSVW" +Should be "SSVW" + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_TRAILING.cob b/gcc/testsuite/cobol.dg/group2/INSPECT_TRAILING.cob new file mode 100644 index 0000000..231913c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_TRAILING.cob @@ -0,0 +1,58 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/INSPECT_TRAILING.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + 01 the-text pic x(30) value " middle". + 01 counter pic 9999. + 01 expected pic 9999. + 01 should-be pic zzz9. + 01 but-is pic zzz9. + 01 msg pic x(100). + procedure division. + + move "inspect for leading spaces" to msg + move zero to counter + inspect the-text tallying counter for leading spaces + move 4 to expected + perform result. + + move "inspect for trailing spaces with reverse" to msg + move zero to counter + inspect function reverse(the-text) tallying counter for leading spaces + move 20 to expected + perform result. + + move "inspect for trailing spaces with reversed variable" to msg + move function reverse(the-text) to the-text + move zero to counter + inspect the-text tallying counter for leading spaces + move 20 to expected + perform result. + + move "inspect for trailing spaces with INSPECT TRAILING extension" to msg + move function reverse(the-text) to the-text + move zero to counter + inspect the-text tallying counter for trailing spaces + move 20 to expected + perform result. + + inspect the-text replacing trailing space by "X" + display the-text + + stop run. + + result. + display function trim(msg) ": " with no advancing + move expected to should-be + if counter equal to expected + display function trim(should-be) + else + move counter to but-is + display "should be " function trim(should-be) + " but is " function trim(but-is) + end-if. + diff --git a/gcc/testsuite/cobol.dg/group2/INSPECT_TRAILING.out b/gcc/testsuite/cobol.dg/group2/INSPECT_TRAILING.out new file mode 100644 index 0000000..e55c3e9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_TRAILING.out @@ -0,0 +1,6 @@ +inspect for leading spaces: 4 +inspect for trailing spaces with reverse: 20 +inspect for trailing spaces with reversed variable: 20 +inspect for trailing spaces with INSPECT TRAILING extension: 20 + middleXXXXXXXXXXXXXXXXXXXX + diff --git a/gcc/testsuite/cobol.dg/group2/Indicators_______________-____D__.cob b/gcc/testsuite/cobol.dg/group2/Indicators_______________-____D__.cob new file mode 100644 index 0000000..fe988ee --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Indicators_______________-____D__.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + *> { dg-options "-ffixed-form" } + *> { dg-output-file "group2/Indicators_______________-____D__.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. FF2. + *Asterisk in correct column + / + PROCEDURE DIVISION. + DISPLAY "gekk + -"os rule". + DISPLAY "gerb + * ISO says blank and comment lines do not interfere with + * literal continuation + + -"ils don't rule". + * "D" is a deprecated feature of COBOL dropped from + * the ISO-IEC standard. Lines with "D" in the indicator + * column were enabled when OBJECT COMPUTER contained + * "WITH DEBUG MODE". Otherwise they were treated as + * comments. This behavior is a "vendor extension" to + * the current standard but allows old code to be used + * as it was prior to the deprecation. + D DISPLAY 'Should not display'. + EXIT PROGRAM. + diff --git a/gcc/testsuite/cobol.dg/group2/Indicators_______________-____D__.out b/gcc/testsuite/cobol.dg/group2/Indicators_______________-____D__.out new file mode 100644 index 0000000..8ad4d0a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Indicators_______________-____D__.out @@ -0,0 +1,3 @@ +gekkos rule +gerbils don't rule + diff --git a/gcc/testsuite/cobol.dg/group2/Intrinsics_without_FUNCTION_keyword__2_.cob b/gcc/testsuite/cobol.dg/group2/Intrinsics_without_FUNCTION_keyword__2_.cob new file mode 100644 index 0000000..b94adf5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Intrinsics_without_FUNCTION_keyword__2_.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + REPOSITORY. + FUNCTION PI + FUNCTION E. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC 99V99. + PROCEDURE DIVISION. + MOVE PI TO Z. + MOVE E TO Z. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MULTIPLY_to_FIX4.cob b/gcc/testsuite/cobol.dg/group2/MULTIPLY_to_FIX4.cob new file mode 100644 index 0000000..1f9b8dc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MULTIPLY_to_FIX4.cob @@ -0,0 +1,101 @@ + *> { dg-do run } + *> { dg-output-file "group2/MULTIPLY_to_FIX4.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. onsize. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FIX4DISPLAY PIC 9(4) DISPLAY. + 01 FIX4PACKED PIC 9(4) PACKED-DECIMAL. + 01 FIX4BINARY PIC 9(4) BINARY. + 01 FIX4COMP5 PIC 9(4) COMP-5. + 01 FLTSHORT FLOAT-SHORT. + 01 FLTLONG FLOAT-LONG. + 01 FLTEXT FLOAT-EXTENDED. + + PROCEDURE DIVISION. + + DISPLAY "Checking size error on FIX4DISPLAY" + MOVE 1 TO FIX4DISPLAY + PERFORM 10 TIMEs + DISPLAY " FIX4DISPLAY is : " FIX4DISPLAY + MULTIPLY 10 BY FIX4DISPLAY + ON SIZE ERROR DISPLAY " Got size error" GO TO DONE1 + END-MULTIPLY + END-PERFORM. + DONE1. + DISPLAY " Final is : " FIX4DISPLAY + DISPLAY "." + + DISPLAY "Checking size error on FIX4PACKED" + MOVE 1 TO FIX4PACKED + PERFORM 10 TIMEs + DISPLAY " FIX4PACKED is : " FIX4PACKED + MULTIPLY 10 BY FIX4PACKED + ON SIZE ERROR DISPLAY " Got size error" GO TO DONE2 + END-MULTIPLY + END-PERFORM. + DONE2. + DISPLAY " Final is : " FIX4PACKED + DISPLAY "." + + DISPLAY "Checking size error on FIX4BINARY" + MOVE 1 TO FIX4BINARY + PERFORM 10 TIMEs + DISPLAY " FIX4BINARY is : " FIX4BINARY + MULTIPLY 10 BY FIX4BINARY + ON SIZE ERROR DISPLAY " Got size error" GO TO DONE3 + END-MULTIPLY + END-PERFORM. + DONE3. + DISPLAY " Final is : " FIX4BINARY + DISPLAY "." + + DISPLAY "Checking size error on FIX4COMP5" + MOVE 1 TO FIX4COMP5 + PERFORM 10 TIMEs + DISPLAY " FIX4COMP5 is : " FIX4COMP5 + MULTIPLY 10 BY FIX4COMP5 + ON SIZE ERROR DISPLAY " Got size error" GO TO DONE4 + END-MULTIPLY + END-PERFORM. + DONE4. + DISPLAY " Final is : " FIX4COMP5 + DISPLAY "." + + DISPLAY "Checking size error on FLTSHORT" + MOVE 1.E34 TO FLTSHORT + PERFORM 10 TIMEs + DISPLAY " FLTSHORT is : " FLTSHORT + MULTIPLY 10 BY FLTSHORT + ON SIZE ERROR DISPLAY " Got size error" GO TO DONE5 + END-MULTIPLY + END-PERFORM. + DONE5. + DISPLAY " Final is : " FLTSHORT + DISPLAY "." + + MOVE 1.E304 TO FLTLONG + PERFORM 1000 TIMEs + DISPLAY " FLTLONG is : " FLTLONG + MULTIPLY 10 BY FLTLONG + ON SIZE ERROR DISPLAY " Got size error" GO TO DONE6 + END-MULTIPLY + END-PERFORM. + DONE6. + DISPLAY " Final is : " FLTLONG + DISPLAY "." + + MOVE 1.E4928 TO FLTEXT + PERFORM 10 TIMEs + DISPLAY " FLTEXT is : " FLTEXT + MULTIPLY 10 BY FLTEXT + ON SIZE ERROR DISPLAY " Got size error" GO TO DONE7 + END-MULTIPLY + END-PERFORM. + DONE7. + DISPLAY " Final is : " FLTEXT + DISPLAY ".". + + END PROGRAM onsize. + diff --git a/gcc/testsuite/cobol.dg/group2/MULTIPLY_to_FIX4.out b/gcc/testsuite/cobol.dg/group2/MULTIPLY_to_FIX4.out new file mode 100644 index 0000000..90cf292 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MULTIPLY_to_FIX4.out @@ -0,0 +1,58 @@ +Checking size error on FIX4DISPLAY + FIX4DISPLAY is : 0001 + FIX4DISPLAY is : 0010 + FIX4DISPLAY is : 0100 + FIX4DISPLAY is : 1000 + Got size error + Final is : 1000 +. +Checking size error on FIX4PACKED + FIX4PACKED is : 0001 + FIX4PACKED is : 0010 + FIX4PACKED is : 0100 + FIX4PACKED is : 1000 + Got size error + Final is : 1000 +. +Checking size error on FIX4BINARY + FIX4BINARY is : 0001 + FIX4BINARY is : 0010 + FIX4BINARY is : 0100 + FIX4BINARY is : 1000 + Got size error + Final is : 1000 +. +Checking size error on FIX4COMP5 + FIX4COMP5 is : 0001 + FIX4COMP5 is : 0010 + FIX4COMP5 is : 0100 + FIX4COMP5 is : 1000 + Got size error + Final is : 1000 +. +Checking size error on FLTSHORT + FLTSHORT is : 9.99999979E+33 + FLTSHORT is : 9.999999419E+34 + FLTSHORT is : 9.999999617E+35 + FLTSHORT is : 9.999999934E+36 + FLTSHORT is : 9.99999968E+37 + Got size error + Final is : 9.99999968E+37 +. + FLTLONG is : 9.99999999999999939E+303 + FLTLONG is : 9.99999999999999939E+304 + FLTLONG is : 9.99999999999999861E+305 + FLTLONG is : 9.99999999999999861E+306 + FLTLONG is : 9.99999999999999811E+307 + Got size error + Final is : 9.99999999999999811E+307 +. + FLTEXT is : 9.999999999999999999999999999999999576E+4927 + FLTEXT is : 9.999999999999999999999999999999999856E+4928 + FLTEXT is : 1.000000000000000000000000000000000053E+4930 + FLTEXT is : 1.000000000000000000000000000000000124E+4931 + FLTEXT is : 1.000000000000000000000000000000000124E+4932 + Got size error + Final is : 1.000000000000000000000000000000000124E+4932 +. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_arithmetic.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_arithmetic.cob new file mode 100644 index 0000000..09303a2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_arithmetic.cob @@ -0,0 +1,24 @@ + *> { dg-do run } + *> { dg-output-file "group2/PACKED-DECIMAL_arithmetic.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99 USAGE PACKED-DECIMAL VALUE 0. + 01 Y PIC 99 USAGE PACKED-DECIMAL VALUE 9. + PROCEDURE DIVISION. + COMPUTE X = 1 + END-COMPUTE. + DISPLAY X + END-DISPLAY. + COMPUTE X = Y + END-COMPUTE. + DISPLAY X + END-DISPLAY. + COMPUTE X = X + Y + END-COMPUTE. + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_arithmetic.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_arithmetic.out new file mode 100644 index 0000000..79f7d9d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_arithmetic.out @@ -0,0 +1,4 @@ +01 +09 +18 + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__1_.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__1_.cob new file mode 100644 index 0000000..f718cf4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__1_.cob @@ -0,0 +1,52 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/PACKED-DECIMAL_basic_comp-3_comp-6__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x1 PIC 9 COMP-3. + 01 x2 PIC 99 COMP-3. + 01 x3 PIC 999 COMP-3. + 01 x4 PIC 9999 COMP-3. + 01 x5 PIC 99999 COMP-3. + 01 x6 PIC 999999 COMP-3. + 01 y1 PIC 9 COMP-6. + 01 y2 PIC 99 COMP-6. + 01 y3 PIC 999 COMP-6. + 01 y4 PIC 9999 COMP-6. + 01 y5 PIC 99999 COMP-6. + 01 y6 PIC 999999 COMP-6. + procedure division. + display "check lengths of comp-3" + display FUNCTION LENGTH(x1) " should be 1" + display FUNCTION LENGTH(x2) " should be 2" + display FUNCTION LENGTH(x3) " should be 2" + display FUNCTION LENGTH(x4) " should be 3" + display FUNCTION LENGTH(x5) " should be 3" + display FUNCTION LENGTH(x6) " should be 4" + display "check lengths of comp-6" + display FUNCTION LENGTH(y1) " should be 1" + display FUNCTION LENGTH(y2) " should be 1" + display FUNCTION LENGTH(y3) " should be 2" + display FUNCTION LENGTH(y4) " should be 2" + display FUNCTION LENGTH(y5) " should be 3" + display FUNCTION LENGTH(y6) " should be 3" + move 654321 to x1 x2 x3 x4 x5 x6 y1 y2 y3 y4 y5 y6 + display "results of MOVE TO COMP-3" + display x1 + display x2 + display x3 + display x4 + display x5 + display x6 + display "results of MOVE TO COMP-6" + display y1 + display y2 + display y3 + display y4 + display y5 + display y6 + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__1_.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__1_.out new file mode 100644 index 0000000..ae8169d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__1_.out @@ -0,0 +1,29 @@ +check lengths of comp-3 +1 should be 1 +2 should be 2 +2 should be 2 +3 should be 3 +3 should be 3 +4 should be 4 +check lengths of comp-6 +1 should be 1 +1 should be 1 +2 should be 2 +2 should be 2 +3 should be 3 +3 should be 3 +results of MOVE TO COMP-3 +1 +21 +321 +4321 +54321 +654321 +results of MOVE TO COMP-6 +1 +21 +321 +4321 +54321 +654321 + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.cob new file mode 100644 index 0000000..52a4e0a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.cob @@ -0,0 +1,41 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + 01 vars. + 05 var1d . + 10 var01 pic 99v99 comp-3 value 43.21 . + 10 filler binary-double value zero . + 05 var1 redefines var1d pointer . + 05 var2d . + 10 var02 pic s99v99 comp-3 value 43.21 . + 10 filler binary-double value zero . + 05 var2 redefines var2d pointer . + 05 var3d . + 10 var03 pic s99v99 comp-3 value -43.21 . + 10 filler binary-double value zero . + 05 var3 redefines var3d pointer . + 05 var4d . + 10 var04 pic 99v99 comp-6 value 43.21 . + 10 filler binary-double value zero . + 05 var4 redefines var4d pointer . + procedure division. + display length of var01 space var1 space space var01 + display length of var02 space var2 space var02 + display length of var03 space var3 space var03 + display length of var04 space var4 space space var04 + move 12.34 to var01 + move 12.34 to var02 + move 12.34 to var03 + move 12.34 to var04 + display function length(var01) space var1 space space var01 + display function length(var02) space var2 space var02 + display function length(var03) space var3 space var03 + display function length(var04) space var4 space space var04 + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out new file mode 100644 index 0000000..6acdee4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out @@ -0,0 +1,9 @@ +3 0x00000000001f3204 43.21 +3 0x00000000001c3204 +43.21 +3 0x00000000001d3204 -43.21 +2 0x0000000000002143 43.21 +3 0x00000000004f2301 12.34 +3 0x00000000004c2301 +12.34 +3 0x00000000004c2301 +12.34 +2 0x0000000000003412 12.34 + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_dump.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_dump.cob new file mode 100644 index 0000000..f4c7550 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_dump.cob @@ -0,0 +1,486 @@ + *> { dg-do run } + *> { dg-output-file "group2/PACKED-DECIMAL_dump.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G-1. + 02 X-1 PIC 9(1) VALUE 1 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-2. + 02 X-2 PIC 9(2) VALUE 12 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-3. + 02 X-3 PIC 9(3) VALUE 123 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-4. + 02 X-4 PIC 9(4) VALUE 1234 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-5. + 02 X-5 PIC 9(5) VALUE 12345 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-6. + 02 X-6 PIC 9(6) VALUE 123456 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-7. + 02 X-7 PIC 9(7) VALUE 1234567 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-8. + 02 X-8 PIC 9(8) VALUE 12345678 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-9. + 02 X-9 PIC 9(9) VALUE 123456789 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-10. + 02 X-10 PIC 9(10) VALUE 1234567890 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-11. + 02 X-11 PIC 9(11) VALUE 12345678901 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-12. + 02 X-12 PIC 9(12) VALUE 123456789012 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-13. + 02 X-13 PIC 9(13) VALUE 1234567890123 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-14. + 02 X-14 PIC 9(14) VALUE 12345678901234 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-15. + 02 X-15 PIC 9(15) VALUE 123456789012345 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-16. + 02 X-16 PIC 9(16) VALUE 1234567890123456 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-17. + 02 X-17 PIC 9(17) VALUE 12345678901234567 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-18. + 02 X-18 PIC 9(18) VALUE 123456789012345678 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S1. + 02 X-S1 PIC S9(1) VALUE -1 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S2. + 02 X-S2 PIC S9(2) VALUE -12 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S3. + 02 X-S3 PIC S9(3) VALUE -123 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S4. + 02 X-S4 PIC S9(4) VALUE -1234 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S5. + 02 X-S5 PIC S9(5) VALUE -12345 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S6. + 02 X-S6 PIC S9(6) VALUE -123456 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S7. + 02 X-S7 PIC S9(7) VALUE -1234567 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S8. + 02 X-S8 PIC S9(8) VALUE -12345678 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S9. + 02 X-S9 PIC S9(9) VALUE -123456789 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S10. + 02 X-S10 PIC S9(10) VALUE -1234567890 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S11. + 02 X-S11 PIC S9(11) VALUE -12345678901 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S12. + 02 X-S12 PIC S9(12) VALUE -123456789012 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S13. + 02 X-S13 PIC S9(13) VALUE -1234567890123 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S14. + 02 X-S14 PIC S9(14) VALUE -12345678901234 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S15. + 02 X-S15 PIC S9(15) VALUE -123456789012345 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S16. + 02 X-S16 PIC S9(16) VALUE -1234567890123456 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S17. + 02 X-S17 PIC S9(17) VALUE -12345678901234567 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + 01 G-S18. + 02 X-S18 PIC S9(18) VALUE -123456789012345678 + COMP-3. + 02 FILLER PIC X(18) VALUE SPACE. + PROCEDURE DIVISION. + *> Dump all values + CALL "dump" USING G-1 + END-CALL. + CALL "dump" USING G-2 + END-CALL. + CALL "dump" USING G-3 + END-CALL. + CALL "dump" USING G-4 + END-CALL. + CALL "dump" USING G-5 + END-CALL. + CALL "dump" USING G-6 + END-CALL. + CALL "dump" USING G-7 + END-CALL. + CALL "dump" USING G-8 + END-CALL. + CALL "dump" USING G-9 + END-CALL. + CALL "dump" USING G-10 + END-CALL. + CALL "dump" USING G-11 + END-CALL. + CALL "dump" USING G-12 + END-CALL. + CALL "dump" USING G-13 + END-CALL. + CALL "dump" USING G-14 + END-CALL. + CALL "dump" USING G-15 + END-CALL. + CALL "dump" USING G-16 + END-CALL. + CALL "dump" USING G-17 + END-CALL. + CALL "dump" USING G-18 + END-CALL. + CALL "dump" USING G-S1 + END-CALL. + CALL "dump" USING G-S2 + END-CALL. + CALL "dump" USING G-S3 + END-CALL. + CALL "dump" USING G-S4 + END-CALL. + CALL "dump" USING G-S5 + END-CALL. + CALL "dump" USING G-S6 + END-CALL. + CALL "dump" USING G-S7 + END-CALL. + CALL "dump" USING G-S8 + END-CALL. + CALL "dump" USING G-S9 + END-CALL. + CALL "dump" USING G-S10 + END-CALL. + CALL "dump" USING G-S11 + END-CALL. + CALL "dump" USING G-S12 + END-CALL. + CALL "dump" USING G-S13 + END-CALL. + CALL "dump" USING G-S14 + END-CALL. + CALL "dump" USING G-S15 + END-CALL. + CALL "dump" USING G-S16 + END-CALL. + CALL "dump" USING G-S17 + END-CALL. + CALL "dump" USING G-S18 + END-CALL. + INITIALIZE X-1. + CALL "dump" USING G-1 + END-CALL. + INITIALIZE X-2. + CALL "dump" USING G-2 + END-CALL. + INITIALIZE X-3. + CALL "dump" USING G-3 + END-CALL. + INITIALIZE X-4. + CALL "dump" USING G-4 + END-CALL. + INITIALIZE X-5. + CALL "dump" USING G-5 + END-CALL. + INITIALIZE X-6. + CALL "dump" USING G-6 + END-CALL. + INITIALIZE X-7. + CALL "dump" USING G-7 + END-CALL. + INITIALIZE X-8. + CALL "dump" USING G-8 + END-CALL. + INITIALIZE X-9. + CALL "dump" USING G-9 + END-CALL. + INITIALIZE X-10. + CALL "dump" USING G-10 + END-CALL. + INITIALIZE X-11. + CALL "dump" USING G-11 + END-CALL. + INITIALIZE X-12. + CALL "dump" USING G-12 + END-CALL. + INITIALIZE X-13. + CALL "dump" USING G-13 + END-CALL. + INITIALIZE X-14. + CALL "dump" USING G-14 + END-CALL. + INITIALIZE X-15. + CALL "dump" USING G-15 + END-CALL. + INITIALIZE X-16. + CALL "dump" USING G-16 + END-CALL. + INITIALIZE X-17. + CALL "dump" USING G-17 + END-CALL. + INITIALIZE X-18. + CALL "dump" USING G-18 + END-CALL. + INITIALIZE X-S1. + CALL "dump" USING G-S1 + END-CALL. + INITIALIZE X-S2. + CALL "dump" USING G-S2 + END-CALL. + INITIALIZE X-S3. + CALL "dump" USING G-S3 + END-CALL. + INITIALIZE X-S4. + CALL "dump" USING G-S4 + END-CALL. + INITIALIZE X-S5. + CALL "dump" USING G-S5 + END-CALL. + INITIALIZE X-S6. + CALL "dump" USING G-S6 + END-CALL. + INITIALIZE X-S7. + CALL "dump" USING G-S7 + END-CALL. + INITIALIZE X-S8. + CALL "dump" USING G-S8 + END-CALL. + INITIALIZE X-S9. + CALL "dump" USING G-S9 + END-CALL. + INITIALIZE X-S10. + CALL "dump" USING G-S10 + END-CALL. + INITIALIZE X-S11. + CALL "dump" USING G-S11 + END-CALL. + INITIALIZE X-S12. + CALL "dump" USING G-S12 + END-CALL. + INITIALIZE X-S13. + CALL "dump" USING G-S13 + END-CALL. + INITIALIZE X-S14. + CALL "dump" USING G-S14 + END-CALL. + INITIALIZE X-S15. + CALL "dump" USING G-S15 + END-CALL. + INITIALIZE X-S16. + CALL "dump" USING G-S16 + END-CALL. + INITIALIZE X-S17. + CALL "dump" USING G-S17 + END-CALL. + INITIALIZE X-S18. + CALL "dump" USING G-S18 + END-CALL. + MOVE ZERO TO X-1. + CALL "dump" USING G-1 + END-CALL. + MOVE ZERO TO X-2. + CALL "dump" USING G-2 + END-CALL. + MOVE ZERO TO X-3. + CALL "dump" USING G-3 + END-CALL. + MOVE ZERO TO X-4. + CALL "dump" USING G-4 + END-CALL. + MOVE ZERO TO X-5. + CALL "dump" USING G-5 + END-CALL. + MOVE ZERO TO X-6. + CALL "dump" USING G-6 + END-CALL. + MOVE ZERO TO X-7. + CALL "dump" USING G-7 + END-CALL. + MOVE ZERO TO X-8. + CALL "dump" USING G-8 + END-CALL. + MOVE ZERO TO X-9. + CALL "dump" USING G-9 + END-CALL. + MOVE ZERO TO X-10. + CALL "dump" USING G-10 + END-CALL. + MOVE ZERO TO X-11. + CALL "dump" USING G-11 + END-CALL. + MOVE ZERO TO X-12. + CALL "dump" USING G-12 + END-CALL. + MOVE ZERO TO X-13. + CALL "dump" USING G-13 + END-CALL. + MOVE ZERO TO X-14. + CALL "dump" USING G-14 + END-CALL. + MOVE ZERO TO X-15. + CALL "dump" USING G-15 + END-CALL. + MOVE ZERO TO X-16. + CALL "dump" USING G-16 + END-CALL. + MOVE ZERO TO X-17. + CALL "dump" USING G-17 + END-CALL. + MOVE ZERO TO X-18. + CALL "dump" USING G-18 + END-CALL. + MOVE ZERO TO X-S1. + CALL "dump" USING G-S1 + END-CALL. + MOVE ZERO TO X-S2. + CALL "dump" USING G-S2 + END-CALL. + MOVE ZERO TO X-S3. + CALL "dump" USING G-S3 + END-CALL. + MOVE ZERO TO X-S4. + CALL "dump" USING G-S4 + END-CALL. + MOVE ZERO TO X-S5. + CALL "dump" USING G-S5 + END-CALL. + MOVE ZERO TO X-S6. + CALL "dump" USING G-S6 + END-CALL. + MOVE ZERO TO X-S7. + CALL "dump" USING G-S7 + END-CALL. + MOVE ZERO TO X-S8. + CALL "dump" USING G-S8 + END-CALL. + MOVE ZERO TO X-S9. + CALL "dump" USING G-S9 + END-CALL. + MOVE ZERO TO X-S10. + CALL "dump" USING G-S10 + END-CALL. + MOVE ZERO TO X-S11. + CALL "dump" USING G-S11 + END-CALL. + MOVE ZERO TO X-S12. + CALL "dump" USING G-S12 + END-CALL. + MOVE ZERO TO X-S13. + CALL "dump" USING G-S13 + END-CALL. + MOVE ZERO TO X-S14. + CALL "dump" USING G-S14 + END-CALL. + MOVE ZERO TO X-S15. + CALL "dump" USING G-S15 + END-CALL. + MOVE ZERO TO X-S16. + CALL "dump" USING G-S16 + END-CALL. + MOVE ZERO TO X-S17. + CALL "dump" USING G-S17 + END-CALL. + MOVE ZERO TO X-S18. + CALL "dump" USING G-S18 + END-CALL. + STOP RUN. + END PROGRAM prog. + IDENTIFICATION DIVISION. + PROGRAM-ID. dump. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 HEXCHARS. + 02 HEXCHART PIC X(16) VALUE "0123456789abcdef". + 02 HEXCHAR REDEFINES HEXCHART PIC X OCCURS 16. + 01 BYTE-TO-DUMP PIC X(1). + 01 FILLER. + 02 DUMPER1 PIC 9999 COMP-5. + 02 DUMPER2 REDEFINES DUMPER1 PIC X(1). + 01 THE-BYTE PIC 99. + 01 LADVANCE PIC 9. + LINKAGE SECTION. + 01 G-VAL PIC X(20). + 01 G-PTR REDEFINES G-VAL USAGE POINTER. + PROCEDURE DIVISION USING G-VAL. + MOVE 1 TO THE-BYTE + MOVE 0 TO LADVANCE + PERFORM UNTIL THE-BYTE GREATER THAN 10 + MOVE G-VAL(THE-BYTE:1) TO BYTE-TO-DUMP + IF THE-BYTE EQUAL TO 10 MOVE 1 TO LADVANCE END-IF + PERFORM DUMP-BYTE + ADD 1 TO THE-BYTE + END-PERFORM. + GOBACK. + DUMP-BYTE. + MOVE ZERO TO DUMPER1 + MOVE BYTE-TO-DUMP TO DUMPER2 + DIVIDE DUMPER1 BY 16 GIVING DUMPER1 + ADD 1 TO DUMPER1 + DISPLAY HEXCHAR(DUMPER1) NO ADVANCING. + MOVE ZERO TO DUMPER1 + MOVE BYTE-TO-DUMP TO DUMPER2 + MOVE FUNCTION MOD(DUMPER1 16) TO DUMPER1 + ADD 1 TO DUMPER1 + IF LADVANCE EQUAL TO 1 THEN + DISPLAY HEXCHAR(DUMPER1) + ELSE + DISPLAY HEXCHAR(DUMPER1) NO ADVANCING + END-IF. + END PROGRAM dump. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_dump.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_dump.out new file mode 100644 index 0000000..31a5a79 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_dump.out @@ -0,0 +1,109 @@ +1f202020202020202020 +012f2020202020202020 +123f2020202020202020 +01234f20202020202020 +12345f20202020202020 +0123456f202020202020 +1234567f202020202020 +012345678f2020202020 +123456789f2020202020 +01234567890f20202020 +12345678901f20202020 +0123456789012f202020 +1234567890123f202020 +012345678901234f2020 +123456789012345f2020 +01234567890123456f20 +12345678901234567f20 +0123456789012345678f +1d202020202020202020 +012d2020202020202020 +123d2020202020202020 +01234d20202020202020 +12345d20202020202020 +0123456d202020202020 +1234567d202020202020 +012345678d2020202020 +123456789d2020202020 +01234567890d20202020 +12345678901d20202020 +0123456789012d202020 +1234567890123d202020 +012345678901234d2020 +123456789012345d2020 +01234567890123456d20 +12345678901234567d20 +0123456789012345678d +0f202020202020202020 +000f2020202020202020 +000f2020202020202020 +00000f20202020202020 +00000f20202020202020 +0000000f202020202020 +0000000f202020202020 +000000000f2020202020 +000000000f2020202020 +00000000000f20202020 +00000000000f20202020 +0000000000000f202020 +0000000000000f202020 +000000000000000f2020 +000000000000000f2020 +00000000000000000f20 +00000000000000000f20 +0000000000000000000f +0c202020202020202020 +000c2020202020202020 +000c2020202020202020 +00000c20202020202020 +00000c20202020202020 +0000000c202020202020 +0000000c202020202020 +000000000c2020202020 +000000000c2020202020 +00000000000c20202020 +00000000000c20202020 +0000000000000c202020 +0000000000000c202020 +000000000000000c2020 +000000000000000c2020 +00000000000000000c20 +00000000000000000c20 +0000000000000000000c +0f202020202020202020 +000f2020202020202020 +000f2020202020202020 +00000f20202020202020 +00000f20202020202020 +0000000f202020202020 +0000000f202020202020 +000000000f2020202020 +000000000f2020202020 +00000000000f20202020 +00000000000f20202020 +0000000000000f202020 +0000000000000f202020 +000000000000000f2020 +000000000000000f2020 +00000000000000000f20 +00000000000000000f20 +0000000000000000000f +0c202020202020202020 +000c2020202020202020 +000c2020202020202020 +00000c20202020202020 +00000c20202020202020 +0000000c202020202020 +0000000c202020202020 +000000000c2020202020 +000000000c2020202020 +00000000000c20202020 +00000000000c20202020 +0000000000000c202020 +0000000000000c202020 +000000000000000c2020 +000000000000000c2020 +00000000000000000c20 +00000000000000000c20 +0000000000000000000c + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__1_.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__1_.cob new file mode 100644 index 0000000..a117325 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__1_.cob @@ -0,0 +1,119 @@ + *> { dg-do run } + *> { dg-output-file "group2/PACKED-DECIMAL_numeric_test__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X-2 PIC X(2). + 02 N-2 REDEFINES X-2 PIC 999 USAGE PACKED-DECIMAL. + 02 N-S2 REDEFINES X-2 PIC S999 USAGE PACKED-DECIMAL. + PROCEDURE DIVISION. + MOVE X"0000" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "1 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "2 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + MOVE X"000c" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "3 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "OK" + END-DISPLAY + ELSE + DISPLAY "4 NG" + END-DISPLAY + END-IF. + MOVE X"000d" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "5 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "OK" + END-DISPLAY + ELSE + DISPLAY "6 NG" + END-DISPLAY + END-IF. + MOVE X"000f" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "OK" + END-DISPLAY + ELSE + DISPLAY "7 NG" + END-DISPLAY + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "8 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + MOVE X"1234" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "9 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "10 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + MOVE X"999f" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "OK" + END-DISPLAY + ELSE + DISPLAY "11 NG" + END-DISPLAY + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "12 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + MOVE X"ffff" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "13 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "14 NG" + END-DISPLAY + ELSE + DISPLAY "OK" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__1_.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__1_.out new file mode 100644 index 0000000..b2fdeb2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__1_.out @@ -0,0 +1,15 @@ +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__2_.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__2_.cob new file mode 100644 index 0000000..7c7d2b0 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__2_.cob @@ -0,0 +1,91 @@ + *> { dg-do run } + *> { dg-output-file "group2/PACKED-DECIMAL_numeric_test__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X-2 PIC X(2). + 02 N-2 REDEFINES X-2 PIC 999 USAGE PACKED-DECIMAL. + 02 N-S2 REDEFINES X-2 PIC S999 USAGE PACKED-DECIMAL. + PROCEDURE DIVISION. + MOVE X"0000" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "NG 1" + ELSE + DISPLAY "OK" + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "NG 2" + ELSE + DISPLAY "OK" + END-IF. + MOVE X"000c" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "NG 3" + ELSE + DISPLAY "OK" + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "OK" + ELSE + DISPLAY "NG 4" + END-IF. + MOVE X"000d" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "NG 5" + ELSE + DISPLAY "OK" + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "OK" + ELSE + DISPLAY "NG 6" + END-IF. + MOVE X"000f" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "OK" + ELSE + DISPLAY "NG 7" + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "NG 8" + ELSE + DISPLAY "OK" + END-IF. + MOVE X"1234" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "NG 9" + ELSE + DISPLAY "OK" + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "NG 10" + ELSE + DISPLAY "OK" + END-IF. + MOVE X"999f" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "OK" + ELSE + DISPLAY "NG 11" + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "NG 12" + ELSE + DISPLAY "OK" + END-IF. + MOVE X"ffff" TO X-2. + IF N-2 IS NUMERIC + DISPLAY "NG 13" + ELSE + DISPLAY "OK" + END-IF. + IF N-S2 IS NUMERIC + DISPLAY "NG 14" + ELSE + DISPLAY "OK" + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__2_.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__2_.out new file mode 100644 index 0000000..b2fdeb2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_numeric_test__2_.out @@ -0,0 +1,15 @@ +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK +OK + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_DISPLAY.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_DISPLAY.cob new file mode 100644 index 0000000..4b3d391 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_DISPLAY.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + *> { dg-output-file "group2/PACKED-DECIMAL_used_with_DISPLAY.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-99 PIC 99 USAGE PACKED-DECIMAL. + 01 X-S99 PIC S99 USAGE PACKED-DECIMAL. + 01 X-999 PIC 999 USAGE PACKED-DECIMAL. + 01 X-S999 PIC S999 USAGE PACKED-DECIMAL. + PROCEDURE DIVISION. + MOVE 0 TO X-99. + DISPLAY X-99 + END-DISPLAY. + MOVE 99 TO X-99. + DISPLAY X-99 + END-DISPLAY. + MOVE 0 TO X-S99. + DISPLAY X-S99 + END-DISPLAY. + MOVE -1 TO X-S99. + DISPLAY X-S99 + END-DISPLAY. + MOVE 0 TO X-999. + DISPLAY X-999 + END-DISPLAY. + MOVE 123 TO X-999. + DISPLAY X-999 + END-DISPLAY. + MOVE 0 TO X-S999. + DISPLAY X-S999 + END-DISPLAY. + MOVE -123 TO X-S999. + DISPLAY X-S999 + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_DISPLAY.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_DISPLAY.out new file mode 100644 index 0000000..4d26a95 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_DISPLAY.out @@ -0,0 +1,9 @@ +00 +99 ++00 +-01 +000 +123 ++000 +-123 + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_INITIALIZE.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_INITIALIZE.cob new file mode 100644 index 0000000..5bd324b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_INITIALIZE.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + *> { dg-output-file "group2/PACKED-DECIMAL_used_with_INITIALIZE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-99 PIC 99 USAGE PACKED-DECIMAL. + 01 X-S99 PIC S99 USAGE PACKED-DECIMAL. + 01 X-999 PIC 999 USAGE PACKED-DECIMAL. + 01 X-S999 PIC S999 USAGE PACKED-DECIMAL. + PROCEDURE DIVISION. + INITIALIZE X-99. + DISPLAY X-99 + END-DISPLAY. + INITIALIZE X-S99. + DISPLAY X-S99 + END-DISPLAY. + INITIALIZE X-999. + DISPLAY X-999 + END-DISPLAY. + INITIALIZE X-S999. + DISPLAY X-S999 + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_INITIALIZE.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_INITIALIZE.out new file mode 100644 index 0000000..ff3759e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_INITIALIZE.out @@ -0,0 +1,5 @@ +00 ++00 +000 ++000 + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_MOVE.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_MOVE.cob new file mode 100644 index 0000000..cfdc8db --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_MOVE.cob @@ -0,0 +1,40 @@ + *> { dg-do run } + *> { dg-output-file "group2/PACKED-DECIMAL_used_with_MOVE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-99 PIC 99 USAGE PACKED-DECIMAL. + 01 X-S99 PIC S99 USAGE PACKED-DECIMAL. + 01 X-999 PIC 999 USAGE PACKED-DECIMAL. + 01 X-S999 PIC S999 USAGE PACKED-DECIMAL. + 01 C-P1234 PIC 9999 VALUE 1234. + 01 C-N1234 PIC S9999 VALUE -1234. + PROCEDURE DIVISION. + MOVE C-P1234 TO X-99. + DISPLAY X-99 + END-DISPLAY. + MOVE C-P1234 TO X-S99. + DISPLAY X-S99 + END-DISPLAY. + MOVE C-P1234 TO X-999. + DISPLAY X-999 + END-DISPLAY. + MOVE C-P1234 TO X-S999. + DISPLAY X-S999 + END-DISPLAY. + MOVE C-N1234 TO X-99. + DISPLAY X-99 + END-DISPLAY. + MOVE C-N1234 TO X-S99. + DISPLAY X-S99 + END-DISPLAY. + MOVE C-N1234 TO X-999. + DISPLAY X-999 + END-DISPLAY. + MOVE C-N1234 TO X-S999. + DISPLAY X-S999 + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_MOVE.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_MOVE.out new file mode 100644 index 0000000..ddb1080 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_used_with_MOVE.out @@ -0,0 +1,9 @@ +34 ++34 +234 ++234 +34 +-34 +234 +-234 + diff --git a/gcc/testsuite/cobol.dg/group2/POINTER__display.cob b/gcc/testsuite/cobol.dg/group2/POINTER__display.cob new file mode 100644 index 0000000..46a7cb1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/POINTER__display.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/POINTER__display.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 PTR USAGE POINTER VALUE NULL. + PROCEDURE DIVISION. + DISPLAY PTR + END-DISPLAY. + SET PTR UP BY 1 + DISPLAY PTR + SET PTR DOWN BY 1 + DISPLAY PTR + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/POINTER__display.out b/gcc/testsuite/cobol.dg/group2/POINTER__display.out new file mode 100644 index 0000000..c8ee9bc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/POINTER__display.out @@ -0,0 +1,4 @@ +0x0000000000000000 +0x0000000000000001 +0x0000000000000000 + diff --git a/gcc/testsuite/cobol.dg/group2/Program-to-program_parameters_and_retvals.cob b/gcc/testsuite/cobol.dg/group2/Program-to-program_parameters_and_retvals.cob new file mode 100644 index 0000000..6e0443d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Program-to-program_parameters_and_retvals.cob @@ -0,0 +1,237 @@ + *> { dg-do run } + *> { dg-output-file "group2/Program-to-program_parameters_and_retvals.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 var1 pic 9 VALUE 1. + 01 var2 BINARY-CHAR VALUE 22. + 01 var3 pic s999 COMP-3 VALUE -333. + 01 var4 pic 9999 BINARY VALUE 4444. + 01 var5 pic 99.99 VALUE "12.34". + 01 var6 pic s999V999 COMP-5 VALUE -123.456. + 01 var7 float-short VALUE 1.23E10. + 01 var8 float-long VALUE -1.23E20. + 01 var9 float-extended VALUE 1.23E40. + 01 var64 pic 9(15) VALUE 987654321098765. + 01 var128 pic s9(30) VALUE -987654321098765432109876543210. + 01 filler. + 02 varpd pic 9(18) comp-5 value 1250999747361. + 02 varp redefines varpd pointer. + 01 varg. + 02 varg1 pic x(7) VALUE "That's". + 02 varg2 pic x(5) VALUE "all," . + 02 varg3 pic x(7) VALUE "folks!". + + 01 var1r pic 9 . + 01 var2r BINARY-CHAR . + 01 var3r pic s999 COMP-3 . + 01 var4r pic 9999 BINARY . + 01 var5r pic 99.99 . + 01 var6r pic s999V999 COMP-5 . + 01 var7r float-short . + 01 var8r float-long . + 01 var9r float-extended . + 01 var64r pic 9(15) . + 01 var128r pic s9(30) . + 01 varpr pointer. + 01 vargr. + 02 varg1 pic x(7). + 02 varg2 pic x(5). + 02 varg3 pic x(7). + + PROCEDURE DIVISION. + display var1 + call "rvar1" USING by value var1 RETURNING var1r + display var1r + + display var2 + call "rvar2" USING by reference var2 RETURNING var2r + display var2r + + display var3 + call "rvar3" USING by content var3 RETURNING var3r + display var3r + + display var4 + call "rvar4" USING by value var4 RETURNING var4r + display var4r + + display var5 + call "rvar5" USING by reference var5 RETURNING var5r + display var5r + + display var6 + call "rvar6" USING by content var6 RETURNING var6r + display var6r + + display var7 + call "rvar7" USING by reference var7 RETURNING var7r + display var7r + + display var8 + call "rvar8" USING by value var8 RETURNING var8r + display var8r + + display var9 + call "rvar9" USING by content var9 RETURNING var9r + display var9r + + display var64 + call "rvar64" USING by value var64 RETURNING var64r + display var64r + + display var128 + call "rvar128" USING by reference var128 RETURNING var128r + display var128r + + display varp + call "rvarp" USING by reference varp RETURNING varpr + display varpr + + display """"varg"""" + call "rvarg" USING by reference varg RETURNING vargr + display """"vargr"""" + + GOBACK. + END PROGRAM prog. + + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar1. + DATA DIVISION. + LINKAGE SECTION. + 01 var pic 9 . + 01 varr pic 9 . + PROCEDURE DIVISION USING by value var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar1. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar2. + DATA DIVISION. + LINKAGE SECTION. + 01 var BINARY-CHAR . + 01 varr BINARY-CHAR . + PROCEDURE DIVISION USING by reference var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar2. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar3. + DATA DIVISION. + LINKAGE SECTION. + 01 var pic s999 COMP-3 . + 01 varr pic s999 COMP-3 . + PROCEDURE DIVISION USING by reference var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar3. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar4. + DATA DIVISION. + LINKAGE SECTION. + 01 var pic 9999 BINARY . + 01 varr pic 9999 BINARY . + PROCEDURE DIVISION USING by value var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar4. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar5. + DATA DIVISION. + LINKAGE SECTION. + 01 var pic 99.99 . + 01 varr pic 99.99 . + PROCEDURE DIVISION USING by reference var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar5. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar6. + DATA DIVISION. + LINKAGE SECTION. + 01 var pic s999V999 COMP-5 . + 01 varr pic s999V999 COMP-5 . + PROCEDURE DIVISION USING reference var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar6. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar7. + DATA DIVISION. + LINKAGE SECTION. + 01 var float-short . + 01 varr float-short . + PROCEDURE DIVISION USING by reference VAR RETURNING varr. + MOVE var TO varr. + GOBACK. + END PROGRAM rvar7. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar8. + DATA DIVISION. + LINKAGE SECTION. + 01 var float-long . + 01 varr float-long . + PROCEDURE DIVISION USING by value var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar8. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar9. + DATA DIVISION. + LINKAGE SECTION. + 01 var float-extended . + 01 varr float-extended . + PROCEDURE DIVISION USING by reference var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar9. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar64. + DATA DIVISION. + LINKAGE SECTION. + 01 var pic 9(15) . + 01 varr pic 9(15) . + PROCEDURE DIVISION USING by value var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar64. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvar128. + DATA DIVISION. + LINKAGE SECTION. + 01 var pic s9(30) . + 01 varr pic s9(30) . + PROCEDURE DIVISION USING by reference var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvar128. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvarp. + DATA DIVISION. + LINKAGE SECTION. + 01 var pointer . + 01 varr pointer . + PROCEDURE DIVISION USING by reference var RETURNING varr. + SET varr TO var. + END PROGRAM rvarp. + + IDENTIFICATION DIVISION. + PROGRAM-ID. rvarg. + DATA DIVISION. + LINKAGE SECTION. + 01 var. + 02 varg1 pic x(7). + 02 varg2 pic x(5). + 02 varg3 pic x(7). + 01 varr. + 02 varg1 pic x(7). + 02 varg2 pic x(5). + 02 varg3 pic x(7). + PROCEDURE DIVISION USING by reference var RETURNING varr. + MOVE var TO varr. + END PROGRAM rvarg. + diff --git a/gcc/testsuite/cobol.dg/group2/Program-to-program_parameters_and_retvals.out b/gcc/testsuite/cobol.dg/group2/Program-to-program_parameters_and_retvals.out new file mode 100644 index 0000000..ce543df --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Program-to-program_parameters_and_retvals.out @@ -0,0 +1,27 @@ +1 +1 ++022 ++022 +-333 +-333 +4444 +4444 +12.34 +12.34 +-123.456 +-123.456 +1.230000026E+10 +1.230000026E+10 +-1.23E+20 +-1.23E+20 +1.23E+40 +1.23E+40 +987654321098765 +987654321098765 +-987654321098765432109876543210 +-987654321098765432109876543210 +0x0000012345654321 +0x0000012345654321 +"That's all, folks! " +"That's all, folks! " + diff --git a/gcc/testsuite/cobol.dg/group2/Recursive_FUNCTION_with_local-storage.cob b/gcc/testsuite/cobol.dg/group2/Recursive_FUNCTION_with_local-storage.cob new file mode 100644 index 0000000..122aab7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Recursive_FUNCTION_with_local-storage.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + *> { dg-output-file "group2/Recursive_FUNCTION_with_local-storage.out" } + IDENTIFICATION DIVISION. + FUNCTION-ID. callee. + DATA DIVISION. + LOCAL-STORAGE SECTION. + 01 LCL-X PIC 999 . + LINKAGE SECTION. + 01 parm PIC 999. + 01 retval PIC 999. + PROCEDURE DIVISION USING parm RETURNING retval. + display "On entry, parm is: " parm + move parm to lcl-x + move parm to retval + subtract 1 from parm + if parm > 0 + display "A The function returns " function callee(parm). + if lcl-x not equal to retval + display "On exit, lcl-s and retval are: " lcl-x " and " retval + display "But they should be equal to each other" + end-if + goback. + end function callee. + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + REPOSITORY. + FUNCTION callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 val PIC 999 VALUE 5. + PROCEDURE DIVISION. + DISPLAY "Starting value is: " val + display "B The function returns " function callee(val). + STOP RUN. + end program caller. + diff --git a/gcc/testsuite/cobol.dg/group2/Recursive_FUNCTION_with_local-storage.out b/gcc/testsuite/cobol.dg/group2/Recursive_FUNCTION_with_local-storage.out new file mode 100644 index 0000000..3ccd69a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Recursive_FUNCTION_with_local-storage.out @@ -0,0 +1,12 @@ +Starting value is: 005 +On entry, parm is: 005 +On entry, parm is: 004 +On entry, parm is: 003 +On entry, parm is: 002 +On entry, parm is: 001 +A The function returns 001 +A The function returns 002 +A The function returns 003 +A The function returns 004 +B The function returns 005 + diff --git a/gcc/testsuite/cobol.dg/group2/Repository_functions_clause.cob b/gcc/testsuite/cobol.dg/group2/Repository_functions_clause.cob new file mode 100644 index 0000000..cc306b4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Repository_functions_clause.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/Repository_functions_clause.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SOURCE-COMPUTER. a. + OBJECT-COMPUTER. a. + REPOSITORY. + FUNCTION ALL INTRINSIC. + PROCEDURE DIVISION. + DISPLAY "OK". + diff --git a/gcc/testsuite/cobol.dg/group2/Repository_functions_clause.out b/gcc/testsuite/cobol.dg/group2/Repository_functions_clause.out new file mode 100644 index 0000000..885fd66 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Repository_functions_clause.out @@ -0,0 +1,2 @@ +OK + diff --git a/gcc/testsuite/cobol.dg/group2/Simple_floating-point_MOVE.cob b/gcc/testsuite/cobol.dg/group2/Simple_floating-point_MOVE.cob new file mode 100644 index 0000000..50f9ffa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Simple_floating-point_MOVE.cob @@ -0,0 +1,48 @@ + *> { dg-do run } + *> { dg-output-file "group2/Simple_floating-point_MOVE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-move. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 S1 PIC 999V99 DISPLAY VALUE 123.45 . + 01 S2 PIC 999V99 COMP VALUE 123.45 . + 01 S3 PIC 999V99 COMP-3 VALUE 123.45 . + 01 S4 PIC 999V99 COMP-5 VALUE 123.45 . + 01 S5 FLOAT-SHORT VALUE 123.45 . + 01 S6 FLOAT-LONG VALUE 123.45 . + 01 S7 FLOAT-EXTENDED VALUE 123.45 . + 01 D1 PIC 999V99 DISPLAY . + 01 D2 PIC 999V99 COMP . + 01 D3 PIC 999V99 COMP-3 . + 01 D4 PIC 999V99 COMP-5 . + 01 D5 FLOAT-SHORT . + 01 D6 FLOAT-LONG . + 01 D7 FLOAT-EXTENDED . + PROCEDURE DIVISION. + MOVE S1 TO D1 D2 D3 D4 D5 D6 D7 + PERFORM DISPLAY-D. + MOVE S2 TO D1 D2 D3 D4 D5 D6 D7 + PERFORM DISPLAY-D. + MOVE S3 TO D1 D2 D3 D4 D5 D6 D7 + PERFORM DISPLAY-D. + MOVE S4 TO D1 D2 D3 D4 D5 D6 D7 + PERFORM DISPLAY-D. + MOVE S5 TO D1 D2 D3 D4 D5 D6 D7 + PERFORM DISPLAY-D. + MOVE S6 TO D1 D2 D3 D4 D5 D6 D7 + PERFORM DISPLAY-D. + MOVE S7 TO D1 D2 D3 D4 D5 D6 D7 + PERFORM DISPLAY-D. + GOBACK. + DISPLAY-D. + DISPLAY D1 SPACE + D2 SPACE + D3 SPACE + D4 SPACE + D5 SPACE + D6 SPACE + D7 . + MOVE 0 TO D1 D2 D3 D4 D5 D6 D7. + END PROGRAM float-move. + diff --git a/gcc/testsuite/cobol.dg/group2/Simple_floating-point_MOVE.out b/gcc/testsuite/cobol.dg/group2/Simple_floating-point_MOVE.out new file mode 100644 index 0000000..fb07251 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Simple_floating-point_MOVE.out @@ -0,0 +1,8 @@ +123.45 123.45 123.45 123.45 123.4499969 123.450000000000003 123.4500000000000000000000000000000025 +123.45 123.45 123.45 123.45 123.4499969 123.450000000000003 123.4500000000000000000000000000000025 +123.45 123.45 123.45 123.45 123.4499969 123.450000000000003 123.4500000000000000000000000000000025 +123.45 123.45 123.45 123.45 123.4499969 123.450000000000003 123.4500000000000000000000000000000025 +123.44 123.45 123.44 123.45 123.4499969 123.449996948242188 123.4499969482421875 +123.45 123.45 123.45 123.45 123.4499969 123.450000000000003 123.4500000000000028421709430404007435 +123.45 123.45 123.45 123.45 123.4499969 123.450000000000003 123.4500000000000000000000000000000025 + diff --git a/gcc/testsuite/cobol.dg/group2/Simple_floating-point_VALUE_and_MOVE.cob b/gcc/testsuite/cobol.dg/group2/Simple_floating-point_VALUE_and_MOVE.cob new file mode 100644 index 0000000..42d5954 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Simple_floating-point_VALUE_and_MOVE.cob @@ -0,0 +1,176 @@ + *> { dg-do run } + *> { dg-output-file "group2/Simple_floating-point_VALUE_and_MOVE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-demo. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P-1 PIC 999PPPPPP COMP-5 VALUE 123000000. + 01 C-1A COMP-1 VALUE 12.3456E-7. + 01 C-1B COMP-1 VALUE 12.3456E-6. + 01 C-1C COMP-1 VALUE 12.3456E-5. + 01 C-1D COMP-1 VALUE 12.3456E-4. + 01 C-1E COMP-1 VALUE 12.3456E-3. + 01 C-1F COMP-1 VALUE 12.3456E-2. + 01 C-1G COMP-1 VALUE 12.3456E-1. + 01 C-1H COMP-1 VALUE 12.3456E0 . + 01 C-1I COMP-1 VALUE 12.3456E1 . + 01 C-1J COMP-1 VALUE 12.3456E2 . + 01 C-1K COMP-1 VALUE 12.3456E3 . + 01 C-1L COMP-1 VALUE 12.3456E4 . + 01 C-1M COMP-1 VALUE 12.3456E5 . + 01 C-1N COMP-1 VALUE 12.3456E6 . + 01 C-1O COMP-1 VALUE 12.3456E7 . + 01 C-1P COMP-1 VALUE 12.3456E8 . + 01 C-1Q COMP-1 VALUE 12.3456E9 . + 01 C-1R COMP-1 VALUE 12.3456E10. + 01 C-1S COMP-1 VALUE 12.3456E11. + 01 C-2A COMP-2 VALUE 12.3456789098765E-7. + 01 C-2B COMP-2 VALUE 12.3456789098765E-6. + 01 C-2C COMP-2 VALUE 12.3456789098765E-5. + 01 C-2D COMP-2 VALUE 12.3456789098765E-4. + 01 C-2E COMP-2 VALUE 12.3456789098765E-3. + 01 C-2F COMP-2 VALUE 12.3456789098765E-2. + 01 C-2G COMP-2 VALUE 12.3456789098765E-1. + 01 C-2H COMP-2 VALUE 12.3456789098765E0 . + 01 C-2I COMP-2 VALUE 12.3456789098765E1 . + 01 C-2J COMP-2 VALUE 12.3456789098765E2 . + 01 C-2K COMP-2 VALUE 12.3456789098765E3 . + 01 C-2L COMP-2 VALUE 12.3456789098765E4 . + 01 C-2M COMP-2 VALUE 12.3456789098765E5 . + 01 C-2N COMP-2 VALUE 12.3456789098765E6 . + 01 C-2O COMP-2 VALUE 12.3456789098765E7 . + 01 C-2P COMP-2 VALUE 12.3456789098765E8 . + 01 C-2Q COMP-2 VALUE 12.3456789098765E9 . + 01 C-2R COMP-2 VALUE 12.3456789098765E10. + 01 C-2S COMP-2 VALUE 12.3456789098765E11. + 01 C-2T COMP-2 VALUE 12.3456789098765E12. + 01 C-2U COMP-2 VALUE 12.3456789098765E13. + 01 C-2V COMP-2 VALUE 12.3456789098765E14. + 01 C-2W COMP-2 VALUE 12.3456789098765E15. + 01 C-2X COMP-2 VALUE 12.3456789098765E16. + 01 C-EA FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E-7. + 01 C-EB FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E-6. + 01 C-EC FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E-5. + 01 C-ED FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E-4. + 01 C-EE FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E-3. + 01 C-EF FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E-2. + 01 C-EG FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E-1. + 01 C-EH FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E0 . + 01 C-EI FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E1 . + 01 C-EJ FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E2 . + 01 C-EK FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E3 . + 01 C-EL FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E4 . + 01 C-EM FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E5 . + 01 C-EN FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E6 . + 01 C-EO FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E7 . + 01 C-EP FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E8 . + 01 C-EQ FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E9 . + 01 C-ER FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E10. + 01 C-ES FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E11. + 01 C-ET FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E12. + 01 C-EU FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E13. + 01 C-EV FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E14. + 01 C-EW FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E15. + 01 C-EX FLOAT-EXTENDED VALUE 11.11222233334444995555666677778888E16. + 01 A PIC X(24). + PROCEDURE DIVISION. + DISPLAY "Variations on COMP-1 12." + MOVE 12.E-7 TO C-1A . + MOVE 12.E-6 TO C-1B . + MOVE 12.E-5 TO C-1C . + MOVE 12.E-4 TO C-1D . + MOVE 12.E-3 TO C-1E . + MOVE 12.E-2 TO C-1F . + MOVE 12.E-1 TO C-1G . + MOVE 12.E0 TO C-1H . + MOVE 12.E1 TO C-1I . + MOVE 12.E2 TO C-1J . + MOVE 12.E3 TO C-1K . + MOVE 12.E4 TO C-1L . + MOVE 12.E5 TO C-1M . + MOVE 12.E6 TO C-1N . + MOVE 12.E7 TO C-1O . + MOVE 12.E8 TO C-1P . + MOVE 12.E9 TO C-1Q . + MOVE 12.E10 TO C-1R . + MOVE 12.E11 TO C-1S . + PERFORM DISPLAY-COMP-1. + DISPLAY "Variations on COMP-2 12.3456789098765" + PERFORM DISPLAY-COMP-2. + DISPLAY "Variations on COMP-2 12." + MOVE 12.E-7 TO C-2A . + MOVE 12.E-6 TO C-2B . + MOVE 12.E-5 TO C-2C . + MOVE 12.E-4 TO C-2D . + MOVE 12.E-3 TO C-2E . + MOVE 12.E-2 TO C-2F . + MOVE 12.E-1 TO C-2G . + MOVE 12.E0 TO C-2H . + MOVE 12.E1 TO C-2I . + MOVE 12.E2 TO C-2J . + MOVE 12.E3 TO C-2K . + MOVE 12.E4 TO C-2L . + MOVE 12.E5 TO C-2M . + MOVE 12.E6 TO C-2N . + MOVE 12.E7 TO C-2O . + MOVE 12.E8 TO C-2P . + MOVE 12.E9 TO C-2Q . + MOVE 12.E10 TO C-2R . + MOVE 12.E11 TO C-2S . + MOVE 12.E12 TO C-2T . + MOVE 12.E13 TO C-2U . + MOVE 12.E14 TO C-2V . + MOVE 12.E15 TO C-2W . + MOVE 12.E16 TO C-2X . + PERFORM DISPLAY-COMP-2. + DISPLAY "Variations on FLOAT-EXTENDED 11.11222233334444995555666677778888" + PERFORM DISPLAY-EXTENDED. + GOBACK. + DISPLAY-COMP-1. + DISPLAY C-1A + DISPLAY C-1B + DISPLAY C-1C + DISPLAY C-1D + DISPLAY C-1E + DISPLAY C-1F + DISPLAY C-1G + DISPLAY C-1H + DISPLAY C-1I + DISPLAY C-1J + DISPLAY C-1K + DISPLAY C-1L + DISPLAY C-1M + DISPLAY C-1N. + DISPLAY-COMP-2. + DISPLAY C-2A + DISPLAY C-2B + DISPLAY C-2C + DISPLAY C-2D + DISPLAY C-2E + DISPLAY C-2F + DISPLAY C-2G + DISPLAY C-2H + DISPLAY C-2I + DISPLAY C-2J + DISPLAY C-2K + DISPLAY C-2L + DISPLAY C-2M + DISPLAY C-2N. + DISPLAY-EXTENDED. + DISPLAY C-EA + DISPLAY C-EB + DISPLAY C-EC + DISPLAY C-ED + DISPLAY C-EE + DISPLAY C-EF + DISPLAY C-EG + DISPLAY C-EH + DISPLAY C-EI + DISPLAY C-EJ + DISPLAY C-EK + DISPLAY C-EL + DISPLAY C-EM + DISPLAY C-EN. + END PROGRAM float-demo. + diff --git a/gcc/testsuite/cobol.dg/group2/Simple_floating-point_VALUE_and_MOVE.out b/gcc/testsuite/cobol.dg/group2/Simple_floating-point_VALUE_and_MOVE.out new file mode 100644 index 0000000..bf1afbf --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Simple_floating-point_VALUE_and_MOVE.out @@ -0,0 +1,61 @@ +Variations on COMP-1 12. +1.200000042E-06 +1.200000042E-05 +0.000119999997 +0.001200000057 +0.0120000001 +0.1199999973 +1.200000048 +12 +120 +1200 +12000 +120000 +1.2E+06 +1.2E+07 +Variations on COMP-2 12.3456789098765 +1.23456789098764994E-06 +1.23456789098764994E-05 +0.000123456789098764987 +0.00123456789098764998 +0.0123456789098764994 +0.123456789098764994 +1.23456789098765007 +12.3456789098765007 +123.456789098765 +1234.56789098764989 +12345.6789098765003 +123456.789098765003 +1.23456789098765003E+06 +1.23456789098764993E+07 +Variations on COMP-2 12. +1.19999999999999995E-06 +1.20000000000000003E-05 +0.000120000000000000003 +0.00119999999999999989 +0.0120000000000000002 +0.119999999999999996 +1.19999999999999996 +12 +120 +1200 +12000 +120000 +1.2E+06 +1.2E+07 +Variations on FLOAT-EXTENDED 11.11222233334444995555666677778888 +1.111222233334444995555666677778887977E-06 +1.11122223333444499555566667777888794E-05 +0.0001111222233334444995555666677778887999 +0.001111222233334444995555666677778888046 +0.01111222233334444995555666677778887971 +0.1111222233334444995555666677778887971 +1.111222233334444995555666677778887923 +11.11222233334444995555666677778888 +111.1222233334444995555666677778888062 +1111.222233334444995555666677778888012 +11112.22233334444995555666677778888052 +111122.2233334444995555666677778887957 +1.111222233334444995555666677778887982E+06 +1.111222233334444995555666677778888023E+07 + diff --git a/gcc/testsuite/cobol.dg/group2/UDF_RETURNING_group_and_PIC_9_5_.cob b/gcc/testsuite/cobol.dg/group2/UDF_RETURNING_group_and_PIC_9_5_.cob new file mode 100644 index 0000000..d4df058 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UDF_RETURNING_group_and_PIC_9_5_.cob @@ -0,0 +1,51 @@ + *> { dg-do run } + *> { dg-output-file "group2/UDF_RETURNING_group_and_PIC_9_5_.out" } + + IDENTIFICATION DIVISION. + FUNCTION-ID. COPYPAR. + DATA DIVISION. + LINKAGE SECTION. + 01 PARSA. + 02 PAR1 PICTURE X(32). + 02 PAR2 PICTURE X(32). + 01 PARSB. + 02 PAR1 PICTURE X(32). + 02 PAR2 PICTURE X(32). + PROCEDURE DIVISION USING PARSA RETURNING PARSB. + MOVE PARSA TO PARSB + DISPLAY """" PARSB """" + GOBACK. + END FUNCTION COPYPAR. + IDENTIFICATION DIVISION. + FUNCTION-ID. COPYPAR2. + DATA DIVISION. + LINKAGE SECTION. + 01 PARSB PIC 99999. + 01 PAR5 PIC 99999. + PROCEDURE DIVISION USING PAR5 RETURNING PARSB. + MOVE PAR5 TO PARSB + DISPLAY PARSB + GOBACK. + END FUNCTION COPYPAR2. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + REPOSITORY. + FUNCTION COPYPAR, COPYPAR2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 PARS1. + 02 PAR1 PICTURE X(32) VALUE "Santa". + 02 PAR2 PICTURE X(32) VALUE "Claus". + 01 PARS2. + 02 PAR1 PICTURE X(32). + 02 PAR2 PICTURE X(32). + 01 PAR5 PICTURE 99999 VALUE 54321. + PROCEDURE DIVISION. + MOVE COPYPAR(PARS1) TO PARS2 + DISPLAY """" PARS2 """". + DISPLAY COPYPAR2(PAR5) + STOP RUN. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/UDF_RETURNING_group_and_PIC_9_5_.out b/gcc/testsuite/cobol.dg/group2/UDF_RETURNING_group_and_PIC_9_5_.out new file mode 100644 index 0000000..1361e9a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UDF_RETURNING_group_and_PIC_9_5_.out @@ -0,0 +1,5 @@ +"Santa Claus " +"Santa Claus " +54321 +54321 + diff --git a/gcc/testsuite/cobol.dg/group2/UDF_fibonacci_recursion.cob b/gcc/testsuite/cobol.dg/group2/UDF_fibonacci_recursion.cob new file mode 100644 index 0000000..71ef09b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UDF_fibonacci_recursion.cob @@ -0,0 +1,39 @@ + *> { dg-do run } + *> { dg-output-file "group2/UDF_fibonacci_recursion.out" } + + identification division. + function-id. fib-func. + data division. + working-storage section. + 01 instance pic 9999 value 0. + linkage section. + 01 n binary-char unsigned. + 01 f-n binary-long unsigned. + procedure division using n returning f-n. + evaluate true + when n = 0 + move 0 to f-n + when n = 1 + move 1 to f-n + when other + compute f-n = fib-func(n - 1) + fib-func(n - 2) + end-evaluate + goback . + end function fib-func. + + identification division. + program-id. pmain. + environment division. + configuration section. + repository. + function fib-func. + data division. + working-storage section. + 01 n binary-char unsigned. + procedure division. + perform varying n from 1 by 1 until n > 16 + display "fibonacci(" n "): " fib-func(n) + end-perform + stop run. + end program pmain. + diff --git a/gcc/testsuite/cobol.dg/group2/UDF_fibonacci_recursion.out b/gcc/testsuite/cobol.dg/group2/UDF_fibonacci_recursion.out new file mode 100644 index 0000000..34dabfb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UDF_fibonacci_recursion.out @@ -0,0 +1,17 @@ +fibonacci(001): 1 +fibonacci(002): 1 +fibonacci(003): 2 +fibonacci(004): 3 +fibonacci(005): 5 +fibonacci(006): 8 +fibonacci(007): 13 +fibonacci(008): 21 +fibonacci(009): 34 +fibonacci(010): 55 +fibonacci(011): 89 +fibonacci(012): 144 +fibonacci(013): 233 +fibonacci(014): 377 +fibonacci(015): 610 +fibonacci(016): 987 + diff --git a/gcc/testsuite/cobol.dg/group2/UDF_in_COMPUTE.cob b/gcc/testsuite/cobol.dg/group2/UDF_in_COMPUTE.cob new file mode 100644 index 0000000..74576b6 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UDF_in_COMPUTE.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + *> { dg-output-file "group2/UDF_in_COMPUTE.out" } + + IDENTIFICATION DIVISION. + FUNCTION-ID. func. + + DATA DIVISION. + LINKAGE SECTION. + 01 num PIC 999. + + PROCEDURE DIVISION RETURNING num. + MOVE 100 TO num + . + END FUNCTION func. + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + REPOSITORY. + FUNCTION func. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x PIC 999. + + PROCEDURE DIVISION. + COMPUTE x = 101 + FUNCTION func + DISPLAY x + . + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/UDF_in_COMPUTE.out b/gcc/testsuite/cobol.dg/group2/UDF_in_COMPUTE.out new file mode 100644 index 0000000..d757a46 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UDF_in_COMPUTE.out @@ -0,0 +1,2 @@ +201 + diff --git a/gcc/testsuite/cobol.dg/group2/UDF_with_recursion.cob b/gcc/testsuite/cobol.dg/group2/UDF_with_recursion.cob new file mode 100644 index 0000000..1e9b378 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UDF_with_recursion.cob @@ -0,0 +1,49 @@ + *> { dg-do run } + *> { dg-output-file "group2/UDF_with_recursion.out" } + + IDENTIFICATION DIVISION. + FUNCTION-ID. foo. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 ttl PIC 9 VALUE 1. + + LOCAL-STORAGE SECTION. + 01 num PIC 9. + + LINKAGE SECTION. + 01 arg PIC 9. + 01 ret PIC 9. + + PROCEDURE DIVISION USING arg RETURNING ret. + IF arg < 5 + ADD 1 TO arg GIVING num END-ADD + MOVE FUNCTION foo (num) TO ret + ELSE + MOVE arg TO ret + END-IF + DISPLAY "Step: " ttl ", Arg: " arg ", Return: " ret + END-DISPLAY + ADD 1 to ttl END-ADD + GOBACK. + END FUNCTION foo. + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + REPOSITORY. + FUNCTION foo. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 num PIC 9 VALUE 1. + + PROCEDURE DIVISION. + DISPLAY "Return value '" FUNCTION foo (num) "'" + WITH NO ADVANCING + END-DISPLAY + GOBACK. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/UDF_with_recursion.out b/gcc/testsuite/cobol.dg/group2/UDF_with_recursion.out new file mode 100644 index 0000000..13bd1e9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UDF_with_recursion.out @@ -0,0 +1,6 @@ +Step: 1, Arg: 5, Return: 5 +Step: 2, Arg: 4, Return: 5 +Step: 3, Arg: 3, Return: 5 +Step: 4, Arg: 2, Return: 5 +Step: 5, Arg: 1, Return: 5 +Return value '5' diff --git a/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.cob b/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.cob new file mode 100644 index 0000000..3753e7a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.cob @@ -0,0 +1,36 @@ + *> { dg-do run } + *> { dg-output-file "group2/call_subprogram_using_pointer__passing_pointer.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 varp program-pointer. + PROCEDURE DIVISION. + SET varp TO ENTRY "ref". + CALL "sub" USING BY VALUE varp. + end program prog. + + IDENTIFICATION DIVISION. + PROGRAM-ID. sub. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 param pic x(12) value "hi". + LINKAGE SECTION. + 77 varp program-pointer. + PROCEDURE DIVISION USING BY VALUE varp. + DISPLAY "About to call 'ref hi' directly" + CALL "ref" USING param. + DISPLAY "About to call 'ref hi' indirectly" + CALL varp USING param. + end program sub. + + IDENTIFICATION DIVISION. + PROGRAM-ID. ref. + DATA DIVISION. + LINKAGE SECTION. + 77 greeting pic x(12). + PROCEDURE DIVISION using greeting. + DISPLAY """" greeting """". + end program ref. + diff --git a/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.out b/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.out new file mode 100644 index 0000000..7a12ec1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.out @@ -0,0 +1,5 @@ +About to call 'ref hi' directly +"hi " +About to call 'ref hi' indirectly +"hi " + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_1.cob b/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_1.cob new file mode 100644 index 0000000..442888b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_1.cob @@ -0,0 +1,90 @@ + *> { dg-do run } + *> { dg-output-file "group2/floating-point_ADD_FORMAT_1.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-arith1. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 S1 PIC 999V99 DISPLAY VALUE 123.45 . + 01 S2 PIC 999V99 COMP VALUE 123.45 . + 01 S3 PIC 999V99 COMP-3 VALUE 123.45 . + 01 S4 PIC 999V99 COMP-5 VALUE 123.45 . + 01 S5 FLOAT-SHORT VALUE 123.45 . + 01 S6 FLOAT-LONG VALUE 123.45 . + 01 S7 FLOAT-EXTENDED VALUE 123.45 . + 01 D1 PIC 999V99 DISPLAY . + 01 D2 PIC 999V99 COMP . + 01 D3 PIC 999V99 COMP-3 . + 01 D4 PIC 999V99 COMP-5 . + 01 D5 FLOAT-SHORT . + 01 D6 FLOAT-LONG . + 01 D7 FLOAT-EXTENDED . + PROCEDURE DIVISION. + MOVE S1 TO D1 ADD S1 TO D1 + MOVE S2 TO D2 ADD S2 TO D2 + MOVE S3 TO D3 ADD S3 TO D3 + MOVE S4 TO D4 ADD S4 TO D4 + MOVE S5 TO D5 ADD S5 TO D5 + MOVE S6 TO D6 ADD S6 TO D6 + MOVE S7 TO D7 ADD S7 TO D7 + PERFORM DISPLAY-D. + MOVE S1 TO D1 ADD S2 TO D1 + MOVE S2 TO D2 ADD S3 TO D2 + MOVE S3 TO D3 ADD S4 TO D3 + MOVE S4 TO D4 ADD S5 TO D4 + MOVE S5 TO D5 ADD S6 TO D5 + MOVE S6 TO D6 ADD S7 TO D6 + MOVE S7 TO D7 ADD S1 TO D7 + PERFORM DISPLAY-D. + MOVE S1 TO D1 ADD S3 TO D1 + MOVE S2 TO D2 ADD S4 TO D2 + MOVE S3 TO D3 ADD S5 TO D3 + MOVE S4 TO D4 ADD S6 TO D4 + MOVE S5 TO D5 ADD S7 TO D5 + MOVE S6 TO D6 ADD S1 TO D6 + MOVE S7 TO D7 ADD S2 TO D7 + PERFORM DISPLAY-D. + MOVE S1 TO D1 ADD S4 TO D1 + MOVE S2 TO D2 ADD S5 TO D2 + MOVE S3 TO D3 ADD S6 TO D3 + MOVE S4 TO D4 ADD S7 TO D4 + MOVE S5 TO D5 ADD S1 TO D5 + MOVE S6 TO D6 ADD S2 TO D6 + MOVE S7 TO D7 ADD S3 TO D7 + PERFORM DISPLAY-D. + MOVE S1 TO D1 ADD S5 TO D1 + MOVE S2 TO D2 ADD S6 TO D2 + MOVE S3 TO D3 ADD S7 TO D3 + MOVE S4 TO D4 ADD S1 TO D4 + MOVE S5 TO D5 ADD S2 TO D5 + MOVE S6 TO D6 ADD S3 TO D6 + MOVE S7 TO D7 ADD S4 TO D7 + PERFORM DISPLAY-D. + MOVE S1 TO D1 ADD S6 TO D1 + MOVE S2 TO D2 ADD S7 TO D2 + MOVE S3 TO D3 ADD S1 TO D3 + MOVE S4 TO D4 ADD S2 TO D4 + MOVE S5 TO D5 ADD S3 TO D5 + MOVE S6 TO D6 ADD S4 TO D6 + MOVE S7 TO D7 ADD S5 TO D7 + PERFORM DISPLAY-D. + MOVE S1 TO D1 ADD S7 TO D1 + MOVE S2 TO D2 ADD S1 TO D2 + MOVE S3 TO D3 ADD S2 TO D3 + MOVE S4 TO D4 ADD S3 TO D4 + MOVE S5 TO D5 ADD S4 TO D5 + MOVE S6 TO D6 ADD S5 TO D6 + MOVE S7 TO D7 ADD S6 TO D7 + PERFORM DISPLAY-D. + GOBACK. + DISPLAY-D. + DISPLAY D1 SPACE + D2 SPACE + D3 SPACE + D4 SPACE + D5 SPACE + D6 SPACE + D7 . + MOVE 0 TO D1 D2 D3 D4 D5 D6 D7. + END PROGRAM float-arith1. + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_1.out b/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_1.out new file mode 100644 index 0000000..d48643c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_1.out @@ -0,0 +1,8 @@ +246.90 246.90 246.90 246.90 246.8999939 246.900000000000006 246.9000000000000000000000000000000049 +246.90 246.90 246.90 246.89 246.8999939 246.900000000000006 246.9000000000000000000000000000000049 +246.90 246.90 246.89 246.90 246.8999939 246.900000000000006 246.9000000000000000000000000000000049 +246.90 246.89 246.90 246.90 246.8999939 246.900000000000006 246.9000000000000000000000000000000049 +246.89 246.90 246.90 246.90 246.8999939 246.900000000000006 246.9000000000000000000000000000000049 +246.90 246.90 246.90 246.90 246.8999939 246.900000000000006 246.8999969482421874999999999999999901 +246.90 246.90 246.90 246.90 246.8999939 246.899996948242176 246.9000000000000028421709430404007336 + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_2.cob b/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_2.cob new file mode 100644 index 0000000..ef3f730 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_2.cob @@ -0,0 +1,96 @@ + *> { dg-do run } + *> { dg-output-file "group2/floating-point_ADD_FORMAT_2.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-add2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 S1 PIC 999V99 DISPLAY VALUE 123.45 . + 01 S2 PIC 999V99 COMP VALUE 123.45 . + 01 S3 PIC 999V99 COMP-3 VALUE 123.45 . + 01 S4 PIC 999V99 COMP-5 VALUE 123.45 . + 01 S5 FLOAT-SHORT VALUE 123.45 . + 01 S6 FLOAT-LONG VALUE 123.45 . + 01 S7 FLOAT-EXTENDED VALUE 123.45 . + 01 D1 PIC 999V99 DISPLAY VALUE 543.21 . + 01 D2 PIC 999V99 COMP VALUE 543.21 . + 01 D3 PIC 999V99 COMP-3 VALUE 543.21 . + 01 D4 PIC 999V99 COMP-5 VALUE 543.21 . + 01 D5 FLOAT-SHORT VALUE 543.21 . + 01 D6 FLOAT-LONG VALUE 543.21 . + 01 D7 FLOAT-EXTENDED VALUE 543.21 . + 01 X1 PIC 999V99 DISPLAY . + 01 X2 PIC 999V99 COMP . + 01 X3 PIC 999V99 COMP-3 . + 01 X4 PIC 999V99 COMP-5 . + 01 X5 FLOAT-SHORT . + 01 X6 FLOAT-LONG . + 01 X7 FLOAT-EXTENDED . + PROCEDURE DIVISION. + ADD S1 TO D1 GIVING X1 + ADD S2 TO D2 GIVING X2 + ADD S3 TO D3 GIVING X3 + ADD S4 TO D4 GIVING X4 + ADD S5 TO D5 GIVING X5 + ADD S6 TO D6 GIVING X6 + ADD S7 TO D7 GIVING X7 + PERFORM DISPLAY-X. + ADD S2 TO D1 GIVING X1 + ADD S3 TO D2 GIVING X2 + ADD S4 TO D3 GIVING X3 + ADD S5 TO D4 GIVING X4 + ADD S6 TO D5 GIVING X5 + ADD S7 TO D6 GIVING X6 + ADD S1 TO D7 GIVING X7 + PERFORM DISPLAY-X. + ADD S3 TO D1 GIVING X1 + ADD S4 TO D2 GIVING X2 + ADD S5 TO D3 GIVING X3 + ADD S6 TO D4 GIVING X4 + ADD S7 TO D5 GIVING X5 + ADD S1 TO D6 GIVING X6 + ADD S2 TO D7 GIVING X7 + PERFORM DISPLAY-X. + ADD S4 TO D1 GIVING X1 + ADD S5 TO D2 GIVING X2 + ADD S6 TO D3 GIVING X3 + ADD S7 TO D4 GIVING X4 + ADD S1 TO D5 GIVING X5 + ADD S2 TO D6 GIVING X6 + ADD S3 TO D7 GIVING X7 + PERFORM DISPLAY-X. + ADD S5 TO D1 GIVING X1 + ADD S6 TO D2 GIVING X2 + ADD S7 TO D3 GIVING X3 + ADD S1 TO D4 GIVING X4 + ADD S2 TO D5 GIVING X5 + ADD S3 TO D6 GIVING X6 + ADD S4 TO D7 GIVING X7 + PERFORM DISPLAY-X. + ADD S6 TO D1 GIVING X1 + ADD S7 TO D2 GIVING X2 + ADD S1 TO D3 GIVING X3 + ADD S2 TO D4 GIVING X4 + ADD S3 TO D5 GIVING X5 + ADD S4 TO D6 GIVING X6 + ADD S5 TO D7 GIVING X7 + PERFORM DISPLAY-X. + ADD S7 TO D1 GIVING X1 + ADD S1 TO D2 GIVING X2 + ADD S2 TO D3 GIVING X3 + ADD S3 TO D4 GIVING X4 + ADD S4 TO D5 GIVING X5 + ADD S5 TO D6 GIVING X6 + ADD S6 TO D7 GIVING X7 + PERFORM DISPLAY-X. + GOBACK. + DISPLAY-X. + DISPLAY X1 SPACE + X2 SPACE + X3 SPACE + X4 SPACE + X5 SPACE + X6 SPACE + X7 . + END PROGRAM float-add2. + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_2.out b/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_2.out new file mode 100644 index 0000000..933b56d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_ADD_FORMAT_2.out @@ -0,0 +1,8 @@ +666.66 666.66 666.66 666.66 666.6600342 666.660000000000082 666.660000000000000000000000000000071 +666.66 666.66 666.66 666.65 666.6600342 666.660000000000082 666.660000000000000000000000000000071 +666.66 666.66 666.65 666.66 666.6600342 666.660000000000082 666.660000000000000000000000000000071 +666.66 666.65 666.66 666.66 666.6600342 666.660000000000082 666.660000000000000000000000000000071 +666.65 666.66 666.66 666.66 666.6600342 666.660000000000082 666.660000000000000000000000000000071 +666.66 666.66 666.66 666.66 666.6600342 666.660000000000082 666.6599969482421875000000000000000316 +666.66 666.66 666.66 666.66 666.6600342 666.659996948242224 666.660000000000002842170943040400775 + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_1.cob b/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_1.cob new file mode 100644 index 0000000..efe3d97 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_1.cob @@ -0,0 +1,90 @@ + *> { dg-do run } + *> { dg-output-file "group2/floating-point_DIVIDE_FORMAT_1.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-div1. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 S1 PIC 999V99 DISPLAY VALUE 1.1 . + 01 S2 PIC 999V99 COMP VALUE 1.1 . + 01 S3 PIC 999V99 COMP-3 VALUE 1.1 . + 01 S4 PIC 999V99 COMP-5 VALUE 1.1 . + 01 S5 FLOAT-SHORT VALUE 1.1 . + 01 S6 FLOAT-LONG VALUE 1.1 . + 01 S7 FLOAT-EXTENDED VALUE 1.1 . + 01 D1 PIC 999V99 DISPLAY VALUE 611.05. + 01 D2 PIC 999V99 COMP VALUE 611.05. + 01 D3 PIC 999V99 COMP-3 VALUE 611.05. + 01 D4 PIC 999V99 COMP-5 VALUE 611.05. + 01 D5 FLOAT-SHORT VALUE 611.05. + 01 D6 FLOAT-LONG VALUE 611.05. + 01 D7 FLOAT-EXTENDED VALUE 611.05. + PROCEDURE DIVISION. + DIVIDE S1 INTO D1 + DIVIDE S2 INTO D2 + DIVIDE S3 INTO D3 + DIVIDE S4 INTO D4 + DIVIDE S5 INTO D5 + DIVIDE S6 INTO D6 + DIVIDE S7 INTO D7 + PERFORM DISPLAY-D. + DIVIDE S1 INTO D2 + DIVIDE S2 INTO D3 + DIVIDE S3 INTO D4 + DIVIDE S4 INTO D5 + DIVIDE S5 INTO D6 + DIVIDE S6 INTO D7 + DIVIDE S7 INTO D1 + PERFORM DISPLAY-D. + DIVIDE S1 INTO D3 + DIVIDE S2 INTO D4 + DIVIDE S3 INTO D5 + DIVIDE S4 INTO D6 + DIVIDE S5 INTO D7 + DIVIDE S6 INTO D1 + DIVIDE S7 INTO D2 + PERFORM DISPLAY-D. + DIVIDE S1 INTO D4 + DIVIDE S2 INTO D5 + DIVIDE S3 INTO D6 + DIVIDE S4 INTO D7 + DIVIDE S5 INTO D1 + DIVIDE S6 INTO D2 + DIVIDE S7 INTO D3 + PERFORM DISPLAY-D. + DIVIDE S1 INTO D5 + DIVIDE S2 INTO D6 + DIVIDE S3 INTO D7 + DIVIDE S4 INTO D1 + DIVIDE S5 INTO D2 + DIVIDE S6 INTO D3 + DIVIDE S7 INTO D4 + PERFORM DISPLAY-D. + DIVIDE S1 INTO D6 + DIVIDE S2 INTO D7 + DIVIDE S3 INTO D1 + DIVIDE S4 INTO D2 + DIVIDE S5 INTO D3 + DIVIDE S6 INTO D4 + DIVIDE S7 INTO D5 + PERFORM DISPLAY-D. + DIVIDE S1 INTO D7 + DIVIDE S2 INTO D1 + DIVIDE S3 INTO D2 + DIVIDE S4 INTO D3 + DIVIDE S5 INTO D4 + DIVIDE S6 INTO D5 + DIVIDE S7 INTO D6 + PERFORM DISPLAY-D. + GOBACK. + DISPLAY-D. + DISPLAY D1 SPACE + D2 SPACE + D3 SPACE + D4 SPACE + D5 SPACE + D6 SPACE + D7 . + INITIALIZE D1 D2 D3 D4 D5 D6 D7 ALL VALUE. + END PROGRAM float-div1. + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_1.out b/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_1.out new file mode 100644 index 0000000..cc7a177 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_1.out @@ -0,0 +1,8 @@ +555.50 555.50 555.50 555.50 555.5 555.499999999999886 555.4999999999999999999999999999999014 +555.49 555.50 555.50 555.50 555.5 555.499987959861983 555.4999999999999551469898051436793168 +555.49 555.49 555.50 555.50 555.5 555.5 555.4999879598620163340565002169066332 +555.49 555.49 555.49 555.50 555.5 555.5 555.4999999999999999999999999999999014 +555.50 555.49 555.49 555.49 555.5 555.5 555.4999999999999999999999999999999014 +555.50 555.50 555.49 555.49 555.5 555.5 555.4999999999999999999999999999999014 +555.50 555.50 555.50 555.49 555.5 555.5 555.4999999999999999999999999999999014 + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_2.cob b/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_2.cob new file mode 100644 index 0000000..068844b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_2.cob @@ -0,0 +1,96 @@ + *> { dg-do run } + *> { dg-output-file "group2/floating-point_DIVIDE_FORMAT_2.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-DIVIDE2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 S1 PIC 999V99 DISPLAY VALUE 123.21 . + 01 S2 PIC 999V99 COMP VALUE 123.21 . + 01 S3 PIC 999V99 COMP-3 VALUE 123.21 . + 01 S4 PIC 999V99 COMP-5 VALUE 123.21 . + 01 S5 FLOAT-SHORT VALUE 123.21 . + 01 S6 FLOAT-LONG VALUE 123.21 . + 01 S7 FLOAT-EXTENDED VALUE 123.21 . + 01 D1 PIC 999V99 DISPLAY VALUE 111.00 . + 01 D2 PIC 999V99 COMP VALUE 111.00 . + 01 D3 PIC 999V99 COMP-3 VALUE 111.00 . + 01 D4 PIC 999V99 COMP-5 VALUE 111.00 . + 01 D5 FLOAT-SHORT VALUE 111.00 . + 01 D6 FLOAT-LONG VALUE 111.00 . + 01 D7 FLOAT-EXTENDED VALUE 111.00 . + 01 X1 PIC 999V99 DISPLAY . + 01 X2 PIC 999V99 COMP . + 01 X3 PIC 999V99 COMP-3 . + 01 X4 PIC 999V99 COMP-5 . + 01 X5 FLOAT-SHORT . + 01 X6 FLOAT-LONG . + 01 X7 FLOAT-EXTENDED . + PROCEDURE DIVISION. + DIVIDE S1 BY D1 GIVING X1 + DIVIDE S2 BY D2 GIVING X2 + DIVIDE S3 BY D3 GIVING X3 + DIVIDE S4 BY D4 GIVING X4 + DIVIDE S5 BY D5 GIVING X5 + DIVIDE S6 BY D6 GIVING X6 + DIVIDE S7 BY D7 GIVING X7 + PERFORM DISPLAY-X. + DIVIDE S2 BY D1 GIVING X1 + DIVIDE S3 BY D2 GIVING X2 + DIVIDE S4 BY D3 GIVING X3 + DIVIDE S5 BY D4 GIVING X4 + DIVIDE S6 BY D5 GIVING X5 + DIVIDE S7 BY D6 GIVING X6 + DIVIDE S1 BY D7 GIVING X7 + PERFORM DISPLAY-X. + DIVIDE S3 BY D1 GIVING X1 + DIVIDE S4 BY D2 GIVING X2 + DIVIDE S5 BY D3 GIVING X3 + DIVIDE S6 BY D4 GIVING X4 + DIVIDE S7 BY D5 GIVING X5 + DIVIDE S1 BY D6 GIVING X6 + DIVIDE S2 BY D7 GIVING X7 + PERFORM DISPLAY-X. + DIVIDE S4 BY D1 GIVING X1 + DIVIDE S5 BY D2 GIVING X2 + DIVIDE S6 BY D3 GIVING X3 + DIVIDE S7 BY D4 GIVING X4 + DIVIDE S1 BY D5 GIVING X5 + DIVIDE S2 BY D6 GIVING X6 + DIVIDE S3 BY D7 GIVING X7 + PERFORM DISPLAY-X. + DIVIDE S5 BY D1 GIVING X1 + DIVIDE S6 BY D2 GIVING X2 + DIVIDE S7 BY D3 GIVING X3 + DIVIDE S1 BY D4 GIVING X4 + DIVIDE S2 BY D5 GIVING X5 + DIVIDE S3 BY D6 GIVING X6 + DIVIDE S4 BY D7 GIVING X7 + PERFORM DISPLAY-X. + DIVIDE S6 BY D1 GIVING X1 + DIVIDE S7 BY D2 GIVING X2 + DIVIDE S1 BY D3 GIVING X3 + DIVIDE S2 BY D4 GIVING X4 + DIVIDE S3 BY D5 GIVING X5 + DIVIDE S4 BY D6 GIVING X6 + DIVIDE S5 BY D7 GIVING X7 + PERFORM DISPLAY-X. + DIVIDE S7 BY D1 GIVING X1 + DIVIDE S1 BY D2 GIVING X2 + DIVIDE S2 BY D3 GIVING X3 + DIVIDE S3 BY D4 GIVING X4 + DIVIDE S4 BY D5 GIVING X5 + DIVIDE S5 BY D6 GIVING X6 + DIVIDE S6 BY D7 GIVING X7 + PERFORM DISPLAY-X. + GOBACK. + DISPLAY-X. + DISPLAY X1 SPACE + X2 SPACE + X3 SPACE + X4 SPACE + X5 SPACE + X6 SPACE + X7 . + END PROGRAM float-DIVIDE2. + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_2.out b/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_2.out new file mode 100644 index 0000000..1723f56 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_DIVIDE_FORMAT_2.out @@ -0,0 +1,8 @@ +001.11 001.11 001.11 001.11 1.110000014 1.10999999999999988 1.109999999999999999999999999999999892 +001.11 001.11 001.11 001.10 1.110000014 1.1100000000000001 1.109999999999999999999999999999999892 +001.11 001.11 001.10 001.10 1.110000014 1.1100000000000001 1.109999999999999999999999999999999892 +001.11 001.10 001.10 001.10 1.110000014 1.1100000000000001 1.109999999999999999999999999999999892 +001.10 001.10 001.10 001.11 1.110000014 1.1100000000000001 1.109999999999999999999999999999999892 +001.10 001.10 001.11 001.11 1.110000014 1.1100000000000001 1.10999999175200591216216216216216224 +001.10 001.11 001.11 001.11 1.110000014 1.10999999175200581 1.109999999999999943668684011811877144 + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_1.cob b/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_1.cob new file mode 100644 index 0000000..4365a40 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_1.cob @@ -0,0 +1,90 @@ + *> { dg-do run } + *> { dg-output-file "group2/floating-point_MULTIPLY_FORMAT_1.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-mult1. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 S1 PIC 999V99 DISPLAY VALUE 1.2 . + 01 S2 PIC 999V99 COMP VALUE 1.2 . + 01 S3 PIC 999V99 COMP-3 VALUE 1.2 . + 01 S4 PIC 999V99 COMP-5 VALUE 1.2 . + 01 S5 FLOAT-SHORT VALUE 1.2 . + 01 S6 FLOAT-LONG VALUE 1.2 . + 01 S7 FLOAT-EXTENDED VALUE 1.2 . + 01 D1 PIC 999V99 DISPLAY VALUE 1.1. + 01 D2 PIC 999V99 COMP VALUE 1.1. + 01 D3 PIC 999V99 COMP-3 VALUE 1.1. + 01 D4 PIC 999V99 COMP-5 VALUE 1.1. + 01 D5 FLOAT-SHORT VALUE 1.1. + 01 D6 FLOAT-LONG VALUE 1.1. + 01 D7 FLOAT-EXTENDED VALUE 1.1. + PROCEDURE DIVISION. + MULTIPLY S1 BY D1 + MULTIPLY S2 BY D2 + MULTIPLY S3 BY D3 + MULTIPLY S4 BY D4 + MULTIPLY S5 BY D5 + MULTIPLY S6 BY D6 + MULTIPLY S7 BY D7 + PERFORM DISPLAY-D. + MULTIPLY S1 BY D2 + MULTIPLY S2 BY D3 + MULTIPLY S3 BY D4 + MULTIPLY S4 BY D5 + MULTIPLY S5 BY D6 + MULTIPLY S6 BY D7 + MULTIPLY S7 BY D1 + PERFORM DISPLAY-D. + MULTIPLY S1 BY D3 + MULTIPLY S2 BY D4 + MULTIPLY S3 BY D5 + MULTIPLY S4 BY D6 + MULTIPLY S5 BY D7 + MULTIPLY S6 BY D1 + MULTIPLY S7 BY D2 + PERFORM DISPLAY-D. + MULTIPLY S1 BY D4 + MULTIPLY S2 BY D5 + MULTIPLY S3 BY D6 + MULTIPLY S4 BY D7 + MULTIPLY S5 BY D1 + MULTIPLY S6 BY D2 + MULTIPLY S7 BY D3 + PERFORM DISPLAY-D. + MULTIPLY S1 BY D5 + MULTIPLY S2 BY D6 + MULTIPLY S3 BY D7 + MULTIPLY S4 BY D1 + MULTIPLY S5 BY D2 + MULTIPLY S6 BY D3 + MULTIPLY S7 BY D4 + PERFORM DISPLAY-D. + MULTIPLY S1 BY D6 + MULTIPLY S2 BY D7 + MULTIPLY S3 BY D1 + MULTIPLY S4 BY D2 + MULTIPLY S5 BY D3 + MULTIPLY S6 BY D4 + MULTIPLY S7 BY D5 + PERFORM DISPLAY-D. + MULTIPLY S1 BY D7 + MULTIPLY S2 BY D1 + MULTIPLY S3 BY D2 + MULTIPLY S4 BY D3 + MULTIPLY S5 BY D4 + MULTIPLY S6 BY D5 + MULTIPLY S7 BY D6 + PERFORM DISPLAY-D. + GOBACK. + DISPLAY-D. + DISPLAY D1 SPACE + D2 SPACE + D3 SPACE + D4 SPACE + D5 SPACE + D6 SPACE + D7 . + INITIALIZE D1 D2 D3 D4 D5 D6 D7 ALL VALUE. + END PROGRAM float-mult1. + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_1.out b/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_1.out new file mode 100644 index 0000000..2722545 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_1.out @@ -0,0 +1,8 @@ +001.32 001.32 001.32 001.32 1.320000052 1.32000000000000006 1.320000000000000000000000000000000054 +001.32 001.32 001.32 001.32 1.320000052 1.3200000524520874 1.319999999999999951150186916493112221 +001.31 001.32 001.32 001.32 1.320000052 1.32000000000000006 1.32000005245208740234375 +001.32 001.31 001.32 001.32 1.320000052 1.32000000000000006 1.320000000000000000000000000000000054 +001.32 001.32 001.31 001.32 1.320000052 1.32000000000000006 1.320000000000000000000000000000000054 +001.32 001.32 001.32 001.31 1.320000052 1.32000000000000006 1.320000000000000000000000000000000054 +001.32 001.32 001.32 001.32 1.320000052 1.32000000000000006 1.320000000000000000000000000000000054 + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_2.cob b/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_2.cob new file mode 100644 index 0000000..183f1af --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_2.cob @@ -0,0 +1,96 @@ + *> { dg-do run } + *> { dg-output-file "group2/floating-point_MULTIPLY_FORMAT_2.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-MULTIPLY2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 S1 PIC 999V99 DISPLAY VALUE 111.00 . + 01 S2 PIC 999V99 COMP VALUE 111.00 . + 01 S3 PIC 999V99 COMP-3 VALUE 111.00 . + 01 S4 PIC 999V99 COMP-5 VALUE 111.00 . + 01 S5 FLOAT-SHORT VALUE 111.00 . + 01 S6 FLOAT-LONG VALUE 111.00 . + 01 S7 FLOAT-EXTENDED VALUE 111.00 . + 01 D1 PIC 999V99 DISPLAY VALUE 1.11 . + 01 D2 PIC 999V99 COMP VALUE 1.11 . + 01 D3 PIC 999V99 COMP-3 VALUE 1.11 . + 01 D4 PIC 999V99 COMP-5 VALUE 1.11 . + 01 D5 FLOAT-SHORT VALUE 1.11 . + 01 D6 FLOAT-LONG VALUE 1.11 . + 01 D7 FLOAT-EXTENDED VALUE 1.11 . + 01 X1 PIC 999V99 DISPLAY . + 01 X2 PIC 999V99 COMP . + 01 X3 PIC 999V99 COMP-3 . + 01 X4 PIC 999V99 COMP-5 . + 01 X5 FLOAT-SHORT . + 01 X6 FLOAT-LONG . + 01 X7 FLOAT-EXTENDED . + PROCEDURE DIVISION. + MULTIPLY S1 BY D1 GIVING X1 + MULTIPLY S2 BY D2 GIVING X2 + MULTIPLY S3 BY D3 GIVING X3 + MULTIPLY S4 BY D4 GIVING X4 + MULTIPLY S5 BY D5 GIVING X5 + MULTIPLY S6 BY D6 GIVING X6 + MULTIPLY S7 BY D7 GIVING X7 + PERFORM DISPLAY-X. + MULTIPLY S2 BY D1 GIVING X1 + MULTIPLY S3 BY D2 GIVING X2 + MULTIPLY S4 BY D3 GIVING X3 + MULTIPLY S5 BY D4 GIVING X4 + MULTIPLY S6 BY D5 GIVING X5 + MULTIPLY S7 BY D6 GIVING X6 + MULTIPLY S1 BY D7 GIVING X7 + PERFORM DISPLAY-X. + MULTIPLY S3 BY D1 GIVING X1 + MULTIPLY S4 BY D2 GIVING X2 + MULTIPLY S5 BY D3 GIVING X3 + MULTIPLY S6 BY D4 GIVING X4 + MULTIPLY S7 BY D5 GIVING X5 + MULTIPLY S1 BY D6 GIVING X6 + MULTIPLY S2 BY D7 GIVING X7 + PERFORM DISPLAY-X. + MULTIPLY S4 BY D1 GIVING X1 + MULTIPLY S5 BY D2 GIVING X2 + MULTIPLY S6 BY D3 GIVING X3 + MULTIPLY S7 BY D4 GIVING X4 + MULTIPLY S1 BY D5 GIVING X5 + MULTIPLY S2 BY D6 GIVING X6 + MULTIPLY S3 BY D7 GIVING X7 + PERFORM DISPLAY-X. + MULTIPLY S5 BY D1 GIVING X1 + MULTIPLY S6 BY D2 GIVING X2 + MULTIPLY S7 BY D3 GIVING X3 + MULTIPLY S1 BY D4 GIVING X4 + MULTIPLY S2 BY D5 GIVING X5 + MULTIPLY S3 BY D6 GIVING X6 + MULTIPLY S4 BY D7 GIVING X7 + PERFORM DISPLAY-X. + MULTIPLY S6 BY D1 GIVING X1 + MULTIPLY S7 BY D2 GIVING X2 + MULTIPLY S1 BY D3 GIVING X3 + MULTIPLY S2 BY D4 GIVING X4 + MULTIPLY S3 BY D5 GIVING X5 + MULTIPLY S4 BY D6 GIVING X6 + MULTIPLY S5 BY D7 GIVING X7 + PERFORM DISPLAY-X. + MULTIPLY S7 BY D1 GIVING X1 + MULTIPLY S1 BY D2 GIVING X2 + MULTIPLY S2 BY D3 GIVING X3 + MULTIPLY S3 BY D4 GIVING X4 + MULTIPLY S4 BY D5 GIVING X5 + MULTIPLY S5 BY D6 GIVING X6 + MULTIPLY S6 BY D7 GIVING X7 + PERFORM DISPLAY-X. + GOBACK. + DISPLAY-X. + DISPLAY X1 SPACE + X2 SPACE + X3 SPACE + X4 SPACE + X5 SPACE + X6 SPACE + X7 . + END PROGRAM float-MULTIPLY2. + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_2.out b/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_2.out new file mode 100644 index 0000000..c8f6231 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_MULTIPLY_FORMAT_2.out @@ -0,0 +1,8 @@ +123.21 123.21 123.21 123.21 123.2099991 123.210000000000008 123.2100000000000000000000000000000069 +123.21 123.21 123.21 123.21 123.2099991 123.210000000000008 123.2100000000000000000000000000000069 +123.21 123.21 123.21 123.21 123.2099991 123.210000000000008 123.2100000000000000000000000000000069 +123.21 123.21 123.21 123.21 123.2099991 123.210000000000008 123.2100000000000000000000000000000069 +123.21 123.21 123.21 123.21 123.2099991 123.210000000000008 123.2100000000000000000000000000000069 +123.21 123.21 123.21 123.21 123.2099991 123.210000000000008 123.2100000000000000000000000000000069 +123.21 123.21 123.21 123.21 123.2099991 123.210000000000008 123.2100000000000000000000000000000069 + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_1.cob b/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_1.cob new file mode 100644 index 0000000..7ba8161 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_1.cob @@ -0,0 +1,90 @@ + *> { dg-do run } + *> { dg-output-file "group2/floating-point_SUBTRACT_FORMAT_1.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-sub1. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 S1 PIC 999V99 DISPLAY VALUE 111.11 . + 01 S2 PIC 999V99 COMP VALUE 111.11 . + 01 S3 PIC 999V99 COMP-3 VALUE 111.11 . + 01 S4 PIC 999V99 COMP-5 VALUE 111.11 . + 01 S5 FLOAT-SHORT VALUE 111.11 . + 01 S6 FLOAT-LONG VALUE 111.11 . + 01 S7 FLOAT-EXTENDED VALUE 111.11 . + 01 D1 PIC 999V99 DISPLAY VALUE 666.66. + 01 D2 PIC 999V99 COMP VALUE 666.66. + 01 D3 PIC 999V99 COMP-3 VALUE 666.66. + 01 D4 PIC 999V99 COMP-5 VALUE 666.66. + 01 D5 FLOAT-SHORT VALUE 666.66. + 01 D6 FLOAT-LONG VALUE 666.66. + 01 D7 FLOAT-EXTENDED VALUE 666.66. + PROCEDURE DIVISION. + SUBTRACT S1 FROM D1 + SUBTRACT S1 FROM D2 + SUBTRACT S1 FROM D3 + SUBTRACT S1 FROM D4 + SUBTRACT S1 FROM D5 + SUBTRACT S1 FROM D6 + SUBTRACT S1 FROM D7 + PERFORM DISPLAY-D. + SUBTRACT S2 FROM D2 + SUBTRACT S2 FROM D3 + SUBTRACT S2 FROM D4 + SUBTRACT S2 FROM D5 + SUBTRACT S2 FROM D6 + SUBTRACT S2 FROM D7 + SUBTRACT S2 FROM D1 + PERFORM DISPLAY-D. + SUBTRACT S3 FROM D3 + SUBTRACT S3 FROM D4 + SUBTRACT S3 FROM D5 + SUBTRACT S3 FROM D6 + SUBTRACT S3 FROM D7 + SUBTRACT S3 FROM D1 + SUBTRACT S3 FROM D2 + PERFORM DISPLAY-D. + SUBTRACT S4 FROM D4 + SUBTRACT S4 FROM D5 + SUBTRACT S4 FROM D6 + SUBTRACT S4 FROM D7 + SUBTRACT S4 FROM D1 + SUBTRACT S4 FROM D2 + SUBTRACT S4 FROM D3 + PERFORM DISPLAY-D. + SUBTRACT S5 FROM D5 + SUBTRACT S5 FROM D6 + SUBTRACT S5 FROM D7 + SUBTRACT S5 FROM D1 + SUBTRACT S5 FROM D2 + SUBTRACT S5 FROM D3 + SUBTRACT S5 FROM D4 + PERFORM DISPLAY-D. + SUBTRACT S6 FROM D6 + SUBTRACT S6 FROM D7 + SUBTRACT S6 FROM D1 + SUBTRACT S6 FROM D2 + SUBTRACT S6 FROM D3 + SUBTRACT S6 FROM D4 + SUBTRACT S6 FROM D5 + PERFORM DISPLAY-D. + SUBTRACT S7 FROM D7 + SUBTRACT S7 FROM D1 + SUBTRACT S7 FROM D2 + SUBTRACT S7 FROM D3 + SUBTRACT S7 FROM D4 + SUBTRACT S7 FROM D5 + SUBTRACT S7 FROM D6 + PERFORM DISPLAY-D. + GOBACK. + DISPLAY-D. + DISPLAY D1 SPACE + D2 SPACE + D3 SPACE + D4 SPACE + D5 SPACE + D6 SPACE + D7 . + INITIALIZE D1 D2 D3 D4 D5 D6 D7 ALL VALUE. + END PROGRAM float-sub1. + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_1.out b/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_1.out new file mode 100644 index 0000000..39978ac --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_1.out @@ -0,0 +1,8 @@ +555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606 +555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606 +555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606 +555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606 +555.54 555.54 555.54 555.54 555.5499878 555.549999389648406 555.5499993896484374999999999999999724 +555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5500000000000005684341886080801211 +555.54 555.54 555.54 555.54 555.5499878 555.549999999999955 555.5499999999999999999999999999999606 + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_2.cob b/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_2.cob new file mode 100644 index 0000000..fa7d6a1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_2.cob @@ -0,0 +1,96 @@ + *> { dg-do run } + *> { dg-output-file "group2/floating-point_SUBTRACT_FORMAT_2.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-SUBTRACT2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 S1 PIC 999V99 DISPLAY VALUE 123.45 . + 01 S2 PIC 999V99 COMP VALUE 123.45 . + 01 S3 PIC 999V99 COMP-3 VALUE 123.45 . + 01 S4 PIC 999V99 COMP-5 VALUE 123.45 . + 01 S5 FLOAT-SHORT VALUE 123.45 . + 01 S6 FLOAT-LONG VALUE 123.45 . + 01 S7 FLOAT-EXTENDED VALUE 123.45 . + 01 D1 PIC 999V99 DISPLAY VALUE 678.55 . + 01 D2 PIC 999V99 COMP VALUE 678.55 . + 01 D3 PIC 999V99 COMP-3 VALUE 678.55 . + 01 D4 PIC 999V99 COMP-5 VALUE 678.55 . + 01 D5 FLOAT-SHORT VALUE 678.55 . + 01 D6 FLOAT-LONG VALUE 678.55 . + 01 D7 FLOAT-EXTENDED VALUE 678.55 . + 01 X1 PIC 999V99 DISPLAY . + 01 X2 PIC 999V99 COMP . + 01 X3 PIC 999V99 COMP-3 . + 01 X4 PIC 999V99 COMP-5 . + 01 X5 FLOAT-SHORT . + 01 X6 FLOAT-LONG . + 01 X7 FLOAT-EXTENDED . + PROCEDURE DIVISION. + SUBTRACT S1 FROM D1 GIVING X1 + SUBTRACT S2 FROM D2 GIVING X2 + SUBTRACT S3 FROM D3 GIVING X3 + SUBTRACT S4 FROM D4 GIVING X4 + SUBTRACT S5 FROM D5 GIVING X5 + SUBTRACT S6 FROM D6 GIVING X6 + SUBTRACT S7 FROM D7 GIVING X7 + PERFORM DISPLAY-X. + SUBTRACT S2 FROM D1 GIVING X1 + SUBTRACT S3 FROM D2 GIVING X2 + SUBTRACT S4 FROM D3 GIVING X3 + SUBTRACT S5 FROM D4 GIVING X4 + SUBTRACT S6 FROM D5 GIVING X5 + SUBTRACT S7 FROM D6 GIVING X6 + SUBTRACT S1 FROM D7 GIVING X7 + PERFORM DISPLAY-X. + SUBTRACT S3 FROM D1 GIVING X1 + SUBTRACT S4 FROM D2 GIVING X2 + SUBTRACT S5 FROM D3 GIVING X3 + SUBTRACT S6 FROM D4 GIVING X4 + SUBTRACT S7 FROM D5 GIVING X5 + SUBTRACT S1 FROM D6 GIVING X6 + SUBTRACT S2 FROM D7 GIVING X7 + PERFORM DISPLAY-X. + SUBTRACT S4 FROM D1 GIVING X1 + SUBTRACT S5 FROM D2 GIVING X2 + SUBTRACT S6 FROM D3 GIVING X3 + SUBTRACT S7 FROM D4 GIVING X4 + SUBTRACT S1 FROM D5 GIVING X5 + SUBTRACT S2 FROM D6 GIVING X6 + SUBTRACT S3 FROM D7 GIVING X7 + PERFORM DISPLAY-X. + SUBTRACT S5 FROM D1 GIVING X1 + SUBTRACT S6 FROM D2 GIVING X2 + SUBTRACT S7 FROM D3 GIVING X3 + SUBTRACT S1 FROM D4 GIVING X4 + SUBTRACT S2 FROM D5 GIVING X5 + SUBTRACT S3 FROM D6 GIVING X6 + SUBTRACT S4 FROM D7 GIVING X7 + PERFORM DISPLAY-X. + SUBTRACT S6 FROM D1 GIVING X1 + SUBTRACT S7 FROM D2 GIVING X2 + SUBTRACT S1 FROM D3 GIVING X3 + SUBTRACT S2 FROM D4 GIVING X4 + SUBTRACT S3 FROM D5 GIVING X5 + SUBTRACT S4 FROM D6 GIVING X6 + SUBTRACT S5 FROM D7 GIVING X7 + PERFORM DISPLAY-X. + SUBTRACT S7 FROM D1 GIVING X1 + SUBTRACT S1 FROM D2 GIVING X2 + SUBTRACT S2 FROM D3 GIVING X3 + SUBTRACT S3 FROM D4 GIVING X4 + SUBTRACT S4 FROM D5 GIVING X5 + SUBTRACT S5 FROM D6 GIVING X6 + SUBTRACT S6 FROM D7 GIVING X7 + PERFORM DISPLAY-X. + GOBACK. + DISPLAY-X. + DISPLAY X1 SPACE + X2 SPACE + X3 SPACE + X4 SPACE + X5 SPACE + X6 SPACE + X7 . + END PROGRAM float-SUBTRACT2. + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_2.out b/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_2.out new file mode 100644 index 0000000..e0bf4c9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_SUBTRACT_FORMAT_2.out @@ -0,0 +1,8 @@ +555.10 555.10 555.10 555.10 555.0999756 555.100000000000023 555.1000000000000000000000000000000197 +555.10 555.10 555.10 555.10 555.0999756 555.100000000000023 555.1000000000000000000000000000000197 +555.10 555.10 555.10 555.10 555.0999756 555.100000000000023 555.1000000000000000000000000000000197 +555.10 555.10 555.10 555.10 555.0999756 555.100000000000023 555.1000000000000000000000000000000197 +555.10 555.10 555.10 555.10 555.0999756 555.100000000000023 555.1000000000000000000000000000000197 +555.10 555.10 555.10 555.10 555.0999756 555.100000000000023 555.1000000000000000000000000000000197 +555.10 555.10 555.10 555.10 555.0999756 555.100000000000023 555.1000000000000000000000000000000197 + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_literals.cob b/gcc/testsuite/cobol.dg/group2/floating-point_literals.cob new file mode 100644 index 0000000..51d823207 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_literals.cob @@ -0,0 +1,48 @@ + *> { dg-do run } + *> { dg-output-file "group2/floating-point_literals.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. float-literal. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 D1 PIC 999V9999 DISPLAY . + 01 D2 PIC 999V9999 COMP . + 01 D3 PIC 999V9999 COMP-3 . + 01 D4 PIC 999V9999 COMP-5 . + 01 D5 FLOAT-SHORT . + 01 D6 FLOAT-LONG . + 01 D7 FLOAT-EXTENDED . + PROCEDURE DIVISION. + DISPLAY -555 + DISPLAY -555.55 + DISPLAY -555.55e206 + DISPLAY 555 + DISPLAY 555.55 + DISPLAY 555.55e206 + MOVE 333.33 TO D1 + MOVE 333.33 TO D2 + MOVE 333.33 TO D3 + MOVE 333.33 TO D4 + MOVE 333.33e20 TO D5 + MOVE 333.33e100 TO D6 + MOVE 333.33e200 TO D7 + PERFORM DISPLAY-D. + ADD 222.22 TO D1 + ADD 222.22 TO D2 + ADD 222.22 TO D3 + ADD 222.22 TO D4 + ADD 222.22e20 TO D5 + ADD 222.22e100 TO D6 + ADD 222.22e200 TO D7 + PERFORM DISPLAY-D. + GOBACK. + DISPLAY-D. + DISPLAY D1 SPACE + D2 SPACE + D3 SPACE + D4 SPACE + D5 SPACE + D6 SPACE + D7 . + END PROGRAM float-literal. + diff --git a/gcc/testsuite/cobol.dg/group2/floating-point_literals.out b/gcc/testsuite/cobol.dg/group2/floating-point_literals.out new file mode 100644 index 0000000..6417d01 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/floating-point_literals.out @@ -0,0 +1,9 @@ +-555 +-555.55 +-5.5555E+208 +555 +555.55 +5.5555E+208 +333.3300 333.3300 333.3300 333.3300 3.333300083E+22 3.33329999999999994E+102 3.333300000000000000000000000000000168E+202 +555.5500 555.5500 555.5500 555.5500 5.555499988E+22 5.55549999999999973E+102 5.555500000000000000000000000000000029E+202 + diff --git a/gcc/testsuite/cobol.dg/literal1.cob b/gcc/testsuite/cobol.dg/literal1.cob new file mode 100644 index 0000000..43369e0 --- /dev/null +++ b/gcc/testsuite/cobol.dg/literal1.cob @@ -0,0 +1,14 @@ +*> { dg-do run } +*> Make sure we properly round to integer when computing the initial +*> binary representation of a literal +IDENTIFICATION DIVISION. +PROGRAM-ID. literal1. +DATA DIVISION. +WORKING-STORAGE SECTION. + 77 VAR8 PIC 999V9(8) COMP-5 . + 77 VAR555 PIC 999V99999999 COMP-5 VALUE 555.55555555. + PROCEDURE DIVISION. + MOVE 555.55555555 TO VAR8 + ADD 0.00000001 TO VAR555 GIVING VAR8 ROUNDED + IF VAR8 NOT EQUAL TO 555.55555556 STOP RUN ERROR 1. + END PROGRAM literal1. diff --git a/gcc/testsuite/cobol.dg/output1.cob b/gcc/testsuite/cobol.dg/output1.cob new file mode 100644 index 0000000..9475bde --- /dev/null +++ b/gcc/testsuite/cobol.dg/output1.cob @@ -0,0 +1,14 @@ +*> { dg-do run } +*> { dg-output {-0.00012(\n|\r\n|\r)} } +*> { dg-output {0.00012(\n|\r\n|\r)} } +*> { dg-output {1234.66(\n|\r\n|\r)} } +*> { dg-output {-99.8(\n|\r\n|\r)} } +IDENTIFICATION DIVISION. +PROGRAM-ID. output1. +ENVIRONMENT DIVISION. +PROCEDURE DIVISION. + DISPLAY -0.00012 + DISPLAY 0.00012 + DISPLAY 1234.66 + DISPLAY -99.8 + STOP RUN. |