From 3d05d7e96f0adf8d7f8ec83c63045ba3c70b5f20 Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Thu, 4 Jan 2024 19:21:43 -0500
Subject: [PATCH] UAT - more shuffling of tests
---
gcc/cobol/UAT/failsuite.src/run_functions.at | 495 ------------------
gcc/cobol/UAT/failsuite.src/syn_move.at | 32 --
gcc/cobol/UAT/skipsuite.at | 6 +-
gcc/cobol/UAT/skipsuite.src/run_functions.at | 499 +++++++++++++++++++
gcc/cobol/UAT/testsuite.src/run_functions.at | 19 +
gcc/cobol/UAT/testsuite.src/syn_move.at | 28 ++
gcc/cobol/failures/playpen/playpen.cbl | 29 +-
7 files changed, 563 insertions(+), 545 deletions(-)
create mode 100644 gcc/cobol/UAT/skipsuite.src/run_functions.at
diff --git a/gcc/cobol/UAT/failsuite.src/run_functions.at b/gcc/cobol/UAT/failsuite.src/run_functions.at
index 9760fd5b601e..ef5097aece6d 100644
--- a/gcc/cobol/UAT/failsuite.src/run_functions.at
+++ b/gcc/cobol/UAT/failsuite.src/run_functions.at
@@ -21,441 +21,6 @@
### ISO+IEC+1989-2002 15 Intrinsic Functions
### ISO+IEC+1989-2002 9.4 User-Defined Functions
-AT_SETUP([FUNCTION CONTENT-LENGTH])
-AT_KEYWORDS([functions length])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 P USAGE POINTER.
- 01 X PIC X(4) VALUE Z"ABC".
- 01 TEST-FLD USAGE BINARY-LONG.
- PROCEDURE DIVISION.
- MOVE FUNCTION CONTENT-LENGTH ( P )
- TO TEST-FLD.
- IF TEST-FLD NOT = 0
- DISPLAY 'CONTENT-LENGTH NULL wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
- SET P TO ADDRESS OF X
- MOVE FUNCTION CONTENT-LENGTH ( P )
- TO TEST-FLD
- IF TEST-FLD NOT = 3
- DISPLAY 'CONTENT-LENGTH z"abc" wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION CONTENT-OF])
-AT_KEYWORDS([functions POINTER literal BASED ALLOCATE FREE EXCEPTION-STATUS])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 P USAGE POINTER.
- 01 X PIC X(4) VALUE Z"ABC".
- 01 B PIC X(10) BASED.
- PROCEDURE DIVISION.
- SET P TO ADDRESS OF X
- IF FUNCTION CONTENT-OF ( P ) NOT EQUAL 'ABC' THEN
- DISPLAY 'CONTENT-OF(ptr) wrong' END-DISPLAY
- END-IF
- IF FUNCTION CONTENT-OF ( P, 2 ) NOT EQUAL 'AB' THEN
- DISPLAY 'CONTENT-OF(ptr, len) wrong' END-DISPLAY
- END-IF
- IF FUNCTION EXCEPTION-STATUS NOT = SPACES THEN
- DISPLAY 'unexpected exception (1): '
- FUNCTION EXCEPTION-STATUS
- END-DISPLAY
- END-IF
- SET P TO NULL
- MOVE 'PPPP' TO X
- STRING FUNCTION CONTENT-OF ( P )
- DELIMITED BY SIZE
- INTO X
- END-STRING
- *> Note: result *should* depend on dialect option zero-length literals
- IF X NOT EQUAL 'PPPP' THEN
- DISPLAY 'CONTENT-OF empty POINTER wrong: "'" X "'"
- END-DISPLAY
- END-IF
- IF FUNCTION EXCEPTION-STATUS NOT = "EC-DATA-PTR-NULL" THEN
- DISPLAY 'missing exception (1)'
- END-DISPLAY
- END-IF
- ALLOCATE B INITIALIZED
- SET P TO ADDRESS OF B
- IF FUNCTION CONTENT-OF ( P, 1 ) NOT EQUAL SPACES THEN
- DISPLAY 'CONTENT-OF allocated BASED item wrong'
- END-DISPLAY
- END-IF
- IF FUNCTION EXCEPTION-STATUS NOT = SPACES THEN
- DISPLAY 'unexpected exception (2): '
- FUNCTION EXCEPTION-STATUS
- END-DISPLAY
- END-IF
- FREE B
- SET P TO ADDRESS OF B
- MOVE 'BBBB' TO X
- STRING FUNCTION CONTENT-OF ( P )
- DELIMITED BY SIZE
- INTO X
- END-STRING
- *> Note: result *should* depend on dialect option zero-length literals
- IF X NOT EQUAL 'BBBB' THEN
- DISPLAY 'CONTENT-OF unallocated BASED item wrong: "' X '"'
- END-DISPLAY
- END-IF
- IF FUNCTION EXCEPTION-STATUS NOT = "EC-DATA-PTR-NULL" THEN
- DISPLAY 'missing exception (2)'
- END-DISPLAY
- END-IF
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION CURRENCY-SYMBOL])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-FLD PIC X(8) VALUE SPACES.
- PROCEDURE DIVISION.
- MOVE FUNCTION CURRENCY-SYMBOL TO TEST-FLD.
- DISPLAY "OK" NO ADVANCING
- END-DISPLAY
- STOP RUN.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MODULE-CALLER-ID])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- PROCEDURE DIVISION.
- CALL "prog2"
- END-CALL.
- STOP RUN.
-])
-
-AT_DATA([prog2.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog2.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- PROCEDURE DIVISION.
- DISPLAY FUNCTION MODULE-CALLER-ID NO ADVANCING
- END-DISPLAY.
- EXIT PROGRAM.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COMPILE_MODULE prog2.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [prog])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MODULE-DATE])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-DATE PIC 9(8) VALUE 0.
- PROCEDURE DIVISION.
- MOVE FUNCTION MODULE-DATE TO TEST-DATE.
- IF TEST-DATE NOT = 0
- DISPLAY "OK" NO ADVANCING
- END-DISPLAY
- END-IF.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MODULE-FORMATTED-DATE])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-DATE PIC X(16) VALUE SPACES.
- PROCEDURE DIVISION.
- MOVE FUNCTION MODULE-FORMATTED-DATE TO TEST-DATE.
- IF TEST-DATE NOT = SPACES
- DISPLAY "OK" NO ADVANCING
- END-DISPLAY
- END-IF.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MODULE-ID])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- PROCEDURE DIVISION.
- DISPLAY FUNCTION MODULE-ID NO ADVANCING
- END-DISPLAY.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [prog])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MODULE-PATH])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-PATH PIC X(16) VALUE SPACES.
- PROCEDURE DIVISION.
- MOVE FUNCTION MODULE-PATH TO TEST-PATH.
- IF TEST-PATH NOT = SPACES
- DISPLAY "OK" NO ADVANCING
- END-DISPLAY
- END-IF.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MODULE-SOURCE])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- PROCEDURE DIVISION.
- DISPLAY FUNCTION MODULE-SOURCE NO ADVANCING
- END-DISPLAY.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [prog.cob])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MODULE-TIME])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-TIME PIC 9(6) VALUE 0.
- PROCEDURE DIVISION.
- MOVE FUNCTION MODULE-TIME TO TEST-TIME.
- IF TEST-TIME NOT = 0
- DISPLAY "OK" NO ADVANCING
- END-DISPLAY
- END-IF.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MONETARY-DECIMAL-POINT])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-FLD PIC X(8) VALUE SPACES.
- PROCEDURE DIVISION.
- MOVE FUNCTION MONETARY-DECIMAL-POINT TO TEST-FLD.
- DISPLAY "OK" NO ADVANCING
- END-DISPLAY
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MONETARY-THOUSANDS-SEPARATOR])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-FLD PIC X(8) VALUE SPACES.
- PROCEDURE DIVISION.
- MOVE FUNCTION MONETARY-THOUSANDS-SEPARATOR TO TEST-FLD.
- DISPLAY "OK" NO ADVANCING
- END-DISPLAY
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION NUMERIC-DECIMAL-POINT])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-FLD PIC X(8) VALUE SPACES.
- PROCEDURE DIVISION.
- MOVE FUNCTION NUMERIC-DECIMAL-POINT TO TEST-FLD.
- DISPLAY "OK" NO ADVANCING
- END-DISPLAY
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION NUMERIC-THOUSANDS-SEPARATOR])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-FLD PIC X(8) VALUE SPACES.
- PROCEDURE DIVISION.
- MOVE FUNCTION NUMERIC-THOUSANDS-SEPARATOR TO TEST-FLD.
- DISPLAY "OK" NO ADVANCING
- END-DISPLAY
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION STORED-CHAR-LENGTH])
-AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 Y PIC X(24).
- 01 Z USAGE BINARY-LONG.
- PROCEDURE DIVISION.
- MOVE "123456789012" TO Y.
- MOVE FUNCTION STORED-CHAR-LENGTH ( Y ) TO Z.
- IF Z NOT = 12
- DISPLAY Z
- END-DISPLAY
- END-IF.
- STOP RUN.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
AT_SETUP([Formatted funcs w/ invalid variable format])
AT_KEYWORDS([functions FORMATTED-CURRENT-DATE FORMATTED-DATE
FORMATTED-TIME FORMATTED-DATETIME])
@@ -537,45 +102,6 @@ AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
AT_CLEANUP
-AT_SETUP([FORMATTED-(DATE)TIME with SYSTEM-OFFSET])
-AT_KEYWORDS([functions FORMATTED-TIME FORMATTED-DATETIME extensions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 str PIC X(30).
- 77 val pic 9(02).
-
- PROCEDURE DIVISION.
- MOVE FUNCTION FORMATTED-DATETIME
- ("YYYYDDDThhmmss+hhmm", 1, 45296, SYSTEM-OFFSET)
- TO str
- MOVE FUNCTION TEST-FORMATTED-DATETIME
- ("YYYYDDDThhmmss+hhmm", str) TO val
- IF val not = 0
- DISPLAY "Test 1 failed: " str ' - ' val END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME
- ("hhmmss.ssZ", 45296, SYSTEM-OFFSET)
- TO str
- MOVE FUNCTION TEST-FORMATTED-DATETIME
- ("hhmmss.ssZ", str) TO val
- IF val not = 0
- DISPLAY "Test 2 failed: " str ' - ' val END-DISPLAY
- END-IF
- .
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0])
-
-AT_CLEANUP
-
-
AT_SETUP([Intrinsics without FUNCTION keyword (1)])
AT_KEYWORDS([functions])
AT_DATA([prog.cob], [
@@ -712,24 +238,3 @@ AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
AT_CLEANUP
-AT_SETUP([v2-bugs functions repository])
-AT_KEYWORDS([v1-bugs functions repository])
-# REPOSITORY FUNCTION clause
-AT_XFAIL_IF(true)
-# FUNCTIONS NOT IMPLEMENTED TODO
-# NOT V1 ISSUE!!
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- CONFIGURATION SECTION.
- SOURCE-COMPUTER a.
- OBJECT-COMPUTER a.
- REPOSITORY.
- FUNCTION ALL INTRINSIC.
- PROCEDURE DIVISION.
- DISPLAY "OK".
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CLEANUP
-
diff --git a/gcc/cobol/UAT/failsuite.src/syn_move.at b/gcc/cobol/UAT/failsuite.src/syn_move.at
index cc9878d78774..010e2acae0da 100644
--- a/gcc/cobol/UAT/failsuite.src/syn_move.at
+++ b/gcc/cobol/UAT/failsuite.src/syn_move.at
@@ -22,35 +22,3 @@
## 14.8.24.2 Syntax rules
-AT_SETUP([invalid source for MOVE (2)])
-AT_KEYWORDS([move label program-prototype])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-# cobc is wrong: repo-prog is an error, not warning. It must have
-# been previously defined, or exist as a program-prototype (which we
-# don't support). gcobol stops compiling instead of continuing on to
-# identify the MOVE errors.
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- CONFIGURATION SECTION.
- REPOSITORY.
- PROGRAM repo-prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 77 MAIN-VAR PIC X(3).
- PROCEDURE DIVISION.
- MAIN.
- MOVE MAIN TO MAIN-VAR.
- MOVE repo-prog TO MAIN.
- STOP RUN.
-])
-AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:7: warning: no definition/prototype seen for PROGRAM 'repo-prog'
-prog.cob: in paragraph 'MAIN':
-prog.cob:13: error: 'MAIN' is not a field
-prog.cob:14: error: 'repo-prog' is not a field
-])
-AT_CLEANUP
-
-
diff --git a/gcc/cobol/UAT/skipsuite.at b/gcc/cobol/UAT/skipsuite.at
index 7f90546d28cf..8ec5ef129ae4 100644
--- a/gcc/cobol/UAT/skipsuite.at
+++ b/gcc/cobol/UAT/skipsuite.at
@@ -38,9 +38,9 @@ m4_include([run_accept.at])
AT_BANNER([FILE])
m4_include([run_file.at])
-# functions DEFERRED
-# AT_BANNER([FUNCTIONS])
-# m4_include([functions.at])
+functions DEFERRED
+AT_BANNER([FUNCTIONS])
+m4_include([run_functions.at])
AT_BANNER([FUNDAMENTAL])
m4_include([run_fundamental.at])
diff --git a/gcc/cobol/UAT/skipsuite.src/run_functions.at b/gcc/cobol/UAT/skipsuite.src/run_functions.at
new file mode 100644
index 000000000000..3b2cd37ed266
--- /dev/null
+++ b/gcc/cobol/UAT/skipsuite.src/run_functions.at
@@ -0,0 +1,499 @@
+## Copyright (C) 2003-2012, 2014-2020 Free Software Foundation, Inc.
+## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart
+##
+## This file is part of GnuCOBOL.
+##
+## The GnuCOBOL compiler is free software: you can redistribute it
+## and/or modify it under the terms of the GNU General Public License
+## as published by the Free Software Foundation, either version 3 of the
+## License, or (at your option) any later version.
+##
+## GnuCOBOL is distributed in the hope that it will be useful,
+## but WITHOUT ANY WARRANTY; without even the implied warranty of
+## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+## GNU General Public License for more details.
+##
+## You should have received a copy of the GNU General Public License
+## along with GnuCOBOL. If not, see <https://www.gnu.org/licenses/>.
+
+### GnuCOBOL Test Suite
+
+### ISO+IEC+1989-2002 15 Intrinsic Functions
+### ISO+IEC+1989-2002 9.4 User-Defined Functions
+
+AT_SETUP([FUNCTION CONTENT-LENGTH])
+AT_KEYWORDS([functions length])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 P USAGE POINTER.
+ 01 X PIC X(4) VALUE Z"ABC".
+ 01 TEST-FLD USAGE BINARY-LONG.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION CONTENT-LENGTH ( P )
+ TO TEST-FLD.
+ IF TEST-FLD NOT = 0
+ DISPLAY 'CONTENT-LENGTH NULL wrong: ' TEST-FLD
+ END-DISPLAY
+ END-IF
+ SET P TO ADDRESS OF X
+ MOVE FUNCTION CONTENT-LENGTH ( P )
+ TO TEST-FLD
+ IF TEST-FLD NOT = 3
+ DISPLAY 'CONTENT-LENGTH z"abc" wrong: ' TEST-FLD
+ END-DISPLAY
+ END-IF
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION CONTENT-OF])
+AT_KEYWORDS([functions POINTER literal BASED ALLOCATE FREE EXCEPTION-STATUS])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 P USAGE POINTER.
+ 01 X PIC X(4) VALUE Z"ABC".
+ 01 B PIC X(10) BASED.
+ PROCEDURE DIVISION.
+ SET P TO ADDRESS OF X
+ IF FUNCTION CONTENT-OF ( P ) NOT EQUAL 'ABC' THEN
+ DISPLAY 'CONTENT-OF(ptr) wrong' END-DISPLAY
+ END-IF
+ IF FUNCTION CONTENT-OF ( P, 2 ) NOT EQUAL 'AB' THEN
+ DISPLAY 'CONTENT-OF(ptr, len) wrong' END-DISPLAY
+ END-IF
+ IF FUNCTION EXCEPTION-STATUS NOT = SPACES THEN
+ DISPLAY 'unexpected exception (1): '
+ FUNCTION EXCEPTION-STATUS
+ END-DISPLAY
+ END-IF
+ SET P TO NULL
+ MOVE 'PPPP' TO X
+ STRING FUNCTION CONTENT-OF ( P )
+ DELIMITED BY SIZE
+ INTO X
+ END-STRING
+ *> Note: result *should* depend on dialect option zero-length literals
+ IF X NOT EQUAL 'PPPP' THEN
+ DISPLAY 'CONTENT-OF empty POINTER wrong: "'" X "'"
+ END-DISPLAY
+ END-IF
+ IF FUNCTION EXCEPTION-STATUS NOT = "EC-DATA-PTR-NULL" THEN
+ DISPLAY 'missing exception (1)'
+ END-DISPLAY
+ END-IF
+ ALLOCATE B INITIALIZED
+ SET P TO ADDRESS OF B
+ IF FUNCTION CONTENT-OF ( P, 1 ) NOT EQUAL SPACES THEN
+ DISPLAY 'CONTENT-OF allocated BASED item wrong'
+ END-DISPLAY
+ END-IF
+ IF FUNCTION EXCEPTION-STATUS NOT = SPACES THEN
+ DISPLAY 'unexpected exception (2): '
+ FUNCTION EXCEPTION-STATUS
+ END-DISPLAY
+ END-IF
+ FREE B
+ SET P TO ADDRESS OF B
+ MOVE 'BBBB' TO X
+ STRING FUNCTION CONTENT-OF ( P )
+ DELIMITED BY SIZE
+ INTO X
+ END-STRING
+ *> Note: result *should* depend on dialect option zero-length literals
+ IF X NOT EQUAL 'BBBB' THEN
+ DISPLAY 'CONTENT-OF unallocated BASED item wrong: "' X '"'
+ END-DISPLAY
+ END-IF
+ IF FUNCTION EXCEPTION-STATUS NOT = "EC-DATA-PTR-NULL" THEN
+ DISPLAY 'missing exception (2)'
+ END-DISPLAY
+ END-IF
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION CURRENCY-SYMBOL])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 TEST-FLD PIC X(8) VALUE SPACES.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION CURRENCY-SYMBOL TO TEST-FLD.
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ STOP RUN.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MODULE-CALLER-ID])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ CALL "prog2"
+ END-CALL.
+ STOP RUN.
+])
+
+AT_DATA([prog2.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog2.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ DISPLAY FUNCTION MODULE-CALLER-ID NO ADVANCING
+ END-DISPLAY.
+ EXIT PROGRAM.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COMPILE_MODULE prog2.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [prog])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MODULE-DATE])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 TEST-DATE PIC 9(8) VALUE 0.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION MODULE-DATE TO TEST-DATE.
+ IF TEST-DATE NOT = 0
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MODULE-FORMATTED-DATE])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 TEST-DATE PIC X(16) VALUE SPACES.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION MODULE-FORMATTED-DATE TO TEST-DATE.
+ IF TEST-DATE NOT = SPACES
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MODULE-ID])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ DISPLAY FUNCTION MODULE-ID NO ADVANCING
+ END-DISPLAY.
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [prog])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MODULE-PATH])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 TEST-PATH PIC X(16) VALUE SPACES.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION MODULE-PATH TO TEST-PATH.
+ IF TEST-PATH NOT = SPACES
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MODULE-SOURCE])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ DISPLAY FUNCTION MODULE-SOURCE NO ADVANCING
+ END-DISPLAY.
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [prog.cob])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MODULE-TIME])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 TEST-TIME PIC 9(6) VALUE 0.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION MODULE-TIME TO TEST-TIME.
+ IF TEST-TIME NOT = 0
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MONETARY-DECIMAL-POINT])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 TEST-FLD PIC X(8) VALUE SPACES.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION MONETARY-DECIMAL-POINT TO TEST-FLD.
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MONETARY-THOUSANDS-SEPARATOR])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 TEST-FLD PIC X(8) VALUE SPACES.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION MONETARY-THOUSANDS-SEPARATOR TO TEST-FLD.
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION NUMERIC-DECIMAL-POINT])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 TEST-FLD PIC X(8) VALUE SPACES.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION NUMERIC-DECIMAL-POINT TO TEST-FLD.
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION NUMERIC-THOUSANDS-SEPARATOR])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 TEST-FLD PIC X(8) VALUE SPACES.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION NUMERIC-THOUSANDS-SEPARATOR TO TEST-FLD.
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [OK], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION STORED-CHAR-LENGTH])
+AT_KEYWORDS([functions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 Y PIC X(24).
+ 01 Z USAGE BINARY-LONG.
+ PROCEDURE DIVISION.
+ MOVE "123456789012" TO Y.
+ MOVE FUNCTION STORED-CHAR-LENGTH ( Y ) TO Z.
+ IF Z NOT = 12
+ DISPLAY Z
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+
+
+AT_SETUP([FORMATTED-(DATE)TIME with SYSTEM-OFFSET])
+AT_KEYWORDS([functions FORMATTED-TIME FORMATTED-DATETIME extensions])
+AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 str PIC X(30).
+ 77 val pic 9(02).
+
+ PROCEDURE DIVISION.
+ MOVE FUNCTION FORMATTED-DATETIME
+ ("YYYYDDDThhmmss+hhmm", 1, 45296, SYSTEM-OFFSET)
+ TO str
+ MOVE FUNCTION TEST-FORMATTED-DATETIME
+ ("YYYYDDDThhmmss+hhmm", str) TO val
+ IF val not = 0
+ DISPLAY "Test 1 failed: " str ' - ' val END-DISPLAY
+ END-IF
+
+ MOVE FUNCTION FORMATTED-TIME
+ ("hhmmss.ssZ", 45296, SYSTEM-OFFSET)
+ TO str
+ MOVE FUNCTION TEST-FORMATTED-DATETIME
+ ("hhmmss.ssZ", str) TO val
+ IF val not = 0
+ DISPLAY "Test 2 failed: " str ' - ' val END-DISPLAY
+ END-IF
+ .
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0])
+
+AT_CLEANUP
+
+
diff --git a/gcc/cobol/UAT/testsuite.src/run_functions.at b/gcc/cobol/UAT/testsuite.src/run_functions.at
index bff4e719f7fb..5b7c38621c53 100644
--- a/gcc/cobol/UAT/testsuite.src/run_functions.at
+++ b/gcc/cobol/UAT/testsuite.src/run_functions.at
@@ -3913,3 +3913,22 @@ B The function returns 005
], [])
AT_CLEANUP
+AT_SETUP([Repository functions clause])
+AT_KEYWORDS([functions repository])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ SOURCE-COMPUTER. a.
+ OBJECT-COMPUTER. a.
+ REPOSITORY.
+ FUNCTION ALL INTRINSIC.
+ PROCEDURE DIVISION.
+ DISPLAY "OK".
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([./a.out], [0], [OK
+], [])
+AT_CLEANUP
+
diff --git a/gcc/cobol/UAT/testsuite.src/syn_move.at b/gcc/cobol/UAT/testsuite.src/syn_move.at
index 7bd6a7815f64..962bddfc2cee 100644
--- a/gcc/cobol/UAT/testsuite.src/syn_move.at
+++ b/gcc/cobol/UAT/testsuite.src/syn_move.at
@@ -1038,6 +1038,7 @@ AT_DATA([prog.cob], [
STOP RUN.
])
+
AT_CHECK([$COMPILE_ONLY -dialect mf prog.cob], [1], [],
[prog.cob:15: syntax error: symbol 'MAIN' not found
prog.cob:15: error: invalid MOVE receiving operand
@@ -1053,6 +1054,33 @@ cobol1: error: failed compiling prog.cob
AT_CLEANUP
+AT_SETUP([invalid source for MOVE (2)])
+AT_KEYWORDS([move label program-prototype])
+# cobc is wrong: repo-prog is an error, not warning. It must have
+# been previously defined, or exist as a program-prototype (which we
+# don't support). gcobol stops compiling instead of continuing on to
+# identify the MOVE errors.
+AT_DATA([prog.cob], [ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ PROGRAM repo-prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 MAIN-VAR PIC X(3).
+ PROCEDURE DIVISION.
+ MAIN.
+ MOVE MAIN TO MAIN-VAR.
+ MOVE repo-prog TO MAIN.
+ STOP RUN.
+])
+AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
+[prog.cob:6: error: 'repo-prog' does not name an earlier program
+cobol1: error: failed compiling prog.cob
+])
+AT_CLEANUP
+
AT_SETUP([SET error])
AT_KEYWORDS([move SET-MOVE])
AT_DATA([prog.cob], [
diff --git a/gcc/cobol/failures/playpen/playpen.cbl b/gcc/cobol/failures/playpen/playpen.cbl
index 6eee55391a80..2104a80d8812 100644
--- a/gcc/cobol/failures/playpen/playpen.cbl
+++ b/gcc/cobol/failures/playpen/playpen.cbl
@@ -1,15 +1,14 @@
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 V123 PIC 999 VALUE 123.
- 01 VALB PIC 999 BASED.
- 01 VALB2 PIC 999 BASED.
- 01 VALP POINTER.
- 01 VALP2 POINTER.
- PROCEDURE DIVISION.
- set VALP VALP2 to address of V123.
- set ADDRESS OF VALB ADDRESS OF VALB2 TO VALP.
- display VALB.
- goback.
- end PROGRAM callee.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ PROGRAM repo-prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 MAIN-VAR PIC X(3).
+ PROCEDURE DIVISION.
+ MAIN.
+ MOVE MAIN TO MAIN-VAR.
+ MOVE repo-prog TO MAIN.
+ STOP RUN.
--
GitLab