diff options
Diffstat (limited to 'gcc/testsuite/cobol.dg/group2')
460 files changed, 13643 insertions, 2 deletions
diff --git a/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.cob b/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.cob new file mode 100644 index 0000000..383cd0a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/258_Nested_PERFORM.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + PERFORM 2 TIMES + DISPLAY "X" NO ADVANCING + END-DISPLAY + PERFORM 2 TIMES + DISPLAY "Y" NO ADVANCING + END-DISPLAY + END-PERFORM + END-PERFORM. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.out b/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.out new file mode 100644 index 0000000..3c3d159 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.out @@ -0,0 +1 @@ +XYYXYY diff --git a/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.cob b/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.cob new file mode 100644 index 0000000..295caf5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + *> { dg-output-file "group2/259_PERFORM_VARYING_BY_-0.2.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 X PIC 9v9. + PROCEDURE DIVISION. + PERFORM VARYING X FROM 0.8 BY -0.2 + UNTIL X < 0.4 + DISPLAY "X" NO ADVANCING + END-DISPLAY + END-PERFORM. + IF X NOT = 0.2 + DISPLAY "WRONG X: " X END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.out b/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.out new file mode 100644 index 0000000..dd6d86a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.out @@ -0,0 +1 @@ +XXX diff --git a/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.cob b/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.cob new file mode 100644 index 0000000..5405dba --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.cob @@ -0,0 +1,75 @@ + *> { dg-do run } + *> { dg-output-file "group2/338_Default_Arithmetic__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 NUM-A PIC 9(3) VALUE 399. + 01 NUM-B PIC 9(3) VALUE 211. + 01 NUM-C PIC 9(3)V99 VALUE 212.34. + 01 NUMV1 PIC 9(3)V9. + 01 PICX PIC X VALUE 'A'. + 01 RSLT PIC 9(3). + 01 RSLTV1 PIC 9(3).9. + 01 RSLTV2 PIC 9(3).99. + * + PROCEDURE DIVISION. + MAIN. + COMPUTE RSLT = NUM-A + 1.1. + DISPLAY 'Simple Compute RSLT IS ' RSLT + COMPUTE RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 + DISPLAY 'Single Variable RSLT IS ' RSLT + COMPUTE RSLTV2, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 + DISPLAY 'Compute RSLT IS ' RSLT + DISPLAY 'Compute RSLTv99 IS ' RSLTV2 + COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 + DISPLAY 'Compute RSLT IS ' RSLT + DISPLAY 'Compute RSLTv9 IS ' RSLTV1 + MOVE 0 TO RSLT + ADD NUM-C TO RSLT. + DISPLAY 'Add RSLT IS ' RSLT. + MOVE 0 TO RSLT + ADD NUM-A NUM-C 10 TO RSLT. + DISPLAY 'Add RSLT IS ' RSLT. + SUBTRACT NUM-C FROM RSLT. + DISPLAY 'Subtract RSLT IS ' RSLT. + SUBTRACT NUM-A -10 FROM RSLT. + DISPLAY 'Subtract RSLT IS ' RSLT. + MOVE 0 TO RSLT + ADD NUM-A NUM-C TO RSLT GIVING RSLTV1. + DISPLAY 'Add RSLTv9 IS ' RSLTV1 + MULTIPLY NUM-A BY NUM-C GIVING RSLT. + DISPLAY 'Multiply RSLT IS ' RSLT. + MULTIPLY RSLT BY NUM-C. + DISPLAY 'Multiply RSLT IS ' RSLT. + DIVIDE NUM-A BY 10 GIVING RSLT. + DISPLAY 'Divide RSLT IS ' RSLT. + DIVIDE RSLT BY 4 GIVING RSLTV1. + DISPLAY 'Divide RSLTv9 IS ' RSLTV1. + DIVIDE RSLT BY 4 GIVING RSLT. + DISPLAY 'Divide RSLT IS ' RSLT. + + COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 + DISPLAY 'Simple RSLT IS ' RSLT + ' RSLTv9 IS ' RSLTV1. + + COMPUTE RSLTV1, RSLT = ((NUM-A / (100.55 + -0.550)) + - (NUM-B / (10.11 * 10 - 1.1))) + * (220 / 2.2) + DISPLAY 'Complex RSLT IS ' RSLT + ' RSLTv9 IS ' RSLTV1. + + COMPUTE RSLTV1, RSLT = ((NUM-A / (101 - 1)) + - (NUM-B / (10 * 10))) * (200 / 2) + DISPLAY 'Reduced RSLT IS ' RSLT + ' RSLTv9 IS ' RSLTV1. + MOVE NUM-A TO NUMV1. + IF ((NUMV1 / (101 - 1)) + - (NUM-B / (10 * 10))) * (200 / 2) EQUAL 188 + DISPLAY "Not Using ARITHMETIC-OSVS" + ELSE + DISPLAY "Using ARITHMETIC-OSVS" + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.out b/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.out new file mode 100644 index 0000000..3137fc4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.out @@ -0,0 +1,21 @@ +Simple Compute RSLT IS 400 +Single Variable RSLT IS 188 +Compute RSLT IS 188 +Compute RSLTv99 IS 188.00 +Compute RSLT IS 188 +Compute RSLTv9 IS 188.0 +Add RSLT IS 212 +Add RSLT IS 621 +Subtract RSLT IS 408 +Subtract RSLT IS 019 +Add RSLTv9 IS 611.3 +Multiply RSLT IS 723 +Multiply RSLT IS 723 +Divide RSLT IS 039 +Divide RSLTv9 IS 009.7 +Divide RSLT IS 009 +Simple RSLT IS 188 RSLTv9 IS 188.0 +Complex RSLT IS 188 RSLTv9 IS 188.0 +Reduced RSLT IS 188 RSLTv9 IS 188.0 +Not Using ARITHMETIC-OSVS + diff --git a/gcc/testsuite/cobol.dg/group2/88_level_with_FALSE_IS_clause.cob b/gcc/testsuite/cobol.dg/group2/88_level_with_FALSE_IS_clause.cob new file mode 100644 index 0000000..012da75 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/88_level_with_FALSE_IS_clause.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 MYFLD PIC X(6) VALUE "ABCDEF". + 88 MYFLD88 VALUE "ABCDEF" + FALSE IS "OKOKOK". + PROCEDURE DIVISION. + ASTART SECTION. + A01. + SET MYFLD88 TO FALSE + IF MYFLD NOT = "OKOKOK" + DISPLAY MYFLD + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/88_level_with_FILLER.cob b/gcc/testsuite/cobol.dg/group2/88_level_with_FILLER.cob new file mode 100644 index 0000000..49157f4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/88_level_with_FILLER.cob @@ -0,0 +1,20 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FILLER PIC X VALUE SPACE. + 88 X VALUE "X". + PROCEDURE DIVISION. + IF X + DISPLAY "NOT OK" + END-DISPLAY + END-IF + SET X TO TRUE. + IF NOT X + DISPLAY "NOT OK" + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/88_level_with_THRU.cob b/gcc/testsuite/cobol.dg/group2/88_level_with_THRU.cob new file mode 100644 index 0000000..005bb64 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/88_level_with_THRU.cob @@ -0,0 +1,86 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR-X PIC X VALUE SPACE. + 88 X VALUE "X". + 88 T-Y VALUE "T" THRU "Y". + 01 VAR-9 PIC 9 VALUE ZERO. + 88 V9 VALUE 9. + 88 V2-4 VALUE 2 THRU 4. + PROCEDURE DIVISION. + IF X + DISPLAY "NOT OK '" VAR-X "' IS X" + END-DISPLAY + END-IF + SET X TO TRUE + IF NOT X + DISPLAY "NOT OK '" VAR-X "' IS NOT X" + END-DISPLAY + END-IF + IF NOT T-Y + DISPLAY "NOT OK '" VAR-X "' IS NOT T-Y" + END-DISPLAY + END-IF + SET T-Y TO TRUE + IF NOT T-Y + DISPLAY "NOT OK '" VAR-X "' IS NOT T-Y" + END-DISPLAY + END-IF + MOVE 'Y' TO VAR-X + IF NOT T-Y + DISPLAY "NOT OK '" VAR-X "' IS NOT T-Y" + END-DISPLAY + END-IF + MOVE 'Z' TO VAR-X + IF T-Y + DISPLAY "NOT OK '" VAR-X "' IS T-Y" + END-DISPLAY + END-IF + MOVE 'A' TO VAR-X + IF T-Y + DISPLAY "NOT OK '" VAR-X "' IS T-Y" + END-DISPLAY + END-IF + IF V9 + DISPLAY "NOT OK '" VAR-9 "' IS V9" + END-DISPLAY + END-IF + SET V9 TO TRUE + IF NOT V9 + DISPLAY "NOT OK '" VAR-9 "' IS NOT V9" + END-DISPLAY + END-IF + SET V2-4 TO TRUE + IF V9 + DISPLAY "NOT OK '" VAR-9 "' IS V9" + END-DISPLAY + END-IF + IF NOT V2-4 + DISPLAY "NOT OK '" VAR-9 "' IS NOT V2-4" + END-DISPLAY + END-IF + MOVE 3 TO VAR-9 + IF NOT V2-4 + DISPLAY "NOT OK '" VAR-9 "' IS NOT V2-4" + END-DISPLAY + END-IF + MOVE 4 TO VAR-9 + IF NOT V2-4 + DISPLAY "NOT OK '" VAR-9 "' IS NOT V2-4" + END-DISPLAY + END-IF + MOVE 5 TO VAR-9 + IF V2-4 + DISPLAY "NOT OK '" VAR-9 "' IS V2-4" + END-DISPLAY + END-IF + MOVE 1 TO VAR-9 + IF V2-4 + DISPLAY "NOT OK '" VAR-9 "' IS V2-4" + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ACCEPT_DATE___DAY_and_intrinsic_functions__2_.cob b/gcc/testsuite/cobol.dg/group2/ACCEPT_DATE___DAY_and_intrinsic_functions__2_.cob 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/ADD_CORRESPONDING.cob b/gcc/testsuite/cobol.dg/group2/ADD_CORRESPONDING.cob new file mode 100644 index 0000000..732d241 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ADD_CORRESPONDING.cob @@ -0,0 +1,39 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 GROUP-1. + 05 FIELD-A PIC 9 VALUE 1. + 05 FIELD-B USAGE BINARY-CHAR VALUE 2. + 05 INNER-GROUP. + 10 FIELD-C USAGE COMP-1 VALUE 3. + 05 FIELD-D PIC X VALUE "A". + 01 GROUP-2. + 05 FIELD-A PIC 9. + 05 FIELD-B USAGE BINARY-LONG. + 05 INNER-GROUP. + 10 FIELD-C PIC 9. + 05 FIELD-D PIC 9. + + PROCEDURE DIVISION. + ADD CORRESPONDING GROUP-1 TO GROUP-2. + IF FIELD-A IN GROUP-2 NOT EQUAL 1 THEN + DISPLAY "BAD FIELD-A " FIELD-A IN GROUP-2 + END-DISPLAY + END-IF. + IF FIELD-B IN GROUP-2 NOT EQUAL 2 THEN + DISPLAY "BAD FIELD-B " FIELD-B IN GROUP-2 + END-DISPLAY + END-IF. + IF FIELD-C IN GROUP-2 NOT EQUAL 3 THEN + DISPLAY "BAD FIELD-C " FIELD-C IN GROUP-2 + END-DISPLAY + END-IF. + IF FIELD-D IN GROUP-2 NOT EQUAL 0 THEN + DISPLAY "BAD FIELD-D " FIELD-D IN GROUP-2 + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ADD_SUBTRACT_CORR_mixed_fix___float.cob b/gcc/testsuite/cobol.dg/group2/ADD_SUBTRACT_CORR_mixed_fix___float.cob new file mode 100644 index 0000000..d90ab7b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ADD_SUBTRACT_CORR_mixed_fix___float.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + *> { dg-output-file "group2/ADD_SUBTRACT_CORR_mixed_fix___float.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 GROUP1. + 05 VAR1 PIC 9999 VALUE 1. + 05 VAR2 PIC 9999 VALUE 2. + 05 VAR3 COMP-2 VALUE 3. + 05 VAR4 COMP-2 VALUE 4. + 01 GROUP2. + 05 VAR1 PIC 9999 VALUE 1000. + 05 VAR2 COMP-2 VALUE 2000. + 05 VAR3 PIC 9999 VALUE 3000. + 05 VAR4 COMP-2 VALUE 4000. + PROCEDURE DIVISION. + PERFORM DISP2 + ADD CORRESPONDING GROUP1 TO GROUP2 + PERFORM DISP2 + SUBTRACT CORRESPONDING GROUP1 FROM GROUP2 + PERFORM DISP2. + GOBACK. + DISP2. + DISPLAY + VAR1 OF GROUP2 SPACE + VAR2 OF GROUP2 SPACE + VAR3 OF GROUP2 SPACE + VAR4 OF GROUP2. + END PROGRAM prog. + + diff --git a/gcc/testsuite/cobol.dg/group2/ADD_SUBTRACT_CORR_mixed_fix___float.out b/gcc/testsuite/cobol.dg/group2/ADD_SUBTRACT_CORR_mixed_fix___float.out new file mode 100644 index 0000000..e590ce3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ADD_SUBTRACT_CORR_mixed_fix___float.out @@ -0,0 +1,4 @@ +1000 2000 3000 4000 +1001 2002 3003 4004 +1000 2000 3000 4000 + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.cob b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.cob new file mode 100644 index 0000000..a5ef3a8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.cob @@ -0,0 +1,114 @@ + *> { dg-do run } + *> { dg-output-file "group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out" } + + identification division. + program-id. prog. + procedure division. + display "initialize zeroes" + call "prog-zeroes" + display "initialize low-value" + call "prog-low" + display "initialize spaces" + call "prog-space" + display "initialize high-value" + call "prog-high" + continue. + end program prog. + + identification division. + program-id. prog-space. + options. initialize working-storage spaces. + data division. + working-storage section. + 01 based-var based. + 02 based-x pic x(24) value "I am I, Don Quixote". + 02 based-9 pic 999 value 123. + 02 based-p pointer value NULL. + 01 allocated-pointer pointer. + procedure division. + display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)" + allocate 35 characters returning allocated-pointer + set address of based-var to allocated-pointer + call "reporter" using based-var + free allocated-pointer + goback. + end program prog-space. + + identification division. + program-id. prog-low. + options. initialize working-storage low-values. + data division. + working-storage section. + 01 based-var based. + 02 based-x pic x(24) value "I am I, Don Quixote". + 02 based-9 pic 999 value 123. + 02 based-p pointer value NULL. + 01 allocated-pointer pointer. + procedure division. + display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)" + allocate 35 characters returning allocated-pointer + set address of based-var to allocated-pointer + call "reporter" using based-var + free allocated-pointer + goback. + end program prog-low. + + identification division. + program-id. prog-zeroes. + options. initialize working-storage binary zeroes. + data division. + working-storage section. + 01 based-var based. + 02 based-x pic x(24) value "I am I, Don Quixote". + 02 based-9 pic 999 value 123. + 02 based-p pointer value NULL. + 01 allocated-pointer pointer. + procedure division. + display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)" + allocate 35 characters returning allocated-pointer + set address of based-var to allocated-pointer + call "reporter" using based-var + free allocated-pointer + goback. + end program prog-zeroes. + + identification division. + program-id. prog-high. + options. initialize working-storage high-values. + data division. + working-storage section. + 01 based-var based. + 02 based-x pic x(24) value "I am I, Don Quixote". + 02 based-9 pic 999 value 123. + 02 based-p pointer value NULL. + 01 pval redefines based-var pointer. + 01 allocated-pointer pointer. + procedure division. + display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)" + allocate 35 characters returning allocated-pointer + set address of based-var to allocated-pointer + display pval + free allocated-pointer + goback. + end program prog-high. + + identification division. + program-id. reporter. + data division. + linkage section. + 01 based-var based. + 02 based-x pic x(24). + 02 based-9 pic 999 . + 02 based-p pointer . + procedure division using based-var. + reportt. + display " (1) as allocated" + perform reportt2 + goback. + reportt2. + display " " """" based-x """" with no advancing + display space """" based-9 """" with no advancing + display space based-p. + continue. + end program reporter. + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out new file mode 100644 index 0000000..15e06d1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out @@ -0,0 +1,16 @@ +initialize zeroes +allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) + (1) as allocated + "" "000" 0x0000000000000000 +initialize low-value +allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) + (1) as allocated + "" "000" 0x0000000000000000 +initialize spaces +allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) + (1) as allocated + " " "000" 0x2020202020202020 +initialize high-value +allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) +0xffffffffffffffff + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.cob b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.cob new file mode 100644 index 0000000..abcba96 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.cob @@ -0,0 +1,73 @@ + *> { dg-do run } + *> { dg-output-file "group2/ALLOCATE___FREE_basic_default_versions.out" } + + program-id. prog. + data division. + working-storage section. + 01 based-var pic x(100) based. + 01 mem-pointer pointer. + 01 mem-size pic 999 value 100. + 01 counter pic 99 value zero. + procedure division. + allocate 100 characters returning mem-pointer. + if mem-pointer equal NULL + display "allocate 100 should not be NULL (1)" + else + add 1 to counter. + free mem-pointer + if mem-pointer not equal NULL + display "mem-pointer should be NULL again (1)" + else + add 1 to counter. + + allocate mem-size characters returning mem-pointer. + if mem-pointer equal null + display "allocate mem-size should not be NULL (2)" + else + add 1 to counter. + free mem-pointer + if mem-pointer not equal null + display "mem-pointer should be NULL again (2)" + else + add 1 to counter. + + allocate based-var + if address of based-var equal NULL + display "address of based-var should not be NULL (1)" + else + add 1 to counter + free based-var + if address of based-var not equal NULL + display "address of based-var be NULL (1)" + else + add 1 to counter. + + allocate based-var + if address of based-var equal NULL + display "address of based-var should not be NULL (2)" + else + add 1 to counter. + free address of based-var + if address of based-var not equal NULL + display "address of based-var be NULL (2)" + else + add 1 to counter. + + allocate based-var returning mem-pointer. + if address of based-var equal NULL + display "address of based-var should not be NULL (3)" + else + add 1 to counter. + if mem-pointer equal NULL + display "address of mem-pointer should not be NULL (3)" + else + add 1 to counter. + if address of based-var not equal mem-pointer + display "address of mem-pointer should be equal to mem-pointer (3)" + else + add 1 to counter. + + display "There were " counter " successful tests; should be 11." + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.out b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.out new file mode 100644 index 0000000..ab96696b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.out @@ -0,0 +1,2 @@ +There were 11 successful tests; should be 11. + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__1_.cob b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__1_.cob new file mode 100644 index 0000000..b4929b8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__1_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + LINKAGE SECTION. + 01 MYFLD PIC X(6) BASED VALUE "ABCDEF". + PROCEDURE DIVISION. + ASTART SECTION. + A01. + ALLOCATE MYFLD INITIALIZED. + IF MYFLD NOT = "ABCDEF" + DISPLAY MYFLD + END-DISPLAY + END-IF. + FREE ADDRESS OF MYFLD. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__2_.cob b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__2_.cob new file mode 100644 index 0000000..9820784 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__2_.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 MYFLD BASED. + 03 MYFLDX PIC X. + 03 MYFLD9 PIC 9. + PROCEDURE DIVISION. + IF ADDRESS OF MYFLD NOT = NULL + DISPLAY "BASED ITEM WITH ADDRESS ON START" + END-DISPLAY + END-IF. + FREE MYFLD. + ALLOCATE MYFLD. + IF ADDRESS OF MYFLD = NULL + DISPLAY "BASED ITEM WITHOUT ADDRESS AFTER ALLOCATE" + END-DISPLAY + END-IF. + INITIALIZE MYFLD. + IF MYFLD NOT = " 0" + DISPLAY "BASED ITEM INITIALIZED WRONG: " + WITH NO ADVANCING + END-DISPLAY + DISPLAY MYFLD + END-DISPLAY + END-IF. + + FREE ADDRESS OF MYFLD. + IF ADDRESS OF MYFLD NOT = NULL + DISPLAY "BASED ITEM WITH ADDRESS AFTER FREE" + END-DISPLAY + END-IF. + diff --git a/gcc/testsuite/cobol.dg/group2/ALPHABETIC-LOWER_test.cob b/gcc/testsuite/cobol.dg/group2/ALPHABETIC-LOWER_test.cob new file mode 100644 index 0000000..ff71974 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALPHABETIC-LOWER_test.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(04) VALUE "aaaa". + 01 FILLER REDEFINES X. + 03 XBYTE PIC X. + 03 FILLER PIC XXX. + PROCEDURE DIVISION. + MOVE X"0D" TO XBYTE. + IF X ALPHABETIC-LOWER + DISPLAY "Fail - Not alphabetic lower" + END-DISPLAY + END-IF. + MOVE "a" TO XBYTE. + IF X NOT ALPHABETIC-LOWER + DISPLAY "Fail - Alphabetic lower" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ALPHABETIC-UPPER_test.cob b/gcc/testsuite/cobol.dg/group2/ALPHABETIC-UPPER_test.cob new file mode 100644 index 0000000..a3c7ed8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALPHABETIC-UPPER_test.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(04) VALUE "AAAA". + 01 FILLER REDEFINES X. + 03 XBYTE PIC X. + 03 FILLER PIC XXX. + PROCEDURE DIVISION. + MOVE X"0D" TO XBYTE. + IF X ALPHABETIC-UPPER + DISPLAY "Fail - Not alphabetic upper" + END-DISPLAY + END-IF. + MOVE "A" TO XBYTE. + IF X NOT ALPHABETIC-UPPER + DISPLAY "Fail - Alphabetic upper" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ALPHABETIC_test.cob b/gcc/testsuite/cobol.dg/group2/ALPHABETIC_test.cob new file mode 100644 index 0000000..ebc38cc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALPHABETIC_test.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(04) VALUE "AAAA". + 01 FILLER REDEFINES X. + 03 XBYTE PIC X. + 03 FILLER PIC XXX. + PROCEDURE DIVISION. + MOVE X"0D" TO XBYTE. + IF X ALPHABETIC + DISPLAY "Fail - Alphabetic" + END-DISPLAY + END-IF. + MOVE "A" TO XBYTE. + IF X NOT ALPHABETIC + DISPLAY "Fail - Not Alphabetic" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.cob new file mode 100644 index 0000000..a4dc2e5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/ANY_LENGTH__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P1 PIC X(6) VALUE "OKOKOK". + PROCEDURE DIVISION. + CALL "callee" USING P1 + END-CALL. + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P2 PIC 99. + LINKAGE SECTION. + 01 P1 PIC X ANY LENGTH. + PROCEDURE DIVISION USING P1. + MOVE FUNCTION LENGTH (P1) TO P2. + DISPLAY "The incoming ANY LENGTH is " P2 + DISPLAY "The incoming ANY LENGTH variable is " """" P1 """" + EXIT PROGRAM. + END PROGRAM callee. + END PROGRAM caller. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.out b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.out new file mode 100644 index 0000000..f35acf2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.out @@ -0,0 +1,3 @@ +The incoming ANY LENGTH is 06 +The incoming ANY LENGTH variable is "OKOKOK" + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.cob new file mode 100644 index 0000000..8f152eb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + *> { dg-output-file "group2/ANY_LENGTH__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P1 PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + CALL "callee" USING P1 + END-CALL. + DISPLAY "On return, P1 is " """" P1 """" + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P2 PIC XXX. + LINKAGE SECTION. + 01 P1 PIC X ANY LENGTH. + PROCEDURE DIVISION USING P1. + MOVE P1 TO P2. + DISPLAY "P1 is " """" P1 """" + DISPLAY "P2 is " """" P2 """" + IF P2 NOT = "OK " + DISPLAY P2 + END-DISPLAY + END-IF. + MOVE SPACE TO P1. + EXIT PROGRAM. + END PROGRAM callee. + END PROGRAM caller. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.out b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.out new file mode 100644 index 0000000..e2bc284 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.out @@ -0,0 +1,4 @@ +P1 is "OK" +P2 is "OK " +On return, P1 is " " + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.cob new file mode 100644 index 0000000..6603559 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.cob @@ -0,0 +1,25 @@ + *> { dg-do run } + *> { dg-output-file "group2/ANY_LENGTH__3_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(20) VALUE ALL "X". + PROCEDURE DIVISION. + CALL "subprog" USING str. + IDENTIFICATION DIVISION. + PROGRAM-ID. subprog. + DATA DIVISION. + LINKAGE SECTION. + 01 str PIC X ANY LENGTH. + PROCEDURE DIVISION USING str. + MOVE "abcd" TO str + DISPLAY FUNCTION TRIM (str) + MOVE "abcd" TO str (5:) + DISPLAY FUNCTION TRIM (str) + MOVE ALL "a" TO str + DISPLAY FUNCTION TRIM (str). + END PROGRAM subprog. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.out b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.out new file mode 100644 index 0000000..7e58e05 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.out @@ -0,0 +1,4 @@ +abcd +abcdabcd +aaaaaaaaaaaaaaaaaaaa + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__4_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__4_.cob new file mode 100644 index 0000000..b4dcddc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__4_.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(20) VALUE ALL "X". + + PROCEDURE DIVISION. + CALL "subprog" USING str + move ' 45' to str + CALL "subprog" USING str + . + + IDENTIFICATION DIVISION. + PROGRAM-ID. subprog. + + DATA DIVISION. + LINKAGE SECTION. + 01 str PIC X ANY LENGTH. + + PROCEDURE DIVISION USING str. + IF str = 'X' + DISPLAY 'X is X' + END-IF + IF str = space + DISPLAY 'X is space' + END-IF + . + END PROGRAM subprog. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.cob new file mode 100644 index 0000000..fb8dfa9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + *> { dg-output-file "group2/ANY_LENGTH__5_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + CALL "subprog" + GOBACK. + IDENTIFICATION DIVISION. + PROGRAM-ID. subprog. + DATA DIVISION. + LINKAGE SECTION. + 01 str1 PIC X ANY LENGTH. + 01 str2 PIC X ANY LENGTH. + PROCEDURE DIVISION USING optional str1 optional str2. + DISPLAY 'IN' WITH NO ADVANCING. + END PROGRAM subprog. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.out b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.out new file mode 100644 index 0000000..2c9e08f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.out @@ -0,0 +1 @@ +IN diff --git a/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.cob b/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.cob new file mode 100644 index 0000000..76b1fb4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.cob @@ -0,0 +1,45 @@ + *> { dg-do run } + *> { dg-options "-Wno-truncate" } + *> { dg-output-file "group2/Alphanumeric_MOVE_with_truncation.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x-left PIC X(03). + 01 x-right PIC X(03) JUSTIFIED RIGHT. + PROCEDURE DIVISION. + MOVE '1234' TO x-left, x-right + DISPLAY """" x-left """" space """" x-right """" + IF x-left not = '123' + OR x-right not = '234' + DISPLAY 'error with "1234":' + END-DISPLAY + DISPLAY x-left + END-DISPLAY + DISPLAY x-right + END-DISPLAY + END-IF + MOVE ' 3' TO x-left, x-right + DISPLAY """" x-left """" space """" x-right """" + IF x-left not = spaces + OR x-right not = ' 3' + DISPLAY 'error with " 3":' + END-DISPLAY + DISPLAY x-left + END-DISPLAY + DISPLAY x-right + END-DISPLAY + END-IF + MOVE '3 ' TO x-left, x-right + DISPLAY """" x-left """" space """" x-right """" + IF x-left not = '3' + OR x-right not = spaces + DISPLAY 'error with "3 ":' + END-DISPLAY + DISPLAY x-left + END-DISPLAY + DISPLAY x-right + END-DISPLAY + END-IF. + diff --git a/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.out b/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.out new file mode 100644 index 0000000..1bddffb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.out @@ -0,0 +1,4 @@ +"123" "234" +" " " 3" +"3 " " " + diff --git a/gcc/testsuite/cobol.dg/group2/Alphanumeric_and_binary_numeric.cob b/gcc/testsuite/cobol.dg/group2/Alphanumeric_and_binary_numeric.cob new file mode 100644 index 0000000..8ce12ee --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Alphanumeric_and_binary_numeric.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-X PIC XXXX VALUE "0001". + 01 X-9 PIC 9999 COMP VALUE 1. + PROCEDURE DIVISION. + IF X-X = X-9 + STOP RUN + END-IF. + DISPLAY "NG" NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/BLANK_WHEN_ZERO.cob b/gcc/testsuite/cobol.dg/group2/BLANK_WHEN_ZERO.cob new file mode 100644 index 0000000..ae0aa71 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/BLANK_WHEN_ZERO.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/BLANK_WHEN_ZERO.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x PIC 9, BLANK WHEN ZERO, VALUE 1. + PROCEDURE DIVISION. + DISPLAY "X should be 1: " """" x """" + MOVE 0 TO x + DISPLAY "X should be blank: " """" FUNCTION TRIM(x) """" + MOVE ZERO TO x + DISPLAY "X should be blank: " """" FUNCTION TRIM(x) """" + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/BLANK_WHEN_ZERO.out b/gcc/testsuite/cobol.dg/group2/BLANK_WHEN_ZERO.out new file mode 100644 index 0000000..a03f1d1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/BLANK_WHEN_ZERO.out @@ -0,0 +1,4 @@ +X should be 1: "1" +X should be blank: "" +X should be blank: "" + diff --git a/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.cob b/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.cob new file mode 100644 index 0000000..0c5647c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + *> { dg-output-file "group2/CALL_with_OMITTED_parameter.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P1 PIC X VALUE "A". + 01 P2 PIC X VALUE "B". + PROCEDURE DIVISION. + DISPLAY "Should see AB" + CALL "callee" USING P1 P2 + DISPLAY "Should see A" + CALL "callee" USING P1 + END-CALL. + DISPLAY "Should see A" + CALL "callee" USING P1 OMITTED + END-CALL. + STOP RUN. + END PROGRAM caller. + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + LINKAGE SECTION. + 01 P1 PIC X. + 01 P2 PIC X. + PROCEDURE DIVISION USING P1 OPTIONAL P2. + DISPLAY """" P1 WITH NO ADVANCING + IF P2 NOT OMITTED + DISPLAY P2 """" + END-DISPLAY + ELSE + DISPLAY """" + END-DISPLAY + END-IF. + EXIT PROGRAM. + END PROGRAM callee. + diff --git a/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.out b/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.out new file mode 100644 index 0000000..1a77e2c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.out @@ -0,0 +1,7 @@ +Should see AB +"AB" +Should see A +"A" +Should see A +"A" + diff --git a/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.cob b/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.cob new file mode 100644 index 0000000..0c4e115 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.cob @@ -0,0 +1,28 @@ + *> { dg-do run } + *> { dg-output-file "group2/CONTINUE_AFTER_1_SECONDS.out" } + + program-id. prog. + data division. + working-storage section. + 01 tod pic x(64). + 01 tstart pic 9999. + 01 tend pic 9999. + 01 tspan pic 9999. + procedure division. + accept tod from time + move tod(5:) to tstart + continue after 1.0 seconds. + accept tod from time + move tod(5:) to tend + if tend < tstart + compute tend = tend + 6000 + end-if + compute tspan = tend - tstart + if tspan >= 75 and tspan <= 125 + display "Looks good" + else + display "Looks bad! " tstart space tend space tspan + end-if + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.out b/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.out new file mode 100644 index 0000000..74b5c81 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.out @@ -0,0 +1,2 @@ +Looks good + diff --git a/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.cob b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.cob new file mode 100644 index 0000000..f1ebd6a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + *> { dg-output-file "group2/CURRENCY_SIGN.out" } + + PROGRAM-ID. prog. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURRENCY SIGN IS "Y". + + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 amount pic Y(6)9.99. + + PROCEDURE DIVISION. + Move 1512.34 to Amount + Display "Amount is #" Amount '#' with no advancing. + + GOBACK + . + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.out b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.out new file mode 100644 index 0000000..d49ed31 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.out @@ -0,0 +1 @@ +Amount is # Y1512.34# diff --git a/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob new file mode 100644 index 0000000..eff0822 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob @@ -0,0 +1,32 @@ + *> { dg-do run } + *> { dg-output-file "group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.out" } + + PROGRAM-ID. prog. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + *> note the space after EUR / before ct. + CURRENCY SIGN IS "EUR " WITH PICTURE SYMBOL "U", + CURRENCY SIGN IS " ct (EUR)" WITH PICTURE SYMBOL "c", + Currency Sign is "$US" with Picture Symbol "$". + + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 EUROS PIC U99v99. + 77 cents PIC 9,999c. + 77 DOLLARS Pic $$,$$9.99. + + PROCEDURE DIVISION. + MOVE 12.34 TO EUROS + MULTIPLY euros BY 100 GIVING cents. + DISPLAY "#" EUROS "# equal #" cents '#'. + Move 1500 to DOLLARS + Display "Invoice amount #1 is " DOLLARS '.'. + Move 12.34 to DOLLARS + Display "Invoice amount #2 is " DOLLARS '.'. + + GOBACK + . + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.out b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.out new file mode 100644 index 0000000..861e65a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.out @@ -0,0 +1,4 @@ +#EUR 12.34# equal #1,234 ct (EUR)# +Invoice amount #1 is $US1,500.00. +Invoice amount #2 is $US12.34. + diff --git a/gcc/testsuite/cobol.dg/group2/Check_for_equality_of_COMP-1___COMP-2.cob b/gcc/testsuite/cobol.dg/group2/Check_for_equality_of_COMP-1___COMP-2.cob new file mode 100644 index 0000000..76bafa4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Check_for_equality_of_COMP-1___COMP-2.cob @@ -0,0 +1,106 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SRC1 COMP-2 VALUE 11.55. + 01 DST1 COMP-1. + 01 SRC2 COMP-1 VALUE 11.55. + 01 DST2 COMP-2. + + PROCEDURE DIVISION. + MOVE SRC1 TO DST1. + IF DST1 not = 11.55 + DISPLAY 'error: move/compare FLOAT-LONG to FLOAT-SHORT failed ' DST1 + END-DISPLAY + END-IF. + + MOVE SRC1 TO DST2. + IF DST1 not = 11.55 + DISPLAY 'error: move/compare FLOAT-LONG to FLOAT-LONG failed ' DST2 + END-DISPLAY + END-IF. + + MOVE ZERO TO DST1. + MOVE ZERO TO DST2. + + MOVE SRC2 TO DST1. + IF DST1 not = 11.55 + DISPLAY 'error: move/compare FLOAT-SHORT to FLOAT-SHORT failed: ' DST1 + END-DISPLAY + END-IF. + + MOVE SRC2 TO DST2. + IF DST2 not = 11.5500001907348633 + DISPLAY 'error: move/compare COMP-2 to literal failed: ' DST2 + END-DISPLAY + END-IF. + + MOVE ZERO TO DST1. + IF not (DST1 = 0 AND 0.0) + DISPLAY "Zero compare failed: " DST1 END-DISPLAY + END-IF. + + MOVE -0.0 TO DST1. + IF not (DST1 = 0 AND 0.0) + DISPLAY "Negative Zero compare failed: " DST1 + END-DISPLAY + END-IF. + + MOVE 1.1234567 TO DST1. + MOVE DST1 TO DST2. + IF DST2 not = 1.12345671653747559 + DISPLAY "move/compare number to FLOAT to DOUBLE failed: " + DST1 " - " DST2 + END-DISPLAY + END-IF. + + * Check for Tolerance + MOVE 1.1234567 TO DST1. + MOVE 1.1234568 TO DST2. + IF DST1 = DST2 THEN + DISPLAY 'move/compare of very near numbers failed (not identical): ' DST1 " - " DST2 + END-DISPLAY + END-IF. + + * Within tolerance by definition, therefore not checked + * MULTIPLY 10000000000 BY DST1 DST2 END-MULTIPLY. + * IF DST1 = DST2 THEN + * DISPLAY "compare of very near numbers computed failed (id + *- "entical): " DST1 " - " DST2 + * END-DISPLAY + * END-IF. + + MOVE 1.1234567 TO DST1. + MOVE 1.1234569 TO DST2. + IF DST1 = DST2 THEN + DISPLAY 'move/compare of near equal numbers failed (identical): ' DST1 " - " DST2 + END-DISPLAY + END-IF. + + MOVE 0.0001 TO DST1. + MOVE 0.0000 TO DST2. + IF DST1 = DST2 THEN + DISPLAY 'move/compare of nearly equal very small numbers failed (identical): ' DST1 " - " DST2 + END-DISPLAY + END-IF. + + MOVE 1000001.0 TO DST1. + MOVE 1000000.0 TO DST2. + IF DST1 = DST2 THEN + DISPLAY 'move/compare of nearly equal big numbers failed (identical): ' DST1 " - " DST2 + END-DISPLAY + END-IF. + + * Within tolerance by definition, therefore not checked + * MOVE 1000000000.0 TO DST1. + * MOVE 1000000001.0 TO DST2. + * IF DST1 = DST2 THEN + * DISPLAY 'move/compare of nearly equal very big numbers fa + *- 'iled (identical): ' DST1 " - " DST2 + * END-DISPLAY + * END-IF. + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Class_check_with_reference_modification.cob b/gcc/testsuite/cobol.dg/group2/Class_check_with_reference_modification.cob new file mode 100644 index 0000000..62d6bc8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Class_check_with_reference_modification.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(6) VALUE "123 ". + PROCEDURE DIVISION. + IF X(1:3) NUMERIC + STOP RUN + END-IF. + DISPLAY "NG" NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Compare_COMP-2_with_floating-point_literal.cob b/gcc/testsuite/cobol.dg/group2/Compare_COMP-2_with_floating-point_literal.cob new file mode 100644 index 0000000..677fadc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Compare_COMP-2_with_floating-point_literal.cob @@ -0,0 +1,43 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR COMP-2 VALUE 0.0. + + PROCEDURE DIVISION. + MOVE 9.899999999999E+304 TO VAR + IF VAR < 0 + DISPLAY "error: compare " VAR " < " 0 " failed!" + END-DISPLAY + END-IF. + IF VAR < 9.799999999999E+304 + DISPLAY 'error: compare ' VAR ' < ' 9.799999999999E+304 + ' failed!' + END-DISPLAY + END-IF. + IF VAR > 9.999999999999E+304 + DISPLAY 'error: compare ' VAR ' > ' 9.999999999999E+304 + ' failed!' + END-DISPLAY + END-IF. + MOVE -9.899999999999E+304 TO VAR + IF VAR > 0 + DISPLAY 'error: compare ' VAR ' > ' 0 + ' failed!' + END-DISPLAY + END-IF. + IF VAR < -9.999999999999E+304 + DISPLAY 'error: compare ' VAR ' < ' -9.999999999999E+304 + ' failed!' + END-DISPLAY + END-IF. + IF VAR > -9.799999999999E+304 + DISPLAY 'error: compare ' VAR ' > ' -9.799999999999E+304 + ' failed!' + END-DISPLAY + END-IF. + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.cob b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.cob new file mode 100644 index 0000000..797c6fe --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.cob @@ -0,0 +1,76 @@ + *> { dg-do run } + *> { dg-output-file "group2/Complex_HEX__VALUE_and_MOVE.out" } + + identification division. + program-id. hex-init. + data division. + working-storage section. + 01 var-01020304. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE X'01020304'. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + + 01 var-low. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE LOW-VALUES. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 var-space. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE SPACE. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 var-quote. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE QUOTE. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 var-zero. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE ZERO. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 var-high. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE HIGH-VALUES. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 move-target. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE "3333". + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + procedure division. + display "the value is " as-pointer of var-01020304. + display "should be 0x3333040302013333" + display "var-low : " as-pointer of var-low + display "var-space: " as-pointer of var-space + display "var-quote: " as-pointer of var-quote + display "var-zero : " as-pointer of var-zero + display "var-high : " as-pointer of var-high + display "initial " as-pointer of move-target + move low-value to as-value of move-target + display "low-value " as-pointer of move-target + move space to as-value of move-target + display "space " as-pointer of move-target + move quote to as-value of move-target + display "quote " as-pointer of move-target + move zeroes to as-value of move-target + display "zeroes " as-pointer of move-target + move high-value to as-value of move-target + display "high-value " as-pointer of move-target + move X'01020304' to as-value of move-target + display "01020304 " as-pointer of move-target + move "33333333" to move-target + move X'00' to filler3 of move-target(1:1) + display "ref-mod " as-pointer of move-target + stop run. + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.out b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.out new file mode 100644 index 0000000..366d0c2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.out @@ -0,0 +1,16 @@ +the value is 0x3333040302013333 +should be 0x3333040302013333 +var-low : 0x3333000000003333 +var-space: 0x3333202020203333 +var-quote: 0x3333222222223333 +var-zero : 0x3333303030303333 +var-high : 0x3333ffffffff3333 +initial 0x3333333333333333 +low-value 0x3333000000003333 +space 0x3333202020203333 +quote 0x3333222222223333 +zeroes 0x3333303030303333 +high-value 0x3333ffffffff3333 +01020304 0x3333040302013333 +ref-mod 0x3300333333333333 + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_IF.cob b/gcc/testsuite/cobol.dg/group2/Complex_IF.cob new file mode 100644 index 0000000..aa3ebde --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_IF.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + *> { dg-output-file "group2/Complex_IF.out" } + identification division. + program-id. phonebook. + data division. + working-storage section. + 01 name1 pic x(10) value "one". + 01 name2 pic x(10) value "two". + 01 flag pic x value 'a'. + procedure division. + move 'l' to flag + perform checkit + goback. + checkit. + if (name1 = name2 and flag = "F" or "f" ) + or flag = "L" or "l" + then + display "the test is TRUE" + else + display "the test is FALSE" + end-if. + end program phonebook. + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_IF.out b/gcc/testsuite/cobol.dg/group2/Complex_IF.out new file mode 100644 index 0000000..ce94a61 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_IF.out @@ -0,0 +1,2 @@ +the test is TRUE + diff --git a/gcc/testsuite/cobol.dg/group2/Concatenation_operator.cob b/gcc/testsuite/cobol.dg/group2/Concatenation_operator.cob new file mode 100644 index 0000000..fef757b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Concatenation_operator.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/Concatenation_operator.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 STR PIC X(05). + PROCEDURE DIVISION. + MOVE "OK" & " " + & "OK" + TO STR + DISPLAY STR NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Concatenation_operator.out b/gcc/testsuite/cobol.dg/group2/Concatenation_operator.out new file mode 100644 index 0000000..618798a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Concatenation_operator.out @@ -0,0 +1 @@ +OK OK diff --git a/gcc/testsuite/cobol.dg/group2/Contained_program_visibility__3_.cob b/gcc/testsuite/cobol.dg/group2/Contained_program_visibility__3_.cob new file mode 100644 index 0000000..624a9e1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Contained_program_visibility__3_.cob @@ -0,0 +1,42 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(5) GLOBAL VALUE "prog1". + PROCEDURE DIVISION. + IF X NOT = "prog1" + DISPLAY X + END-DISPLAY + END-IF. + CALL "prog2" + END-CALL. + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(5) GLOBAL VALUE "prog2". + PROCEDURE DIVISION. + IF X NOT = "prog2" + DISPLAY X + END-DISPLAY + END-IF. + CALL "prog3" + END-CALL. + EXIT PROGRAM. + END PROGRAM prog2. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog3 COMMON. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + IF X NOT = "prog1" + DISPLAY X + END-DISPLAY + END-IF. + EXIT PROGRAM. + END PROGRAM prog3. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Contained_program_visibility__4_.cob b/gcc/testsuite/cobol.dg/group2/Contained_program_visibility__4_.cob new file mode 100644 index 0000000..923ce76 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Contained_program_visibility__4_.cob @@ -0,0 +1,46 @@ + *> { dg-do run } + *> { dg-output-file "group2/Contained_program_visibility__4_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY "P1" NO ADVANCING + END-DISPLAY. + CALL "prog2" + END-CALL + CALL "prog3" + END-CALL + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY "P2" NO ADVANCING + END-DISPLAY. + EXIT PROGRAM. + END PROGRAM prog2. + END PROGRAM prog. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog3. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY "P3" NO ADVANCING + END-DISPLAY. + CALL "prog2" + END-CALL. + EXIT PROGRAM. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY "P4" NO ADVANCING + END-DISPLAY. + EXIT PROGRAM. + END PROGRAM prog2. + END PROGRAM prog3. + diff --git a/gcc/testsuite/cobol.dg/group2/Contained_program_visibility__4_.out b/gcc/testsuite/cobol.dg/group2/Contained_program_visibility__4_.out new file mode 100644 index 0000000..f31c96b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Contained_program_visibility__4_.out @@ -0,0 +1 @@ +P1P2P3P4 diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__1_.cob b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__1_.cob new file mode 100644 index 0000000..37f5c47 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__1_.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/Context_sensitive_words__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 BYTE-LENGTH PIC 9. + 01 X CONSTANT AS BYTE-LENGTH OF BYTE-LENGTH. + PROCEDURE DIVISION. + MOVE X TO BYTE-LENGTH. + DISPLAY BYTE-LENGTH NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__1_.out b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__1_.out new file mode 100644 index 0000000..d00491f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__1_.out @@ -0,0 +1 @@ +1 diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__2_.cob b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__2_.cob new file mode 100644 index 0000000..d29f505 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__2_.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/Context_sensitive_words__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 YYYYMMDD PIC 9 VALUE 0. + 01 X PIC X(16). + PROCEDURE DIVISION. + ACCEPT X FROM DATE YYYYMMDD + END-ACCEPT. + DISPLAY YYYYMMDD NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__2_.out b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__2_.out new file mode 100644 index 0000000..573541a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__2_.out @@ -0,0 +1 @@ +0 diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__3_.cob b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__3_.cob new file mode 100644 index 0000000..0326650 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__3_.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/Context_sensitive_words__3_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 YYYYDDD PIC 9 VALUE 0. + 01 X PIC X(16). + PROCEDURE DIVISION. + ACCEPT X FROM DAY YYYYDDD + END-ACCEPT. + DISPLAY YYYYDDD NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__3_.out b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__3_.out new file mode 100644 index 0000000..573541a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__3_.out @@ -0,0 +1 @@ +0 diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__4_.cob b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__4_.cob new file mode 100644 index 0000000..05f2197 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__4_.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + *> { dg-output-file "group2/Context_sensitive_words__4_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + REPOSITORY. + FUNCTION ALL INTRINSIC. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INTRINSIC PIC 9 VALUE 0. + PROCEDURE DIVISION. + DISPLAY INTRINSIC NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__4_.out b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__4_.out new file mode 100644 index 0000000..573541a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__4_.out @@ -0,0 +1 @@ +0 diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__5_.cob b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__5_.cob new file mode 100644 index 0000000..8a96cf1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__5_.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/Context_sensitive_words__5_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog RECURSIVE. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 RECURSIVE PIC 9 VALUE 0. + PROCEDURE DIVISION. + DISPLAY RECURSIVE NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__5_.out b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__5_.out new file mode 100644 index 0000000..573541a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__5_.out @@ -0,0 +1 @@ +0 diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__6_.cob b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__6_.cob new file mode 100644 index 0000000..f83cb63 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__6_.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/Context_sensitive_words__6_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 NORMAL PIC 9 VALUE 0. + PROCEDURE DIVISION. + DISPLAY NORMAL NO ADVANCING *> Intentionally no period or END-DISPLAY + STOP RUN NORMAL. + diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__6_.out b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__6_.out new file mode 100644 index 0000000..573541a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__6_.out @@ -0,0 +1 @@ +0 diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__7_.cob b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__7_.cob new file mode 100644 index 0000000..0ad5cc8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__7_.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + *> { dg-output-file "group2/Context_sensitive_words__7_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 9 VALUE 0. + 01 AWAY-FROM-ZERO PIC 9 VALUE 0. + PROCEDURE DIVISION. + COMPUTE X ROUNDED MODE AWAY-FROM-ZERO + AWAY-FROM-ZERO = 1.1 + END-COMPUTE + DISPLAY X AWAY-FROM-ZERO NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__7_.out b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__7_.out new file mode 100644 index 0000000..aabe6ec --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__7_.out @@ -0,0 +1 @@ +21 diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__8_.cob b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__8_.cob new file mode 100644 index 0000000..8943f92 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__8_.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + *> { dg-output-file "group2/Context_sensitive_words__8_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 UNBNDED. + 03 ATTRIBUTES PIC 9 VALUE 0. + 01 LOC. + 03 NAMESPACE PIC 9 VALUE 1. + PROCEDURE DIVISION. + DISPLAY UNBNDED ATTRIBUTES + NAMESPACE IN LOC + NO ADVANCING. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__8_.out b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__8_.out new file mode 100644 index 0000000..5325a8d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Context_sensitive_words__8_.out @@ -0,0 +1 @@ +001 diff --git a/gcc/testsuite/cobol.dg/group2/DEBUG_Line.cob b/gcc/testsuite/cobol.dg/group2/DEBUG_Line.cob new file mode 100644 index 0000000..a7dca5d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DEBUG_Line.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/DEBUG_Line.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SOURCE-COMPUTER. + Linux WITH DEBUGGING MODE. + PROCEDURE DIVISION. + *> Success is printing this message. If nothing comes out, the + *> test fails. + D DISPLAY "DEBUG MESSAGE" NO ADVANCING. + EXIT PROGRAM. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/DEBUG_Line.out b/gcc/testsuite/cobol.dg/group2/DEBUG_Line.out new file mode 100644 index 0000000..6a3f59c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DEBUG_Line.out @@ -0,0 +1 @@ +DEBUG MESSAGE diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.cob new file mode 100644 index 0000000..2362d15 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + MOVE FUNCTION MIN (3,,,,,,5) TO X. + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.out new file mode 100644 index 0000000..0b9310e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.out @@ -0,0 +1,2 @@ +00,50 + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.cob new file mode 100644 index 0000000..b69ee3b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + MOVE FUNCTION MIN (3,,,,,, 5) TO X. + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.out new file mode 100644 index 0000000..9dcfab9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.out @@ -0,0 +1,2 @@ +03,00 + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.cob new file mode 100644 index 0000000..114b9ea --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__3_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + MOVE FUNCTION MIN (3,,,,,, 1,5) TO X. + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.out new file mode 100644 index 0000000..5a24d4d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.out @@ -0,0 +1,2 @@ +01,50 + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.cob new file mode 100644 index 0000000..d969c73 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__4_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + MOVE FUNCTION MIN (3, 1,5) TO X. + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.out new file mode 100644 index 0000000..5a24d4d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.out @@ -0,0 +1,2 @@ +01,50 + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.cob new file mode 100644 index 0000000..2ca9881 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__5_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + COMPUTE X=1 + ,1 + END-COMPUTE + DISPLAY X + END-DISPLAY. + COMPUTE X=1*,1 + END-COMPUTE + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.out new file mode 100644 index 0000000..809e6ae --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.out @@ -0,0 +1,3 @@ +01,10 +00,10 + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_and_assignment_NumericDisplay.cob b/gcc/testsuite/cobol.dg/group2/DISPLAY_and_assignment_NumericDisplay.cob new file mode 100644 index 0000000..2b31113 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_and_assignment_NumericDisplay.cob @@ -0,0 +1,82 @@ + *> { dg-do run } + *> { dg-output-file "group2/DISPLAY_and_assignment_NumericDisplay.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 vars. + 05 vars-display-1. + 10 var01a pic 99v999 display value 54.321 . + 10 var01b pic s99v999 display value 54.321 . + 10 var01c pic s99v999 leading display value -54.321 . + 10 var01d pic s99v999 trailing display value 54.321 . + 10 var01e pic s99v999 leading separate display value -54.321 . + 10 var01f pic s99v999 trailing separate display value 54.321 . + 05 vars-display-2. + 10 var01g pic 9999ppp display value 4321000 . + 10 var01h pic s9999ppp display value 4321000 . + 10 var01i pic s9999ppp leading display value -4321000 . + 10 var01j pic s9999ppp trailing display value 4321000 . + 10 var01k pic s9999ppp leading separate display value -4321000 . + 10 var01l pic s9999ppp trailing separate display value 4321000 . + 05 vars-display-3. + 10 var01m pic ppp9999 display value .0001234 . + 10 var01n pic sppp9999 display value .0001234 . + 10 var01o pic sppp9999 leading display value -.0001234 . + 10 var01p pic sppp9999 trailing display value .0001234 . + 10 var01q pic sppp9999 leading separate display value -.0001234 . + 10 var01r pic sppp9999 trailing separate display value .0001234 . + procedure division. + display var01a + display var01b + display var01c + display var01d + display var01e + display var01f + display var01g + display var01h + display var01i + display var01j + display var01k + display var01l + display var01m + display var01n + display var01o + display var01p + display var01q + display var01r + + move 12.345 to var01a var01c var01e + move -12.345 to var01b var01d var01f + + move 9876000 to var01g var01i var01k + move -9876000 to var01h var01j var01l + + move .0006789 to var01m var01o var01q + move -.0006789 to var01n var01p var01r + + display var01a + display var01b + display var01c + display var01d + display var01e + display var01f + display var01g + display var01h + display var01i + display var01j + display var01k + display var01l + display var01m + display var01n + display var01o + display var01p + display var01q + display var01r + + continue. + quit. + goback. + end program prog. + + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_and_assignment_NumericDisplay.out b/gcc/testsuite/cobol.dg/group2/DISPLAY_and_assignment_NumericDisplay.out new file mode 100644 index 0000000..b18b32d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_and_assignment_NumericDisplay.out @@ -0,0 +1,37 @@ +54.321 ++54.321 +-54.321 ++54.321 +-54.321 +54.321+ +4321000 ++4321000 +-4321000 ++4321000 +-4321000 +4321000+ +.0001234 ++.0001234 +-.0001234 ++.0001234 +-.0001234 +.0001234+ +12.345 +-12.345 ++12.345 +-12.345 ++12.345 +12.345- +9876000 +-9876000 ++9876000 +-9876000 ++9876000 +9876000- +.0006789 +-.0006789 ++.0006789 +-.0006789 ++.0006789 +.0006789- + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_MOVE_statement.cob b/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_MOVE_statement.cob new file mode 100644 index 0000000..50c1391 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_MOVE_statement.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + *> { dg-output-file "group2/DISPLAY_data_items_with_MOVE_statement.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-ABC PIC XXX VALUE "abc". + 01 X-123 PIC 999 VALUE 123. + 01 X-P123 PIC S999 VALUE +123. + 01 X-N123 PIC S999 VALUE -123. + 01 X-12-3 PIC 99V9 VALUE 12.3. + 01 X-P12-3 PIC S99V9 VALUE +12.3. + 01 X-N12-3 PIC S99V9 VALUE -12.3. + PROCEDURE DIVISION. + MOVE "abc" TO X-ABC. + DISPLAY X-ABC + END-DISPLAY. + MOVE 123 TO X-123. + DISPLAY X-123 + END-DISPLAY. + MOVE +123 TO X-P123. + DISPLAY X-P123 + END-DISPLAY. + MOVE -123 TO X-N123. + DISPLAY X-N123 + END-DISPLAY. + MOVE 12.3 TO X-12-3. + DISPLAY X-12-3 + END-DISPLAY. + MOVE +12.3 TO X-P12-3. + DISPLAY X-P12-3 + END-DISPLAY. + MOVE -12.3 TO X-N12-3. + DISPLAY X-N12-3 + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_MOVE_statement.out b/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_MOVE_statement.out new file mode 100644 index 0000000..e0624a9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_MOVE_statement.out @@ -0,0 +1,8 @@ +abc +123 ++123 +-123 +12.3 ++12.3 +-12.3 + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_VALUE_clause.cob b/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_VALUE_clause.cob new file mode 100644 index 0000000..6e502cb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_VALUE_clause.cob @@ -0,0 +1,31 @@ + *> { dg-do run } + *> { dg-output-file "group2/DISPLAY_data_items_with_VALUE_clause.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-ABC PIC XXX VALUE "abc". + 01 X-123 PIC 999 VALUE 123. + 01 X-P123 PIC S999 VALUE +123. + 01 X-N123 PIC S999 VALUE -123. + 01 X-12-3 PIC 99V9 VALUE 12.3. + 01 X-P12-3 PIC S99V9 VALUE +12.3. + 01 X-N12-3 PIC S99V9 VALUE -12.3. + PROCEDURE DIVISION. + DISPLAY X-ABC + END-DISPLAY. + DISPLAY X-123 + END-DISPLAY. + DISPLAY X-P123 + END-DISPLAY. + DISPLAY X-N123 + END-DISPLAY. + DISPLAY X-12-3 + END-DISPLAY. + DISPLAY X-P12-3 + END-DISPLAY. + DISPLAY X-N12-3 + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_VALUE_clause.out b/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_VALUE_clause.out new file mode 100644 index 0000000..e0624a9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_data_items_with_VALUE_clause.out @@ -0,0 +1,8 @@ +abc +123 ++123 +-123 +12.3 ++12.3 +-12.3 + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_literals__DECIMAL-POINT_is_COMMA.cob b/gcc/testsuite/cobol.dg/group2/DISPLAY_literals__DECIMAL-POINT_is_COMMA.cob new file mode 100644 index 0000000..8bb5a58 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_literals__DECIMAL-POINT_is_COMMA.cob @@ -0,0 +1,24 @@ + *> { dg-do run } + *> { dg-output-file "group2/DISPLAY_literals__DECIMAL-POINT_is_COMMA.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + PROCEDURE DIVISION. + DISPLAY 12,3 + END-DISPLAY. + DISPLAY +12,3 + END-DISPLAY. + DISPLAY -12,3 + END-DISPLAY. + DISPLAY 1,23E0 + END-DISPLAY. + DISPLAY +1,23E0 + END-DISPLAY. + DISPLAY -1,23E0 + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_literals__DECIMAL-POINT_is_COMMA.out b/gcc/testsuite/cobol.dg/group2/DISPLAY_literals__DECIMAL-POINT_is_COMMA.out new file mode 100644 index 0000000..4f56ca9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_literals__DECIMAL-POINT_is_COMMA.out @@ -0,0 +1,7 @@ +12,3 +12,3 +-12,3 +1,23 +1,23 +-1,23 + 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/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.cob b/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.cob new file mode 100644 index 0000000..60310f7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.cob @@ -0,0 +1,30 @@ + *> { dg-do run } + *> { dg-output-file "group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x PIC 9 VALUE 1. + 01 y PIC 9. + 01 a COMP-1 VALUE 1.E20. + 01 b COMP-1 VALUE 1.E20. + PROCEDURE DIVISION. + DIVIDE x BY 0.1 GIVING y + DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-TRUNCATION' + DISPLAY 'Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF. + SET LAST EXCEPTION TO OFF + MULTIPLY a BY b GIVING b + DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-OVERFLOW' + DISPLAY 'Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF. + diff --git a/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.out b/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.out new file mode 100644 index 0000000..8c86ad2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.out @@ -0,0 +1,3 @@ +EC-SIZE-TRUNCATION +EC-SIZE-OVERFLOW + diff --git a/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.cob b/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.cob new file mode 100644 index 0000000..8b5657b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.cob @@ -0,0 +1,64 @@ + *> { dg-do run } + *> { dg-output-file "group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x PIC 9 VALUE 0. + 01 y PIC 9 VALUE 0. + 01 fx comp-2 VALUE 0. + 01 fy comp-2 VALUE 0. + PROCEDURE DIVISION. + DISPLAY "Fixed-point divide by zero:" + DIVIDE x BY y GIVING y + DISPLAY "1 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-ZERO-DIVIDE' + DISPLAY '1 Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + SET LAST EXCEPTION TO OFF + DISPLAY "2 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION EXCEPTION-STATUS NOT = SPACES + DISPLAY '2 Exception is not empty after reset: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + MOVE 0 TO y + COMPUTE y = x - 1 / y + 6.5 + DISPLAY "3 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-ZERO-DIVIDE' + DISPLAY '3 Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF. + SET LAST EXCEPTION TO OFF + DISPLAY "Floating-point divide by zero:" + DIVIDE fx BY fy GIVING fy + DISPLAY "4 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-ZERO-DIVIDE' + DISPLAY '4 Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + SET LAST EXCEPTION TO OFF + DISPLAY "5 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION EXCEPTION-STATUS NOT = SPACES + DISPLAY '5 Exception is not empty after reset: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + MOVE 0 TO fy + COMPUTE fy = fx - 1 / fy + 6.5 + DISPLAY "6 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-ZERO-DIVIDE' + DISPLAY '6 Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF. + diff --git a/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.out b/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.out new file mode 100644 index 0000000..93da1b8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.out @@ -0,0 +1,9 @@ +Fixed-point divide by zero: +1 - "EC-SIZE-ZERO-DIVIDE" +2 - "" +3 - "EC-SIZE-ZERO-DIVIDE" +Floating-point divide by zero: +4 - "EC-SIZE-ZERO-DIVIDE" +5 - "" +6 - "EC-SIZE-ZERO-DIVIDE" + diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PARAGRAPH.cob b/gcc/testsuite/cobol.dg/group2/EXIT_PARAGRAPH.cob new file mode 100644 index 0000000..b637ecb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PARAGRAPH.cob @@ -0,0 +1,21 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INDVAL PIC 9(4). + PROCEDURE DIVISION. + A01. + PERFORM VARYING INDVAL FROM 1 BY 1 UNTIL INDVAL > 10 + IF INDVAL > 2 + EXIT PARAGRAPH + END-IF + END-PERFORM. + A02. + IF INDVAL NOT = 3 + DISPLAY INDVAL NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.cob b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.cob new file mode 100644 index 0000000..d944ccd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/EXIT_PERFORM.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + PERFORM 2 TIMES + DISPLAY "OK" NO ADVANCING + END-DISPLAY + EXIT PERFORM + DISPLAY "NOT OK" + END-DISPLAY + END-PERFORM + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.out b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.out new file mode 100644 index 0000000..d86bac9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.out @@ -0,0 +1 @@ +OK diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.cob b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.cob new file mode 100644 index 0000000..7d67bd1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/EXIT_PERFORM_CYCLE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + PERFORM 2 TIMES + DISPLAY "OK" NO ADVANCING + END-DISPLAY + EXIT PERFORM CYCLE + DISPLAY "NOT OK" + END-DISPLAY + END-PERFORM + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.out b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.out new file mode 100644 index 0000000..d65874e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.out @@ -0,0 +1 @@ +OKOK diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_SECTION.cob b/gcc/testsuite/cobol.dg/group2/EXIT_SECTION.cob new file mode 100644 index 0000000..fc670f1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_SECTION.cob @@ -0,0 +1,25 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INDVAL PIC 9(4). + PROCEDURE DIVISION. + A01 SECTION. + A011. + PERFORM VARYING INDVAL FROM 1 BY 1 UNTIL INDVAL > 10 + IF INDVAL > 2 + EXIT SECTION + END-IF + END-PERFORM. + A012. + DISPLAY INDVAL NO ADVANCING + END-DISPLAY. + A02 SECTION. + IF INDVAL NOT = 3 + DISPLAY INDVAL NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.cob b/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.cob new file mode 100644 index 0000000..d8c81a3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.cob @@ -0,0 +1,43 @@ + *> { dg-do run } + *> { dg-output-file "group2/FLOAT-LONG_with_SIZE_ERROR.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + *------------------------ + 77 counter pic s9(4) binary value zero. + * FLOAT-LONG + 77 doubleValue COMP-2 value 2. + 77 lastDoubleValue COMP-2. + ****************************************************************** + procedure division. + main section. + perform varying counter from 1 by 1 until + counter > 1060 + *> display 'counter: ' counter ', value: ' doubleValue + compute doubleValue = doubleValue * 2 + ON SIZE ERROR + display 'SIZE ERROR raised' + end-display + display 'SIZE ERROR, last value = ' doubleValue + end-display + exit perform + not ON SIZE ERROR + if doubleValue > lastdoubleValue + move doubleValue to lastdoubleValue + else + display 'math ERROR, last value > current: ' + lastdoubleValue ' > ' doubleValue + end-display + exit perform + end-if + end-compute + end-perform + display "counter is " counter + if not (counter >= 1023 and <=1025) + display ' ' + display 'counter is ' counter + end-if + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.out b/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.out new file mode 100644 index 0000000..208bd8a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.out @@ -0,0 +1,4 @@ +SIZE ERROR raised +SIZE ERROR, last value = 8.98846567431157954E+307 +counter is +1023 + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.cob b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.cob new file mode 100644 index 0000000..e00676c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.cob @@ -0,0 +1,164 @@ + *> { dg-do run } + *> { dg-output-file "group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 CMP1 COMP-1. + 01 SV1 COMP-1. + 01 CMP2 COMP-2. + 01 SV2 COMP-2. + + PROCEDURE DIVISION. + CND-000. + + DISPLAY "--- COMP-1 ---" + COMPUTE CMP1 = (((1.0E7 / 2.1E0) / 3.1E0) - 5.0E-1) * 6.0E0 + DISPLAY "A: " CMP1 + COMPUTE CMP1 = (((1.0E7 / 2.9E0) / 3.9E0) - 5.0E-1) * 6.0E0 + DISPLAY "B: " CMP1 + MOVE ZERO TO CMP1. + COMPUTE CMP1 = 1.0E3 / 2.1E0 + ON SIZE ERROR DISPLAY "Z: " CMP1 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "Z: " CMP1 " IS OK" + END-COMPUTE. + + DISPLAY " ..." + DISPLAY "--- COMP-2 ---" + COMPUTE CMP2 = (((1.0E7 / 2.1E0) / 3.1E0) - 5.0E-1) * 6.0E0 + *> because of possible rounding of intermediates and different + *> precision depending on math library / version: plain DISPLAY + IF CMP2 >= 9216586.86175114 AND <= 9216586.86175116 + DISPLAY "A ~ 9216586.86175115" + ELSE + DISPLAY "A: " CMP2 + END-IF + COMPUTE CMP2 = (((1.0E7 / 2.9E0) / 3.9E0) - 5.0E-1) * 6.0E0 + IF CMP2 >= 5305036.7877983 AND <= 5305036.7877985 + DISPLAY "B ~ 5305036.787798408" + ELSE + DISPLAY "B: " CMP2 + END-IF + MOVE ZERO TO CMP2. + COMPUTE CMP2 = 1.0E3 / 2.1E0 + ON SIZE ERROR DISPLAY "Z: " CMP2 " SIZE ERROR" + NOT ON SIZE ERROR + *> see note above + IF CMP2 >= 476.1904761904760 AND <= 476.1904761904763 + DISPLAY "Z ~ 476.1904761904761 IS OK" + ELSE + DISPLAY "Z: " CMP2 " IS OK" + END-IF + END-COMPUTE. + + DISPLAY " ..." + DISPLAY "--- 99 + 1 / 3 ---" + MOVE -1 TO CMP1, CMP2. + COMPUTE CMP1 = 99 + 1 / 3 + ON SIZE ERROR DISPLAY "CMP1: " CMP1 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "CMP1: " CMP1 " IS OK" + END-COMPUTE. + COMPUTE CMP2 = 99 + 1 / 3 + ON SIZE ERROR DISPLAY "CMP2: " CMP2 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "CMP2: " CMP2 " IS OK" + END-COMPUTE. + + DISPLAY " ..." + DISPLAY "--- 99 ---" + MOVE -1 TO CMP1, CMP2. + COMPUTE CMP1 = 99 + ON SIZE ERROR DISPLAY "CMP1: " CMP1 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "CMP1: " CMP1 " IS OK" + END-COMPUTE. + COMPUTE CMP2 = 99 + ON SIZE ERROR DISPLAY "CMP2: " CMP2 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "CMP2: " CMP2 " IS OK" + END-COMPUTE. + + CND-100-OK. + DISPLAY " ..." + DISPLAY "--- Test overflow ---" + + MOVE 990000 TO CMP1. + PERFORM 6500 TIMES + MOVE CMP1 TO SV1 + COMPUTE CMP1 = CMP1 * 10 + ON SIZE ERROR GO TO CND-350-ERR + END-COMPUTE + IF CMP1 < 9.0 + GO TO CND-350-ERR + END-IF + END-PERFORM. + DISPLAY "CMP1: " CMP1 " IS OK". + GO TO CND-350-OK. + CND-350-ERR. + DISPLAY "CMP1: after " SV1 " SIZE ERROR". + + CND-350-OK. + MOVE 9900000000 TO CMP2. + PERFORM 6500 TIMES + MOVE CMP2 TO SV2 + COMPUTE CMP2 = CMP2 * 10 + ON SIZE ERROR GO TO CND-380-ERR + END-COMPUTE + IF CMP2 < 9.0 + GO TO CND-380-ERR + END-IF + END-PERFORM. + DISPLAY "CMP2: " CMP2 " IS OK". + GO TO CND-500-OK. + CND-380-ERR. + *> because of possible rounding of intermediates and different + *> precision depending on math library / version: plain DISPLAY + IF SV2 >= 9.899999999999E+307 AND + <= 9.900000000001E+307 + DISPLAY "CMP2: after ~ 9.899999999999781E+307 SIZE ERROR" + ELSE + DISPLAY "CMP2: after " SV2 " SIZE ERROR" + END-IF + . + + CND-500-OK. + MOVE 0.000000099 TO CMP1. + PERFORM 350 TIMES + MOVE CMP1 TO SV1 + COMPUTE CMP1 = CMP1 / 10.0 + ON SIZE ERROR GO TO CND-500-ERR + END-COMPUTE + IF CMP1 = 0.0 + GO TO CND-500-ERR + END-IF + END-PERFORM. + DISPLAY "CMP1: " CMP1 " IS OK". + GO TO CND-600-OK. + CND-500-ERR. + DISPLAY "CMP1: after " SV1 " SIZE ERROR". + + CND-600-OK. + MOVE 0.000000099 TO CMP2. + PERFORM 350 TIMES + MOVE CMP2 TO SV2 + COMPUTE CMP2 = CMP2 / 10.0 + ON SIZE ERROR GO TO CND-600-ERR + END-COMPUTE + IF CMP2 = 0.0 + GO TO CND-600-ERR + END-IF + END-PERFORM. + DISPLAY "CMP2: " CMP2 " IS OK". + GO TO CND-600-XIT. + CND-600-ERR. + IF SV2 >= 9.8813129168249E-324 AND <= 9.881312916825E-324 + DISPLAY "CMP2: after ~ 9.881312916824931E-324 SIZE ERROR" + ELSE + DISPLAY "CMP2: after " SV2 " SIZE ERROR" + END-IF + . + CND-600-XIT. + + CND-999. + STOP RUN. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.out b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.out new file mode 100644 index 0000000..18fc770 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.out @@ -0,0 +1,24 @@ +--- COMP-1 --- +A: 9.216587E+06 +B: 5.305037E+06 +Z: 476.1904907 IS OK + ... +--- COMP-2 --- +A ~ 9216586.86175115 +B ~ 5305036.787798408 +Z ~ 476.1904761904761 IS OK + ... +--- 99 + 1 / 3 --- +CMP1: 99.33333588 IS OK +CMP2: 99.3333333333333286 IS OK + ... +--- 99 --- +CMP1: 99 IS OK +CMP2: 99 IS OK + ... +--- Test overflow --- +CMP1: after 9.899998274E+37 SIZE ERROR +CMP2: after ~ 9.899999999999781E+307 SIZE ERROR +CMP1: after 1.401298464E-45 SIZE ERROR +CMP2: after ~ 9.881312916824931E-324 SIZE ERROR + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.cob b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.cob new file mode 100644 index 0000000..b194442 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.cob @@ -0,0 +1,40 @@ + *> { dg-do run } + *> { dg-output-file "group2/FLOAT-SHORT_with_SIZE_ERROR.out" } + + identification division. + program-id. prog. + + data division. + working-storage section. + *------------------------ + 77 counter pic s9(4) binary value zero. + * FLOAT-SHORT (if binary-comp-1 is not active) + 77 floatValue COMP-1 value 2. + 77 lastFloatValue COMP-1. + + ****************************************************************** + procedure division. + main section. + perform varying counter from 1 by 1 until + counter > 130 + *> display 'counter: ' counter ', value: ' floatValue + compute floatValue = floatValue * 2 + ON SIZE ERROR + display 'SIZE ERROR, last value = ' floatValue + exit perform + not ON SIZE ERROR + if floatValue > lastFloatValue + move floatValue to lastFloatValue + else + display 'math ERROR, last value > current: ' + lastFloatValue ' > ' floatValue + exit perform + end-if + end-compute + end-perform + if counter not = 127 + display 'counter is ' counter + end-if + + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.out b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.out new file mode 100644 index 0000000..e5ba05f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.out @@ -0,0 +1,2 @@ +SIZE ERROR, last value = 1.701411835E+38 + 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..88b1b84 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob @@ -0,0 +1,335 @@ + *> { dg-do run } + *> { dg-set-target-env-var TZ UTC0 } + + 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_SQRT__2_.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_SQRT__2_.cob new file mode 100644 index 0000000..c1f4ba8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SQRT__2_.cob @@ -0,0 +1,13 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_SQRT__2_.out" } + program-id. sqbug. + procedure division. + if function sqrt (0) = 0 *> if4034.2 + display 'ok' else display 'bad'. + display "sqrt(0) " """" function trim (function exception-status) """" + set last exception to off + if function sqrt (-0.1) = 0 *> if4034.2 + display 'ok' else display 'bad'. + display "sqrt(-0.1) " """" function trim (function exception-status) """" + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_SQRT__2_.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_SQRT__2_.out new file mode 100644 index 0000000..0783ac5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_SQRT__2_.out @@ -0,0 +1,5 @@ +ok +sqrt(0) "" +bad +sqrt(-0.1) "EC-ARGUMENT-FUNCTION" + 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/Fixed_continuation_indicator.cob b/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.cob new file mode 100644 index 0000000..2c23e7b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + *> { dg-output-file "group2/Fixed_continuation_indicator.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(333) VALUE + '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWX + - 'YZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUV + - 'WXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRST + - 'UVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQR + - 'STUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOP + - 'QRSTUVWXYZ'. + PROCEDURE DIVISION. + DISPLAY X NO ADVANCING + END-DISPLAY. + DISPLAY '_' + END-DISPLAY. + MOVE + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567 + - "89abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345 + - "6789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123 + - "456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01 + - "23456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXY + - "Z + - "0123456789" TO X. + DISPLAY X NO ADVANCING + END-DISPLAY. + DISPLAY '_' + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.out b/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.out new file mode 100644 index 0000000..2a472b8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.out @@ -0,0 +1,3 @@ +0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ _ +abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 _ + diff --git a/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__1_.cob b/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__1_.cob new file mode 100644 index 0000000..6d89908 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__1_.cob @@ -0,0 +1,42 @@ + *> { dg-do compile } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT TEST-FILE + ASSIGN "TESTFILE" + ACCESS DYNAMIC + ORGANIZATION RELATIVE + STATUS TESTSTAT + RELATIVE KEY TESTKEY + . + DATA DIVISION. + FILE SECTION. + FD TEST-FILE GLOBAL. + 01 TEST-REC PIC X(4). + WORKING-STORAGE SECTION. + 01 GLOBVALS. + 03 TESTKEY PIC 9(4). + 03 TESTSTAT PIC XX. + PROCEDURE DIVISION. + OPEN INPUT TEST-FILE. + CALL "prog2" + END-CALL. + CLOSE TEST-FILE. + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + READ TEST-FILE + INVALID KEY + DISPLAY "NOK" + END-DISPLAY + END-READ. + EXIT PROGRAM. + END PROGRAM prog2. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__2_.cob b/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__2_.cob new file mode 100644 index 0000000..44d5b2e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__2_.cob @@ -0,0 +1,42 @@ + *> { dg-do compile } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT TEST-FILE + ASSIGN "TESTFILE" + ACCESS DYNAMIC + ORGANIZATION INDEXED + STATUS TESTSTAT + RECORD KEY TESTKEY + . + DATA DIVISION. + FILE SECTION. + FD TEST-FILE GLOBAL. + 01 TEST-REC. + 03 TESTKEY PIC X(4). + WORKING-STORAGE SECTION. + 01 GLOBVALS. + 03 TESTSTAT PIC XX. + PROCEDURE DIVISION. + OPEN INPUT TEST-FILE. + CALL "prog2" + END-CALL. + CLOSE TEST-FILE. + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + READ TEST-FILE + INVALID KEY + DISPLAY "NOK" + END-DISPLAY + END-READ. + EXIT PROGRAM. + END PROGRAM prog2. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__3_.cob b/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__3_.cob new file mode 100644 index 0000000..0f423babd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__3_.cob @@ -0,0 +1,41 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT TEST-FILE + ASSIGN "TESTFILE" + ACCESS DYNAMIC + ORGANIZATION RELATIVE + STATUS TESTSTAT + RELATIVE KEY TESTKEY + . + DATA DIVISION. + FILE SECTION. + FD TEST-FILE GLOBAL. + 01 TEST-REC PIC X(4). + WORKING-STORAGE SECTION. + 01 GLOBVALS. + 03 TESTKEY PIC 9(4). + 03 TESTSTAT PIC XX. + PROCEDURE DIVISION. + MOVE "00" TO TESTSTAT. + CALL "prog2" + END-CALL. + IF TESTSTAT = "00" + DISPLAY "Not OK" + END-DISPLAY + END-IF. + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + OPEN INPUT TEST-FILE. + EXIT PROGRAM. + END PROGRAM prog2. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__4_.cob b/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__4_.cob new file mode 100644 index 0000000..116a935 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/GLOBAL_FD__4_.cob @@ -0,0 +1,41 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT TEST-FILE + ASSIGN "TESTFILE" + ACCESS DYNAMIC + ORGANIZATION INDEXED + STATUS TESTSTAT + RECORD KEY TESTKEY + . + DATA DIVISION. + FILE SECTION. + FD TEST-FILE GLOBAL. + 01 TEST-REC. + 03 TESTKEY PIC X(4). + WORKING-STORAGE SECTION. + 01 GLOBVALS. + 03 TESTSTAT PIC XX. + PROCEDURE DIVISION. + MOVE "00" TO TESTSTAT. + CALL "prog2" + END-CALL. + IF TESTSTAT = "00" + DISPLAY "Not OK" + END-DISPLAY + END-IF. + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + OPEN INPUT TEST-FILE. + EXIT PROGRAM. + END PROGRAM prog2. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/GLOBAL_at_lower_level.cob b/gcc/testsuite/cobol.dg/group2/GLOBAL_at_lower_level.cob new file mode 100644 index 0000000..f4b5cba --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/GLOBAL_at_lower_level.cob @@ -0,0 +1,37 @@ + *> { dg-do run } + *> { dg-output-file "group2/GLOBAL_at_lower_level.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(5) GLOBAL VALUE "prog1". + PROCEDURE DIVISION. + DISPLAY X + END-DISPLAY. + CALL "prog2" + END-CALL + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(5) GLOBAL VALUE "prog2". + PROCEDURE DIVISION. + DISPLAY X + END-DISPLAY. + CALL "prog3" + END-CALL + EXIT PROGRAM. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog3. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY X + END-DISPLAY. + EXIT PROGRAM. + END PROGRAM prog3. + END PROGRAM prog2. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/GLOBAL_at_lower_level.out b/gcc/testsuite/cobol.dg/group2/GLOBAL_at_lower_level.out new file mode 100644 index 0000000..ab69cb1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/GLOBAL_at_lower_level.out @@ -0,0 +1,4 @@ +prog1 +prog2 +prog2 + diff --git a/gcc/testsuite/cobol.dg/group2/GLOBAL_at_same_level.cob b/gcc/testsuite/cobol.dg/group2/GLOBAL_at_same_level.cob new file mode 100644 index 0000000..749a26c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/GLOBAL_at_same_level.cob @@ -0,0 +1,37 @@ + *> { dg-do run } + *> { dg-output-file "group2/GLOBAL_at_same_level.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(5) GLOBAL VALUE "prog1". + PROCEDURE DIVISION. + DISPLAY X + END-DISPLAY. + CALL "prog2" + END-CALL + CALL "prog3" + END-CALL + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(5) GLOBAL VALUE "prog2". + PROCEDURE DIVISION. + DISPLAY X + END-DISPLAY. + EXIT PROGRAM. + END PROGRAM prog2. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog3. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY X + END-DISPLAY. + EXIT PROGRAM. + END PROGRAM prog3. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/GLOBAL_at_same_level.out b/gcc/testsuite/cobol.dg/group2/GLOBAL_at_same_level.out new file mode 100644 index 0000000..4bc5d8b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/GLOBAL_at_same_level.out @@ -0,0 +1,4 @@ +prog1 +prog2 +prog1 + diff --git a/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.cob b/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.cob new file mode 100644 index 0000000..9722ebd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/Hexadecimal_literal.out" } + + >>DEFINE CHARSET AS 'ASCII' + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + >>IF CHARSET = 'EBCDIC' + DISPLAY X"F1F2F3" + >>ELSE + DISPLAY X"313233" + >>END-IF + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.out b/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.out new file mode 100644 index 0000000..cc12087 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.out @@ -0,0 +1,2 @@ +123 + 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..91440f5 --- /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). + 01 pitem redefines item pointer. + procedure division. + move all "abcd" to item + inspect item converting "abcd" to low-values + display "low-values " space """" pitem """" + move all "abcd" to item + inspect item converting "abcd" to spaces + display "spaces " space """" pitem """" + move all "abcd" to item + inspect item converting "abcd" to zeros + display "zeros " space """" pitem """" + move all "abcd" to item + inspect item converting "abcd" to quotes + display "quotes " space """" pitem """" + move all "abcd" to item + inspect item converting "abcd" to high-values + display "high-values" space """" pitem """" + 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..23ce49b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constants.out @@ -0,0 +1,6 @@ +low-values "0x0000000000000000" +spaces "0x2020202020202020" +zeros "0x3030303030303030" +quotes "0x2222222222222222" +high-values "0xffffffffffffffff" + 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..2f306f1 --- /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..0e4297d --- /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..0b6c00c --- /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..03a0b07 --- /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..5ef97e1 --- /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..40cecfc --- /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..abf9eb9 --- /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/Index_and_parenthesized_expression.cob b/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.cob new file mode 100644 index 0000000..88c24fd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/Index_and_parenthesized_expression.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X OCCURS 1 INDEXED BY I. + PROCEDURE DIVISION. + IF I < (I + 2) + DISPLAY "OK" NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.out b/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.out new file mode 100644 index 0000000..d86bac9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.out @@ -0,0 +1 @@ +OK 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..39a0c5b --- /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 INTRINSIC + FUNCTION E INTRINSIC. + 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_OF_omnibus.cob b/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.cob new file mode 100644 index 0000000..7b24aed --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.cob @@ -0,0 +1,107 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + *> { dg-output-file "group2/LENGTH_OF_omnibus.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 LENGTH OF" + + move "Length of desc1" to msg + move 50 to should-be + move length of desc1 to but-is + perform result-is + + move "Length of desc1-entry" to msg + move 5 to should-be + move length of desc1-entry to but-is + perform result-is + + move "Length of desc1-entry(1)" to msg + move 5 to should-be + move length of desc1-entry(1) to but-is + perform result-is + + move "Length of desc2" to msg + move 50 to should-be + move length of desc2 to but-is + perform result-is + + move "Length of desc2-table" to msg + move 5 to should-be + move length of desc2-table to but-is + perform result-is + + move "Length of desc2-entry" to msg + move 5 to should-be + move length of desc2-entry to but-is + perform result-is + + move "Length of desc2-entry(1)" to msg + move 5 to should-be + move length of desc2-entry(1) to but-is + perform result-is + + move 5 to desc3-lim + + move "Length of desc3" to msg + move 750 to should-be + move length of desc3 to but-is + perform result-is + + move "Length of desc3-outer" to msg + move 150 to should-be + move length of desc3-outer to but-is + perform result-is + + move "Length of desc3-outer(1)" to msg + move 150 to should-be + move length of desc3-outer(1) to but-is + perform result-is + + move "Length of desc3-outer-txt" to msg + move 7 to should-be + move length of desc3-outer-txt to but-is + perform result-is + + move "Length of desc3-inner" to msg + move 13 to should-be + move length of desc3-inner to but-is + perform result-is + + move "Length of desc3-inner(1)" to msg + move 13 to should-be + move length of 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/LENGTH_OF_omnibus.out b/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.out new file mode 100644 index 0000000..e4cf801 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.out @@ -0,0 +1,15 @@ +using LENGTH OF +Length of desc1: 50 +Length of desc1-entry: 5 +Length of desc1-entry(1): 5 +Length of desc2: 50 +Length of desc2-table: 5 +Length of desc2-entry: 5 +Length of desc2-entry(1): 5 +Length of desc3: 750 +Length of desc3-outer: 150 +Length of desc3-outer(1): 150 +Length of desc3-outer-txt: 7 +Length of desc3-inner: 13 +Length of desc3-inner(1): 13 + diff --git a/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.cob b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.cob new file mode 100644 index 0000000..a4410fa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.cob @@ -0,0 +1,28 @@ + *> { dg-do run } + *> { dg-output-file "group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + PROCEDURE DIVISION. + CALL "callee" + END-CALL. + STOP RUN. + end program caller. + + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WRK-X PIC 999 VALUE 5. + LOCAL-STORAGE SECTION. + 01 LCL-X PIC 999 . + PROCEDURE DIVISION. + display "On entry: " wrk-x + move wrk-x to lcl-x + subtract 1 from wrk-x + if wrk-x > 0 + call "callee". + display "On exit: " lcl-x + goback. + end program callee. + diff --git a/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.out b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.out new file mode 100644 index 0000000..839de4f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.out @@ -0,0 +1,11 @@ +On entry: 005 +On entry: 004 +On entry: 003 +On entry: 002 +On entry: 001 +On exit: 001 +On exit: 002 +On exit: 003 +On exit: 004 +On exit: 005 + diff --git a/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.cob b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.cob new file mode 100644 index 0000000..64d0072 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.cob @@ -0,0 +1,28 @@ + *> { dg-do run } + *> { dg-output-file "group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + PROCEDURE DIVISION. + CALL "callee" + END-CALL. + STOP RUN. + end program caller. + + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WRK-X PIC 999 VALUE 5. + LOCAL-STORAGE SECTION. + 01 LCL-X PIC 999 . + PROCEDURE DIVISION. + display "On entry: " wrk-x + move wrk-x to lcl-x + subtract 1 from wrk-x + if wrk-x > 0 + call "callee". + display "On exit: " lcl-x + goback. + end program callee. + diff --git a/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.out b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.out new file mode 100644 index 0000000..839de4f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.out @@ -0,0 +1,11 @@ +On entry: 005 +On entry: 004 +On entry: 003 +On entry: 002 +On entry: 001 +On exit: 001 +On exit: 002 +On exit: 003 +On exit: 004 +On exit: 005 + 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/MOVE_Z_literal_.cob b/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.cob new file mode 100644 index 0000000..c92ab35 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.cob @@ -0,0 +1,34 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_Z_literal_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC XXXX. + 01 XRED REDEFINES X. + 03 XBYTE1 PIC X. + 03 XBYTE2 PIC X. + 03 XBYTE3 PIC X. + 03 XBYTE4 PIC X. + PROCEDURE DIVISION. + MOVE Z"012" TO X. + IF XBYTE1 = "0" AND + XBYTE2 = "1" AND + XBYTE3 = "2" AND + XBYTE4 = LOW-VALUE + DISPLAY "OK" NO ADVANCING + END-DISPLAY + ELSE + DISPLAY "X = " X (1:3) NO ADVANCING + END-DISPLAY + IF XBYTE4 = LOW-VALUE + DISPLAY " WITH LOW-VALUE" + END-DISPLAY + ELSE + DISPLAY " WITHOUT LOW-VALUE BUT '" XBYTE4 "'" + END-DISPLAY + END-IF + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.out b/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.out new file mode 100644 index 0000000..d86bac9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.out @@ -0,0 +1 @@ +OK diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_indexes.cob b/gcc/testsuite/cobol.dg/group2/MOVE_indexes.cob new file mode 100644 index 0000000..9ededd2c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_indexes.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X OCCURS 10 INDEXED I. + PROCEDURE DIVISION. + SET I TO ZERO. + SET X(1) TO I + IF X(1) NOT = "0" + DISPLAY X(1) NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.cob b/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.cob new file mode 100644 index 0000000..61be48f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_integer_literal_to_alphanumeric.out" } + + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(04) VALUE SPACES. + PROCEDURE DIVISION. + MOVE 0 TO X. + DISPLAY X NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.out b/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.out new file mode 100644 index 0000000..4af5951 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.out @@ -0,0 +1 @@ +0 diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.cob new file mode 100644 index 0000000..37f813f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.cob @@ -0,0 +1,31 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_to_JUSTIFIED_item.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SRC-1 PIC S9(04) VALUE 11. + 01 SRC-2 PIC S9(04) COMP VALUE 22. + 01 SRC-3 PIC S9(04) COMP-5 VALUE 33. + 01 SRC-4 PIC S9(04)PP VALUE 4400. + 01 SRC-5 PIC S9(04)PPPPP VALUE 55500000. + 01 EDT-FLD PIC X(07) JUSTIFIED RIGHT. + PROCEDURE DIVISION. + MOVE SRC-1 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + MOVE SRC-2 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + MOVE SRC-3 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + MOVE SRC-4 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + MOVE SRC-5 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.out b/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.out new file mode 100644 index 0000000..5e300fa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.out @@ -0,0 +1,6 @@ +> 0011< +> 0022< +> 0033< +> 004400< +>5500000< + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.cob new file mode 100644 index 0000000..86ef0ae --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_to_edited_item__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SRC-1 PIC S99V99 VALUE 1.10. + 01 SRC-2 PIC S99V99 VALUE 0.02. + 01 SRC-3 PIC S99V99 VALUE -0.03. + 01 SRC-4 PIC S99V99 VALUE -0.04. + 01 SRC-5 PIC S99V99 VALUE -0.05. + 01 EDT-1 PIC -(04)9. + 01 EDT-2 PIC -(04)9. + 01 EDT-3 PIC -(04)9. + 01 EDT-4 PIC +(04)9. + 01 EDT-5 PIC -(05). + PROCEDURE DIVISION. + MOVE SRC-1 TO EDT-1. + MOVE SRC-2 TO EDT-2. + MOVE SRC-3 TO EDT-3. + MOVE SRC-4 TO EDT-4. + MOVE SRC-5 TO EDT-5. + DISPLAY '>' EDT-1 '<' + END-DISPLAY. + DISPLAY '>' EDT-2 '<' + END-DISPLAY. + DISPLAY '>' EDT-3 '<' + END-DISPLAY. + DISPLAY '>' EDT-4 '<' + END-DISPLAY. + DISPLAY '>' EDT-5 '<' + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.out b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.out new file mode 100644 index 0000000..9557d50 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.out @@ -0,0 +1,6 @@ +> 1< +> 0< +> 0< +> +0< +> < + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.cob new file mode 100644 index 0000000..cde8096 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_to_edited_item__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SRC-1 PIC S99V99 VALUE -0.06. + 01 SRC-2 PIC S99V99 VALUE -0.07. + 01 SRC-3 PIC S99V99 VALUE -0.08. + 01 SRC-4 PIC S99V99 VALUE -0.09. + 01 SRC-5 PIC S99V99 VALUE -1.10. + 01 EDT-1 PIC 9(04)-. + 01 EDT-2 PIC 9(04)+. + 01 EDT-3 PIC Z(04)+. + 01 EDT-4 PIC 9(04)DB. + 01 EDT-5 PIC 9(04)DB. + PROCEDURE DIVISION. + MOVE SRC-1 TO EDT-1. + MOVE SRC-2 TO EDT-2. + MOVE SRC-3 TO EDT-3. + MOVE SRC-4 TO EDT-4. + MOVE SRC-5 TO EDT-5. + DISPLAY '>' EDT-1 '<' + END-DISPLAY. + DISPLAY '>' EDT-2 '<' + END-DISPLAY. + DISPLAY '>' EDT-3 '<' + END-DISPLAY. + DISPLAY '>' EDT-4 '<' + END-DISPLAY. + DISPLAY '>' EDT-5 '<' + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.out b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.out new file mode 100644 index 0000000..a704296 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.out @@ -0,0 +1,6 @@ +>0000 < +>0000+< +> < +>0000 < +>0001DB< + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.cob new file mode 100644 index 0000000..92711a9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_to_item_with_simple_and_floating_insertion.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 num-1 PIC -*B*99. + 01 num-2 PIC $BB**,***.**. + 01 num-3 PIC $BB--,---.--. + + PROCEDURE DIVISION. + MOVE -123 TO num-1 + DISPLAY ">" num-1 "<" + + MOVE 1234.56 TO num-2 + DISPLAY ">" num-2 "<" + + MOVE 1234.56 TO num-3 + DISPLAY ">" num-3 "<" + . + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.out b/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.out new file mode 100644 index 0000000..9012693 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.out @@ -0,0 +1,4 @@ +>-**123< +>$ *1,234.56< +>$ 1,234.56< + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_itself.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_itself.cob new file mode 100644 index 0000000..475b5d9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_itself.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99 VALUE 12. + PROCEDURE DIVISION. + MOVE X TO X. + IF X NOT = 12 + DISPLAY X NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_with_group_refmod.cob b/gcc/testsuite/cobol.dg/group2/MOVE_with_group_refmod.cob new file mode 100644 index 0000000..834d81d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_with_group_refmod.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC 9999 VALUE 1234. + PROCEDURE DIVISION. + MOVE "99" TO G(3:2). + IF G NOT = "1299" + DISPLAY G NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod.cob b/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod.cob new file mode 100644 index 0000000..455951a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 9(4) VALUE 0. + PROCEDURE DIVISION. + MOVE "1" TO X(1:1). + IF X NOT = 1000 + DISPLAY X NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod__variable_.cob b/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod__variable_.cob new file mode 100644 index 0000000..b3fb550 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod__variable_.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "1234". + 01 Y PIC X(4) VALUE "abcd". + 01 I PIC 9 VALUE 1. + PROCEDURE DIVISION. + MOVE X(1:I) TO Y. + IF Y NOT = "1 " + DISPLAY Y NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MULTIPLY_BY_literal_in_INITIAL_program.cob b/gcc/testsuite/cobol.dg/group2/MULTIPLY_BY_literal_in_INITIAL_program.cob new file mode 100644 index 0000000..56f4703 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MULTIPLY_BY_literal_in_INITIAL_program.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog INITIAL. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 num PIC 9(4) VALUE 5. + 01 result PIC 9(4). + 01 ws-temp PIC 9(8)V99. + 01 ws-temp2 PIC 9(3)V99 VALUE 10.50. + PROCEDURE DIVISION. + MULTIPLY num BY 4 GIVING result + MOVE 1.10 TO WS-TEMP. + MULTIPLY WS-TEMP2 BY WS-TEMP GIVING WS-TEMP. + diff --git a/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.cob b/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.cob new file mode 100644 index 0000000..6aa9388 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + *> { dg-output-file "group2/Multi-target_MOVE_with_subscript_re-evaluation.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. mover. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FILLER. + 02 ADATA VALUE "654321". + 02 A REDEFINES ADATA PIC 9 OCCURS 6 TIMES. + 02 B PIC 9. + 02 CDATA VALUE "999999". + 02 C REDEFINES CDATA PIC 9 OCCURS 6 TIMES. + 01 TEMP PIC 9. + PROCEDURE DIVISION. + INITIALIZE CDATA ALL TO VALUE + MOVE 2 TO B + MOVE A(B) TO B, C(B) + *> That should pick up 5, move it to B, and then move 5 to C(5), + IF CDATA NOT EQUAL TO "999959" + DISPLAY CDATA " Should be ""999959"", but isn't" + ELSE + DISPLAY CDATA " Should be ""999959""". + *> See 14.9.25.4 MOVE General Rules + INITIALIZE CDATA ALL TO VALUE + MOVE 2 TO B + MOVE A(B) TO TEMP + MOVE TEMP TO B + MOVE TEMP TO C(B) + IF CDATA NOT EQUAL TO "999959" + DISPLAY CDATA " Should be ""999959"", but isn't" + ELSE + DISPLAY CDATA " Should be ""999959""". + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.out b/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.out new file mode 100644 index 0000000..30076d7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.out @@ -0,0 +1,3 @@ +999959 Should be "999959" +999959 Should be "999959" + diff --git a/gcc/testsuite/cobol.dg/group2/Multiple_INDEXED_BY_variables_with_the_same_name.cob b/gcc/testsuite/cobol.dg/group2/Multiple_INDEXED_BY_variables_with_the_same_name.cob new file mode 100644 index 0000000..4bcc06c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Multiple_INDEXED_BY_variables_with_the_same_name.cob @@ -0,0 +1,24 @@ + *> { dg-do run } + *> { dg-output-file "group2/Multiple_INDEXED_BY_variables_with_the_same_name.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 GROUP-1-TABLE. + 05 TABLE-LEVEL-1 VALUE "ABCDEFGHIJKLMNO". + 06 TABLE-ITEM PICTURE X OCCURS 15 TIMES INDEXED BY IND. + 88 EQUALS-M VALUE "M". + 01 GROUP-2-TABLE. + 05 TABLE-LEVEL-1 VALUE "abcdefghijklmno". + 06 TABLE-ITEM PICTURE X OCCURS 15 TIMES INDEXED BY IND. + 88 EQUALS-M VALUE "M". + PROCEDURE DIVISION. + set IND OF GROUP-1-TABLE to 2 + set IND OF GROUP-2-TABLE to 4 + display "The output should be ""Db""" + display "The output is " """" + TABLE-ITEM of GROUP-1-TABLE(IND OF GROUP-2-TABLE) + TABLE-ITEM of GROUP-2-TABLE(IND OF GROUP-1-TABLE) + """" + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/Multiple_INDEXED_BY_variables_with_the_same_name.out b/gcc/testsuite/cobol.dg/group2/Multiple_INDEXED_BY_variables_with_the_same_name.out new file mode 100644 index 0000000..c4d70c9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Multiple_INDEXED_BY_variables_with_the_same_name.out @@ -0,0 +1,3 @@ +The output should be "Db" +The output is "Db" + diff --git a/gcc/testsuite/cobol.dg/group2/Named_conditionals_-_fixed__float__and_alphabetic.cob b/gcc/testsuite/cobol.dg/group2/Named_conditionals_-_fixed__float__and_alphabetic.cob new file mode 100644 index 0000000..92a6511 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Named_conditionals_-_fixed__float__and_alphabetic.cob @@ -0,0 +1,69 @@ + *> { dg-do run } + *> { dg-output-file "group2/Named_conditionals_-_fixed__float__and_alphabetic.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 makeofcar pic x(10). + 88 volksgroup value "skoda", "seat", + "audi", "volkswagen" + false "boat". + 88 germanmade value "volkswagen", "audi", + "mercedes", "bmw", + "porsche". + 01 agegroup pic 999. + 88 child value 0 through 12. + 88 teen value 13 through 19. + 88 adult value 20 through 999. + 01 floats float-long. + 88 neg value -1 through -.1 . + 88 zed value zero . + 88 pos value .1 through 1.0 . + procedure division. + move "ford" to makeofcar + display function trim (makeofcar) + if volksgroup display " volksgroup" end-if + if germanmade display " germanmade" end-if + move "skoda" to makeofcar + display function trim (makeofcar) + if volksgroup display " volksgroup" end-if + if germanmade display " germanmade" end-if + move "volkswagen" to makeofcar + display function trim (makeofcar) + if volksgroup display " volksgroup" end-if + if germanmade display " germanmade" end-if + move 5 to agegroup. + display agegroup with no advancing + if child display " child" end-if + if teen display " teen" end-if + if adult display " adult" end-if + move 15 to agegroup. + display agegroup with no advancing + if child display " child" end-if + if teen display " teen" end-if + if adult display " adult" end-if + move 75 to agegroup. + display agegroup with no advancing + if child display " child" end-if + if teen display " teen" end-if + if adult display " adult" end-if + move -0.5 to floats + display floats with no advancing + if neg display " minus" end-if + if zed display " zero" end-if + if pos display " plus" end-if + move zero to floats + display floats with no advancing + if neg display " minus" end-if + if zed display " zero" end-if + if pos display " plus" end-if + move 0.5 to floats + display floats with no advancing + if neg display " minus" end-if + if zed display " zero" end-if + if pos display " plus" end-if + continue. + quit. + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Named_conditionals_-_fixed__float__and_alphabetic.out b/gcc/testsuite/cobol.dg/group2/Named_conditionals_-_fixed__float__and_alphabetic.out new file mode 100644 index 0000000..9ac5e44 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Named_conditionals_-_fixed__float__and_alphabetic.out @@ -0,0 +1,13 @@ +ford +skoda + volksgroup +volkswagen + volksgroup + germanmade +005 child +015 teen +075 adult +-0.5 minus +0 zero +0.5 plus + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.cob b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.cob new file mode 100644 index 0000000..6b38f79 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/Non-numeric_data_in_numeric_items__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X. + 03 X-NUM PIC 9(06) VALUE 123. + 77 NUM PIC 9(06). + PROCEDURE DIVISION. + MOVE x"0000" TO X (2:2) + IF X-NUM NUMERIC + DISPLAY "low-value is numeric" UPON SYSERR + END-DISPLAY + END-IF + MOVE x"01" TO X (3:1) + IF X-NUM NUMERIC + DISPLAY "SOH is numeric" UPON SYSERR + END-DISPLAY + END-IF + MOVE X-NUM TO NUM + DISPLAY "test over" + END-DISPLAY + * + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.out b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.out new file mode 100644 index 0000000..ac61d84 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.out @@ -0,0 +1,2 @@ +test over + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob new file mode 100644 index 0000000..e80071f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + *> { dg-output-file "group2/Non-numeric_data_in_numeric_items__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X. + 03 X-NUM PIC 9(06) PACKED-DECIMAL VALUE 123. + 77 NUM PIC 9(06). + PROCEDURE DIVISION. + MOVE x"0A" TO X (2:1) + IF X-NUM NUMERIC + DISPLAY "bad prog" + END-DISPLAY + END-IF + MOVE X-NUM TO NUM + DISPLAY "test over" + END-DISPLAY + * + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out new file mode 100644 index 0000000..ac61d84 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out @@ -0,0 +1,2 @@ +test over + diff --git a/gcc/testsuite/cobol.dg/group2/Non-overflow_after_overflow.cob b/gcc/testsuite/cobol.dg/group2/Non-overflow_after_overflow.cob new file mode 100644 index 0000000..fb6cdc7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-overflow_after_overflow.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 9(2) VALUE 0. + 01 Y PIC 9(2) VALUE 0. + PROCEDURE DIVISION. + COMPUTE X = 100 + END-COMPUTE. + COMPUTE Y = 99 + END-COMPUTE. + IF Y NOT = 99 + DISPLAY Y NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Numeric_operations__1_.cob b/gcc/testsuite/cobol.dg/group2/Numeric_operations__1_.cob new file mode 100644 index 0000000..1e8f48e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric_operations__1_.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC S9V9. + 01 Y PIC S9V9 COMP-3. + PROCEDURE DIVISION. + MOVE -0.1 TO X. + ADD 1 TO X. + IF X NOT = 0.9 + DISPLAY X + END-DISPLAY + END-IF. + MOVE 0.1 TO X. + SUBTRACT 1 FROM X. + IF X NOT = -0.9 + DISPLAY X + END-DISPLAY + END-IF. + MOVE -0.1 TO Y. + ADD 1 TO Y. + IF Y NOT = 0.9 + DISPLAY Y + END-DISPLAY + END-IF. + MOVE 0.1 TO Y. + SUBTRACT 1 FROM Y. + IF Y NOT = -0.9 + DISPLAY Y + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Numeric_operations__2_.cob b/gcc/testsuite/cobol.dg/group2/Numeric_operations__2_.cob new file mode 100644 index 0000000..d7d71d7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric_operations__2_.cob @@ -0,0 +1,292 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FIELD PIC S9(1)V9(1). + 01 FELD2 PIC S9(5)V9(5). + 01 FELD3 PIC 9(1)V9(1). + 01 FELD4 PIC S9(1). + PROCEDURE DIVISION. + MOVE 0.2 TO FIELD + ADD 1 TO FIELD + IF FIELD NOT = 1.2 + DISPLAY "Test 1 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + ADD -1 TO FIELD + IF FIELD NOT = -0.8 + DISPLAY "Test 2 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + ADD 1 TO FIELD + IF FIELD NOT = 0.8 + DISPLAY "Test 3 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + ADD -1 TO FIELD + IF FIELD NOT = -1.2 + DISPLAY "Test 4 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + SUBTRACT 1 FROM FIELD + IF FIELD NOT = -0.8 + DISPLAY "Test 5 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + SUBTRACT -1 FROM FIELD + IF FIELD NOT = 1.2 + DISPLAY "Test 6 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + SUBTRACT 1 FROM FIELD + IF FIELD NOT = -1.2 + DISPLAY "Test 7 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + SUBTRACT -1 FROM FIELD + IF FIELD NOT = 0.8 + DISPLAY "Test 8 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + ADD 1 TO FELD2 + IF FELD2 NOT = 1.2 + DISPLAY "Test 9 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + ADD -1 TO FELD2 + IF FELD2 NOT = -0.8 + DISPLAY "Test 10 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + ADD 1 TO FELD2 + IF FELD2 NOT = 0.8 + DISPLAY "Test 11 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + ADD -1 TO FELD2 + IF FELD2 NOT = -1.2 + DISPLAY "Test 12 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + SUBTRACT 1 FROM FELD2 + IF FELD2 NOT = -0.8 + DISPLAY "Test 13 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + SUBTRACT -1 FROM FELD2 + IF FELD2 NOT = 1.2 + DISPLAY "Test 14 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + SUBTRACT 1 FROM FELD2 + IF FELD2 NOT = -1.2 + DISPLAY "Test 15 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + SUBTRACT -1 FROM FELD2 + IF FELD2 NOT = 0.8 + DISPLAY "Test 16 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + ADD 1 TO FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 17 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + ADD -1 TO FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 18 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + ADD 1 TO FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 19 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + ADD -1 TO FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 20 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + SUBTRACT 1 FROM FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 21 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + SUBTRACT -1 FROM FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 22 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + SUBTRACT 1 FROM FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 23 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + SUBTRACT -1 FROM FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 24 " FELD3 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + ADD 1 TO FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 25 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + ADD -1 TO FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 26 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + ADD 1 TO FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 27 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + ADD -1 TO FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 28 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + SUBTRACT 1 FROM FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 29 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + SUBTRACT -1 FROM FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 30 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + SUBTRACT 1 FROM FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 31 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + SUBTRACT -1 FROM FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 32 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + ADD 2 TO FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 33 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + ADD -2 TO FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 34 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + ADD 2 TO FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 35 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + ADD -2 TO FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 36 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + SUBTRACT 2 FROM FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 37 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + SUBTRACT -2 FROM FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 38 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + SUBTRACT 2 FROM FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 39 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + SUBTRACT -2 FROM FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 40 " FELD4 + END-DISPLAY + END-IF. + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Numeric_operations__3_.cob b/gcc/testsuite/cobol.dg/group2/Numeric_operations__3_.cob new file mode 100644 index 0000000..e56804a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric_operations__3_.cob @@ -0,0 +1,292 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FIELD PIC S9(1)V9(1) COMP-3. + 01 FELD2 PIC S9(5)V9(5) COMP-3. + 01 FELD3 PIC 9(1)V9(1) COMP-3. + 01 FELD4 PIC S9(1) COMP-3. + PROCEDURE DIVISION. + MOVE 0.2 TO FIELD + ADD 1 TO FIELD + IF FIELD NOT = 1.2 + DISPLAY "Test 1 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + ADD -1 TO FIELD + IF FIELD NOT = -0.8 + DISPLAY "Test 2 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + ADD 1 TO FIELD + IF FIELD NOT = 0.8 + DISPLAY "Test 3 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + ADD -1 TO FIELD + IF FIELD NOT = -1.2 + DISPLAY "Test 4 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + SUBTRACT 1 FROM FIELD + IF FIELD NOT = -0.8 + DISPLAY "Test 5 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + SUBTRACT -1 FROM FIELD + IF FIELD NOT = 1.2 + DISPLAY "Test 6 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + SUBTRACT 1 FROM FIELD + IF FIELD NOT = -1.2 + DISPLAY "Test 7 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + SUBTRACT -1 FROM FIELD + IF FIELD NOT = 0.8 + DISPLAY "Test 8 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + ADD 1 TO FELD2 + IF FELD2 NOT = 1.2 + DISPLAY "Test 9 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + ADD -1 TO FELD2 + IF FELD2 NOT = -0.8 + DISPLAY "Test 10 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + ADD 1 TO FELD2 + IF FELD2 NOT = 0.8 + DISPLAY "Test 11 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + ADD -1 TO FELD2 + IF FELD2 NOT = -1.2 + DISPLAY "Test 12 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + SUBTRACT 1 FROM FELD2 + IF FELD2 NOT = -0.8 + DISPLAY "Test 13 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + SUBTRACT -1 FROM FELD2 + IF FELD2 NOT = 1.2 + DISPLAY "Test 14 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + SUBTRACT 1 FROM FELD2 + IF FELD2 NOT = -1.2 + DISPLAY "Test 15 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + SUBTRACT -1 FROM FELD2 + IF FELD2 NOT = 0.8 + DISPLAY "Test 16 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + ADD 1 TO FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 17 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + ADD -1 TO FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 18 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + ADD 1 TO FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 19 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + ADD -1 TO FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 20 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + SUBTRACT 1 FROM FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 21 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + SUBTRACT -1 FROM FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 22 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + SUBTRACT 1 FROM FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 23 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + SUBTRACT -1 FROM FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 24 " FELD3 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + ADD 1 TO FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 25 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + ADD -1 TO FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 26 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + ADD 1 TO FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 27 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + ADD -1 TO FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 28 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + SUBTRACT 1 FROM FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 29 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + SUBTRACT -1 FROM FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 30 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + SUBTRACT 1 FROM FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 31 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + SUBTRACT -1 FROM FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 32 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + ADD 2 TO FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 33 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + ADD -2 TO FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 34 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + ADD 2 TO FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 35 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + ADD -2 TO FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 36 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + SUBTRACT 2 FROM FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 37 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + SUBTRACT -2 FROM FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 38 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + SUBTRACT 2 FROM FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 39 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + SUBTRACT -2 FROM FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 40 " FELD4 + END-DISPLAY + END-IF. + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Numeric_operations__4_.cob b/gcc/testsuite/cobol.dg/group2/Numeric_operations__4_.cob new file mode 100644 index 0000000..2b5c8ee --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric_operations__4_.cob @@ -0,0 +1,292 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FIELD PIC S9(1)V9(1) COMP. + 01 FELD2 PIC S9(5)V9(5) COMP. + 01 FELD3 PIC 9(1)V9(1) COMP. + 01 FELD4 PIC S9(1) COMP. + PROCEDURE DIVISION. + MOVE 0.2 TO FIELD + ADD 1 TO FIELD + IF FIELD NOT = 1.2 + DISPLAY "Test 1 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + ADD -1 TO FIELD + IF FIELD NOT = -0.8 + DISPLAY "Test 2 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + ADD 1 TO FIELD + IF FIELD NOT = 0.8 + DISPLAY "Test 3 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + ADD -1 TO FIELD + IF FIELD NOT = -1.2 + DISPLAY "Test 4 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + SUBTRACT 1 FROM FIELD + IF FIELD NOT = -0.8 + DISPLAY "Test 5 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + SUBTRACT -1 FROM FIELD + IF FIELD NOT = 1.2 + DISPLAY "Test 6 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + SUBTRACT 1 FROM FIELD + IF FIELD NOT = -1.2 + DISPLAY "Test 7 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + SUBTRACT -1 FROM FIELD + IF FIELD NOT = 0.8 + DISPLAY "Test 8 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + ADD 1 TO FELD2 + IF FELD2 NOT = 1.2 + DISPLAY "Test 9 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + ADD -1 TO FELD2 + IF FELD2 NOT = -0.8 + DISPLAY "Test 10 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + ADD 1 TO FELD2 + IF FELD2 NOT = 0.8 + DISPLAY "Test 11 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + ADD -1 TO FELD2 + IF FELD2 NOT = -1.2 + DISPLAY "Test 12 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + SUBTRACT 1 FROM FELD2 + IF FELD2 NOT = -0.8 + DISPLAY "Test 13 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + SUBTRACT -1 FROM FELD2 + IF FELD2 NOT = 1.2 + DISPLAY "Test 14 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + SUBTRACT 1 FROM FELD2 + IF FELD2 NOT = -1.2 + DISPLAY "Test 15 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + SUBTRACT -1 FROM FELD2 + IF FELD2 NOT = 0.8 + DISPLAY "Test 16 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + ADD 1 TO FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 17 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + ADD -1 TO FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 18 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + ADD 1 TO FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 19 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + ADD -1 TO FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 20 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + SUBTRACT 1 FROM FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 21 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + SUBTRACT -1 FROM FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 22 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + SUBTRACT 1 FROM FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 23 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + SUBTRACT -1 FROM FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 24 " FELD3 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + ADD 1 TO FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 25 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + ADD -1 TO FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 26 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + ADD 1 TO FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 27 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + ADD -1 TO FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 28 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + SUBTRACT 1 FROM FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 29 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + SUBTRACT -1 FROM FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 30 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + SUBTRACT 1 FROM FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 31 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + SUBTRACT -1 FROM FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 32 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + ADD 2 TO FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 33 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + ADD -2 TO FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 34 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + ADD 2 TO FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 35 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + ADD -2 TO FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 36 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + SUBTRACT 2 FROM FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 37 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + SUBTRACT -2 FROM FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 38 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + SUBTRACT 2 FROM FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 39 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + SUBTRACT -2 FROM FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 40 " FELD4 + END-DISPLAY + END-IF. + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Numeric_operations__5_.cob b/gcc/testsuite/cobol.dg/group2/Numeric_operations__5_.cob new file mode 100644 index 0000000..1f72e69 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric_operations__5_.cob @@ -0,0 +1,292 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FIELD PIC S9(1)V9(1) COMP-5. + 01 FELD2 PIC S9(5)V9(5) COMP-5. + 01 FELD3 PIC 9(1)V9(1) COMP-5. + 01 FELD4 PIC S9(1) COMP-5. + PROCEDURE DIVISION. + MOVE 0.2 TO FIELD + ADD 1 TO FIELD + IF FIELD NOT = 1.2 + DISPLAY "Test 1 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + ADD -1 TO FIELD + IF FIELD NOT = -0.8 + DISPLAY "Test 2 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + ADD 1 TO FIELD + IF FIELD NOT = 0.8 + DISPLAY "Test 3 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + ADD -1 TO FIELD + IF FIELD NOT = -1.2 + DISPLAY "Test 4 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + SUBTRACT 1 FROM FIELD + IF FIELD NOT = -0.8 + DISPLAY "Test 5 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FIELD + SUBTRACT -1 FROM FIELD + IF FIELD NOT = 1.2 + DISPLAY "Test 6 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + SUBTRACT 1 FROM FIELD + IF FIELD NOT = -1.2 + DISPLAY "Test 7 " FIELD + END-DISPLAY + END-IF. + + MOVE -0.2 TO FIELD + SUBTRACT -1 FROM FIELD + IF FIELD NOT = 0.8 + DISPLAY "Test 8 " FIELD + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + ADD 1 TO FELD2 + IF FELD2 NOT = 1.2 + DISPLAY "Test 9 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + ADD -1 TO FELD2 + IF FELD2 NOT = -0.8 + DISPLAY "Test 10 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + ADD 1 TO FELD2 + IF FELD2 NOT = 0.8 + DISPLAY "Test 11 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + ADD -1 TO FELD2 + IF FELD2 NOT = -1.2 + DISPLAY "Test 12 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + SUBTRACT 1 FROM FELD2 + IF FELD2 NOT = -0.8 + DISPLAY "Test 13 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD2 + SUBTRACT -1 FROM FELD2 + IF FELD2 NOT = 1.2 + DISPLAY "Test 14 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + SUBTRACT 1 FROM FELD2 + IF FELD2 NOT = -1.2 + DISPLAY "Test 15 " FELD2 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD2 + SUBTRACT -1 FROM FELD2 + IF FELD2 NOT = 0.8 + DISPLAY "Test 16 " FELD2 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + ADD 1 TO FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 17 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + ADD -1 TO FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 18 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + ADD 1 TO FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 19 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + ADD -1 TO FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 20 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + SUBTRACT 1 FROM FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 21 " FELD3 + END-DISPLAY + END-IF. + + MOVE 0.2 TO FELD3 + SUBTRACT -1 FROM FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 22 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + SUBTRACT 1 FROM FELD3 + IF FELD3 NOT = 0.8 + DISPLAY "Test 23 " FELD3 + END-DISPLAY + END-IF. + + MOVE -0.2 TO FELD3 + SUBTRACT -1 FROM FELD3 + IF FELD3 NOT = 1.2 + DISPLAY "Test 24 " FELD3 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + ADD 1 TO FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 25 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + ADD -1 TO FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 26 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + ADD 1 TO FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 27 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + ADD -1 TO FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 28 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + SUBTRACT 1 FROM FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 29 " FELD4 + END-DISPLAY + END-IF. + + MOVE 2 TO FELD4 + SUBTRACT -1 FROM FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 30 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + SUBTRACT 1 FROM FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 31 " FELD4 + END-DISPLAY + END-IF. + + MOVE -2 TO FELD4 + SUBTRACT -1 FROM FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 32 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + ADD 2 TO FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 33 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + ADD -2 TO FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 34 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + ADD 2 TO FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 35 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + ADD -2 TO FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 36 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + SUBTRACT 2 FROM FELD4 + IF FELD4 NOT = -1 + DISPLAY "Test 37 " FELD4 + END-DISPLAY + END-IF. + + MOVE 1 TO FELD4 + SUBTRACT -2 FROM FELD4 + IF FELD4 NOT = 3 + DISPLAY "Test 38 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + SUBTRACT 2 FROM FELD4 + IF FELD4 NOT = -3 + DISPLAY "Test 39 " FELD4 + END-DISPLAY + END-IF. + + MOVE -1 TO FELD4 + SUBTRACT -2 FROM FELD4 + IF FELD4 NOT = 1 + DISPLAY "Test 40 " FELD4 + END-DISPLAY + END-IF. + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Numeric_operations__7_.cob b/gcc/testsuite/cobol.dg/group2/Numeric_operations__7_.cob new file mode 100644 index 0000000..df517db --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric_operations__7_.cob @@ -0,0 +1,283 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FIELD PIC S9(4)V9(2) COMP-5. + 01 FIELD-DISP PIC S9(4)V9(2) DISPLAY. + PROCEDURE DIVISION. + MOVE 0.2 TO FIELD. + ADD 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 + 13 + 14 + 15 + 16 + 17 + 18 + 19 + 20 + 21 + 22 + 23 + 24 + 25 + 26 + 27 + 28 + 29 + 30 + 31 + 32 + 33 + 34 + 35 + 36 + 37 + 38 + 39 + 40 + 41 + 42 + 43 + 44 + 45 + 46 + 47 + 48 + 49 + 50 + 51 + 52 + 53 + 54 + 55 + 56 + 57 + 58 + 59 + 60 + 61 + 62 + 63 + 64 + 65 + 66 + 67 + 68 + 69 + 70 + 71 + 72 + 73 + 74 + 75 + 76 + 77 + 78 + 79 + 80 + 81 + 82 + 83 + 84 + 85 + 86 + 87 + 88 + 89 + 90 + 91 + 92 + 93 + 94 + 95 + 96 + 97 + 98 + 99 + 100 + 101 + 102 + 103 + 104 + 105 + 106 + 107 + 108 + 109 + 110 + 111 + 112 + 113 + 114 + 115 + 116 + 117 + 118 + 119 + 120 + 121 + 122 + 123 + 124 + 125 + 126 + 127 + 128 + 129 + TO FIELD + END-ADD. + IF FIELD NOT = 8385.2 + MOVE FIELD TO FIELD-DISP + DISPLAY 'ADD with wrong result: ' FIELD-DISP + END-DISPLAY + END-IF. + COMPUTE FIELD = (0.2 + + 2 + + 3 + + 4 + + 5 + + 6 + + 7 + + 8 + + 9 + + 10 + + 11 + + 12 + + 13 + + 14 + + 15 + + 16 + + 17 + + 18 + + 19 + + 20 + + 21 + + 22 + + 23 + + 24 + + 25 + + 26 + + 27 + + 28 + + 29 + + 30 + + 31 + + 32 + + 33 + + 34 + + 35 + + 36 + + 37 + + 38 + + 39 + + 40 + + 41 + + 42 + + 43 + + 44 + + 45 + + 46 + + 47 + + 48 + + 49 + + 50 + + 51 + + 52 + + 53 + + 54 + + 55 + + 56 + + 57 + + 58 + - 59 + - 60 + - 61 + - 62 + - 63 + - 64 + - 65 + - 66 + - 67 + - 68 + - 69 + - 70 + - 71 + - 72 + - 73 + - 74 + - 75 + - 76 + - 77 + - 78 + - 79 + - 80 + - 81 + - 82 + - 83 + - 84 + - 85 + - 86 + - 87 + - 88 + - 89 + - 90 + - 91 + - 92 + - 93 + - 94 + - 95 + - 96 + - 97 + - 98 + - 99 + - 100 + - 101 + - 102 + - 103 + - 104 + - 105 + - 106 + - 107 + - 108 + - 109 + - 110 + - 111 + - 112 + - 113 + - 114 + - 115 + - 116 + - 117 + - 118 + - 119 + - 120 + - 121 + - 122 + - 123 + - 124 + - 125 + - 126 + - 127) + * 12800000000 + / 12900000000 + END-COMPUTE. + IF FIELD NOT = -4670.31 + MOVE FIELD TO FIELD-DISP + DISPLAY 'COMPUTE with wrong result: ' FIELD-DISP + END-DISPLAY + END-IF. + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Numeric_operations__8_.cob b/gcc/testsuite/cobol.dg/group2/Numeric_operations__8_.cob new file mode 100644 index 0000000..68d5f9b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric_operations__8_.cob @@ -0,0 +1,37 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 COMPUTE-DATA. + 2 COMPUTE-8 PICTURE 999 VALUE ZERO. + PROCEDURE DIVISION. + COMPUTE COMPUTE-8 = (((24.0 + 1) * (60 - 10)) / 125) ** 2 + IF COMPUTE-8 NOT = 100 + DISPLAY 'COMPUTE with wrong result: ' COMPUTE-8 + END-DISPLAY + END-IF + COMPUTE COMPUTE-8 = 55 / (1 - 2 + 1) + NOT ON SIZE ERROR + DISPLAY 'SIZE ERROR not set from divide by zero!' + END-DISPLAY + END-COMPUTE + COMPUTE COMPUTE-8 = 0 ** 1 + IF COMPUTE-8 NOT = 0 + DISPLAY '0 ** 1 <> 0: ' COMPUTE-8 + END-DISPLAY + END-IF + COMPUTE COMPUTE-8 = 55 ** 0 + IF COMPUTE-8 NOT = 1 + DISPLAY '55 ** 0 <> 1: ' COMPUTE-8 + END-DISPLAY + END-IF + COMPUTE COMPUTE-8 = 1 ** 55 + IF COMPUTE-8 NOT = 1 + DISPLAY '11 ** 55 <> 1: ' COMPUTE-8 + END-DISPLAY + END-IF + + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/OCCURS_clause_with_1_entry.cob b/gcc/testsuite/cobol.dg/group2/OCCURS_clause_with_1_entry.cob new file mode 100644 index 0000000..f244407 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/OCCURS_clause_with_1_entry.cob @@ -0,0 +1,40 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 D1. + 03 FILLER OCCURS 1. + 05 D1-ENTRY PIC X(03) value '123'. + 01 D2. + 03 D2-ENTRY PIC X(03) value 'ABC' OCCURS 1. + 01 D1TOR. + 03 FILLER PIC X(03) value '456'. + 01 D1-R REDEFINES D1TOR. + 03 FILLER OCCURS 1. + 05 D1-R-ENTRY PIC X(03). + 01 D2TOR. + 03 FILLER PIC X(03) value 'DEF'. + 01 D2-R REDEFINES D2TOR. + 03 D2-R-ENTRY PIC X(03) OCCURS 1. + + PROCEDURE DIVISION. + IF D1-ENTRY (1) NOT = "123" + DISPLAY D1-ENTRY (1) + END-DISPLAY + END-IF. + IF D2-ENTRY (1) NOT = "ABC" + DISPLAY D2-ENTRY (1) + END-DISPLAY + END-IF. + IF D1-R-ENTRY (1) NOT = "456" + DISPLAY D1-R-ENTRY (1) + END-DISPLAY + END-IF. + IF D2-R-ENTRY (1) NOT = "DEF" + DISPLAY D2-R-ENTRY (1) + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.cob b/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.cob new file mode 100644 index 0000000..ff047bf --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.cob @@ -0,0 +1,40 @@ + *> { dg-do run } + *> { dg-output-file "group2/OSVS_Arithmetic_Test__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAL PIC S9(7)V99 COMP-3 VALUE 20500. + 01 DIV1 PIC S9(7)V99 COMP-3 VALUE 0.9. + 01 DIV2 PIC S9(7)V99 COMP-3 VALUE 33.45. + 01 DIV3 PIC S9(7)V99 COMP-3 VALUE 9. + 01 MUL1 PIC S9(7)V99 COMP-3 VALUE 10. + 01 MUL2 PIC S9(7)V99 COMP-3 VALUE 5. + 01 MUL3 PIC S9(7)V99 COMP-3 VALUE 2. + 01 RES PIC S9(7)V99 COMP-3. + PROCEDURE DIVISION. + COMPUTE RES = VAL / DIV1 / DIV2. + DISPLAY 'RES = ' RES. + COMPUTE RES ROUNDED = VAL / DIV1 / DIV2. + DISPLAY 'RES ROUNDED = ' RES. + COMPUTE RES = VAL * MUL1 / DIV3 / DIV2. + DISPLAY 'RES MULT1 = ' RES. + COMPUTE RES = VAL * MUL2 * MUL3 / DIV3 / DIV2. + DISPLAY 'RES MULT2 = ' RES. + COMPUTE RES = VAL / DIV1. + DISPLAY 'RES 1 = ' RES. + COMPUTE RES = RES / DIV2. + DISPLAY 'RES F = ' RES. + COMPUTE RES = + VAL / DIV1 / DIV2. + DISPLAY 'RES NOT ROUNDED = ' RES. + COMPUTE RES ROUNDED MODE NEAREST-AWAY-FROM-ZERO = + VAL / DIV1 / DIV2. + DISPLAY 'RES ROUNDED NEAREST-AWAY = ' RES. + COMPUTE RES ROUNDED MODE AWAY-FROM-ZERO = + VAL / DIV1 / DIV2. + DISPLAY 'RES ROUNDED AWAY = ' RES. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.out b/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.out new file mode 100644 index 0000000..d0816cd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.out @@ -0,0 +1,10 @@ +RES = +0000680.95 +RES ROUNDED = +0000680.95 +RES MULT1 = +0000680.95 +RES MULT2 = +0000680.95 +RES 1 = +0022777.77 +RES F = +0000680.94 +RES NOT ROUNDED = +0000680.95 +RES ROUNDED NEAREST-AWAY = +0000680.95 +RES ROUNDED AWAY = +0000680.96 + 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/PERFORM_..._CONTINUE.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_..._CONTINUE.cob new file mode 100644 index 0000000..5f39fc5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_..._CONTINUE.cob @@ -0,0 +1,9 @@ + *> { dg-do compile } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + PERFORM 2 TIMES + CONTINUE + END-PERFORM. + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_inline__1_.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_inline__1_.cob new file mode 100644 index 0000000..7f6f3aa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_inline__1_.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INDVAL PIC 9(4). + PROCEDURE DIVISION. + PERFORM VARYING INDVAL FROM 1 + BY 1 UNTIL INDVAL > 2 + CONTINUE + END-PERFORM + IF INDVAL NOT = 3 + DISPLAY INDVAL NO ADVANCING + END-DISPLAY + END-IF + STOP RUN + . + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_inline__2_.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_inline__2_.cob new file mode 100644 index 0000000..e3e0458 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_inline__2_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INDVAL PIC 9(4). + PROCEDURE DIVISION. + PERFORM VARYING INDVAL FROM 1 + BY 1 UNTIL INDVAL > 2 + CONTINUE + END-PERFORM + IF INDVAL NOT = 3 + DISPLAY INDVAL NO ADVANCING + END-DISPLAY + END-IF + . + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_type_OSVS.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_type_OSVS.cob new file mode 100644 index 0000000..e64d679 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_type_OSVS.cob @@ -0,0 +1,28 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 MYOCC PIC 9(8) COMP VALUE 0. + PROCEDURE DIVISION. + ASTART SECTION. + A01. + PERFORM BTEST. + IF MYOCC NOT = 2 + DISPLAY MYOCC + END-DISPLAY + END-IF. + STOP RUN. + BTEST SECTION. + B01. + PERFORM B02 VARYING MYOCC FROM 1 BY 1 + UNTIL MYOCC > 5. + GO TO B99. + B02. + IF MYOCC > 1 + GO TO B99 + END-IF. + B99. + EXIT. + diff --git a/gcc/testsuite/cobol.dg/group2/PIC_ZZZ-__ZZZ_.cob b/gcc/testsuite/cobol.dg/group2/PIC_ZZZ-__ZZZ_.cob new file mode 100644 index 0000000..a8ad589 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PIC_ZZZ-__ZZZ_.cob @@ -0,0 +1,44 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-ZZZN PIC ZZZ-. + 01 XZN-RED REDEFINES X-ZZZN PIC X(4). + 01 X-ZZZP PIC ZZZ+. + 01 XZP-RED REDEFINES X-ZZZP PIC X(4). + PROCEDURE DIVISION. + MOVE -1 TO X-ZZZN. + IF XZN-RED NOT = " 1-" + DISPLAY "(" X-ZZZN ")" + END-DISPLAY + END-IF. + MOVE 0 TO X-ZZZN. + IF XZN-RED NOT = " " + DISPLAY "(" X-ZZZN ")" + END-DISPLAY + END-IF. + MOVE +1 TO X-ZZZN. + IF XZN-RED NOT = " 1 " + DISPLAY "(" X-ZZZN ")" + END-DISPLAY + END-IF. + + MOVE -1 TO X-ZZZP. + IF XZP-RED NOT = " 1-" + DISPLAY "(" X-ZZZP ")" + END-DISPLAY + END-IF. + MOVE 0 TO X-ZZZP. + IF XZP-RED NOT = " " + DISPLAY "(" X-ZZZP ")" + END-DISPLAY + END-IF. + MOVE +1 TO X-ZZZP. + IF XZP-RED NOT = " 1+" + DISPLAY "(" X-ZZZP ")" + END-DISPLAY + END-IF. + STOP RUN. + 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/Quick_check_of_PIC_XX_COMP-5.cob b/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.cob new file mode 100644 index 0000000..5e73de6 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/Quick_check_of_PIC_XX_COMP-5.out" } + identification division. + program-id. wrapper. + data division. + working-storage section. + 01 memx pic x(2) comp-5. + 77 ptr pointer. + procedure division. + Initialize ptr.display "LENGTH OF X(2) is " length of memx + move 12345 to memx + display memx + IF ptr <> NULL then display 'bad pointer'. + goback. + end program wrapper. + diff --git a/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.out b/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.out new file mode 100644 index 0000000..a79f3be --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.out @@ -0,0 +1,3 @@ +LENGTH OF X(2) is 2 +12345 + diff --git a/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.cob b/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.cob new file mode 100644 index 0000000..70564e4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.cob @@ -0,0 +1,11 @@ + *> { dg-do run } + *> { dg-output-file "group2/Quote_marks_in_comment_paragraphs.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATE-written. hello'". + *> Written is intentionally lowercase. + *> extra " to fix syntax highlighting + PROCEDURE DIVISION. + DISPLAY "Hello, world!". + diff --git a/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.out b/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.out new file mode 100644 index 0000000..297edb3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.out @@ -0,0 +1,2 @@ +Hello, world! + diff --git a/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.cob b/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.cob new file mode 100644 index 0000000..2367ad5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + *> { dg-output-file "group2/REDEFINES_values_on_FILLER_and_INITIALIZE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TSRDF. + 05 WS-ASK-ID-DATE PIC X(10). + 05 WS-ASK-ID-DATE-R REDEFINES WS-ASK-ID-DATE. + 10 WS-ASK-ID-DATE-YYYY PIC 9(4) VALUE 2017. + 10 FILLER PIC X VALUE '-'. + 10 WS-ASK-ID-DATE-MM PIC 9(2). + 10 FILLER PIC X VALUE '-'. + 10 WS-ASK-ID-DATE-DD PIC 9(2). + PROCEDURE DIVISION. + MOVE ALL '*' TO WS-ASK-ID-DATE + MOVE 2015 TO WS-ASK-ID-DATE-YYYY + MOVE 08 TO WS-ASK-ID-DATE-MM + MOVE 21 TO WS-ASK-ID-DATE-DD + DISPLAY "The date is " WS-ASK-ID-DATE " Compiled". + + INITIALIZE WS-ASK-ID-DATE-R. + MOVE 08 TO WS-ASK-ID-DATE-MM + MOVE 21 TO WS-ASK-ID-DATE-DD + DISPLAY "The date is " WS-ASK-ID-DATE " INITIALIZE". + + INITIALIZE WS-ASK-ID-DATE-R WITH FILLER. + MOVE 08 TO WS-ASK-ID-DATE-MM + MOVE 21 TO WS-ASK-ID-DATE-DD + DISPLAY "The date is " WS-ASK-ID-DATE " WITH FILLER". + + INITIALIZE WS-ASK-ID-DATE-R WITH FILLER ALL TO VALUE. + MOVE 08 TO WS-ASK-ID-DATE-MM + MOVE 21 TO WS-ASK-ID-DATE-DD + DISPLAY "The date is " WS-ASK-ID-DATE " ALL TO VALUE". + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.out b/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.out new file mode 100644 index 0000000..6a24172 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.out @@ -0,0 +1,5 @@ +The date is 2015*08*21 Compiled +The date is 0000*08*21 INITIALIZE +The date is 0000 08 21 WITH FILLER +The date is 2017-08-21 ALL TO VALUE + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_AWAY-FROM-ZERO.cob b/gcc/testsuite/cobol.dg/group2/ROUNDED_AWAY-FROM-ZERO.cob new file mode 100644 index 0000000..dc7ddad --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_AWAY-FROM-ZERO.cob @@ -0,0 +1,55 @@ + *> { dg-do run } + *> { dg-output-file "group2/ROUNDED_AWAY-FROM-ZERO.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 M PIC S9. + 01 N PIC S9. + 01 O PIC S9. + 01 P PIC S9. + 01 Q PIC S9. + 01 R PIC S9. + 01 S PIC S9. + 01 T PIC S9. + 01 U PIC S9. + 01 V PIC S9. + PROCEDURE DIVISION. + COMPUTE M ROUNDED MODE AWAY-FROM-ZERO + = 2.49 + END-COMPUTE + COMPUTE N ROUNDED MODE AWAY-FROM-ZERO + = -2.49 + END-COMPUTE + COMPUTE O ROUNDED MODE AWAY-FROM-ZERO + = 2.50 + END-COMPUTE + COMPUTE P ROUNDED MODE AWAY-FROM-ZERO + = -2.50 + END-COMPUTE + COMPUTE Q ROUNDED MODE AWAY-FROM-ZERO + = 3.49 + END-COMPUTE + COMPUTE R ROUNDED MODE AWAY-FROM-ZERO + = -3.49 + END-COMPUTE + COMPUTE S ROUNDED MODE AWAY-FROM-ZERO + = 3.50 + END-COMPUTE + COMPUTE T ROUNDED MODE AWAY-FROM-ZERO + = -3.50 + END-COMPUTE + COMPUTE U ROUNDED MODE AWAY-FROM-ZERO + = 3.510 + END-COMPUTE + COMPUTE V ROUNDED MODE AWAY-FROM-ZERO + = -3.510 + END-COMPUTE + DISPLAY M " " N " " O " " P " " Q " " R " " S " " T + " " U " " V + NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_AWAY-FROM-ZERO.out b/gcc/testsuite/cobol.dg/group2/ROUNDED_AWAY-FROM-ZERO.out new file mode 100644 index 0000000..67784de --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_AWAY-FROM-ZERO.out @@ -0,0 +1 @@ ++3 -3 +3 -3 +4 -4 +4 -4 +4 -4 diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-AWAY-FROM-ZERO.cob b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-AWAY-FROM-ZERO.cob new file mode 100644 index 0000000..8a1e0ca --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-AWAY-FROM-ZERO.cob @@ -0,0 +1,55 @@ + *> { dg-do run } + *> { dg-output-file "group2/ROUNDED_NEAREST-AWAY-FROM-ZERO.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 M PIC S9. + 01 N PIC S9. + 01 O PIC S9. + 01 P PIC S9. + 01 Q PIC S9. + 01 R PIC S9. + 01 S PIC S9. + 01 T PIC S9. + 01 U PIC S9. + 01 V PIC S9. + PROCEDURE DIVISION. + COMPUTE M ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = 2.49 + END-COMPUTE + COMPUTE N ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = -2.49 + END-COMPUTE + COMPUTE O ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = 2.50 + END-COMPUTE + COMPUTE P ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = -2.50 + END-COMPUTE + COMPUTE Q ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = 3.49 + END-COMPUTE + COMPUTE R ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = -3.49 + END-COMPUTE + COMPUTE S ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = 3.50 + END-COMPUTE + COMPUTE T ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = -3.50 + END-COMPUTE + COMPUTE U ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = 3.510 + END-COMPUTE + COMPUTE V ROUNDED MODE NEAREST-AWAY-FROM-ZERO + = -3.510 + END-COMPUTE + DISPLAY M " " N " " O " " P " " Q " " R " " S " " T + " " U " " V + NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-AWAY-FROM-ZERO.out b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-AWAY-FROM-ZERO.out new file mode 100644 index 0000000..18afa23 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-AWAY-FROM-ZERO.out @@ -0,0 +1 @@ ++2 -2 +3 -3 +3 -3 +4 -4 +4 -4 diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-EVEN.cob b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-EVEN.cob new file mode 100644 index 0000000..77529d2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-EVEN.cob @@ -0,0 +1,55 @@ + *> { dg-do run } + *> { dg-output-file "group2/ROUNDED_NEAREST-EVEN.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 M PIC S9. + 01 N PIC S9. + 01 O PIC S9. + 01 P PIC S9. + 01 Q PIC S9. + 01 R PIC S9. + 01 S PIC S9. + 01 T PIC S9. + 01 U PIC S9. + 01 V PIC S9. + PROCEDURE DIVISION. + COMPUTE M ROUNDED MODE NEAREST-EVEN + = 2.49 + END-COMPUTE + COMPUTE N ROUNDED MODE NEAREST-EVEN + = -2.49 + END-COMPUTE + COMPUTE O ROUNDED MODE NEAREST-EVEN + = 2.50 + END-COMPUTE + COMPUTE P ROUNDED MODE NEAREST-EVEN + = -2.50 + END-COMPUTE + COMPUTE Q ROUNDED MODE NEAREST-EVEN + = 3.49 + END-COMPUTE + COMPUTE R ROUNDED MODE NEAREST-EVEN + = -3.49 + END-COMPUTE + COMPUTE S ROUNDED MODE NEAREST-EVEN + = 3.50 + END-COMPUTE + COMPUTE T ROUNDED MODE NEAREST-EVEN + = -3.50 + END-COMPUTE + COMPUTE U ROUNDED MODE NEAREST-EVEN + = 3.510 + END-COMPUTE + COMPUTE V ROUNDED MODE NEAREST-EVEN + = -3.510 + END-COMPUTE + DISPLAY M " " N " " O " " P " " Q " " R " " S " " T + " " U " " V + NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-EVEN.out b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-EVEN.out new file mode 100644 index 0000000..59e459b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-EVEN.out @@ -0,0 +1 @@ ++2 -2 +2 -2 +3 -3 +4 -4 +4 -4 diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-TOWARD-ZERO.cob b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-TOWARD-ZERO.cob new file mode 100644 index 0000000..6f3f28d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-TOWARD-ZERO.cob @@ -0,0 +1,55 @@ + *> { dg-do run } + *> { dg-output-file "group2/ROUNDED_NEAREST-TOWARD-ZERO.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 M PIC S9. + 01 N PIC S9. + 01 O PIC S9. + 01 P PIC S9. + 01 Q PIC S9. + 01 R PIC S9. + 01 S PIC S9. + 01 T PIC S9. + 01 U PIC S9. + 01 V PIC S9. + PROCEDURE DIVISION. + COMPUTE M ROUNDED MODE NEAREST-TOWARD-ZERO + = 2.49 + END-COMPUTE + COMPUTE N ROUNDED MODE NEAREST-TOWARD-ZERO + = -2.49 + END-COMPUTE + COMPUTE O ROUNDED MODE NEAREST-TOWARD-ZERO + = 2.50 + END-COMPUTE + COMPUTE P ROUNDED MODE NEAREST-TOWARD-ZERO + = -2.50 + END-COMPUTE + COMPUTE Q ROUNDED MODE NEAREST-TOWARD-ZERO + = 3.49 + END-COMPUTE + COMPUTE R ROUNDED MODE NEAREST-TOWARD-ZERO + = -3.49 + END-COMPUTE + COMPUTE S ROUNDED MODE NEAREST-TOWARD-ZERO + = 3.50 + END-COMPUTE + COMPUTE T ROUNDED MODE NEAREST-TOWARD-ZERO + = -3.50 + END-COMPUTE + COMPUTE U ROUNDED MODE NEAREST-TOWARD-ZERO + = 3.510 + END-COMPUTE + COMPUTE V ROUNDED MODE NEAREST-TOWARD-ZERO + = -3.510 + END-COMPUTE + DISPLAY M " " N " " O " " P " " Q " " R " " S " " T + " " U " " V + NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-TOWARD-ZERO.out b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-TOWARD-ZERO.out new file mode 100644 index 0000000..05ce11c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_NEAREST-TOWARD-ZERO.out @@ -0,0 +1 @@ ++2 -2 +2 -2 +3 -3 +3 -3 +4 -4 diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-GREATER.cob b/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-GREATER.cob new file mode 100644 index 0000000..c2b3cf8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-GREATER.cob @@ -0,0 +1,55 @@ + *> { dg-do run } + *> { dg-output-file "group2/ROUNDED_TOWARD-GREATER.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 M PIC S9. + 01 N PIC S9. + 01 O PIC S9. + 01 P PIC S9. + 01 Q PIC S9. + 01 R PIC S9. + 01 S PIC S9. + 01 T PIC S9. + 01 U PIC S9. + 01 V PIC S9. + PROCEDURE DIVISION. + COMPUTE M ROUNDED MODE TOWARD-GREATER + = 2.49 + END-COMPUTE + COMPUTE N ROUNDED MODE TOWARD-GREATER + = -2.49 + END-COMPUTE + COMPUTE O ROUNDED MODE TOWARD-GREATER + = 2.50 + END-COMPUTE + COMPUTE P ROUNDED MODE TOWARD-GREATER + = -2.50 + END-COMPUTE + COMPUTE Q ROUNDED MODE TOWARD-GREATER + = 3.49 + END-COMPUTE + COMPUTE R ROUNDED MODE TOWARD-GREATER + = -3.49 + END-COMPUTE + COMPUTE S ROUNDED MODE TOWARD-GREATER + = 3.50 + END-COMPUTE + COMPUTE T ROUNDED MODE TOWARD-GREATER + = -3.50 + END-COMPUTE + COMPUTE U ROUNDED MODE TOWARD-GREATER + = 3.510 + END-COMPUTE + COMPUTE V ROUNDED MODE TOWARD-GREATER + = -3.510 + END-COMPUTE + DISPLAY M " " N " " O " " P " " Q " " R " " S " " T + " " U " " V + NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-GREATER.out b/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-GREATER.out new file mode 100644 index 0000000..54ab7f3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-GREATER.out @@ -0,0 +1 @@ ++3 -2 +3 -2 +4 -3 +4 -3 +4 -3 diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-LESSER.cob b/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-LESSER.cob new file mode 100644 index 0000000..37c1749 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-LESSER.cob @@ -0,0 +1,55 @@ + *> { dg-do run } + *> { dg-output-file "group2/ROUNDED_TOWARD-LESSER.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 M PIC S9. + 01 N PIC S9. + 01 O PIC S9. + 01 P PIC S9. + 01 Q PIC S9. + 01 R PIC S9. + 01 S PIC S9. + 01 T PIC S9. + 01 U PIC S9. + 01 V PIC S9. + PROCEDURE DIVISION. + COMPUTE M ROUNDED MODE TOWARD-LESSER + = 2.49 + END-COMPUTE + COMPUTE N ROUNDED MODE TOWARD-LESSER + = -2.49 + END-COMPUTE + COMPUTE O ROUNDED MODE TOWARD-LESSER + = 2.50 + END-COMPUTE + COMPUTE P ROUNDED MODE TOWARD-LESSER + = -2.50 + END-COMPUTE + COMPUTE Q ROUNDED MODE TOWARD-LESSER + = 3.49 + END-COMPUTE + COMPUTE R ROUNDED MODE TOWARD-LESSER + = -3.49 + END-COMPUTE + COMPUTE S ROUNDED MODE TOWARD-LESSER + = 3.50 + END-COMPUTE + COMPUTE T ROUNDED MODE TOWARD-LESSER + = -3.50 + END-COMPUTE + COMPUTE U ROUNDED MODE TOWARD-LESSER + = 3.510 + END-COMPUTE + COMPUTE V ROUNDED MODE TOWARD-LESSER + = -3.510 + END-COMPUTE + DISPLAY M " " N " " O " " P " " Q " " R " " S " " T + " " U " " V + NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-LESSER.out b/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-LESSER.out new file mode 100644 index 0000000..2cf5645 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_TOWARD-LESSER.out @@ -0,0 +1 @@ ++2 -3 +2 -3 +3 -4 +3 -4 +3 -4 diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_TRUNCATION.cob b/gcc/testsuite/cobol.dg/group2/ROUNDED_TRUNCATION.cob new file mode 100644 index 0000000..9f46dc7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_TRUNCATION.cob @@ -0,0 +1,55 @@ + *> { dg-do run } + *> { dg-output-file "group2/ROUNDED_TRUNCATION.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 M PIC S9. + 01 N PIC S9. + 01 O PIC S9. + 01 P PIC S9. + 01 Q PIC S9. + 01 R PIC S9. + 01 S PIC S9. + 01 T PIC S9. + 01 U PIC S9. + 01 V PIC S9. + PROCEDURE DIVISION. + COMPUTE M ROUNDED MODE TRUNCATION + = 2.49 + END-COMPUTE + COMPUTE N ROUNDED MODE TRUNCATION + = -2.49 + END-COMPUTE + COMPUTE O ROUNDED MODE TRUNCATION + = 2.50 + END-COMPUTE + COMPUTE P ROUNDED MODE TRUNCATION + = -2.50 + END-COMPUTE + COMPUTE Q ROUNDED MODE TRUNCATION + = 3.49 + END-COMPUTE + COMPUTE R ROUNDED MODE TRUNCATION + = -3.49 + END-COMPUTE + COMPUTE S ROUNDED MODE TRUNCATION + = 3.50 + END-COMPUTE + COMPUTE T ROUNDED MODE TRUNCATION + = -3.50 + END-COMPUTE + COMPUTE U ROUNDED MODE TRUNCATION + = 3.510 + END-COMPUTE + COMPUTE V ROUNDED MODE TRUNCATION + = -3.510 + END-COMPUTE + DISPLAY M " " N " " O " " P " " Q " " R " " S " " T + " " U " " V + NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_TRUNCATION.out b/gcc/testsuite/cobol.dg/group2/ROUNDED_TRUNCATION.out new file mode 100644 index 0000000..c178d5a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_TRUNCATION.out @@ -0,0 +1 @@ ++2 -2 +2 -2 +3 -3 +3 -3 +3 -3 diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_Floating-Point_from_COMPUTE.cob b/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_Floating-Point_from_COMPUTE.cob new file mode 100644 index 0000000..4bc8b28 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_Floating-Point_from_COMPUTE.cob @@ -0,0 +1,427 @@ + *> { dg-do run } + *> { dg-output-file "group2/ROUNDING_omnibus_Floating-Point_from_COMPUTE.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR1 COMP-2. + 01 VAR2 PICTURE S999. + 01 SHOULD_BE PICTURE S999. + 01 RMODE PICTURE X(64). + 01 EMPTY PIC X VALUE " ". + 01 FLAG PIC X. + PROCEDURE DIVISION. + + DISPLAY "ROUNDING from COMP-2 after COMPUTE." + + PERFORM truncation-e. + PERFORM truncation-m. + PERFORM nearest-away-from-zero-e. + PERFORM nearest-away-from-zero-m. + PERFORM away-from-zero-e. + PERFORM away-from-zero-m. + PERFORM nearest-even-e. + PERFORM nearest-even-m. + PERFORM nearest-toward-zero-e. + PERFORM nearest-toward-zero-m. + PERFORM toward-greater-e. + PERFORM toward-greater-m. + PERFORM toward-lesser-e. + PERFORM toward-lesser-m. + PERFORM prohibited-e. + GOBACK. + + truncation-e. + MOVE "TRUNCATION" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + + truncation-m. + MOVE "TRUNCATION" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + + nearest-away-from-zero-e. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + nearest-away-from-zero-m. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + away-from-zero-e. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + away-from-zero-m. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + nearest-even-e. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 110.0 TO VAR1 + MOVE 110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 110.1 TO VAR1 + MOVE 110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 110.5 TO VAR1 + MOVE 110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 110.9 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + MOVE "NEAREST-EVEN" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + + nearest-even-m. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -110.0 TO VAR1 + MOVE -110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -110.1 TO VAR1 + MOVE -110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -110.5 TO VAR1 + MOVE -110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -110.9 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + MOVE "NEAREST-EVEN" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + + nearest-toward-zero-e. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + nearest-toward-zero-m. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + toward-greater-e. + MOVE "TOWARD-GREATER" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + + toward-greater-m. + MOVE "TOWARD-GREATER" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + + toward-lesser-e. + MOVE "TOWARD-LESSER" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + + toward-lesser-m. + MOVE "TOWARD-LESSER" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + + prohibited-e. + MOVE "PROHIBITED - fits" TO RMODE + SET LAST EXCEPTION TO OFF + MOVE 123 TO VAR2 + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE PROHIBITED = VAR1 + PERFORM SHOW_RESULTS + DISPLAY " EXCEPTION STATUS IS " + """" FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """". + + MOVE "PROHIBITED - doesn't fit; no ON ERROR phrase" TO RMODE + SET LAST EXCEPTION TO OFF + MOVE 123 TO VAR2 + MOVE 111.5 TO VAR1 + MOVE 123 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE PROHIBITED = VAR1 + PERFORM SHOW_RESULTS + DISPLAY " EXCEPTION STATUS IS " + """" FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """". + + MOVE "PROHIBITED - doesn't fit; ON ERROR phrase" TO RMODE + SET LAST EXCEPTION TO OFF + MOVE SPACE TO FLAG + MOVE 123 TO VAR2 + MOVE 111.5 TO VAR1 + MOVE 123 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE PROHIBITED = VAR1 + ON SIZE ERROR MOVE 'X' TO FLAG + END-COMPUTE + PERFORM SHOW_RESULTS + IF FLAG EQUAL 'X' + DISPLAY " COMPUTE had an ON SIZE error" + END-IF. + DISPLAY " EXCEPTION STATUS IS " + """" FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """". + + SHOW_RESULTS. + DISPLAY "Rounding mode " FUNCTION TRIM(RMODE) + " " VAR1 " becomes " VAR2 + WITH NO ADVANCING + END-DISPLAY + IF VAR2 EQUALS SHOULD_BE + DISPLAY FUNCTION TRIM(EMPTY) + ELSE + DISPLAY " but it should be " SHOULD_BE + END-IF. + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_Floating-Point_from_COMPUTE.out b/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_Floating-Point_from_COMPUTE.out new file mode 100644 index 0000000..4ff4e29 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_Floating-Point_from_COMPUTE.out @@ -0,0 +1,71 @@ +ROUNDING from COMP-2 after COMPUTE. +Rounding mode TRUNCATION 111 becomes +111 +Rounding mode TRUNCATION 111.099999999999994 becomes +111 +Rounding mode TRUNCATION 111.5 becomes +111 +Rounding mode TRUNCATION 111.900000000000006 becomes +111 +Rounding mode TRUNCATION -111 becomes -111 +Rounding mode TRUNCATION -111.099999999999994 becomes -111 +Rounding mode TRUNCATION -111.5 becomes -111 +Rounding mode TRUNCATION -111.900000000000006 becomes -111 +Rounding mode NEAREST-AWAY-FROM-ZERO 111 becomes +111 +Rounding mode NEAREST-AWAY-FROM-ZERO 111.099999999999994 becomes +111 +Rounding mode NEAREST-AWAY-FROM-ZERO 111.5 becomes +112 +Rounding mode NEAREST-AWAY-FROM-ZERO 111.900000000000006 becomes +112 +Rounding mode NEAREST-AWAY-FROM-ZERO -111 becomes -111 +Rounding mode NEAREST-AWAY-FROM-ZERO -111.099999999999994 becomes -111 +Rounding mode NEAREST-AWAY-FROM-ZERO -111.5 becomes -112 +Rounding mode NEAREST-AWAY-FROM-ZERO -111.900000000000006 becomes -112 +Rounding mode AWAY-FROM-ZERO 111 becomes +111 +Rounding mode AWAY-FROM-ZERO 111.099999999999994 becomes +112 +Rounding mode AWAY-FROM-ZERO 111.5 becomes +112 +Rounding mode AWAY-FROM-ZERO 111.900000000000006 becomes +112 +Rounding mode AWAY-FROM-ZERO -111 becomes -111 +Rounding mode AWAY-FROM-ZERO -111.099999999999994 becomes -112 +Rounding mode AWAY-FROM-ZERO -111.5 becomes -112 +Rounding mode AWAY-FROM-ZERO -111.900000000000006 becomes -112 +Rounding mode NEAREST-EVEN 110 becomes +110 +Rounding mode NEAREST-EVEN 110.099999999999994 becomes +110 +Rounding mode NEAREST-EVEN 110.5 becomes +110 +Rounding mode NEAREST-EVEN 111 becomes +111 +Rounding mode NEAREST-EVEN 111.099999999999994 becomes +111 +Rounding mode NEAREST-EVEN 111.5 becomes +112 +Rounding mode NEAREST-EVEN 111.900000000000006 becomes +112 +Rounding mode NEAREST-EVEN -110 becomes -110 +Rounding mode NEAREST-EVEN -110.099999999999994 becomes -110 +Rounding mode NEAREST-EVEN -110.5 becomes -110 +Rounding mode NEAREST-EVEN -111 becomes -111 +Rounding mode NEAREST-EVEN -111.099999999999994 becomes -111 +Rounding mode NEAREST-EVEN -111.5 becomes -112 +Rounding mode NEAREST-EVEN -111.900000000000006 becomes -112 +Rounding mode NEAREST-TOWARD-ZERO 111 becomes +111 +Rounding mode NEAREST-TOWARD-ZERO 111.099999999999994 becomes +111 +Rounding mode NEAREST-TOWARD-ZERO 111.5 becomes +111 +Rounding mode NEAREST-TOWARD-ZERO 111.900000000000006 becomes +112 +Rounding mode NEAREST-TOWARD-ZERO -111 becomes -111 +Rounding mode NEAREST-TOWARD-ZERO -111.099999999999994 becomes -111 +Rounding mode NEAREST-TOWARD-ZERO -111.5 becomes -111 +Rounding mode NEAREST-TOWARD-ZERO -111.900000000000006 becomes -112 +Rounding mode TOWARD-GREATER 111 becomes +111 +Rounding mode TOWARD-GREATER 111.099999999999994 becomes +112 +Rounding mode TOWARD-GREATER 111.5 becomes +112 +Rounding mode TOWARD-GREATER 111.900000000000006 becomes +112 +Rounding mode TOWARD-GREATER -111 becomes -111 +Rounding mode TOWARD-GREATER -111.099999999999994 becomes -111 +Rounding mode TOWARD-GREATER -111.5 becomes -111 +Rounding mode TOWARD-GREATER -111.900000000000006 becomes -111 +Rounding mode TOWARD-LESSER 111 becomes +111 +Rounding mode TOWARD-LESSER 111.099999999999994 becomes +111 +Rounding mode TOWARD-LESSER 111.5 becomes +111 +Rounding mode TOWARD-LESSER 111.900000000000006 becomes +111 +Rounding mode TOWARD-LESSER -111 becomes -111 +Rounding mode TOWARD-LESSER -111.099999999999994 becomes -112 +Rounding mode TOWARD-LESSER -111.5 becomes -112 +Rounding mode TOWARD-LESSER -111.900000000000006 becomes -112 +Rounding mode PROHIBITED - fits 111 becomes +111 + EXCEPTION STATUS IS "" +Rounding mode PROHIBITED - doesn't fit; no ON ERROR phrase 111.5 becomes +123 + EXCEPTION STATUS IS "EC-SIZE-TRUNCATION" +Rounding mode PROHIBITED - doesn't fit; ON ERROR phrase 111.5 becomes +123 + COMPUTE had an ON SIZE error + EXCEPTION STATUS IS "EC-SIZE-TRUNCATION" + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_NumericDisplay_from_COMPUTE.cob b/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_NumericDisplay_from_COMPUTE.cob new file mode 100644 index 0000000..3138233 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_NumericDisplay_from_COMPUTE.cob @@ -0,0 +1,428 @@ + *> { dg-do run } + *> { dg-output-file "group2/ROUNDING_omnibus_NumericDisplay_from_COMPUTE.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR1 PICTURE S999V9. + 01 VAR2 PICTURE S999. + 01 SHOULD_BE PICTURE S999. + 01 RMODE PICTURE X(64). + 01 EMPTY PIC X VALUE " ". + 01 FLAG PIC X. + PROCEDURE DIVISION. + + DISPLAY "ROUNDING from NumericDisplay after COMPUTE." + + PERFORM truncation-e. + PERFORM truncation-m. + PERFORM nearest-away-from-zero-e. + PERFORM nearest-away-from-zero-m. + PERFORM away-from-zero-e. + PERFORM away-from-zero-m. + PERFORM nearest-even-e. + PERFORM nearest-even-m. + PERFORM nearest-toward-zero-e. + PERFORM nearest-toward-zero-m. + PERFORM toward-greater-e. + PERFORM toward-greater-m. + PERFORM toward-lesser-e. + PERFORM toward-lesser-m. + PERFORM prohibited-e. + GOBACK. + + truncation-e. + MOVE "TRUNCATION" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + + truncation-m. + MOVE "TRUNCATION" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TRUNCATION" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TRUNCATION = VAR1 + PERFORM SHOW_RESULTS. + + nearest-away-from-zero-e. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + nearest-away-from-zero-m. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-AWAY-FROM-ZERO" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + away-from-zero-e. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + away-from-zero-m. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "AWAY-FROM-ZERO" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE AWAY-FROM-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + nearest-even-e. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 110.0 TO VAR1 + MOVE 110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 110.1 TO VAR1 + MOVE 110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 110.5 TO VAR1 + MOVE 110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 110.9 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + MOVE "NEAREST-EVEN" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + + nearest-even-m. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -110.0 TO VAR1 + MOVE -110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -110.1 TO VAR1 + MOVE -110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -110.5 TO VAR1 + MOVE -110 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -110.9 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + MOVE "NEAREST-EVEN" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-EVEN" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-EVEN = VAR1 + PERFORM SHOW_RESULTS. + + nearest-toward-zero-e. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + nearest-toward-zero-m. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + MOVE "NEAREST-TOWARD-ZERO" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE NEAREST-TOWARD-ZERO = VAR1 + PERFORM SHOW_RESULTS. + + toward-greater-e. + MOVE "TOWARD-GREATER" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + + toward-greater-m. + MOVE "TOWARD-GREATER" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-GREATER" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-GREATER = VAR1 + PERFORM SHOW_RESULTS. + + toward-lesser-e. + MOVE "TOWARD-LESSER" TO RMODE + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE 111.1 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE 111.5 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE 111.9 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + + toward-lesser-m. + MOVE "TOWARD-LESSER" TO RMODE + MOVE -111.0 TO VAR1 + MOVE -111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE -111.1 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE -111.5 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + MOVE "TOWARD-LESSER" TO RMODE + MOVE -111.9 TO VAR1 + MOVE -112 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE TOWARD-LESSER = VAR1 + PERFORM SHOW_RESULTS. + + prohibited-e. + MOVE "PROHIBITED - fits" TO RMODE + SET LAST EXCEPTION TO OFF + MOVE 123 TO VAR2 + MOVE 111.0 TO VAR1 + MOVE 111 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE PROHIBITED = VAR1 + PERFORM SHOW_RESULTS + DISPLAY " EXCEPTION STATUS IS " + """" FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """". + + MOVE "PROHIBITED - doesn't fit; no ON ERROR phrase" TO RMODE + SET LAST EXCEPTION TO OFF + MOVE 123 TO VAR2 + MOVE 111.5 TO VAR1 + MOVE 123 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE PROHIBITED = VAR1 + PERFORM SHOW_RESULTS + DISPLAY " EXCEPTION STATUS IS " + """" FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """". + + MOVE "PROHIBITED - doesn't fit; ON ERROR phrase" TO RMODE + SET LAST EXCEPTION TO OFF + MOVE SPACE TO FLAG + MOVE 123 TO VAR2 + MOVE 111.5 TO VAR1 + MOVE 123 TO SHOULD_BE + COMPUTE VAR2 ROUNDED MODE PROHIBITED = VAR1 + ON SIZE ERROR MOVE 'X' TO FLAG + END-COMPUTE + PERFORM SHOW_RESULTS + IF FLAG EQUAL 'X' + DISPLAY " COMPUTE had an ON SIZE error" + END-IF. + DISPLAY " EXCEPTION STATUS IS " + """" FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """". + + SHOW_RESULTS. + DISPLAY "Rounding mode " FUNCTION TRIM(RMODE) + " " VAR1 " becomes " VAR2 + WITH NO ADVANCING + END-DISPLAY + IF VAR2 EQUALS SHOULD_BE + DISPLAY FUNCTION TRIM(EMPTY) + ELSE + DISPLAY " but it should be " SHOULD_BE + END-IF. + + diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_NumericDisplay_from_COMPUTE.out b/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_NumericDisplay_from_COMPUTE.out new file mode 100644 index 0000000..af94786 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ROUNDING_omnibus_NumericDisplay_from_COMPUTE.out @@ -0,0 +1,71 @@ +ROUNDING from NumericDisplay after COMPUTE. +Rounding mode TRUNCATION +111.0 becomes +111 +Rounding mode TRUNCATION +111.1 becomes +111 +Rounding mode TRUNCATION +111.5 becomes +111 +Rounding mode TRUNCATION +111.9 becomes +111 +Rounding mode TRUNCATION -111.0 becomes -111 +Rounding mode TRUNCATION -111.1 becomes -111 +Rounding mode TRUNCATION -111.5 becomes -111 +Rounding mode TRUNCATION -111.9 becomes -111 +Rounding mode NEAREST-AWAY-FROM-ZERO +111.0 becomes +111 +Rounding mode NEAREST-AWAY-FROM-ZERO +111.1 becomes +111 +Rounding mode NEAREST-AWAY-FROM-ZERO +111.5 becomes +112 +Rounding mode NEAREST-AWAY-FROM-ZERO +111.9 becomes +112 +Rounding mode NEAREST-AWAY-FROM-ZERO -111.0 becomes -111 +Rounding mode NEAREST-AWAY-FROM-ZERO -111.1 becomes -111 +Rounding mode NEAREST-AWAY-FROM-ZERO -111.5 becomes -112 +Rounding mode NEAREST-AWAY-FROM-ZERO -111.9 becomes -112 +Rounding mode AWAY-FROM-ZERO +111.0 becomes +111 +Rounding mode AWAY-FROM-ZERO +111.1 becomes +112 +Rounding mode AWAY-FROM-ZERO +111.5 becomes +112 +Rounding mode AWAY-FROM-ZERO +111.9 becomes +112 +Rounding mode AWAY-FROM-ZERO -111.0 becomes -111 +Rounding mode AWAY-FROM-ZERO -111.1 becomes -112 +Rounding mode AWAY-FROM-ZERO -111.5 becomes -112 +Rounding mode AWAY-FROM-ZERO -111.9 becomes -112 +Rounding mode NEAREST-EVEN +110.0 becomes +110 +Rounding mode NEAREST-EVEN +110.1 becomes +110 +Rounding mode NEAREST-EVEN +110.5 becomes +110 +Rounding mode NEAREST-EVEN +111.0 becomes +111 +Rounding mode NEAREST-EVEN +111.1 becomes +111 +Rounding mode NEAREST-EVEN +111.5 becomes +112 +Rounding mode NEAREST-EVEN +111.9 becomes +112 +Rounding mode NEAREST-EVEN -110.0 becomes -110 +Rounding mode NEAREST-EVEN -110.1 becomes -110 +Rounding mode NEAREST-EVEN -110.5 becomes -110 +Rounding mode NEAREST-EVEN -111.0 becomes -111 +Rounding mode NEAREST-EVEN -111.1 becomes -111 +Rounding mode NEAREST-EVEN -111.5 becomes -112 +Rounding mode NEAREST-EVEN -111.9 becomes -112 +Rounding mode NEAREST-TOWARD-ZERO +111.0 becomes +111 +Rounding mode NEAREST-TOWARD-ZERO +111.1 becomes +111 +Rounding mode NEAREST-TOWARD-ZERO +111.5 becomes +111 +Rounding mode NEAREST-TOWARD-ZERO +111.9 becomes +112 +Rounding mode NEAREST-TOWARD-ZERO -111.0 becomes -111 +Rounding mode NEAREST-TOWARD-ZERO -111.1 becomes -111 +Rounding mode NEAREST-TOWARD-ZERO -111.5 becomes -111 +Rounding mode NEAREST-TOWARD-ZERO -111.9 becomes -112 +Rounding mode TOWARD-GREATER +111.0 becomes +111 +Rounding mode TOWARD-GREATER +111.1 becomes +112 +Rounding mode TOWARD-GREATER +111.5 becomes +112 +Rounding mode TOWARD-GREATER +111.9 becomes +112 +Rounding mode TOWARD-GREATER -111.0 becomes -111 +Rounding mode TOWARD-GREATER -111.1 becomes -111 +Rounding mode TOWARD-GREATER -111.5 becomes -111 +Rounding mode TOWARD-GREATER -111.9 becomes -111 +Rounding mode TOWARD-LESSER +111.0 becomes +111 +Rounding mode TOWARD-LESSER +111.1 becomes +111 +Rounding mode TOWARD-LESSER +111.5 becomes +111 +Rounding mode TOWARD-LESSER +111.9 becomes +111 +Rounding mode TOWARD-LESSER -111.0 becomes -111 +Rounding mode TOWARD-LESSER -111.1 becomes -112 +Rounding mode TOWARD-LESSER -111.5 becomes -112 +Rounding mode TOWARD-LESSER -111.9 becomes -112 +Rounding mode PROHIBITED - fits +111.0 becomes +111 + EXCEPTION STATUS IS "" +Rounding mode PROHIBITED - doesn't fit; no ON ERROR phrase +111.5 becomes +123 + EXCEPTION STATUS IS "EC-SIZE-TRUNCATION" +Rounding mode PROHIBITED - doesn't fit; ON ERROR phrase +111.5 becomes +123 + COMPUTE had an ON SIZE error + EXCEPTION STATUS IS "EC-SIZE-TRUNCATION" + 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/Recursive_PERFORM_paragraph.cob b/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.cob new file mode 100644 index 0000000..3eb0685 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + *> { dg-output-file "group2/Recursive_PERFORM_paragraph.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 77 n binary-double unsigned. + 77 f binary-double unsigned. + procedure division. + move 20 to n + move 1 to f + display "compute " n " factorial". + fact. + compute f = f * n + subtract 1 from n + if n not equal to zero then + perform fact + end-if. + end-fact. + display f. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.out b/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.out new file mode 100644 index 0000000..97f0737 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.out @@ -0,0 +1,3 @@ +compute 0000000000000000020 factorial +2432902008176640000 + 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/SORT__EBCDIC_table_sort__1_.cob b/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__1_.cob new file mode 100644 index 0000000..9bf4892 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__1_.cob @@ -0,0 +1,29 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + ALPHABET ALPHA IS EBCDIC. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC X(10) VALUE "d4b2e1a3c5". + 01 G. + 02 TBL OCCURS 10. + 03 X PIC X. + PROCEDURE DIVISION. + MOVE Z TO G. + SORT TBL ASCENDING KEY X SEQUENCE ALPHA. + IF G NOT = "abcde12345" + DISPLAY G + END-DISPLAY + END-IF. + MOVE Z TO G. + SORT TBL DESCENDING KEY X SEQUENCE ALPHA. + IF G NOT = "54321edcba" + DISPLAY G + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__2_.cob b/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__2_.cob new file mode 100644 index 0000000..2a10d2d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__2_.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + OBJECT-COMPUTER. + x86 PROGRAM COLLATING SEQUENCE IS EBCDIC-CODE. + SPECIAL-NAMES. + ALPHABET EBCDIC-CODE IS EBCDIC. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC X(10) VALUE "d4b2e1a3c5". + 01 G. + 02 TBL OCCURS 10. + 03 X PIC X. + PROCEDURE DIVISION. + MOVE Z TO G. + SORT TBL ASCENDING KEY X. + IF G NOT = "abcde12345" + DISPLAY G. + MOVE Z TO G. + SORT TBL DESCENDING KEY X. + IF G NOT = "54321edcba" + DISPLAY G. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort.cob b/gcc/testsuite/cobol.dg/group2/SORT__table_sort.cob new file mode 100644 index 0000000..52fc973 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G VALUE "d4b2e1a3c5". + 02 TBL OCCURS 5. + 03 X PIC X. + 03 Y PIC 9. + PROCEDURE DIVISION. + SORT TBL ASCENDING KEY X. + IF G NOT = "a3b2c5d4e1" + DISPLAY G + END-DISPLAY + END-IF. + SORT TBL DESCENDING KEY Y. + IF G NOT = "c5d4a3b2e1" + DISPLAY G + END-DISPLAY + END-IF. + SORT TBL ASCENDING KEY TBL. + IF G NOT = "a3b2c5d4e1" + DISPLAY G + END-DISPLAY + END-IF. + SORT TBL DESCENDING KEY. + IF G NOT = "e1d4c5b2a3" + DISPLAY G + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.cob b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.cob new file mode 100644 index 0000000..d30b4ea --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.cob @@ -0,0 +1,96 @@ + *> { dg-do run } + *> { dg-output-file "group2/SORT__table_sort__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 K PIC 9(2). + + 01 CNT1 PIC 9(9) COMP-5 VALUE 4. + 01 TAB1. + 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1 + DESCENDING TAB1-NR. + 10 TAB1-NR PIC 99. + + 01 TAB2. + 05 CNT2 PIC 9(9) COMP-5 VALUE 4. + 05 ROW2 OCCURS 1 TO 4 DEPENDING CNT2 + DESCENDING TAB2-NR. + 10 TAB2-NR PIC 99. + + 01 TAB3. + 05 CNT3 PIC 9(9) COMP-5 VALUE 10. + 05 ROW3 OCCURS 1 TO 10 DEPENDING CNT3 + DESCENDING TAB3-NR + ASCENDING TAB3-DATA. + 10 TAB3-NR PIC 99. + 10 FILLER PIC X(2). + 10 TAB3-DATA PIC X(5). + 10 FILLER PIC X(2). + 10 TAB3-DATA2 PIC X(5). + + + PROCEDURE DIVISION. + A. + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + MOVE K TO TAB1-NR(K), TAB2-NR(K) + END-PERFORM + + MOVE 1 TO TAB3-NR(1). + MOVE 1 TO TAB3-NR(8). + MOVE 1 TO TAB3-NR(4). + MOVE 6 TO TAB3-NR(2). + MOVE 5 TO TAB3-NR(3). + MOVE 5 TO TAB3-NR(9). + MOVE 2 TO TAB3-NR(5). + MOVE 2 TO TAB3-NR(10). + MOVE 4 TO TAB3-NR(6). + MOVE 3 TO TAB3-NR(7). + + MOVE "abcde" TO TAB3-DATA(1). + MOVE "AbCde" TO TAB3-DATA(2). + MOVE "abcde" TO TAB3-DATA(3). + MOVE "zyx" TO TAB3-DATA(4). + MOVE "12345" TO TAB3-DATA(5). + MOVE "zyx" TO TAB3-DATA(6). + MOVE "abcde" TO TAB3-DATA(7). + MOVE "AbCde" TO TAB3-DATA(8). + MOVE "abc" TO TAB3-DATA(9). + MOVE "12346" TO TAB3-DATA(10). + + MOVE "day" TO TAB3-DATA2(1). + MOVE "The" TO TAB3-DATA2(2). + MOVE "eats" TO TAB3-DATA2(3). + MOVE "." TO TAB3-DATA2(4). + MOVE "mooos" TO TAB3-DATA2(5). + MOVE "grass" TO TAB3-DATA2(6). + MOVE "and" TO TAB3-DATA2(7). + MOVE "whole" TO TAB3-DATA2(8). + MOVE "cow" TO TAB3-DATA2(9). + MOVE "the" TO TAB3-DATA2(10). + + SORT ROW1 DESCENDING TAB1-NR + SORT ROW2 DESCENDING TAB2-NR + + DISPLAY "SINGLE TABLE" END-DISPLAY + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB1-NR(K) END-DISPLAY + END-PERFORM + + DISPLAY "LOWER LEVEL TABLE" END-DISPLAY + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB2-NR(K) END-DISPLAY + END-PERFORM + + SORT ROW3 DESCENDING TAB3-NR ASCENDING TAB3-DATA + + DISPLAY "MULTY KEY SORT" END-DISPLAY + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 10 + DISPLAY FUNCTION TRIM(ROW3(K)) + END-DISPLAY + END-PERFORM + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.out b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.out new file mode 100644 index 0000000..5866ecf --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.out @@ -0,0 +1,22 @@ +SINGLE TABLE +04 +03 +02 +01 +LOWER LEVEL TABLE +04 +03 +02 +01 +MULTY KEY SORT +06 AbCde The +05 abc cow +05 abcde eats +04 zyx grass +03 abcde and +02 12345 mooos +02 12346 the +01 AbCde whole +01 abcde day +01 zyx . + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.cob b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.cob new file mode 100644 index 0000000..660f93c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.cob @@ -0,0 +1,48 @@ + *> { dg-do run } + *> { dg-output-file "group2/SORT__table_sort__3A_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 K PIC 9(2). + + 01 CNT1 PIC 9(9) COMP-5 VALUE 4. + 01 TAB1. + 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1 + DESCENDING TAB1-NR. + 10 TAB1-NR PIC 99. + 10 TAB-DATA PIC X(5). + 01 TAB2. + 05 ROW2 OCCURS 1 TO 4 DEPENDING CNT1 + ASCENDING ROW2. + 10 TAB2-NR PIC 99. + 10 TAB2-DATA PIC X(5). + + PROCEDURE DIVISION. + A. + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + MOVE K TO TAB1-NR (K) + MOVE 'BLA' TO TAB-DATA(K) + END-PERFORM + + SORT ROW1 + + DISPLAY "After SORT [DESCENDING] ROW1" + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB1-NR(K) NO ADVANCING END-DISPLAY + END-PERFORM + DISPLAY "" + + MOVE TAB1 TO TAB2 + SORT ROW2 + + DISPLAY "After SORT [ASCENDING] ROW2" + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB2-NR(K) NO ADVANCING END-DISPLAY + END-PERFORM + DISPLAY "" + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.out b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.out new file mode 100644 index 0000000..29ea985 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.out @@ -0,0 +1,5 @@ +After SORT [DESCENDING] ROW1 +04030201 +After SORT [ASCENDING] ROW2 +01020304 + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.cob b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.cob new file mode 100644 index 0000000..3afea83 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.cob @@ -0,0 +1,44 @@ + *> { dg-do run } + *> { dg-output-file "group2/SORT__table_sort__3B_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 K PIC 9(2). + + 01 CNT1 PIC 9(9) COMP-5 VALUE 4. + 01 TAB1. + 05 ROW1 OCCURS 5 DESCENDING TAB1-NR. + 10 TAB1-NR PIC 99 VALUE ZERO. + 10 TAB-DATA PIC X(5). + 01 TAB2. + 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1 + DESCENDING TAB1-NR. + 10 TAB1-NR PIC 99. + 10 TAB-DATA PIC X(5). + + PROCEDURE DIVISION. + A. + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + MOVE K TO TAB1-NR OF TAB2(K) + MOVE 'BLA' TO TAB-DATA OF TAB2(K) + END-PERFORM + + DISPLAY "Before sort" + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB1-NR OF TAB2(K) NO ADVANCING END-DISPLAY + END-PERFORM + DISPLAY "" + + SORT ROW1 OF TAB2. + + DISPLAY "After descending sort" + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB1-NR OF TAB2(K) NO ADVANCING END-DISPLAY + END-PERFORM + DISPLAY "" + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.out b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.out new file mode 100644 index 0000000..4721770 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.out @@ -0,0 +1,5 @@ +Before sort +01020304 +After descending sort +04030201 + diff --git a/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.cob b/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.cob new file mode 100644 index 0000000..29b266e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/SOURCE_FIXED_FREE_directives.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + >>SOURCE FREE + DATA DIVISION. + WORKING-STORAGE SECTION. + >>SOURCE FIXED + PROCEDURE DIVISION. FIXED + DISPLAY "OK" NO ADVANCING + END-DISPLAY. + >>SOURCE FREE + DISPLAY + "OK" + NO ADVANCING + END-DISPLAY. + >>SOURCE FORMAT FIXED + DISPLAY "OK" NO ADVANCING FIXED + END-DISPLAY. + >>SOURCE FORMAT IS FREE + DISPLAY + "OK" + NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.out b/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.out new file mode 100644 index 0000000..ed898e2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.out @@ -0,0 +1 @@ +OKOKOKOK diff --git a/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_ERROR_STATUS.cob b/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_ERROR_STATUS.cob new file mode 100644 index 0000000..c5f8fe7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_ERROR_STATUS.cob @@ -0,0 +1,10 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + STOP RUN WITH ERROR STATUS. + diff --git a/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_NORMAL_STATUS.cob b/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_NORMAL_STATUS.cob new file mode 100644 index 0000000..9950a77 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_NORMAL_STATUS.cob @@ -0,0 +1,9 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + STOP RUN WITH NORMAL STATUS. + diff --git a/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.cob b/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.cob new file mode 100644 index 0000000..8397189 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.cob @@ -0,0 +1,104 @@ + *> { dg-do run } + *> { dg-output-file "group2/STRING___UNSTRING__NOT__ON_OVERFLOW.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + 77 simple-str pic x(20). + 77 err-str pic x(50). + *----------------------------------------------------------------- + procedure division. + * STRING test + move spaces to simple-str + string 'data' + delimited by size + into simple-str + on overflow + move spaces to err-str + string 'STRING OVERFLOW' + delimited by size + into err-str + end-string + display err-str upon syserr + end-display + display '1 failed' + end-display + not on overflow + display '1 passed' + end-display + end-string + if simple-str not = 'data' + display 'STRING ERROR (1): "' simple-str '"' + end-display + end-if + * + move spaces to simple-str + string 'data is too big here...' + delimited by size + into simple-str + on overflow + display '2 passed' + end-display + not on overflow + display '2 failed' + end-display + move spaces to err-str + string 'missing OVERFLOW' + delimited by size + into err-str + end-string + display err-str upon syserr + end-display + end-string + if simple-str not = 'data is too big here' + display 'STRING ERROR (2): "' simple-str '"' + end-display + end-if + * + * UNSTRING test + move spaces to simple-str + unstring 'data' + into simple-str + on overflow + move spaces to err-str + unstring 'UNSTRING OVERFLOW' + into err-str + end-unstring + display err-str upon syserr + end-display + display '3 failed' + end-display + not on overflow + display '3 passed' + end-display + end-unstring + if simple-str not = 'data' + display 'UNSTRING ERROR (1): "' simple-str '"' + end-display + end-if + * + move spaces to simple-str + unstring 'data is too big here...' + into simple-str + on overflow + display '4 passed' + end-display + not on overflow + display '4 failed' + end-display + move spaces to err-str + string 'missing OVERFLOW' + delimited by size + into err-str + end-string + display err-str upon syserr + end-display + end-unstring + if simple-str not = 'data is too big here' + display 'UNSTRING ERROR (2): "' simple-str '"' + end-display + end-if + * + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.out b/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.out new file mode 100644 index 0000000..f819dc4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.out @@ -0,0 +1,5 @@ +1 passed +2 passed +3 passed +4 passed + diff --git a/gcc/testsuite/cobol.dg/group2/STRING_with_subscript_reference.cob b/gcc/testsuite/cobol.dg/group2/STRING_with_subscript_reference.cob new file mode 100644 index 0000000..66a5477 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STRING_with_subscript_reference.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X(3) OCCURS 3. + PROCEDURE DIVISION. + MOVE SPACES TO G. + STRING "abc" INTO X(2) + END-STRING. + IF G NOT = " abc " + DISPLAY X(1) NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__1_.cob b/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__1_.cob new file mode 100644 index 0000000..631b48e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__1_.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/Separate_sign_positions__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC S9 VALUE -1 SIGN LEADING SEPARATE. + 01 Y PIC S9 VALUE -1 SIGN TRAILING SEPARATE. + PROCEDURE DIVISION. + DISPLAY X(1:1) X(2:1) NO ADVANCING + END-DISPLAY. + DISPLAY Y(1:1) Y(2:1) NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__1_.out b/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__1_.out new file mode 100644 index 0000000..d981f48 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__1_.out @@ -0,0 +1 @@ +-11- diff --git a/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__2_.cob b/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__2_.cob new file mode 100644 index 0000000..1c6b423 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__2_.cob @@ -0,0 +1,24 @@ + *> { dg-do run } + *> { dg-output-file "group2/Separate_sign_positions__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC S9 SIGN LEADING SEPARATE. + 01 Y PIC S9 SIGN TRAILING SEPARATE. + PROCEDURE DIVISION. + MOVE 0 TO X. + DISPLAY X NO ADVANCING + END-DISPLAY. + MOVE ZERO TO X. + DISPLAY X NO ADVANCING + END-DISPLAY. + MOVE 0 TO Y. + DISPLAY Y NO ADVANCING + END-DISPLAY. + MOVE ZERO TO Y. + DISPLAY Y NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__2_.out b/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__2_.out new file mode 100644 index 0000000..6d2ea72 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Separate_sign_positions__2_.out @@ -0,0 +1 @@ ++0+00+0+ diff --git a/gcc/testsuite/cobol.dg/group2/Simple_TYPEDEF.cob b/gcc/testsuite/cobol.dg/group2/Simple_TYPEDEF.cob new file mode 100644 index 0000000..c2fffbe --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Simple_TYPEDEF.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + + identification division. + program-id. wrapper. + data division. + working-storage section. + 77 UNS-CHAR PIC 9(02) COMP-5 IS TYPEDEF. + 01 Z-H3 PIC X(017) . + 01 I-H3A USAGE UNS-CHAR. + 01 I-H3B USAGE UNS-CHAR. + 78 I-H3-max VALUE LENGTH OF Z-H3. + procedure division. + goback. + end program wrapper. + diff --git a/gcc/testsuite/cobol.dg/group2/Simple_p-scaling.cob b/gcc/testsuite/cobol.dg/group2/Simple_p-scaling.cob new file mode 100644 index 0000000..db3bc41 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Simple_p-scaling.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + *> { dg-output-file "group2/Simple_p-scaling.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + 01 vars. + 05 vars01 picture 99ppp DISPLAY value 78000 . + 05 vars02 picture 99ppp BINARY value 78000 . + 05 vars03 picture 99ppp COMP-3 value 78000 . + 05 vars04 picture 99ppp COMP-5 value 78000 . + 05 vars05 picture 99ppp PACKED-DECIMAL value 78000 . + 01 vary. + 05 vary01 picture ppp99 DISPLAY value 0.00078 . + 05 vary02 picture ppp99 BINARY value 0.00078 . + 05 vary03 picture ppp99 COMP-3 value 0.00078 . + 05 vary04 picture ppp99 COMP-5 value 0.00078 . + 05 vary05 picture ppp99 PACKED-DECIMAL value 0.00078 . + procedure division. + display vars01 + display vars02 + display vars03 + display vars04 + display vars05 + display vary01 + display vary02 + display vary03 + display vary04 + display vary05 + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Simple_p-scaling.out b/gcc/testsuite/cobol.dg/group2/Simple_p-scaling.out new file mode 100644 index 0000000..8d9c45c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Simple_p-scaling.out @@ -0,0 +1,11 @@ +78000 +78000 +78000 +78000 +78000 +.00078 +.00078 +.00078 +.00078 +.00078 + diff --git a/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.cob b/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.cob new file mode 100644 index 0000000..fa43889 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.cob @@ -0,0 +1,20 @@ + *> { dg-do run } + *> { dg-options "-fno-static-call -rdynamic" } + *> { dg-output-file "group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + PROCEDURE DIVISION. + CALL "callee1" ON EXCEPTION + CALL "callee2" ON EXCEPTION + DISPLAY "neither callee1 nor callee2 found" + END-CALL + END-CALL + GOBACK. + END PROGRAM caller. + IDENTIFICATION DIVISION. + PROGRAM-ID. callee2. + PROCEDURE DIVISION. + DISPLAY "this is callee2" NO ADVANCING + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.out b/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.out new file mode 100644 index 0000000..4f18f54 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.out @@ -0,0 +1 @@ +this is callee2 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/UNSTRING_DELIMITED_ALL_LOW-VALUE.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_LOW-VALUE.cob new file mode 100644 index 0000000..495feef --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_LOW-VALUE.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 03 FILLER PIC XXX VALUE "ABC". + 03 FILLER PIC XX VALUE LOW-VALUE. + 03 FILLER PIC XXX VALUE "DEF". + 01 A PIC XXX. + 01 B PIC XXX. + PROCEDURE DIVISION. + UNSTRING G DELIMITED BY ALL LOW-VALUE + INTO A B + END-UNSTRING. + IF A NOT = "ABC" + DISPLAY "A is " """" A """" + END-DISPLAY + END-IF. + IF B NOT = "DEF" + DISPLAY "B is " """" B """" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_SPACE-2.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_SPACE-2.cob new file mode 100644 index 0000000..9bbbd8e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_SPACE-2.cob @@ -0,0 +1,56 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WS-RECORD. + 02 VALUE SPACE PIC X(04). + 02 VALUE "ABC AND DE" PIC X(10). + 02 VALUE SPACE PIC X(07). + 02 VALUE "FG AND HIJ" PIC X(10). + 02 VALUE SPACE PIC X(08). + 01 SPACE-2 PIC X(02) VALUE SPACE. + 01 WS-DUMMY PIC X(15). + 01 WS-POINTER PIC 99. + PROCEDURE DIVISION. + MOVE 1 TO WS-POINTER. + * + PERFORM 0001-SUB. + IF WS-DUMMY NOT = SPACE + DISPLAY "Expected space - Got " WS-DUMMY + END-DISPLAY + END-IF. + IF WS-POINTER NOT = 5 + DISPLAY "Expected 5 - Got " WS-POINTER + END-DISPLAY + END-IF. + * + PERFORM 0001-SUB. + IF WS-DUMMY NOT = "ABC AND DE" + DISPLAY "Expected ABC AND DE - Got " WS-DUMMY + END-DISPLAY + END-IF. + IF WS-POINTER NOT = 21 + DISPLAY "Expected 21 - Got " WS-POINTER + END-DISPLAY + END-IF. + * + PERFORM 0001-SUB. + IF WS-DUMMY NOT = " FG AND HIJ" + DISPLAY "Expected FG AND HIJ - Got " WS-DUMMY + END-DISPLAY + END-IF. + IF WS-POINTER NOT = 40 + DISPLAY "Expected 40 - Got " WS-POINTER + END-DISPLAY + END-IF. + STOP RUN. + 0001-SUB. + UNSTRING WS-RECORD + DELIMITED BY ALL SPACE-2 + INTO WS-DUMMY + POINTER WS-POINTER + END-UNSTRING. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_POINTER.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_POINTER.cob new file mode 100644 index 0000000..5d3fdf2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_POINTER.cob @@ -0,0 +1,45 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WS-LAY-RECORD PIC X(66). + 01 WS-DUMMY PIC X(50). + 01 WS-KEYWORD PIC X(32). + 01 WS-POINTER PIC 99. + PROCEDURE DIVISION. + MOVE + ' 10 AF-RECORD-TYPE-SEQUENCE-04 PIC 9(05) COMP-3.' + TO WS-LAY-RECORD. + MOVE 1 TO WS-POINTER. + PERFORM 0001-SUB. + IF WS-POINTER NOT = 48 + DISPLAY "Expected 48 - Got " WS-POINTER + END-DISPLAY + END-IF. + ADD 7 TO WS-POINTER + END-ADD. + PERFORM 0001-SUB. + IF WS-POINTER NOT = 62 + DISPLAY "Expected 62 - Got " WS-POINTER + END-DISPLAY + END-IF. + PERFORM 0001-SUB. + IF WS-POINTER NOT = 63 + DISPLAY "Expected 63 - Got " WS-POINTER + END-DISPLAY + END-IF. + STOP RUN. + 0001-SUB. + UNSTRING WS-LAY-RECORD + DELIMITED + BY ' PIC ' + OR ' COMP-3' + OR '.' + INTO WS-DUMMY + DELIMITER WS-KEYWORD + POINTER WS-POINTER + END-UNSTRING. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITER_IN.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITER_IN.cob new file mode 100644 index 0000000..714dba1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITER_IN.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WK-CMD PIC X(8) VALUE "WWADDBCC". + 01 WK-SIGNS PIC XX VALUE "AB". + 01 WKS REDEFINES WK-SIGNS. + 03 WK-SIGN PIC X OCCURS 2. + 01 . + 02 WK-DELIM PIC X OCCURS 2. + 01 . + 02 WK-DATA PIC X(2) OCCURS 3. + PROCEDURE DIVISION. + UNSTRING WK-CMD DELIMITED BY WK-SIGN(1) OR WK-SIGN(2) + INTO WK-DATA(1) DELIMITER IN WK-DELIM(1) + WK-DATA(2) DELIMITER IN WK-DELIM(2) + WK-DATA(3) + END-UNSTRING + IF WK-DATA(1) NOT = "WW" + OR WK-DATA(2) NOT = "DD" + OR WK-DATA(3) NOT = "CC" + OR WK-DELIM(1) NOT = "A" + OR WK-DELIM(2) NOT = "B" + DISPLAY """" WK-DATA(1) + WK-DATA(2) + WK-DATA(3) + WK-DELIM(1) + WK-DELIM(2) """" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.cob new file mode 100644 index 0000000..f4c8032 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.cob @@ -0,0 +1,42 @@ + *> { dg-do run } + *> { dg-output-file "group2/UNSTRING_with_FUNCTION___literal.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FILLER. + 05 TSTUNS PIC X(479). + 05 PRM PIC X(16) OCCURS 4 TIMES. + PROCEDURE DIVISION. + MOVE "The,Quick,Brown,Fox" TO TSTUNS. + UNSTRING TSTUNS DELIMITED BY ',' + INTO PRM(1), PRM(2), PRM(3), PRM(4). + DISPLAY "PRM(1) is " PRM(1) ":". + DISPLAY "PRM(2) is " PRM(2) ":". + DISPLAY "PRM(3) is " PRM(3) ":". + DISPLAY "PRM(4) is " PRM(4) ":". + UNSTRING FUNCTION UPPER-CASE(TSTUNS) DELIMITED BY ',' + INTO PRM(1), PRM(2), PRM(3), PRM(4). + DISPLAY "Now using UPPER-CASE" + DISPLAY "PRM(1) is " PRM(1) ":". + DISPLAY "PRM(2) is " PRM(2) ":". + DISPLAY "PRM(3) is " PRM(3) ":". + DISPLAY "PRM(4) is " PRM(4) ":". + UNSTRING "Daddy,was,a,Rolling stone" DELIMITED BY ',' + INTO PRM(1), PRM(2), PRM(3), PRM(4). + DISPLAY "Now using Literal" + DISPLAY "PRM(1) is " PRM(1) ":". + DISPLAY "PRM(2) is " PRM(2) ":". + DISPLAY "PRM(3) is " PRM(3) ":". + DISPLAY "PRM(4) is " PRM(4) ":". + UNSTRING FUNCTION LOWER-CASE("Daddy,was,a,Rolling stone") + DELIMITED BY ',' + INTO PRM(1), PRM(2), PRM(3), PRM(4). + DISPLAY "Now using Literal + LOWER-CASE" + DISPLAY "PRM(1) is " PRM(1) ":". + DISPLAY "PRM(2) is " PRM(2) ":". + DISPLAY "PRM(3) is " PRM(3) ":". + DISPLAY "PRM(4) is " PRM(4) ":". + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.out b/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.out new file mode 100644 index 0000000..297f254 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.out @@ -0,0 +1,20 @@ +PRM(1) is The : +PRM(2) is Quick : +PRM(3) is Brown : +PRM(4) is Fox : +Now using UPPER-CASE +PRM(1) is THE : +PRM(2) is QUICK : +PRM(3) is BROWN : +PRM(4) is FOX : +Now using Literal +PRM(1) is Daddy : +PRM(2) is was : +PRM(3) is a : +PRM(4) is Rolling stone : +Now using Literal + LOWER-CASE +PRM(1) is daddy : +PRM(2) is was : +PRM(3) is a : +PRM(4) is rolling stone : + diff --git a/gcc/testsuite/cobol.dg/group2/_-static__compilation.cob b/gcc/testsuite/cobol.dg/group2/_-static__compilation.cob new file mode 100644 index 0000000..f344a84 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/_-static__compilation.cob @@ -0,0 +1,10 @@ + *> { dg-do run } + *> { dg-options "-static" } + *> { dg-prune-output {warning} } + *> { dg-output {hello, world} } + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + DISPLAY "hello, world". + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.cob b/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.cob new file mode 100644 index 0000000..5cf0446 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.cob @@ -0,0 +1,34 @@ + *> { dg-do run } + *> { dg-output-file "group2/access_to_OPTIONAL_LINKAGE_item_not_passed.out" } + + identification division. + program-id. caller. + data division. + working-storage section. + 01 x pic x(4) value '9876'. + procedure division. + call 'callee' using x + end-call + call 'callee' using omitted + end-call + stop run. + end program caller. + + identification division. + program-id. callee. + data division. + working-storage section. + 01 py pointer. + linkage section. + 01 x. + 05 y pic x(4). + procedure division using optional x. + set py to address of x. + if py is not equal to zero + display y + else + display "parameter omitted" + end-if. + goback. + end program callee. + diff --git a/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.out b/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.out new file mode 100644 index 0000000..9e82a04 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.out @@ -0,0 +1,3 @@ +9876 +parameter omitted + diff --git a/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.cob b/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.cob new file mode 100644 index 0000000..3753e7a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.cob @@ -0,0 +1,36 @@ + *> { dg-do run } + *> { dg-output-file "group2/call_subprogram_using_pointer__passing_pointer.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 varp program-pointer. + PROCEDURE DIVISION. + SET varp TO ENTRY "ref". + CALL "sub" USING BY VALUE varp. + end program prog. + + IDENTIFICATION DIVISION. + PROGRAM-ID. sub. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 param pic x(12) value "hi". + LINKAGE SECTION. + 77 varp program-pointer. + PROCEDURE DIVISION USING BY VALUE varp. + DISPLAY "About to call 'ref hi' directly" + CALL "ref" USING param. + DISPLAY "About to call 'ref hi' indirectly" + CALL varp USING param. + end program sub. + + IDENTIFICATION DIVISION. + PROGRAM-ID. ref. + DATA DIVISION. + LINKAGE SECTION. + 77 greeting pic x(12). + PROCEDURE DIVISION using greeting. + DISPLAY """" greeting """". + end program ref. + diff --git a/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.out b/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.out new file mode 100644 index 0000000..7a12ec1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/call_subprogram_using_pointer__passing_pointer.out @@ -0,0 +1,5 @@ +About to call 'ref hi' directly +"hi " +About to call 'ref hi' indirectly +"hi " + diff --git a/gcc/testsuite/cobol.dg/group2/debugging_lines__WITH_DEBUGGING_MODE_.cob b/gcc/testsuite/cobol.dg/group2/debugging_lines__WITH_DEBUGGING_MODE_.cob new file mode 100644 index 0000000..880d865 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/debugging_lines__WITH_DEBUGGING_MODE_.cob @@ -0,0 +1,21 @@ + *> { dg-do run } + *> { dg-options "-ffixed-form" } + *> { dg-output-file "group2/debugging_lines__WITH_DEBUGGING_MODE_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SOURCE-COMPUTER. mine WITH DEBUGGING MODE. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + * Original "incorrect ordered lines" + * DISPLAY "KO" NO ADVANCING UPON STDOUT + * END-DISPLAY. + D DISPLAY "KO" UPON STDOUT NO ADVANCING + D END-DISPLAY. + DISPLAY "OK" UPON STDOUT NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/debugging_lines__WITH_DEBUGGING_MODE_.out b/gcc/testsuite/cobol.dg/group2/debugging_lines__WITH_DEBUGGING_MODE_.out new file mode 100644 index 0000000..6f0a25f5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/debugging_lines__WITH_DEBUGGING_MODE_.out @@ -0,0 +1 @@ +KOOK diff --git a/gcc/testsuite/cobol.dg/group2/debugging_lines__not_active_.cob b/gcc/testsuite/cobol.dg/group2/debugging_lines__not_active_.cob new file mode 100644 index 0000000..56cb067 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/debugging_lines__not_active_.cob @@ -0,0 +1,14 @@ + *> { dg-do run } + *> { dg-output-file "group2/debugging_lines__not_active_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY "OK" NO ADVANCING + END-DISPLAY. + D DISPLAY "KO" NO ADVANCING + D END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/debugging_lines__not_active_.out b/gcc/testsuite/cobol.dg/group2/debugging_lines__not_active_.out new file mode 100644 index 0000000..d86bac9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/debugging_lines__not_active_.out @@ -0,0 +1 @@ +OK diff --git a/gcc/testsuite/cobol.dg/group2/integer_arithmetic_on_floating-point_var.cob b/gcc/testsuite/cobol.dg/group2/integer_arithmetic_on_floating-point_var.cob new file mode 100644 index 0000000..bf7bd78 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/integer_arithmetic_on_floating-point_var.cob @@ -0,0 +1,29 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x USAGE COMP-1 VALUE 123.456. + PROCEDURE DIVISION. + ADD 360 TO x + IF x > 483.457 OR x < 483.455 + DISPLAY "ADD wrong: " x + MOVE 483.456 TO x + END-IF + SUBTRACT 360 FROM x + IF x > 123.457 OR x < 123.455 + DISPLAY "SUBTRACT wrong: " x + MOVE 123.456 TO x + END-IF + DIVIDE 2 INTO x + IF x > 61.729 OR x < 61.727 + DISPLAY "DIVIDE wrong: " x + MOVE 61.728 TO x + END-IF + MULTIPLY 2 BY x + IF x > 123.457 OR x < 123.455 + DISPLAY "MULTIPLY wrong: " x + END-IF + GOBACK. + |