diff options
Diffstat (limited to 'gcc/testsuite/cobol.dg')
222 files changed, 6057 insertions, 2 deletions
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 index 7a404fd..be58878 100644 --- 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 @@ -1,5 +1,5 @@ *> { dg-do run } - *> { dg-set-target-env-var COB_CURRENT_DATE "2020/06/12 18:45:22" } + *> { dg-set-target-env-var GCOBOL_CURRENT_DATE "2020/06/12 18:45:22" } IDENTIFICATION DIVISION. PROGRAM-ID. prog. 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 index 6014220..665787d 100644 --- 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 @@ -1,5 +1,5 @@ *> { dg-do run } - *> { dg-set-target-env-var COB_CURRENT_DATE "2015/04/05 18:45:22" } + *> { dg-set-target-env-var GCOBOL_CURRENT_DATE "2015/04/05 18:45:22" } *> { dg-output-file "group2/ACCEPT_FROM_TIME___DATE___DAY___DAY-OF-WEEK__2_.out" } IDENTIFICATION DIVISION. diff --git a/gcc/testsuite/cobol.dg/group2/Dynamic_reference_modification.cob b/gcc/testsuite/cobol.dg/group2/Dynamic_reference_modification.cob new file mode 100644 index 0000000..99690da --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Dynamic_reference_modification.cob @@ -0,0 +1,24 @@ + *> { dg-do run } + *> { dg-output-file "group2/Dynamic_reference_modification.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "abcd". + 01 I PIC 9. + PROCEDURE DIVISION. + MOVE 1 TO I. + DISPLAY X(I:1) + END-DISPLAY. + MOVE 4 TO I. + DISPLAY X(I:1) + END-DISPLAY. + MOVE 1 TO I. + DISPLAY X(1:I) + END-DISPLAY. + MOVE 4 TO I. + DISPLAY X(1:I) + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Dynamic_reference_modification.out b/gcc/testsuite/cobol.dg/group2/Dynamic_reference_modification.out new file mode 100644 index 0000000..42a4b69 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Dynamic_reference_modification.out @@ -0,0 +1,5 @@ +a +d +a +abcd + 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..cc2a4e1 --- /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"GCOBOL_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/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/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/Length_overflow__1_.cob b/gcc/testsuite/cobol.dg/group2/Length_overflow__1_.cob new file mode 100644 index 0000000..6475356 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow__1_.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/Length_overflow__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "abcd". + 01 I PIC 9 VALUE 5. + PROCEDURE DIVISION. + >>TURN EC-ALL CHECKING ON + DISPLAY X(1:I) NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow__1_.out b/gcc/testsuite/cobol.dg/group2/Length_overflow__1_.out new file mode 100644 index 0000000..78981922 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow__1_.out @@ -0,0 +1 @@ +a diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.cob b/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.cob new file mode 100644 index 0000000..351c9df --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/Length_overflow__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "abcd". + 01 I PIC 9 VALUE 5. + PROCEDURE DIVISION. + >>TURN EC-ALL CHECKING ON + DISPLAY X(3:I) NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.out b/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.out new file mode 100644 index 0000000..f2ad6c7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.out @@ -0,0 +1 @@ +c diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.cob b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.cob new file mode 100644 index 0000000..9f7fa83 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/Length_overflow_with_offset__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "abcd". + 01 I PIC 9 VALUE 3. + PROCEDURE DIVISION. + >>TURN EC-ALL CHECKING ON + DISPLAY X(3:I) NO ADVANCING. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.out b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.out new file mode 100644 index 0000000..f2ad6c7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.out @@ -0,0 +1 @@ +c diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__2_.cob b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__2_.cob new file mode 100644 index 0000000..d077373 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__2_.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/Length_overflow_with_offset__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "abcd". + 01 I PIC 9 VALUE 3. + PROCEDURE DIVISION. + >>TURN EC-ALL CHECKING ON + IF X(3:I) <> SPACES + DISPLAY X(3:I) NO ADVANCING. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__2_.out b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__2_.out new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__2_.out @@ -0,0 +1 @@ + diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__3_.cob b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__3_.cob new file mode 100644 index 0000000..7fa9843 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__3_.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/Length_overflow_with_offset__3_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "abcd". + 01 I PIC 9 VALUE 3. + PROCEDURE DIVISION. + >>TURN EC-ALL CHECKING ON + EVALUATE TRUE + WHEN I < 2 + AND X(3:I) <> SPACES + DISPLAY "1-" X(3:I) NO ADVANCING + WHEN I < 2 + WHEN X(3:I) <> SPACES + DISPLAY "2-" X(3:I) NO ADVANCING + END-EVALUATE + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__3_.out b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__3_.out new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__3_.out @@ -0,0 +1 @@ + diff --git a/gcc/testsuite/cobol.dg/group2/Offset_overflow.cob b/gcc/testsuite/cobol.dg/group2/Offset_overflow.cob new file mode 100644 index 0000000..8fd5421 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Offset_overflow.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/Offset_overflow.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01. + 03 X PIC X(4) VALUE "abcd". + 03 I PIC 9 VALUE 5. + PROCEDURE DIVISION. + >>TURN EC-ALL CHECKING ON + DISPLAY X(I:1) NO ADVANCING. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Offset_overflow.out b/gcc/testsuite/cobol.dg/group2/Offset_overflow.out new file mode 100644 index 0000000..7ed6ff8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Offset_overflow.out @@ -0,0 +1 @@ +5 diff --git a/gcc/testsuite/cobol.dg/group2/Offset_underflow.cob b/gcc/testsuite/cobol.dg/group2/Offset_underflow.cob new file mode 100644 index 0000000..51100a8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Offset_underflow.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/Offset_underflow.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "abcd". + 01 I PIC 9 VALUE 0. + PROCEDURE DIVISION. + >>TURN EC-ALL CHECKING ON + DISPLAY X(I:1) NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Offset_underflow.out b/gcc/testsuite/cobol.dg/group2/Offset_underflow.out new file mode 100644 index 0000000..78981922 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Offset_underflow.out @@ -0,0 +1 @@ +a 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/Refmod__comparisons_inside_numeric-display.cob b/gcc/testsuite/cobol.dg/group2/Refmod__comparisons_inside_numeric-display.cob new file mode 100644 index 0000000..6fb70f4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Refmod__comparisons_inside_numeric-display.cob @@ -0,0 +1,20 @@ + *> { dg-do run } + *> { dg-output-file "group2/Refmod__comparisons_inside_numeric-display.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 n pic 9(9). + 01 i pic 99. + procedure division. + perform varying i from 1 by 1 until i > 8 + move 88888888 to n + move "12" to n(i:2) + display n + if n(i:2) not equal to "12" + display "Equality is flawed" + end-if + end-perform. + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Refmod__comparisons_inside_numeric-display.out b/gcc/testsuite/cobol.dg/group2/Refmod__comparisons_inside_numeric-display.out new file mode 100644 index 0000000..ac48dc8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Refmod__comparisons_inside_numeric-display.out @@ -0,0 +1,9 @@ +128888888 +012888888 +081288888 +088128888 +088812888 +088881288 +088888128 +088888812 + diff --git a/gcc/testsuite/cobol.dg/group2/Refmod_sources_are_figurative_constants.cob b/gcc/testsuite/cobol.dg/group2/Refmod_sources_are_figurative_constants.cob new file mode 100644 index 0000000..c4af57d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Refmod_sources_are_figurative_constants.cob @@ -0,0 +1,29 @@ + *> { dg-do run } + *> { dg-output-file "group2/Refmod_sources_are_figurative_constants.out" } + + id division. + program-id. prog. + data division. + working-storage section. + 01 varx pic x(8) VALUE '""""""""'. + 01 varp redefines varx pointer. + procedure division. + move "12345678" to varx + display """" varx """" + move "999" to varx(4:3) + display """" varx """" + move LOW-VALUE to varx(4:3). + display """" varx """" + move ZERO to varx(4:3). + display """" varx """" + move SPACE to varx(4:3). + display """" varx """" + move QUOTE to varx(4:3). + display """" varx """" + move HIGH-VALUE to varx(4:3). + display varp + initialize varx all to value + display """" varx """" + . + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Refmod_sources_are_figurative_constants.out b/gcc/testsuite/cobol.dg/group2/Refmod_sources_are_figurative_constants.out new file mode 100644 index 0000000..2f5dadc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Refmod_sources_are_figurative_constants.out @@ -0,0 +1,9 @@ +"12345678" +"12399978" +"123" +"12300078" +"123 78" +"123"""78" +0x3837ffffff333231 +"""""""""" + 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/Static_reference_modification.cob b/gcc/testsuite/cobol.dg/group2/Static_reference_modification.cob new file mode 100644 index 0000000..919ddb3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Static_reference_modification.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + *> { dg-output-file "group2/Static_reference_modification.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "abcd". + PROCEDURE DIVISION. + DISPLAY X(1:1) ":" X(1:2) ":" X(1:3) ":" X(1:4) ":" X(1:) + END-DISPLAY. + DISPLAY X(2:1) ":" X(2:2) ":" X(2:3) ":" X(2:) + END-DISPLAY. + DISPLAY X(3:1) ":" X(3:2) ":" X(3:) + END-DISPLAY. + DISPLAY X(4:1) ":" X(4:) + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Static_reference_modification.out b/gcc/testsuite/cobol.dg/group2/Static_reference_modification.out new file mode 100644 index 0000000..fe51165 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Static_reference_modification.out @@ -0,0 +1,5 @@ +a:ab:abc:abcd:abcd +b:bc:bcd:bcd +c:cd:cd +d:d + 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 " + |