These tests have been curated for relative shortness of output. The worst case has 61 lines.
I am hoping that this one is... Okay for trunk? >From 457d94c65047856123185716e882af18833c67ee Mon Sep 17 00:00:00 2001 From: Bob Dubner mailto:rdub...@symas.com Date: Mon, 17 Mar 2025 21:47:05 -0400 Subject: [PATCH] cobol: Fifteen new cobol.dg testscases. gcc/testsuite * cobol.dg/group1/check_88.cob: New testcase. * cobol.dg/group1/comp5.cob: Likewise. * cobol.dg/group1/declarative_1.cob: Likewise. * cobol.dg/group1/display.cob: Likewise. * cobol.dg/group1/display2.cob: Likewise. * cobol.dg/group1/line-sequential.cob: Likewise. * cobol.dg/group1/multiple-compares.cob: Likewise. * cobol.dg/group1/multiply2.cob: Likewise. * cobol.dg/group1/packed.cob: Likewise. * cobol.dg/group1/perform-nested-exit.cob: Likewise. * cobol.dg/group1/pointer1.cob: Likewise. * cobol.dg/group1/simple-arithmetic.cob: Likewise. * cobol.dg/group1/simple-classes.cob: Likewise. * cobol.dg/group1/simple-if.cob: Likewise. * cobol.dg/group1/simple-perform.cob: Likewise. --- gcc/testsuite/cobol.dg/group1/check_88.cob | 101 +++++++++ gcc/testsuite/cobol.dg/group1/comp5.cob | 72 +++++++ .../cobol.dg/group1/declarative_1.cob | 116 +++++++++++ gcc/testsuite/cobol.dg/group1/display.cob | 14 ++ gcc/testsuite/cobol.dg/group1/display2.cob | 7 + .../cobol.dg/group1/line-sequential.cob | 34 ++++ .../cobol.dg/group1/multiple-compares.cob | 192 ++++++++++++++++++ gcc/testsuite/cobol.dg/group1/multiply2.cob | 68 +++++++ gcc/testsuite/cobol.dg/group1/packed.cob | 73 +++++++ .../cobol.dg/group1/perform-nested-exit.cob | 84 ++++++++ gcc/testsuite/cobol.dg/group1/pointer1.cob | 98 +++++++++ .../cobol.dg/group1/simple-arithmetic.cob | 61 ++++++ .../cobol.dg/group1/simple-classes.cob | 68 +++++++ gcc/testsuite/cobol.dg/group1/simple-if.cob | 143 +++++++++++++ .../cobol.dg/group1/simple-perform.cob | 52 +++++ 15 files changed, 1183 insertions(+) create mode 100644 gcc/testsuite/cobol.dg/group1/check_88.cob create mode 100644 gcc/testsuite/cobol.dg/group1/comp5.cob create mode 100644 gcc/testsuite/cobol.dg/group1/declarative_1.cob create mode 100644 gcc/testsuite/cobol.dg/group1/display.cob create mode 100644 gcc/testsuite/cobol.dg/group1/display2.cob create mode 100644 gcc/testsuite/cobol.dg/group1/line-sequential.cob create mode 100644 gcc/testsuite/cobol.dg/group1/multiple-compares.cob create mode 100644 gcc/testsuite/cobol.dg/group1/multiply2.cob create mode 100644 gcc/testsuite/cobol.dg/group1/packed.cob create mode 100644 gcc/testsuite/cobol.dg/group1/perform-nested-exit.cob create mode 100644 gcc/testsuite/cobol.dg/group1/pointer1.cob create mode 100644 gcc/testsuite/cobol.dg/group1/simple-arithmetic.cob create mode 100644 gcc/testsuite/cobol.dg/group1/simple-classes.cob create mode 100644 gcc/testsuite/cobol.dg/group1/simple-if.cob create mode 100644 gcc/testsuite/cobol.dg/group1/simple-perform.cob diff --git a/gcc/testsuite/cobol.dg/group1/check_88.cob b/gcc/testsuite/cobol.dg/group1/check_88.cob new file mode 100644 index 000000000000..4a7723eb92a3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/check_88.cob @@ -0,0 +1,101 @@ +*> { dg-do run } +*> { dg-output {\-><\-(\n|\r\n|\r)} } +*> { dg-output {\-> <\-(\n|\r\n|\r)} } +*> { dg-output {\->"""<\-(\n|\r\n|\r)} } +*> { dg-output {\->000<\-(\n|\r\n|\r)} } +*> { dg-output {\->ÿÿÿ<\-(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {\-><\-(\n|\r\n|\r)} } +*> { dg-output {\-> <\-(\n|\r\n|\r)} } +*> { dg-output {\->""""<\-(\n|\r\n|\r)} } +*> { dg-output {\->0000<\-(\n|\r\n|\r)} } +*> { dg-output {\->ÿÿÿÿ<\-(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {There should be no garbage after character 32(\n|\r\n|\r)} } +*> { dg-output {\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\*\-\-\-\-\ -\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-(\n|\r\n|\r)} } +*> { dg-output {üüüüüüüüüüüüüüüüüüü Bundesstraße (\n|\r\n|\r)} } +*> { dg-output {üüüüüüüüüüüüüüüüüüü Bundesstraße (\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {There should be no spaces before the final quote(\n|\r\n|\r)} } +*> { dg-output {"üüüüüüüüüüüüüüüüüüü Bundesstraße"(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output { IsLow ""(\n|\r\n|\r)} } +*> { dg-output { IsZero "000"(\n|\r\n|\r)} } +*> { dg-output { IsHi "ÿÿÿ"(\n|\r\n|\r)} } +*> { dg-output { IsBob "bob"(\n|\r\n|\r)} } +*> { dg-output { IsQuote """""(\n|\r\n|\r)} } +*> { dg-output { IsSpace " "(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {CheckBinary Properly True(\n|\r\n|\r)} } +*> { dg-output {CheckBinary Properly False} } + IDENTIFICATION DIVISION. + PROGRAM-ID. check88. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Check88 PIC XXX VALUE SPACE. + 88 CheckSpace VALUE SPACE. + 88 CheckHi VALUE HIGH-VALUES. + 88 CheckLo VALUE LOW-VALUES. + 88 CheckZero VALUE ZERO. + 88 CheckQuotes VALUE QUOTE. + 88 CheckBob VALUE "bob". + 88 CheckBinary VALUE X"000102". *> { dg-warning embedded } + 01 000VARL PIC XXX VALUE LOW-VALUE. + 01 000VARS PIC XXX VALUE SPACE. + 01 000VARQ PIC XXX VALUE QUOTE. + 01 000VARZ PIC XXX VALUE ZERO. + 01 000VARH PIC XXX VALUE HIGH-VALUE. + 01 MOVE-TARGET PIC XXXX. + 01 VAR-UTF8 PIC X(64) VALUE "üüüüüüüüüüüüüüüüüüü Bundesstraße". + *> 01 VAR20 PIC 9V9(20) value "1.1". + 01 VAR99 PIC 999 VALUE ZERO. + PROCEDURE DIVISION. + DISPLAY "->" 000VARL "<-" + DISPLAY "->" 000VARS "<-" + DISPLAY "->" 000VARQ "<-" + DISPLAY "->" 000VARZ "<-" + DISPLAY "->" 000VARH "<-" + DISPLAY SPACE + MOVE LOW-VALUE TO MOVE-TARGET DISPLAY "->" MOVE-TARGET "<-" + MOVE SPACE TO MOVE-TARGET DISPLAY "->" MOVE-TARGET "<-" + MOVE QUOTE TO MOVE-TARGET DISPLAY "->" MOVE-TARGET "<-" + MOVE ZERO TO MOVE-TARGET DISPLAY "->" MOVE-TARGET "<-" + MOVE HIGH-VALUE TO MOVE-TARGET DISPLAY "->" MOVE-TARGET "<-" + DISPLAY SPACE + DISPLAY "There should be no garbage after character 32" + DISPLAY "-------------------------------*" + "--------------------------------" + DISPLAY VAR-UTF8 + MOVE "üüüüüüüüüüüüüüüüüüü Bundesstraße" TO VAR-UTF8 + DISPLAY VAR-UTF8 + DISPLAY SPACE + DISPLAY "There should be no spaces before the final quote" + DISPLAY """" "üüüüüüüüüüüüüüüüüüü Bundesstraße" """" + DISPLAY SPACE + SET CheckLo to TRUE PERFORM Checker DISPLAY """" Check88 """" + SET CheckZero to TRUE PERFORM Checker DISPLAY """" Check88 """" + SET CheckHi to TRUE PERFORM Checker DISPLAY """" Check88 """" + SET CheckBob to TRUE PERFORM Checker DISPLAY """" Check88 """" + SET CheckQuotes to TRUE PERFORM Checker DISPLAY """" Check88 """" + SET CheckSpace to TRUE PERFORM Checker DISPLAY """" Check88 """" + DISPLAY SPACE + MOVE X"000102" TO Check88 + IF CheckBinary + DISPLAY "CheckBinary Properly True" + else + DISPLAY "CheckBinary IMPROPERLY False". + MOVE X"030102" TO Check88 + IF CheckBinary + DISPLAY "CheckBinary IMPROPERLY True" + else + DISPLAY "CheckBinary Properly False". + STOP RUN. + Checker. + *>DISPLAY "Checking '" Check88 "'" + IF CheckHi DISPLAY " IsHi " NO ADVANCING END-IF + IF CheckLo DISPLAY " IsLow " NO ADVANCING END-IF + IF CheckZero DISPLAY " IsZero " NO ADVANCING END-IF + IF CheckBob DISPLAY " IsBob " NO ADVANCING END-IF + IF CheckQuotes DISPLAY " IsQuote " NO ADVANCING END-IF + IF CheckSpace DISPLAY " IsSpace " NO ADVANCING END-IF + . diff --git a/gcc/testsuite/cobol.dg/group1/comp5.cob b/gcc/testsuite/cobol.dg/group1/comp5.cob new file mode 100644 index 000000000000..5576ef9f1908 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/comp5.cob @@ -0,0 +1,72 @@ +*> { dg-do run } +*> { dg-output {0x0000000000000000 Should be 0x0000000000000000(\n|\r\n|\r)} } +*> { dg-output {0x0000000020202020 Should be 0x0000000020202020(\n|\r\n|\r)} } +*> { dg-output {0x0000000030303030 Should be 0x0000000030303030(\n|\r\n|\r)} } +*> { dg-output {0x0000000022222222 Should be 0x0000000022222222(\n|\r\n|\r)} } +*> { dg-output {0x00000000ffffffff Should be 0x00000000ffffffff} } + *> This program is a sanity check of COMP-5 moves and addition. + program-id. comp5. + data division. + working-storage section. + 77 var PIC 999V999 COMP-5 . + 77 var1 PIC 999V9(1) COMP-5 . + 77 var2 PIC 999V9(2) COMP-5 . + 77 var3 PIC 999V9(3) COMP-5 . + 77 var4 PIC 999V9(4) COMP-5 . + 77 var5 PIC 999V9(5) COMP-5 . + 77 var6 PIC 999V9(6) COMP-5 . + 77 var7 PIC 999V9(7) COMP-5 . + 77 var8 PIC 999V9(8) COMP-5 . + 77 var555 PIC 999V99999999 COMP-5 VALUE 555.55555555. + 01 C-5A PIC X(4) VALUE LOW-VALUE. + 01 C-5B PIC X(4) VALUE SPACE. + 01 C-5C PIC X(4) VALUE ZERO. + 01 C-5D PIC X(4) VALUE QUOTE. + 01 C-5E PIC X(4) VALUE HIGH-VALUE. + 01 PTR POINTER. + 01 PC REDEFINES PTR PIC X(4). + procedure division. + move 111.111 to var. + if var not equal to 111.111 display var " should be 111.111". + add 000.001 to var. + if var not equal to 111.112 display var " should be 111.112". + add 000.01 to var. + if var not equal to 111.122 display var " should be 111.122". + add 000.1 to var. + if var not equal to 111.222 display var " should be 111.222". + add 1 to var. + if var not equal to 112.222 display var " should be 112.222". + add 10 to var. + if var not equal to 122.222 display var " should be 122.222". + add 100 to var. + if var not equal to 222.222 display var " should be 222.222". + move 555.55555555 to var1 + move 555.55555555 to var2 + move 555.55555555 to var3 + move 555.55555555 to var4 + move 555.55555555 to var5 + move 555.55555555 to var6 + move 555.55555555 to var7 + move 555.55555555 to var8 + add 0.00000001 TO var555 giving var1 rounded + add 0.00000001 TO var555 giving var2 rounded + add 0.00000001 TO var555 giving var3 rounded + add 0.00000001 TO var555 giving var4 rounded + add 0.00000001 TO var555 giving var5 rounded + add 0.00000001 TO var555 giving var6 rounded + add 0.00000001 TO var555 giving var7 rounded + add 0.00000001 TO var555 giving var8 rounded + if var1 not equal to 555.6 display var1 " should be 555.6". + if var2 not equal to 555.56 display var2 " should be 555.56". + if var3 not equal to 555.556 display var3 " should be 555.556". + if var4 not equal to 555.5556 display var4 " should be 555.5556". + if var5 not equal to 555.55556 display var5 " should be 555.55556". + if var6 not equal to 555.555556 display var6 " should be 555.555556". + if var7 not equal to 555.5555556 display var7 " should be 555.5555556". + if var8 not equal to 555.55555556 display var8 " should be 555.55555556". + MOVE C-5A TO PC DISPLAY PTR " Should be 0x0000000000000000". + MOVE C-5B TO PC DISPLAY PTR " Should be 0x0000000020202020". + MOVE C-5C TO PC DISPLAY PTR " Should be 0x0000000030303030". + MOVE C-5D TO PC DISPLAY PTR " Should be 0x0000000022222222". + MOVE C-5E TO PC DISPLAY PTR " Should be 0x00000000ffffffff". + stop run. diff --git a/gcc/testsuite/cobol.dg/group1/declarative_1.cob b/gcc/testsuite/cobol.dg/group1/declarative_1.cob new file mode 100644 index 000000000000..744495a19eff --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/declarative_1.cob @@ -0,0 +1,116 @@ +*> { dg-do run } +*> { dg-output {Turning EC\-ALL CHECKING OFF \-\- Expecting \+00\.00 from ACOS\(\-3\)(\n|\r\n|\r)} } +*> { dg-output { \+00\.00 TABL\(VSIX\) is 6(\n|\r\n|\r)} } +*> { dg-output {Turning EC\-ARGUMENT\-FUNCTION CHECKING ON(\n|\r\n|\r)} } +*> { dg-output { Expecting \+0\.00 and DECLARATIVE FOR EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} } +*> { dg-output { DECLARATIVE FOR EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} } +*> { dg-output { \+00\.00 TABL\(VSIX\) is 6(\n|\r\n|\r)} } +*> { dg-output {Turning EC\-ARGUMENT CHECKING ON(\n|\r\n|\r)} } +*> { dg-output { Expecting \+0\.00 and DECLARATIVE FOR EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} } +*> { dg-output { DECLARATIVE FOR EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} } +*> { dg-output { \+00\.00 TABL\(VSIX\) is 6(\n|\r\n|\r)} } +*> { dg-output {Turning EC\-ALL CHECKING ON(\n|\r\n|\r)} } +*> { dg-output { Expecting \+0\.00 and DECLARATIVE EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} } +*> { dg-output { Followed by DECLARATIVE EC\-ALL for TABL\(6\) access(\n|\r\n|\r)} } +*> { dg-output { DECLARATIVE FOR EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} } +*> { dg-output { \+00\.00 TABL\(VSIX\) is 1(\n|\r\n|\r)} } +*> { dg-output { DECLARATIVE FOR EC\-ALL} } + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAL PIC S99V99. + 01 FILLER VALUE "1234567890". + 05 TABL PIC X OCCURS 5. + 05 TABL2 PIC X OCCURS 5. + 01 VSIX PIC 9 VALUE 6. + PROCEDURE DIVISION. + DECLARATIVES. + DECLARATIVES-EC-ARGUMENT-FUNCTION SECTION. + USE AFTER EXCEPTION CONDITION EC-ARGUMENT-FUNCTION. + DISPLAY " DECLARATIVE FOR EC-ARGUMENT-FUNCTION". + RESUME NEXT STATEMENT. + DECLARATIVES-EC-ARGUMENT SECTION. + USE AFTER EXCEPTION CONDITION EC-ARGUMENT. + DISPLAY " DECLARATIVE FOR EC-ARGUMENT". + RESUME NEXT STATEMENT. + DECLARATIVES-EC-ALL SECTION. + USE AFTER EXCEPTION CONDITION EC-ALL. + DISPLAY " DECLARATIVE FOR EC-ALL". + RESUME NEXT STATEMENT. + END DECLARATIVES. + *> END DECLARATIVES must be followed by an explicit section. + *> See ISO 2014 section 14.2.1 + *> READ ISO 2023 section 14.2.1 Format 2 (without sections) and + *> you will note that they forgot to isolate the declaratives from + *> the rest of the PROCEDURE DIVISION. So NO an explicit section + *> IS NOT REQUIRED. + *> See below that the >>TURN-EC-ALL CHECKING OFF statements at the end + *> of paragraphs are commented out. As of this writing, GCOBOL improperly + *> treats that as a syntax error. This is a known problem. + MAIN-SECTION SECTION. + PERFORM TEST1. + PERFORM TEST2. + PERFORM TEST3. + PERFORM TEST4. + *> PERFORM TEST5 + GOBACK. + TEST1. + DISPLAY "Turning EC-ALL CHECKING OFF -- Expecting +00.00 from ACOS(-3)" + >>TURN EC-ALL CHECKING OFF + *> The assumption that ACOS should return an invalid response is + *> in violation of the definition of ACOS in the standard. Furthermore, + *> EC-ARGUMENT-FUNCTION is marked FATAL and elsewhere in the standard + *> it says the implementor has the option to continue (scary) or fail. + *> By fail I think that means perform the declarative and then, if + *> the declarative section does not issue a RESUME ... "the run unit is + *> terminated abnormally as specified in 14.6.12, Abnormal run unit + *> termination." Not a segfault, ever. Jim mentioned he was looking for + *> a solution for RESUME but terminating as specified is not a + *> segfault. + MOVE FUNCTION ACOS(-3) TO VAL. + DISPLAY " " VAL WITH NO ADVANCING. + DISPLAY " TABL(VSIX) is " TABL(VSIX). + *> >>TURN EC-ALL CHECKING OFF + TEST2. + >>TURN EC-ALL CHECKING OFF + DISPLAY "Turning EC-ARGUMENT-FUNCTION CHECKING ON" + DISPLAY " " "Expecting +0.00 and DECLARATIVE FOR EC-ARGUMENT-FUNCTION" + >>TURN EC-ARGUMENT-FUNCTION CHECKING ON + MOVE FUNCTION ACOS(-3) TO VAL. + DISPLAY " " VAL WITH NO ADVANCING. + DISPLAY " TABL(VSIX) is " TABL(VSIX). + *> >>TURN EC-ALL CHECKING OFF + TEST3. + >>TURN EC-ALL CHECKING OFF + DISPLAY "Turning EC-ARGUMENT CHECKING ON" + DISPLAY " " "Expecting +0.00 and DECLARATIVE FOR EC-ARGUMENT-FUNCTION" + >>TURN EC-ARGUMENT CHECKING ON + *> Since there is a declarative for EC-ARGUMENT-FUNCTION, per Jim + *> that section will be used in this case and the higher-level + *> exception section will not. If that has changed, then the notion + *> of hierarchic response is different than we agreed. + MOVE FUNCTION ACOS(-3) TO VAL. + DISPLAY " " VAL WITH NO ADVANCING. + DISPLAY " TABL(VSIX) is " TABL(VSIX). + *> >>TURN EC-ALL CHECKING OFF + TEST4. + >>TURN EC-ALL CHECKING OFF + *> Same as previous. + DISPLAY "Turning EC-ALL CHECKING ON" + DISPLAY " " "Expecting +0.00 and DECLARATIVE EC-ARGUMENT-FUNCTION" + DISPLAY " " "Followed by DECLARATIVE EC-ALL for TABL(6) access" + >>TURN EC-ALL CHECKING ON + MOVE FUNCTION ACOS(-3) TO VAL. + DISPLAY " " VAL WITH NO ADVANCING. + DISPLAY " TABL(VSIX) is " TABL(VSIX). + *> >>TURN EC-ALL CHECKING OFF + TEST5. + >>TURN EC-ALL CHECKING OFF + DISPLAY "Turning EC-BOUND-SUBSCRIPT CHECKING ON - expecting default termination" + >>TURN EC-BOUND-SUBSCRIPT CHECKING ON + MOVE FUNCTION ACOS(-3) TO VAL. + DISPLAY " " VAL WITH NO ADVANCING. + DISPLAY " TABL(VSIX) is " TABL(VSIX). + *> >>TURN EC-ALL CHECKING OFF + END PROGRAM prog. diff --git a/gcc/testsuite/cobol.dg/group1/display.cob b/gcc/testsuite/cobol.dg/group1/display.cob new file mode 100644 index 000000000000..f5d92eb266a4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/display.cob @@ -0,0 +1,14 @@ +*> { dg-do run } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {" Marty "(\n|\r\n|\r)} } +*> { dg-output {"Marty"} } + IDENTIFICATION DIVISION. + PROGRAM-ID. disp. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR PIC X(30) VALUE " Marty ". + PROCEDURE DIVISION. + DISPLAY SPACE + DISPLAY """" VAR """" + DISPLAY """" FUNCTION TRIM(VAR) """" + STOP RUN. diff --git a/gcc/testsuite/cobol.dg/group1/display2.cob b/gcc/testsuite/cobol.dg/group1/display2.cob new file mode 100644 index 000000000000..6617c129c4df --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/display2.cob @@ -0,0 +1,7 @@ +*> { dg-do run } +*> { dg-output {1 2} } + IDENTIFICATION DIVISION. + PROGRAM-ID. disp2. + PROCEDURE DIVISION. + DISPLAY 1 SPACE 2 + STOP RUN. diff --git a/gcc/testsuite/cobol.dg/group1/line-sequential.cob b/gcc/testsuite/cobol.dg/group1/line-sequential.cob new file mode 100644 index 000000000000..617f9c9210f9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/line-sequential.cob @@ -0,0 +1,34 @@ +*> { dg-do run } +*> { dg-output {we saw 09 records; there should have been 09} } + identification division. + program-id. line-seq. + environment division. + input-output section. + file-control. + select data-file + assign to + "data.tab" organization line sequential. + data division. + file section. + fd data-file. + 01 data-record pic x(80). + working-storage section. + 01 record-count pic 99 value zero. + procedure division. + move "I am a line" to data-record + open output data-file. + perform 9 times + write data-record + end-perform + close data-file + open input data-file. + read-loop. + read data-file + at end + display "we saw " record-count " records; there should" + " have been 09" + close data-file + stop run. + add 1 to record-count + go to read-loop. + end program line-seq. diff --git a/gcc/testsuite/cobol.dg/group1/multiple-compares.cob b/gcc/testsuite/cobol.dg/group1/multiple-compares.cob new file mode 100644 index 000000000000..341c32a5a5fd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/multiple-compares.cob @@ -0,0 +1,192 @@ +*> { dg-do run } +*> { dg-output {D9 is 002(\n|\r\n|\r)} } +*> { dg-output {B9 is 002(\n|\r\n|\r)} } +*> { dg-output {X1 is '2'(\n|\r\n|\r)} } +*> { dg-output {X2 is ' 2'(\n|\r\n|\r)} } +*> { dg-output {X3 is ' 2'(\n|\r\n|\r)} } +*> { dg-output {X4 is '2'(\n|\r\n|\r)} } +*> { dg-output {X5 is '02'(\n|\r\n|\r)} } +*> { dg-output {X6 is '002'(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {D9 EQUAL TO D9 (\n|\r\n|\r)} } +*> { dg-output {D9 EQUAL TO B9 (\n|\r\n|\r)} } +*> { dg-output {D9 EQUAL TO X1 NOT(\n|\r\n|\r)} } +*> { dg-output {D9 EQUAL TO X2 NOT(\n|\r\n|\r)} } +*> { dg-output {D9 EQUAL TO X3 NOT(\n|\r\n|\r)} } +*> { dg-output {D9 EQUAL TO X4 NOT(\n|\r\n|\r)} } +*> { dg-output {D9 EQUAL TO X5 NOT(\n|\r\n|\r)} } +*> { dg-output {D9 EQUAL TO X6 (\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO D9 (\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO B9 (\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO X1 NOT(\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO X2 NOT(\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO X3 NOT(\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO X4 NOT(\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO X5 NOT(\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO X6 (\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO 2 (\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO 002 (\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO '2' NOT(\n|\r\n|\r)} } +*> { dg-output {B9 EQUAL TO '002' (\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output { 2 EQUAL TO B9 (\n|\r\n|\r)} } +*> { dg-output {'2' EQUAL TO B9 NOT(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output { 002 EQUAL TO B9 (\n|\r\n|\r)} } +*> { dg-output {'002' EQUAL TO B9 (\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output { 2 EQUAL TO 2 (\n|\r\n|\r)} } +*> { dg-output { 2 EQUAL TO '2' (\n|\r\n|\r)} } +*> { dg-output {'2' EQUAL TO 2 (\n|\r\n|\r)} } +*> { dg-output {'2' EQUAL TO '2' (\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output { 2 EQUAL TO 002 (\n|\r\n|\r)} } +*> { dg-output { 2 EQUAL TO '002' NOT(\n|\r\n|\r)} } +*> { dg-output {'2' EQUAL TO 002 NOT(\n|\r\n|\r)} } +*> { dg-output {'2' EQUAL TO '002' NOT(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output { 002 EQUAL TO 2 (\n|\r\n|\r)} } +*> { dg-output { 002 EQUAL TO '2' NOT(\n|\r\n|\r)} } +*> { dg-output {'002' EQUAL TO 2 NOT(\n|\r\n|\r)} } +*> { dg-output {'002' EQUAL TO '2' NOT(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output { 002 EQUAL TO 002 (\n|\r\n|\r)} } +*> { dg-output { 002 EQUAL TO '002' (\n|\r\n|\r)} } +*> { dg-output {'002' EQUAL TO 002 (\n|\r\n|\r)} } +*> { dg-output {'002' EQUAL TO '002' (\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output { 1000 EQUAL TO 999PPP (\n|\r\n|\r)} } +*> { dg-output { 0\.0001 EQUAL TO PPP999 } } + IDENTIFICATION DIVISION. + PROGRAM-ID. bigif. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 D9 PICTURE 999 . *>DISPLAY. + 01 B9 PICTURE 999 BINARY. + 01 X1 PICTURE X . + 01 X2 PICTURE XX . + 01 X3 PICTURE XXX . + 01 X4 PICTURE X . + 01 X5 PICTURE XX . + 01 X6 PICTURE XXX. + 01 AAA PICTURE 999. + 01 999PPP PIC 999PPP BINARY. + 01 PPP999 PIC PPP999 BINARY. + 01 MSG PIC X(24). + PROCEDURE DIVISION. + MOVE 2 TO D9 + MOVE 2 TO B9 + MOVE "2" TO X1 + MOVE " 2" TO X2 + MOVE " 2" TO X3 + MOVE "2" TO X4 + MOVE "02" TO X5 + MOVE "002" TO X6 + DISPLAY "D9 is " D9 + DISPLAY "B9 is " B9 + DISPLAY "X1 is '" X1 "'" + DISPLAY "X2 is '" X2 "'" + DISPLAY "X3 is '" X3 "'" + DISPLAY "X4 is '" X4 "'" + DISPLAY "X5 is '" X5 "'" + DISPLAY "X6 is '" X6 "'" + DISPLAY " " + MOVE "D9 EQUAL TO D9" TO MSG + IF D9 EQUAL TO D9 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "D9 EQUAL TO B9" TO MSG + IF D9 EQUAL TO B9 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "D9 EQUAL TO X1" TO MSG + IF D9 EQUAL TO X1 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "D9 EQUAL TO X2" TO MSG + IF D9 EQUAL TO X2 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "D9 EQUAL TO X3" TO MSG + IF D9 EQUAL TO X3 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "D9 EQUAL TO X4" TO MSG + IF D9 EQUAL TO X4 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "D9 EQUAL TO X5" TO MSG + IF D9 EQUAL TO X5 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "D9 EQUAL TO X6" TO MSG + IF D9 EQUAL TO X6 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + DISPLAY " " + MOVE "B9 EQUAL TO D9" TO MSG + IF B9 EQUAL TO D9 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO B9" TO MSG + IF B9 EQUAL TO B9 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO X1" TO MSG + IF B9 EQUAL TO X1 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO X2" TO MSG + IF B9 EQUAL TO X2 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO X3" TO MSG + IF B9 EQUAL TO X3 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO X4" TO MSG + IF B9 EQUAL TO X4 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO X5" TO MSG + IF B9 EQUAL TO X5 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO X6" TO MSG + IF B9 EQUAL TO X6 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + DISPLAY " " + MOVE "B9 EQUAL TO 2" TO MSG + IF B9 EQUAL TO 2 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO 002" TO MSG + IF B9 EQUAL TO 002 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO '2'" TO MSG + IF B9 EQUAL TO '2' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "B9 EQUAL TO '002'" TO MSG + IF B9 EQUAL TO '002' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + DISPLAY " " + MOVE " 2 EQUAL TO B9" TO MSG + IF 2 EQUAL TO B9 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'2' EQUAL TO B9" TO MSG + IF '2' EQUAL TO B9 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + DISPLAY " " + MOVE " 002 EQUAL TO B9" TO MSG + IF 002 EQUAL TO B9 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'002' EQUAL TO B9" TO MSG + IF '002' EQUAL TO B9 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + DISPLAY " " + MOVE " 2 EQUAL TO 2" TO MSG + IF 2 EQUAL TO 2 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE " 2 EQUAL TO '2'" TO MSG + IF 2 EQUAL TO '2' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'2' EQUAL TO 2" TO MSG + IF '2' EQUAL TO 2 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'2' EQUAL TO '2'" TO MSG + IF '2' EQUAL TO '2' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + DISPLAY " " + MOVE " 2 EQUAL TO 002" TO MSG + IF 2 EQUAL TO 002 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE " 2 EQUAL TO '002'" TO MSG + IF 2 EQUAL TO '002' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'2' EQUAL TO 002" TO MSG + IF '2' EQUAL TO 002 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'2' EQUAL TO '002'" TO MSG + IF '2' EQUAL TO '002' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + DISPLAY " " + MOVE " 002 EQUAL TO 2" TO MSG + IF 002 EQUAL TO 2 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE " 002 EQUAL TO '2'" TO MSG + IF 002 EQUAL TO '2' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'002' EQUAL TO 2" TO MSG + IF '002' EQUAL TO 2 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'002' EQUAL TO '2'" TO MSG + IF '002' EQUAL TO '2' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + DISPLAY " " + MOVE " 002 EQUAL TO 002" TO MSG + IF 002 EQUAL TO 002 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE " 002 EQUAL TO '002'" TO MSG + IF 002 EQUAL TO '002' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'002' EQUAL TO 002" TO MSG + IF '002' EQUAL TO 002 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE "'002' EQUAL TO '002'" TO MSG + IF '002' EQUAL TO '002' THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + DISPLAY " " + MOVE " 1000 EQUAL TO 999PPP" TO MSG + MOVE 1000 TO 999PPP. + IF 1000 EQUAL TO 999PPP THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + MOVE " 0.0001 EQUAL TO PPP999" TO MSG + MOVE 0.0001 TO PPP999. + IF 0.0001 EQUAL TO PPP999 THEN DISPLAY MSG ELSE DISPLAY MSG " NOT" END-IF + STOP RUN. + END PROGRAM bigif. diff --git a/gcc/testsuite/cobol.dg/group1/multiply2.cob b/gcc/testsuite/cobol.dg/group1/multiply2.cob new file mode 100644 index 000000000000..cafe2cc9b3c2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/multiply2.cob @@ -0,0 +1,68 @@ +*> { dg-do run } +*> { dg-output {Test of MULTIPLY\. All results should be 20(\n|\r\n|\r)} } +*> { dg-output {TEST01\-1 20 20 20(\n|\r\n|\r)} } +*> { dg-output {TEST01\-2 20 20 20(\n|\r\n|\r)} } +*> { dg-output {TEST02\-1 20(\n|\r\n|\r)} } +*> { dg-output {TEST02\-2 20(\n|\r\n|\r)} } +*> { dg-output {TEST02\-3 20(\n|\r\n|\r)} } +*> { dg-output {TEST02\-4 20(\n|\r\n|\r)} } +*> { dg-output {TEST02\-5 20 20 20(\n|\r\n|\r)} } +*> { dg-output {TEST02\-6 20 20 20(\n|\r\n|\r)} } +*> { dg-output {TEST02\-7 20 20 20(\n|\r\n|\r)} } +*> { dg-output {TEST02\-8 20 20 20(\n|\r\n|\r)} } +*> { dg-output {Thank you for running the MULTIPLY test\.} } + IDENTIFICATION DIVISION. + PROGRAM-ID. mult. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 A PIC 9 VALUE 4. + 01 B PIC 9 VALUE 5. + 01 X PIC 99 VALUE ZEROS. + 01 Y PIC 99 VALUE ZEROS. + 01 Z PIC 99 VALUE ZEROS. + PROCEDURE DIVISION. + DISPLAY "Test of MULTIPLY. All results should be 20" + *> Two cases of FORMAT 1 + PERFORM SET5. + MULTIPLY 4 BY X Y Z. + DISPLAY "TEST01-1 " X " " Y " " Z + PERFORM SET5. + MULTIPLY A BY X Y Z. + DISPLAY "TEST01-2 " X " " Y " " Z. + *> Eight cases of FORMAT2 2 + PERFORM CLEAR + MULTIPLY 4 BY 5 GIVING X + DISPLAY "TEST02-1 " X + PERFORM CLEAR + MULTIPLY A BY 5 GIVING X + DISPLAY "TEST02-2 " X + PERFORM CLEAR + MULTIPLY 4 BY B GIVING X + DISPLAY "TEST02-3 " X + PERFORM CLEAR + MULTIPLY A BY B GIVING X + DISPLAY "TEST02-4 " X + PERFORM CLEAR + MULTIPLY 4 BY 5 GIVING X Y Z + DISPLAY "TEST02-5 " X " " Y " " Z + PERFORM CLEAR + MULTIPLY A BY 5 GIVING X Y Z + DISPLAY "TEST02-6 " X " " Y " " Z + PERFORM CLEAR + MULTIPLY 4 BY B GIVING X Y Z + DISPLAY "TEST02-7 " X " " Y " " Z + PERFORM CLEAR + MULTIPLY A BY B GIVING X Y Z + DISPLAY "TEST02-8 " X " " Y " " Z + DISPLAY "Thank you for running the MULTIPLY test." + STOP RUN. + CLEAR. + MOVE 0 TO X + MOVE 0 TO Y + MOVE 0 TO Z. + SET5. + MOVE 5 TO X + MOVE 5 TO Y + MOVE 5 TO Z. + LAST-PARAGRAPH. + END PROGRAM mult. diff --git a/gcc/testsuite/cobol.dg/group1/packed.cob b/gcc/testsuite/cobol.dg/group1/packed.cob new file mode 100644 index 000000000000..7a86e7ac0ed0 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/packed.cob @@ -0,0 +1,73 @@ +*> { dg-do run } +*> { dg-output {123(\n|\r\n|\r)} } +*> { dg-output {16146(\n|\r\n|\r)} } +*> { dg-output {0x0000000000003f12(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {123(\n|\r\n|\r)} } +*> { dg-output {16146(\n|\r\n|\r)} } +*> { dg-output {0x0000000000003f12(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {\+123(\n|\r\n|\r)} } +*> { dg-output {15378(\n|\r\n|\r)} } +*> { dg-output {0x0000000000003c12(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {\-123(\n|\r\n|\r)} } +*> { dg-output {15634(\n|\r\n|\r)} } +*> { dg-output {0x0000000000003d12(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {properly FALSE(\n|\r\n|\r)} } +*> { dg-output {properly TRUE(\n|\r\n|\r)} } +*> { dg-output {properly FALSE} } + identification division. + program-id. packed. + data division. + working-storage section. + 01 filler. + 02 as-num binary-double unsigned. + 02 as-hex redefines as-num pointer. + 01 filler. + 02 p1 pic 999 comp-3 value 1. + 02 dp1 redefines p1 binary-short unsigned. + 01 filler. + 02 sp1 pic s999 comp-3 value 1. + 02 sdp1 redefines sp1 binary-short unsigned. + procedure division. + move 123 to p1 + display p1 + display dp1 + move dp1 to as-num. + display as-hex. + display space + move -123 to p1 + display p1 + display dp1 + move dp1 to as-num. + display as-hex. + display space + move 123 to sp1 + display sp1 + display sdp1 + move sdp1 to as-num. + display as-hex. + display space + move -123 to sp1 + display sp1 + display sdp1 + move sdp1 to as-num. + display as-hex. + display space + move 2 to p1 + move 2 to sp1 + if p1 < sp1 + DISPLAY "improperly TRUE" + else + DISPLAY "properly FALSE". + if p1 = sp1 + DISPLAY "properly TRUE" + else + DISPLAY "improperly FALSE". + if p1 > sp1 + DISPLAY "improperly TRUE" + else + DISPLAY "properly FALSE". + stop run. diff --git a/gcc/testsuite/cobol.dg/group1/perform-nested-exit.cob b/gcc/testsuite/cobol.dg/group1/perform-nested-exit.cob new file mode 100644 index 000000000000..e256056f4736 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/perform-nested-exit.cob @@ -0,0 +1,84 @@ +*> { dg-do run } +*> { dg-output {00 About to start\.\.\.(\n|\r\n|\r)} } +*> { dg-output {01 I am a(\n|\r\n|\r)} } +*> { dg-output {02 I am b(\n|\r\n|\r)} } +*> { dg-output {03 I am c(\n|\r\n|\r)} } +*> { dg-output {04 I am d(\n|\r\n|\r)} } +*> { dg-output {04 fall through to z(\n|\r\n|\r)} } +*> { dg-output {04 I am z(\n|\r\n|\r)} } +*> { dg-output {03 back from d through z; fall through to d(\n|\r\n|\r)} } +*> { dg-output {03 I am d(\n|\r\n|\r)} } +*> { dg-output {03 fall through to z(\n|\r\n|\r)} } +*> { dg-output {03 I am z(\n|\r\n|\r)} } +*> { dg-output {02 back from c through z; fall through to c(\n|\r\n|\r)} } +*> { dg-output {02 I am c(\n|\r\n|\r)} } +*> { dg-output {03 I am d(\n|\r\n|\r)} } +*> { dg-output {03 fall through to z(\n|\r\n|\r)} } +*> { dg-output {03 I am z(\n|\r\n|\r)} } +*> { dg-output {02 back from d through z; fall through to d(\n|\r\n|\r)} } +*> { dg-output {02 I am d(\n|\r\n|\r)} } +*> { dg-output {02 fall through to z(\n|\r\n|\r)} } +*> { dg-output {02 I am z(\n|\r\n|\r)} } +*> { dg-output {01 back from b through z; fall through to b(\n|\r\n|\r)} } +*> { dg-output {01 I am b(\n|\r\n|\r)} } +*> { dg-output {02 I am c(\n|\r\n|\r)} } +*> { dg-output {03 I am d(\n|\r\n|\r)} } +*> { dg-output {03 fall through to z(\n|\r\n|\r)} } +*> { dg-output {03 I am z(\n|\r\n|\r)} } +*> { dg-output {02 back from d through z; fall through to d(\n|\r\n|\r)} } +*> { dg-output {02 I am d(\n|\r\n|\r)} } +*> { dg-output {02 fall through to z(\n|\r\n|\r)} } +*> { dg-output {02 I am z(\n|\r\n|\r)} } +*> { dg-output {01 back from c through z; fall through to c(\n|\r\n|\r)} } +*> { dg-output {01 I am c(\n|\r\n|\r)} } +*> { dg-output {02 I am d(\n|\r\n|\r)} } +*> { dg-output {02 fall through to z(\n|\r\n|\r)} } +*> { dg-output {02 I am z(\n|\r\n|\r)} } +*> { dg-output {01 back from d through z; fall through to d(\n|\r\n|\r)} } +*> { dg-output {01 I am d(\n|\r\n|\r)} } +*> { dg-output {01 fall through to z(\n|\r\n|\r)} } +*> { dg-output {01 I am z(\n|\r\n|\r)} } +*> { dg-output {00 back from a through z} } + ID DIVISION. + PROGRAM-ID. playpen. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy pic x. + 01 level pic 99 value 0. + PROCEDURE DIVISION. + display level " About to start...". + add 1 to level + perform a through z. + subtract 1 from level + display level " back from a through z". + STOP RUN. + a. + display level " I am a" + add 1 to level + perform b through z + subtract 1 from level + display level + " back from b through z; fall through to b". + b. + display level " I am b" + add 1 to level + perform c through z + subtract 1 from level + display level + " back from c through z; fall through to c". + c. + display level " I am c" + add 1 to level + perform d through z. + subtract 1 from level + display level + " back from d through z; fall through to d". + d. + display level " I am d" + display level + " fall through to z". + z. + display level " I am z". + zzz. + display level " I am zzz". + END PROGRAM playpen. diff --git a/gcc/testsuite/cobol.dg/group1/pointer1.cob b/gcc/testsuite/cobol.dg/group1/pointer1.cob new file mode 100644 index 000000000000..0fa3a0eb7e49 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/pointer1.cob @@ -0,0 +1,98 @@ +*> { dg-do run } +*> { dg-output {000000259(\n|\r\n|\r)} } +*> { dg-output {0x0000000000000103(\n|\r\n|\r)} } +*> { dg-output {Faith (\n|\r\n|\r)} } +*> { dg-output {Hope (\n|\r\n|\r)} } +*> { dg-output {Charity (\n|\r\n|\r)} } +*> { dg-output {Pointers are correctly equal (\n|\r\n|\r)} } +*> { dg-output {Pointers are correctly different(\n|\r\n|\r)} } +*> { dg-output {Pointers are correctly different(\n|\r\n|\r)} } +*> { dg-output {Pointers are correctly different(\n|\r\n|\r)} } +*> { dg-output {Pointers are correctly different(\n|\r\n|\r)} } +*> { dg-output {Pointers are correctly equal (\n|\r\n|\r)} } +*> { dg-output {Pointers are correctly equal (\n|\r\n|\r)} } +*> { dg-output {Pointers are correctly equal (\n|\r\n|\r)} } +*> { dg-output {NOT EQUAL is correctly FALSE } } + ID DIVISION. + PROGRAM-ID. pointers. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WS-POINTER USAGE IS POINTER . + 01 WS-PVALUE REDEFINES WS-POINTER PIC 9(9) COMP-5. + 01 WS-POINTER2 USAGE IS POINTER . + 01 WS-PVALUE2 REDEFINES WS-POINTER2 PIC 9(9) COMP-5. + 01 VALUE-SOURCE1 PIC X(12). + 01 VALUE-SOURCE2 PIC X(12). + 01 VALUE-SOURCE3 PIC X(12). + 01 VALUE-DEST PIC X(12). + LINKAGE SECTION. + 01 DEREFERENCER PIC X(12). + PROCEDURE DIVISION. + MOVE 259 TO WS-PVALUE + DISPLAY WS-PVALUE + DISPLAY WS-POINTER + *> Pointer manipulation: ADDRESS OF to ADDRESS OF + MOVE "Faith" TO VALUE-SOURCE1 + SET ADDRESS OF DEREFERENCER TO ADDRESS OF VALUE-SOURCE1 + MOVE DEREFERENCER TO VALUE-DEST + DISPLAY VALUE-DEST + *> Pointer manipulation: POINTER to ADDRESS OF + *> ADDRESS OF to POINTER + MOVE "Hope" TO VALUE-SOURCE2 + SET WS-POINTER TO ADDRESS OF VALUE-SOURCE2 + SET ADDRESS OF DEREFERENCER TO WS-POINTER + DISPLAY DEREFERENCER + *> Pointer manipulation: Pointer to pointer: + MOVE "Charity" TO VALUE-SOURCE3 + SET WS-POINTER2 TO ADDRESS OF VALUE-SOURCE3 + SET WS-POINTER TO WS-POINTER2 + SET ADDRESS OF DEREFERENCER TO WS-POINTER + DISPLAY DEREFERENCER + IF WS-POINTER EQUAL TO WS-POINTER2 + DISPLAY "Pointers are correctly equal " + ELSE + DISPLAY "Pointers are incorrectly different". + SET WS-POINTER2 TO ADDRESS OF VALUE-DEST + IF WS-POINTER EQUAL TO WS-POINTER2 + DISPLAY "Pointers are incorrectly equal" + ELSE + DISPLAY "Pointers are correctly different" + SET WS-POINTER TO NULL + IF WS-POINTER EQUAL TO WS-POINTER2 + DISPLAY "Pointers are incorrectly equal" + ELSE + DISPLAY "Pointers are correctly different" + IF NULL EQUAL TO WS-POINTER2 + DISPLAY "Pointers are incorrectly equal" + ELSE + DISPLAY "Pointers are correctly different" + IF WS-POINTER2 EQUAL TO NULL + DISPLAY "Pointers are incorrectly equal" + ELSE + DISPLAY "Pointers are correctly different" + SET WS-POINTER2 TO NULL + IF WS-POINTER EQUAL TO WS-POINTER2 + DISPLAY "Pointers are correctly equal " + ELSE + DISPLAY "Pointers are incorrectly different". + IF WS-POINTER EQUAL TO NULL + DISPLAY "Pointers are correctly equal " + ELSE + DISPLAY "Pointers are incorrectly different". + IF WS-POINTER EQUAL TO NULL + DISPLAY "Pointers are correctly equal " + ELSE + DISPLAY "Pointers are incorrectly different". + PERFORM one-last-dance + STOP RUN. + one-last-dance. + IF WS-POINTER NOT EQUAL TO NULL + *>Making sure comments don't cause trouble + DISPLAY "Pointers are incorrectly EQUAL " + ELSE + *>Making sure comments don't cause trouble + DISPLAY "NOT EQUAL is correctly FALSE " + END-IF. + one-last-dance-end. + DISPLAY "We should never get here". + END PROGRAM pointers. diff --git a/gcc/testsuite/cobol.dg/group1/simple-arithmetic.cob b/gcc/testsuite/cobol.dg/group1/simple-arithmetic.cob new file mode 100644 index 000000000000..b367fc157df5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/simple-arithmetic.cob @@ -0,0 +1,61 @@ +*> { dg-do run } +*> { dg-output {Numeric Display arithmetic(\n|\r\n|\r)} } +*> { dg-output {Num1 is \+5; Num2 is \+4(\n|\r\n|\r)} } +*> { dg-output {Product should be \+20, is = \+20(\n|\r\n|\r)} } +*> { dg-output {Sum should be \+09, is = \+09(\n|\r\n|\r)} } +*> { dg-output {Difference should be \-01, is = \-01(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {COMP\-5 Arithmetic(\n|\r\n|\r)} } +*> { dg-output {Num1_5 is \+0000000000005; Num2_5 is \+0000000000004(\n|\r\n|\r)} } +*> { dg-output {Product should be \+0000000000020, is = \+0000000000020(\n|\r\n|\r)} } +*> { dg-output {Sum should be \+0000000000009, is = \+0000000000009(\n|\r\n|\r)} } +*> { dg-output {Difference should be \-0000000000001, is = \-0000000000001(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {COMP\-3 Arithmetic(\n|\r\n|\r)} } +*> { dg-output {Num1_3 is \+0000000000005; Num2_3 is \+0000000000004(\n|\r\n|\r)} } +*> { dg-output {Product should be \+0000000000020, is = \+0000000000020(\n|\r\n|\r)} } +*> { dg-output {Sum should be \+0000000000009, is = \+0000000000009(\n|\r\n|\r)} } +*> { dg-output {Difference should be \-0000000000001, is = \-0000000000001(\n|\r\n|\r)} } +*> { dg-output { } } + IDENTIFICATION DIVISION. + PROGRAM-ID. math. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Num1 PIC S9 VALUE 5. + 01 Num2 PIC S9 VALUE 4. + 01 Result PIC S99 VALUE ZEROS. + 01 Num1_5 PIC S9999999999999 COMP-5 VALUE 5. + 01 Num2_5 PIC S9999999999999 COMP-5 VALUE 4. + 01 Result_5 PIC S9999999999999 COMP-5 VALUE ZEROS. + 01 Num1_3 PIC S9999999999999 COMP-3 VALUE 5. + 01 Num2_3 PIC S9999999999999 COMP-3 VALUE 4. + 01 Result_3 PIC S9999999999999 COMP-3 VALUE ZEROS. + PROCEDURE DIVISION. + DISPLAY "Numeric Display arithmetic" + DISPLAY "Num1 is " Num1 "; Num2 is " Num2 + MULTIPLY Num1 BY Num2 GIVING Result + DISPLAY "Product should be +20, is = ", Result + ADD Num1 TO Num2 GIVING Result + DISPLAY "Sum should be +09, is = ", Result + SUBTRACT Num1 FROM Num2 GIVING Result + DISPLAY "Difference should be -01, is = ", Result + DISPLAY " " + DISPLAY "COMP-5 Arithmetic" + DISPLAY "Num1_5 is " Num1_5 "; Num2_5 is " Num2_5 + MULTIPLY Num1_5 BY Num2_5 GIVING Result_5 + DISPLAY "Product should be +0000000000020, is = ", Result_5 + ADD Num1_5 TO Num2_5 GIVING Result_5 + DISPLAY "Sum should be +0000000000009, is = ", Result_5 + SUBTRACT Num1_5 FROM Num2_5 GIVING Result_5 + DISPLAY "Difference should be -0000000000001, is = ", Result_5 + DISPLAY " " + DISPLAY "COMP-3 Arithmetic" + DISPLAY "Num1_3 is " Num1_3 "; Num2_3 is " Num2_3 + MULTIPLY Num1_3 BY Num2_3 GIVING Result_3 + DISPLAY "Product should be +0000000000020, is = ", Result_3 + ADD Num1_3 TO Num2_3 GIVING Result_3 + DISPLAY "Sum should be +0000000000009, is = ", Result_3 + SUBTRACT Num1_3 FROM Num2_3 GIVING Result_3 + DISPLAY "Difference should be -0000000000001, is = ", Result_3 + DISPLAY " " + STOP RUN. diff --git a/gcc/testsuite/cobol.dg/group1/simple-classes.cob b/gcc/testsuite/cobol.dg/group1/simple-classes.cob new file mode 100644 index 000000000000..6b3a90d14524 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/simple-classes.cob @@ -0,0 +1,68 @@ +*> { dg-do run } +*> { dg-output {0 is a hexadecimal number(\n|\r\n|\r)} } +*> { dg-output {Dead is a hexadecimal number(\n|\r\n|\r)} } +*> { dg-output {Fred is not a hexadecimal number(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {0 is not a real name(\n|\r\n|\r)} } +*> { dg-output {Dead is a real name(\n|\r\n|\r)} } +*> { dg-output {Fred is a real name(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {0 is not alphabetic(\n|\r\n|\r)} } +*> { dg-output {Dead is alphabetic(\n|\r\n|\r)} } +*> { dg-output {Fred is alphabetic(\n|\r\n|\r)} } +*> { dg-output { } } +IDENTIFICATION DIVISION. +PROGRAM-ID. test. +AUTHOR. Michael Coughlan. +*> This routine is based on Listing-5-1 +ENVIRONMENT DIVISION. +CONFIGURATION SECTION. +SPECIAL-NAMES. + CLASS HexNumber IS "0" THRU "9", "A" THRU "F", "a" THRU "f", SPACE + CLASS RealName IS "A" THRU "Z", "a" THRU "z", "'", SPACE. +DATA DIVISION. +WORKING-STORAGE SECTION. +01 NumIn PIC X(4). +01 NameIn PIC X(15). +PROCEDURE DIVISION. + MOVE "0" TO NumIn + PERFORM TestHex. + MOVE "Dead" TO NumIn + PERFORM TestHex. + MOVE "Fred" TO NumIn + PERFORM TestHex. + DISPLAY " " + MOVE "0" TO NameIn + PERFORM TestRealname + MOVE "Dead" TO NameIn + PERFORM TestRealname + MOVE "Fred" TO NameIn + PERFORM TestRealname + DISPLAY " " + MOVE "0" TO NameIn + PERFORM TestAlphabetic + MOVE "Dead" TO NameIn + PERFORM TestAlphabetic + MOVE "Fred" TO NameIn + PERFORM TestAlphabetic + DISPLAY " " + STOP RUN. +TestRealname. + IF NameIn IS RealName THEN + DISPLAY NameIn " is a real name" + ELSE + DISPLAY NameIn " is not a real name" + END-IF. +TestHex. + IF NumIn IS HexNumber THEN + DISPLAY NumIn " is a hexadecimal number" + ELSE + DISPLAY NumIn " is not a hexadecimal number" + END-IF. +TestAlphabetic. + IF NameIn IS ALPHABETIC + DISPLAY NameIn " is alphabetic" + ELSE + DISPLAY NameIn " is not alphabetic" + END-IF. + END PROGRAM test. diff --git a/gcc/testsuite/cobol.dg/group1/simple-if.cob b/gcc/testsuite/cobol.dg/group1/simple-if.cob new file mode 100644 index 000000000000..6cf6ec6dd2ea --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/simple-if.cob @@ -0,0 +1,143 @@ +*> { dg-do run } +*> { dg-output {A_4 is 0005(\n|\r\n|\r)} } +*> { dg-output {B_4 is 0007(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {VALID: A_4 < B_4(\n|\r\n|\r)} } +*> { dg-output {VALID: A_4 <= B_4(\n|\r\n|\r)} } +*> { dg-output {VALID: A_4 <> B_4(\n|\r\n|\r)} } +*> { dg-output {VALID: A_4 NOT = B_4(\n|\r\n|\r)} } +*> { dg-output {VALID: A_4 NOT > B_4(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {CORRECTLY_TRUE: A_4 < B_4(\n|\r\n|\r)} } +*> { dg-output {CORRECTLY_TRUE: A_4 <= B_4(\n|\r\n|\r)} } +*> { dg-output {CORRECTLY_ELSE: A_4 = B_4(\n|\r\n|\r)} } +*> { dg-output {CORRECTLY_TRUE: A_4 <> B_4(\n|\r\n|\r)} } +*> { dg-output {CORRECTLY_ELSE: A_4 >= B_4(\n|\r\n|\r)} } +*> { dg-output {CORRECTLY_ELSE: A_4 > B_4(\n|\r\n|\r)} } +*> { dg-output { (\n|\r\n|\r)} } +*> { dg-output {CORRECTLY_ELSE: A_4 NOT < B_4(\n|\r\n|\r)} } +*> { dg-output {CORRECTLY_TRUE: A_4 NOT = B_4(\n|\r\n|\r)} } +*> { dg-output {CORRECTLY_ELSE: A_4 NOT > B_4(\n|\r\n|\r)} } +*> { dg-output { } } +* Not strictly Reference Format + IDENTIFICATION DIVISION. + PROGRAM-ID. test. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 A_4 PIC 9999 VALUE 5. + 01 B_4 PIC 9999 VALUE 7. + PROCEDURE DIVISION. + DISPLAY "A_4 is " A_4 + DISPLAY "B_4 is " B_4 + DISPLAY " " +*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF A_4 < B_4 THEN + DISPLAY "VALID: A_4 < B_4" + END-IF + IF A_4 <= B_4 THEN + DISPLAY "VALID: A_4 <= B_4" + END-IF + IF A_4 = B_4 THEN + DISPLAY "FALSE: A_4 = B_4" + END-IF + IF A_4 <> B_4 THEN + DISPLAY "VALID: A_4 <> B_4" + END-IF + IF A_4 >= B_4 THEN + DISPLAY "FALSE: A_4 >= B_4" + END-IF + IF A_4 > B_4 THEN + DISPLAY "FALSE: A_4 > B_4" + END-IF +*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF A_4 NOT < B_4 THEN + DISPLAY "FALSE: A_4 NOT < B_4" + END-IF +* This test works when compiled with GnuCOBOL +* IF A_4 NOT <= B_4 THEN +* DISPLAY "FALSE: A_4 NOT <= B_4" +* END-IF + IF A_4 NOT = B_4 THEN + DISPLAY "VALID: A_4 NOT = B_4" + END-IF +* This test works when compiled with GnuCOBOL +* IF A_4 NOT <> B_4 THEN +* DISPLAY "FALSE: A_4 NOT <> B_4" +* END-IF +* This test works when compiled with GnuCOBOL +* IF A_4 NOT >= B_4 THEN +* DISPLAY "VALID: A_4 NOT >= B_4" +* END-IF + IF A_4 NOT > B_4 THEN + DISPLAY "VALID: A_4 NOT > B_4" + END-IF + DISPLAY " " +*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF A_4 < B_4 THEN + DISPLAY "CORRECTLY_TRUE: A_4 < B_4" + ELSE + DISPLAY "INCORRECT: A_4 < B_4" + END-IF + IF A_4 <= B_4 THEN + DISPLAY "CORRECTLY_TRUE: A_4 <= B_4" + ELSE + DISPLAY "INCORRECT: A_4 <= B_4" + END-IF + IF A_4 = B_4 THEN + DISPLAY "INCORRECT: A_4 = B_4" + ELSE + DISPLAY "CORRECTLY_ELSE: A_4 = B_4" + END-IF + IF A_4 <> B_4 THEN + DISPLAY "CORRECTLY_TRUE: A_4 <> B_4" + ELSE + DISPLAY "INCORRECT: A_4 <> B_4" + END-IF + IF A_4 >= B_4 THEN + DISPLAY "INCORRECT: A_4 >= B_4" + ELSE + DISPLAY "CORRECTLY_ELSE: A_4 >= B_4" + END-IF + IF A_4 > B_4 THEN + DISPLAY "INCORRECT: A_4 > B_4" + ELSE + DISPLAY "CORRECTLY_ELSE: A_4 > B_4" + END-IF + DISPLAY " " +*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF A_4 NOT < B_4 THEN + DISPLAY "INCORRECT: A_4 NOT < B_4" + ELSE + DISPLAY "CORRECTLY_ELSE: A_4 NOT < B_4" + END-IF +* This test works when compiled with GnuCOBOL +* IF A_4 NOT <= B_4 THEN +* DISPLAY "INCORRECT: A_4 NOT <= B_4" +* ELSE +* DISPLAY "CORRECTLY_ELSE: A_4 NOT <= B_4" +* END-IF + IF A_4 NOT = B_4 THEN + DISPLAY "CORRECTLY_TRUE: A_4 NOT = B_4" + ELSE + DISPLAY "INCORRECT: A_4 NOT = B_4" + END-IF +* This test works when compiled with GnuCOBOL +* IF A_4 NOT <> B_4 THEN +* DISPLAY "INCORRECT: A_4 NOT <> B_4" +* ELSE +* DISPLAY "CORRECTLY_ELSE: A_4 NOT <> B_4" +* END-IF +* This test works when compiled with GnuCOBOL +* IF A_4 NOT >= B_4 THEN +* DISPLAY "CORRECTLY_TRUE: A_4 NOT >= B_4" +* ELSE +* DISPLAY "INCORRECT: A_4 NOT >= B_4" +* END-IF + IF A_4 NOT > B_4 THEN + DISPLAY "CORRECTLY_ELSE: A_4 NOT > B_4" + ELSE + DISPLAY "INCORRECT: A_4 NOT > B_4" + END-IF + DISPLAY " " +*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + STOP RUN. diff --git a/gcc/testsuite/cobol.dg/group1/simple-perform.cob b/gcc/testsuite/cobol.dg/group1/simple-perform.cob new file mode 100644 index 000000000000..00f7b6f4058c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group1/simple-perform.cob @@ -0,0 +1,52 @@ +*> { dg-do run } +*> { dg-output {Do a forward\-reference PERFORM para_CCC(\n|\r\n|\r)} } +*> { dg-output { We are inside para_CCC(\n|\r\n|\r)} } +*> { dg-output {We are about to fall through the para_AAA, para_BBB, and para_CCC definitions(\n|\r\n|\r)} } +*> { dg-output { We are inside para_AAA(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output { We are inside para_CCC(\n|\r\n|\r)} } +*> { dg-output {We are about to PERFORM para_AAA(\n|\r\n|\r)} } +*> { dg-output { We are inside para_AAA(\n|\r\n|\r)} } +*> { dg-output {We are about to PERFORM para_BBB three times(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output {We are about to PERFORM para_BBB through para_CCC(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output { We are inside para_CCC(\n|\r\n|\r)} } +*> { dg-output {We are about to PERFORM para_BBB through para_CCC another five times(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output { We are inside para_CCC(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output { We are inside para_CCC(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output { We are inside para_CCC(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output { We are inside para_CCC(\n|\r\n|\r)} } +*> { dg-output { We are inside para_BBB(\n|\r\n|\r)} } +*> { dg-output { We are inside para_CCC(\n|\r\n|\r)} } +*> { dg-output {Thank you for visiting the PERFORM PARAGRAPH demo} } +IDENTIFICATION DIVISION. +PROGRAM-ID. PerformParagraphs. +PROCEDURE DIVISION. + DISPLAY "Do a forward-reference PERFORM para_CCC" + PERFORM para_CCC + DISPLAY "We are about to fall through the para_AAA, para_BBB, and para_CCC definitions". +para_AAA. + DISPLAY " We are inside para_AAA". +para_BBB. + DISPLAY " We are inside para_BBB". +para_CCC. + DISPLAY " We are inside para_CCC". +para_DDD. + DISPLAY "We are about to PERFORM para_AAA" + PERFORM para_AAA + DISPLAY "We are about to PERFORM para_BBB three times" + PERFORM para_BBB 3 times + DISPLAY "We are about to PERFORM para_BBB through para_CCC" + PERFORM para_BBB through para_CCC + DISPLAY "We are about to PERFORM para_BBB through para_CCC another five times" + PERFORM para_BBB through para_CCC 5 times + DISPLAY "Thank you for visiting the PERFORM PARAGRAPH demo" + STOP RUN. + END PROGRAM PerformParagraphs. -- 2.34.1
