https://gcc.gnu.org/g:ae2f951cc22ba9b0b1c8650d4de553344fc4fb95
commit r15-9005-gae2f951cc22ba9b0b1c8650d4de553344fc4fb95
Author: Bob Dubner <rdub...@symas.com>
Date: Fri Mar 28 08:57:24 2025 -0400
cobol: Eliminate check-cobol -Os failure in EVALUATE testcase
The coding error was the lack of a necessary cast from unsigned
char to int.
gcc/cobol
* genapi.cc: (create_and_call): cast unsigned char to int
gcc/testsuite
* cobol.dg/group2/Complex_EVALUATE__1_.cob: New EVALUTE testcase.
* cobol.dg/group2/Complex_EVALUATE__2_.cob: Likewise.
* cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.cob: Likewise.
* cobol.dg/group2/EVALUATE_condition__2_.cob: Likewise.
* cobol.dg/group2/EVALUATE_doubled_WHEN.cob: Likewise.
* cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.cob:
Likewise.
* cobol.dg/group2/Complex_EVALUATE__1_.out: Known-good data for
testcase.
* cobol.dg/group2/Complex_EVALUATE__2_.out: Likewise.
* cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.out: Likewise.
* cobol.dg/group2/EVALUATE_condition__2_.out: Likewise.
* cobol.dg/group2/EVALUATE_doubled_WHEN.out: Likewise.
* cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.out:
Likewise.
Diff:
---
gcc/cobol/genapi.cc | 3 +-
.../cobol.dg/group2/Complex_EVALUATE__1_.cob | 46 +++++++++++++++++++
.../cobol.dg/group2/Complex_EVALUATE__1_.out | 5 +++
.../cobol.dg/group2/Complex_EVALUATE__2_.cob | 52 ++++++++++++++++++++++
.../cobol.dg/group2/Complex_EVALUATE__2_.out | 15 +++++++
.../cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.cob | 16 +++++++
.../cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.out | 2 +
.../cobol.dg/group2/EVALUATE_condition__2_.cob | 38 ++++++++++++++++
.../cobol.dg/group2/EVALUATE_condition__2_.out | 5 +++
.../cobol.dg/group2/EVALUATE_doubled_WHEN.cob | 30 +++++++++++++
.../cobol.dg/group2/EVALUATE_doubled_WHEN.out | 5 +++
.../EVALUATE_with_WHEN_using_condition-1.cob | 18 ++++++++
.../EVALUATE_with_WHEN_using_condition-1.out | 2 +
13 files changed, 236 insertions(+), 1 deletion(-)
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index bc9153381588..8adc07ec57fa 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -12395,13 +12395,14 @@ create_and_call(size_t narg,
// We got back a 64-bit or 128-bit integer. The called and calling
// programs have to agree on size, but other than that, integer numeric
// types are converted one to the other.
+
gg_call(VOID,
"__gg__int128_to_qualified_field",
gg_get_address_of(returned.field->var_decl_node),
refer_offset_dest(returned),
refer_size_dest(returned),
gg_cast(INT128, returned_value),
- member(returned.field->var_decl_node, "rdigits"),
+ gg_cast(INT, member(returned.field->var_decl_node, "rdigits")),
build_int_cst_type(INT, truncation_e),
null_pointer_node,
NULL_TREE );
diff --git a/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.cob
b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.cob
new file mode 100644
index 000000000000..a070d16108e9
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.cob
@@ -0,0 +1,46 @@
+ *> { dg-do run }
+ *> { dg-output-file "group2/Complex_EVALUATE__1_.out" }
+
+ identification division.
+ function-id. bumper.
+ data division.
+ working-storage section.
+ 77 bump pic 9999 value zero.
+ linkage section.
+ 77 bumped pic 9999.
+ procedure division returning bumped.
+ add 1 to bump.
+ move bump to bumped.
+ goback.
+ end function bumper.
+
+ identification division.
+ program-id. prog.
+ environment division.
+ configuration section.
+ repository.
+ function bumper.
+ data division.
+ working-storage section.
+ 77 bump pic 9999 value zero.
+ 77 bump1 pic 9999 value zero.
+ 77 bump2 pic 9999 value zero.
+ 77 bump3 pic 9999 value zero.
+ procedure division.
+ move function bumper to bump
+ display bump
+ move function bumper to bump
+ display bump
+ move function bumper to bump
+ display bump
+ evaluate function bumper also function bumper also function bumper
+ when 4 also 5 also 6
+ display "properly 4 also 5 also 6"
+ when 7 also 8 also 9
+ display "IMPROPERLY 6 then 7 then 8"
+ when other
+ display "we don't know what's going on"
+ end-evaluate
+ goback.
+ end program prog.
+
diff --git a/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.out
b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.out
new file mode 100644
index 000000000000..d634a794f0f3
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__1_.out
@@ -0,0 +1,5 @@
+0001
+0002
+0003
+properly 4 also 5 also 6
+
diff --git a/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.cob
b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.cob
new file mode 100644
index 000000000000..0e88d74382ee
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.cob
@@ -0,0 +1,52 @@
+ *> { dg-do run }
+ *> { dg-output-file "group2/Complex_EVALUATE__2_.out" }
+
+ identification division.
+ function-id. bumper.
+ data division.
+ working-storage section.
+ 77 bump pic 9999 value zero.
+ linkage section.
+ 77 bumped pic 9999.
+ procedure division returning bumped.
+ add 1 to bump.
+ move bump to bumped.
+ display " bumper is returning " bumped
+ goback.
+ end function bumper.
+
+ identification division.
+ program-id. prog.
+ environment division.
+ configuration section.
+ repository.
+ function bumper.
+ data division.
+ working-storage section.
+ 77 bump pic 9999 value zero.
+ procedure division.
+ display " Prime the pump with three calls to bumper"
+ move function bumper to bump
+ move function bumper to bump
+ move function bumper to bump
+ display " Three calls to BUMPER should follow"
+ evaluate function bumper also function bumper also function bumper
+ when 4 also 5 also 6
+ display "properly 4 also 5 also 6"
+ when 7 also 8 also 9
+ display "IMPROPERLY 7 also 8 also 9"
+ when other
+ display "IMPROPERLY we don't know what's going on"
+ end-evaluate
+ display " Three more calls to BUMPER should follow"
+ evaluate function bumper also function bumper also function bumper
+ when 4 also 5 also 6
+ display "IMPROPERLY 4 also 5 also 6"
+ when 7 also 8 also 9
+ display "properly 7 also 8 also 9"
+ when other
+ display "IMPROPERLY we don't know what's going on"
+ end-evaluate
+ goback.
+ end program prog.
+
diff --git a/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.out
b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.out
new file mode 100644
index 000000000000..b0e9bdb3f898
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/Complex_EVALUATE__2_.out
@@ -0,0 +1,15 @@
+ Prime the pump with three calls to bumper
+ bumper is returning 0001
+ bumper is returning 0002
+ bumper is returning 0003
+ Three calls to BUMPER should follow
+ bumper is returning 0004
+ bumper is returning 0005
+ bumper is returning 0006
+properly 4 also 5 also 6
+ Three more calls to BUMPER should follow
+ bumper is returning 0007
+ bumper is returning 0008
+ bumper is returning 0009
+properly 7 also 8 also 9
+
diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.cob
b/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.cob
new file mode 100644
index 000000000000..798f18b3580a
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.cob
@@ -0,0 +1,16 @@
+ *> { dg-do run }
+ *> { dg-output-file "group2/EVALUATE_WHEN_NEGATIVE.out" }
+
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 77 num pic s9.
+ procedure division.
+ move -1 to num
+ evaluate num
+ when negative
+ display "negative"
+ end-evaluate.
+ end program prog.
+
diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.out
b/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.out
new file mode 100644
index 000000000000..126adb7fbf77
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_WHEN_NEGATIVE.out
@@ -0,0 +1,2 @@
+negative
+
diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.cob
b/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.cob
new file mode 100644
index 000000000000..84bc885276fe
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.cob
@@ -0,0 +1,38 @@
+ *> { dg-do run }
+ *> { dg-output-file "group2/EVALUATE_condition__2_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 XVAL PIC X VALUE '_'.
+ 88 UNDERSCORE VALUE '_'.
+ PROCEDURE DIVISION.
+ DISPLAY 'Next line should be "UNDERSCORE evaluates to TRUE"'
+ EVALUATE TRUE
+ WHEN NOT UNDERSCORE
+ DISPLAY
+ "***IMPROPERLY*** NOT UNDERSCORE evaluates to TRUE"
+ END-DISPLAY
+ END-EVALUATE.
+ EVALUATE TRUE
+ WHEN UNDERSCORE
+ DISPLAY "UNDERSCORE evaluates to TRUE"
+ END-DISPLAY
+ END-EVALUATE.
+
+ DISPLAY
+ 'Next line should be "NOT UNDERSCORE evaluates to FALSE"'
+ EVALUATE FALSE
+ WHEN NOT UNDERSCORE
+ DISPLAY "NOT UNDERSCORE evaluates to FALSE"
+ END-DISPLAY
+ END-EVALUATE.
+ EVALUATE FALSE
+ WHEN UNDERSCORE
+ DISPLAY
+ "***IMPROPERLY*** UNDERSCORE evaluates to FALSE"
+ END-DISPLAY
+ END-EVALUATE.
+ STOP RUN.
+
diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.out
b/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.out
new file mode 100644
index 000000000000..adff5ca7e9d1
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_condition__2_.out
@@ -0,0 +1,5 @@
+Next line should be "UNDERSCORE evaluates to TRUE"
+UNDERSCORE evaluates to TRUE
+Next line should be "NOT UNDERSCORE evaluates to FALSE"
+NOT UNDERSCORE evaluates to FALSE
+
diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.cob
b/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.cob
new file mode 100644
index 000000000000..50ff9586eabb
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.cob
@@ -0,0 +1,30 @@
+ *> { dg-do run }
+ *> { dg-output-file "group2/EVALUATE_doubled_WHEN.out" }
+
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 77 eval pic x(4).
+ procedure division.
+ move "open" to eval
+ display "about to EVALUATE eval " """" eval """"
+ evaluate true
+ when eval = 'open'
+ when eval = 'OPEN'
+ display "Good: We got us an " """" eval """"
+ when other
+ display "BAD!!! It shoulda been " """" eval """"
+ end-evaluate
+ move "OPEN" to eval
+ display "about to EVALUATE eval " """" eval """"
+ evaluate true
+ when eval = 'open'
+ when eval = 'OPEN'
+ display "Good: We got us an " """" eval """"
+ when other
+ display "BAD!!! It shoulda been " """" eval """"
+ end-evaluate
+ goback.
+ end program prog.
+
diff --git a/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.out
b/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.out
new file mode 100644
index 000000000000..c4fa148b2a8c
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_doubled_WHEN.out
@@ -0,0 +1,5 @@
+about to EVALUATE eval "open"
+Good: We got us an "open"
+about to EVALUATE eval "OPEN"
+Good: We got us an "OPEN"
+
diff --git
a/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.cob
b/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.cob
new file mode 100644
index 000000000000..ed4c89a153f9
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.cob
@@ -0,0 +1,18 @@
+ *> { dg-do run }
+ *> { dg-output-file "group2/EVALUATE_with_WHEN_using_condition-1.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 var-1 PIC 99V9.
+ 88 var-1-big VALUE 20 THRU 40.
+ 88 var-1-huge VALUE 40 THRU 99.
+ PROCEDURE DIVISION.
+ EVALUATE TRUE *> not: var-1
+ WHEN var-1-big DISPLAY "big"
+ WHEN var-1-huge DISPLAY "huge"
+ WHEN OTHER DISPLAY "not"
+ END-EVALUATE.
+ END PROGRAM prog.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.out
b/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.out
new file mode 100644
index 000000000000..3043bcc5dfa3
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EVALUATE_with_WHEN_using_condition-1.out
@@ -0,0 +1,2 @@
+not
+
