diff --git a/gcc/cobol/UAT/bugsuite.src/bugs.at b/gcc/cobol/UAT/bugsuite.src/bugs.at
index 5709380d3b20e3894bd75e58e540be67b6b4122f..21b525bffee84f14c04cd9da7b4c793eb26ee283 100644
--- a/gcc/cobol/UAT/bugsuite.src/bugs.at
+++ b/gcc/cobol/UAT/bugsuite.src/bugs.at
@@ -32,3 +32,58 @@ AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([./a.out], [1], [], [])
AT_CLEANUP
+AT_SETUP([Repeated program-id causes a crash])
+AT_KEYWORDS([bugs])
+AT_DATA([prog.cob], [])
+AT_CHECK([$COMPILE prog.cob], [0], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ DISPLAY "Hi."
+ END PROGRAM prog.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ DISPLAY "Hi."
+ END PROGRAM prog.
+], [])
+AT_CHECK([./a.out], [1], [], [])
+AT_CLEANUP
+
+AT_SETUP([Repeated variable name should be an error])
+AT_KEYWORDS([bugs])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 redundant PIC 9.
+ 01 redundant PIC 9.
+ PROCEDURE DIVISION.
+ DISPLAY redundant
+ DISPLAY "Hi".
+ END PROGRAM prog.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([./a.out], [1], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([Empty value shenanigans])
+AT_KEYWORDS([bugs])
+AT_DATA([prog.cob], [IDENTIFICATION DIVISION.
+PROGRAM-ID. routine_128_cobol.
+DATA DIVISION.
+LINKAGE SECTION.
+01 var1 pic 9(30) VALUE .
+01 var2 pic 9(30) VALUE .
+PROCEDURE DIVISION USING var1 RETURNING var2.
+ DISPLAY " I am COBOL routine_128_cobol".
+ DISPLAY var1
+ MOVE var1 TO var2
+ END PROGRAM routine_c.
+])
+AT_CHECK([$COMPILE prog.cob], [1], [], [])
+AT_CLEANUP
+
diff --git a/gcc/cobol/UAT/failsuite.src/run_evaluate.at b/gcc/cobol/UAT/failsuite.src/run_evaluate.at
index 90d5af41347c1e4154f92b630ed78094b286c521..f5d35b3bfd5bb742f1ed0c7d168bebd2755a4f98 100644
--- a/gcc/cobol/UAT/failsuite.src/run_evaluate.at
+++ b/gcc/cobol/UAT/failsuite.src/run_evaluate.at
@@ -8,50 +8,3 @@ AT_COLOR_TESTS
AT_TESTED('$GCOBOL')
-AT_SETUP([EVALUATE condition (2)])
-AT_KEYWORDS([evaluate condition])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([./a.out], [0], [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
-], [])
-AT_CLEANUP
-
-
diff --git a/gcc/cobol/UAT/failsuite.src/run_functions.at b/gcc/cobol/UAT/failsuite.src/run_functions.at
index e9382881337ce350af094044dfb5715f4ad690b5..ef5097aece6d03097fe7348f8b07e13daa53413b 100644
--- a/gcc/cobol/UAT/failsuite.src/run_functions.at
+++ b/gcc/cobol/UAT/failsuite.src/run_functions.at
@@ -21,3842 +21,6 @@
### ISO+IEC+1989-2002 15 Intrinsic Functions
### ISO+IEC+1989-2002 9.4 User-Defined Functions
-AT_SETUP([FUNCTION ABS])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[+0001.2345
-])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION ACOS])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION ANNUITY])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.002932551319648093841642228739002
- 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([FUNCTION ASIN])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION ATAN])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION BYTE-LENGTH])
-AT_KEYWORDS([functions length])
-AT_SKIP_IF(true)
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 X PIC X(4).
- 01 Z PIC N(4).
- 01 TEST-FLD PIC S9(04)V9(08).
- PROCEDURE DIVISION.
- MOVE FUNCTION BYTE-LENGTH ( X )
- TO TEST-FLD.
- IF TEST-FLD NOT = 4
- DISPLAY 'BYTE-LENGTH X(4) wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
- MOVE FUNCTION BYTE-LENGTH ( Z )
- TO TEST-FLD
- IF TEST-FLD NOT = 8
- DISPLAY 'BYTE-LENGTH N(4) wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
-
- MOVE FUNCTION BYTE-LENGTH ( '00128' )
- TO TEST-FLD
- IF TEST-FLD NOT = 5
- DISPLAY 'BYTE-LENGTH "00128" wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
- * note: we currently do not support items of category boolean...
- *> MOVE FUNCTION BYTE-LENGTH ( b'100' )
- *> TO TEST-FLD
- *> IF TEST-FLD NOT = 3
- *> DISPLAY 'BYTE-LENGTH b"100" wrong: ' TEST-FLD
- *> END-DISPLAY
- *> END-IF
- MOVE FUNCTION BYTE-LENGTH ( x'a0' )
- TO TEST-FLD
- IF TEST-FLD NOT = 1
- DISPLAY 'BYTE-LENGTH x"a0" wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
- MOVE FUNCTION BYTE-LENGTH ( z'a0' )
- TO TEST-FLD
- IF TEST-FLD NOT = 3
- DISPLAY 'BYTE-LENGTH z"a0" wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
- * we currently generate national constants as
- * alphanumeric constants...
- * MOVE FUNCTION BYTE-LENGTH ( n'a0' )
- * TO TEST-FLD
- * IF TEST-FLD NOT = 4
- * DISPLAY 'BYTE-LENGTH n"a0" wrong: ' TEST-FLD
- * END-DISPLAY
- * END-IF
- STOP RUN.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [],
-[prog.cob:7: warning: handling of USAGE NATIONAL is unfinished; implementation is likely to be changed
-])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION CHAR])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION COMBINED-DATETIME])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION CONCAT / CONCATENATE])
-AT_KEYWORDS([functions])
-
-# note: CONCAT was added in COBOL 202x with GnuCOBOL's CONCATENATE
-# as blueprint
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION CONCAT with reference modding])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-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
-
-
-# Invalid test.
-# prog.cob:18: ANY LENGTH valid only for 01 in LIKAGE SECTION of a contained program
-# "subprog", so called, is not contained.
-
-AT_SETUP([FUNCTION as CALL parameter BY CONTENT])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
-
- PROCEDURE DIVISION.
- PROG-MAIN.
- CALL "subprog" USING BY CONTENT
- FUNCTION CONCAT("Abc" "D")
- STOP RUN.
- END PROGRAM prog. *> bzzt
-
- *> *****************************
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [AbcD
-], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION COS])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-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 CURRENT-DATE])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION DATE-OF-INTEGER])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION DATE-TO-YYYYMMDD])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION DAY-OF-INTEGER])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION DAY-TO-YYYYDDD])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION E])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION EXCEPTION-FILE])
-AT_KEYWORDS([functions exceptions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[00|35TEST-FILE], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION EXCEPTION-LOCATION])
-AT_KEYWORDS([functions exceptions])
-
-AT_DATA([prog.cob], [
- 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.
- A00-MAIN SECTION.
- A00.
- DISPLAY FUNCTION EXCEPTION-LOCATION '|'
- NO ADVANCING
- END-DISPLAY.
- OPEN INPUT TEST-FILE.
- B00-MAIN SECTION.
- B00.
- DISPLAY FUNCTION EXCEPTION-LOCATION
- NO ADVANCING
- END-DISPLAY.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[ |prog; A00 OF A00-MAIN; 21], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION EXCEPTION-STATEMENT])
-AT_KEYWORDS([functions exceptions])
-
-AT_DATA([prog.cob], [
- 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-STATEMENT '|'
- NO ADVANCING
- END-DISPLAY.
- OPEN INPUT TEST-FILE.
- DISPLAY FUNCTION EXCEPTION-STATEMENT
- NO ADVANCING
- END-DISPLAY.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[ |OPEN ], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION EXCEPTION-STATUS])
-AT_KEYWORDS([functions exceptions])
-
-AT_DATA([prog.cob], [
- 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-STATUS '|'
- NO ADVANCING
- END-DISPLAY.
- OPEN INPUT TEST-FILE.
- DISPLAY FUNCTION EXCEPTION-STATUS
- NO ADVANCING
- END-DISPLAY.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[ |EC-I-O-PERMANENT-ERROR ], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION EXP])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION EXP10])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FACTORIAL])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FORMATTED-CURRENT-DATE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 Datetime-Format CONSTANT "YYYYMMDDThhmmss.ss+hhmm".
- 01 str PIC X(25).
- PROCEDURE DIVISION.
- *> Test normal inputs.
- MOVE FUNCTION FORMATTED-CURRENT-DATE ( Datetime-Format )
- TO str
- IF FUNCTION TEST-FORMATTED-DATETIME ( Datetime-Format, str)
- <> 0
- DISPLAY "Test 1 failed: " str END-DISPLAY
- END-IF.
-
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FORMATTED-DATE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FORMATTED-DATE with ref modding])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FORMATTED-DATETIME])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FORMATTED-DATETIME with ref modding])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FORMATTED-TIME])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 str PIC X(20).
- PROCEDURE DIVISION.
- *> Test normal inputs.
- MOVE FUNCTION FORMATTED-TIME ( "hhmmss", 45296 ) TO str
- IF str <> "123456"
- DISPLAY "Test 1 failed: " str END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME ( "hh:mm:ss", 45296 ) TO str
- IF str <> "12:34:56"
- DISPLAY "Test 2 failed: " str END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME ( "hhmmssZ", 86399, -1 ) TO str
- IF str <> "000059Z"
- DISPLAY "Test 3 failed: " str END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME ( "hh:mm:ssZ", 45296)
- TO str
- IF str <> "12:34:56Z"
- DISPLAY "Test 4 failed: " str END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME ( "hhmmss.ss", 45296.78 ) TO str
- IF str <> "123456.78"
- DISPLAY "Test 5 failed: " str END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME ( "hh:mm:ss.ssZ", 0, 120)
- TO str
- IF str <> "22:00:00.00Z"
- DISPLAY "Test 6 failed: " str END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME ( "hhmmss+hhmm", 45296)
- TO str
- IF str <> "123456+0000"
- DISPLAY "Test 7 failed: " str END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME ( "hh:mm:ss+hh:mm", 45296, 0 )
- TO str
- IF str <> "12:34:56+00:00"
- DISPLAY "Test 8 failed: " str END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME ( "hhmmss+hhmm", 45296, -754)
- TO str
- IF str <> "123456-1234"
- DISPLAY "Test 9 failed: " str END-DISPLAY
- END-IF
-
- *> Test with invalid/missing offset times.
- MOVE FUNCTION FORMATTED-TIME ( "hhmmss+hhmm", 1, 3000 )
- TO str
- IF str <> SPACES
- OR FUNCTION EXCEPTION-STATUS <> "EC-ARGUMENT-FUNCTION"
- OR FUNCTION EXCEPTION-LOCATION <> "prog; ; 60"
- DISPLAY "Test 10 failed: " str END-DISPLAY
- END-IF
-
- MOVE FUNCTION FORMATTED-TIME ( "hhmmss+hhmm", 1, -3000 )
- TO str
- IF str <> SPACES
- OR FUNCTION EXCEPTION-STATUS <> "EC-ARGUMENT-FUNCTION"
- OR FUNCTION EXCEPTION-LOCATION <> "prog; ; 68"
- DISPLAY "Test 11 failed: " str END-DISPLAY
- END-IF
-
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FORMATTED-TIME DP.COMMA])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FORMATTED-TIME with ref modding])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION FRACTION-PART])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 TEST-FLD PIC S9(04)V9(08).
- PROCEDURE DIVISION.
- MOVE FUNCTION FRACTION-PART ( 3.12345 )
- TO TEST-FLD.
- IF TEST-FLD NOT = +0000.12345
- 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.12345
- DISPLAY 'FRACTION-PART ( -3.12345 ) 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 HIGHEST-ALGEBRAIC])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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 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.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION INTEGER])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION INTEGER-OF-DATE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION INTEGER-OF-DAY])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION INTEGER-OF-FORMATTED-DATE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION INTEGER-PART])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LENGTH])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 X PIC S9(4)V9(4) VALUE -1.5.
- 01 N PIC N(9).
- 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 ( N )
- TO TEST-FLD
- IF TEST-FLD NOT = 9
- DISPLAY 'LENGTH N(9) 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
- * note: we currently do not support items of category boolean...
- *> MOVE FUNCTION LENGTH ( b'100' )
- *> TO TEST-FLD
- *> IF TEST-FLD NOT = 3
- *> DISPLAY 'LENGTH b"100" 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
- MOVE FUNCTION LENGTH ( n'a0' )
- TO TEST-FLD
- IF TEST-FLD NOT = 2
- DISPLAY 'LENGTH n"a0" wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [],
-[prog.cob:7: warning: handling of USAGE NATIONAL is unfinished; implementation is likely to be changed
-prog.cob:48: warning: handling of national literal is unfinished; implementation is likely to be changed
-])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LOCALE-COMPARE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LOCALE-DATE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[OK
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LOCALE-TIME])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[OK
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LOCALE-TIME-FROM-SECONDS])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[OK
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LOG])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LOG10])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LOWER-CASE])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LOWER-CASE with reference modding])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION LOWEST-ALGEBRAIC])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
- 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.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MAX])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- PROCEDURE DIVISION.
- DISPLAY FUNCTION MAX ( 3 -14 0 8 -3 )
- END-DISPLAY.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[8
-], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MEAN])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[-001.200
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MEDIAN])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- PROCEDURE DIVISION.
- DISPLAY FUNCTION MEDIAN ( 3 -14 0 8 -3 )
- END-DISPLAY.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[0
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MIDRANGE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[-003.000
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MIN])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- PROCEDURE DIVISION.
- DISPLAY FUNCTION MIN ( 3 -14 0 8 -3 )
- END-DISPLAY.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[-14
-])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MOD (valid)])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MOD (invalid)])
-AT_KEYWORDS([functions exceptions])
-AT_DATA([prog.cob], [
- 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 TRIM(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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION MODULE-CALLER-ID])
-AT_KEYWORDS([functions])
-
-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_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_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_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_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_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_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_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_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_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_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 NUMVAL])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION NUMVAL-C])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION NUMVAL-C DP.COMMA])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION NUMVAL-F])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 X PIC X(12) VALUE " -0.1234E+4 ".
- PROCEDURE DIVISION.
- DISPLAY FUNCTION NUMVAL-F ( X )
- END-DISPLAY.
- STOP RUN.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[-000001234
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION ORD])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[108
-])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION ORD-MAX])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[004
-])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION ORD-MIN])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[002
-])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION PI])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION PRESENT-VALUE])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[00000.5625
-])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION RANDOM])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION RANGE])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION REM (valid)])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION REM (invalid)])
-AT_KEYWORDS([functions exceptions])
-AT_DATA([prog.cob], [
- 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 TRIM(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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION REVERSE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION REVERSE with reference modding])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION SECONDS-FROM-FORMATTED-TIME])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION SECONDS-PAST-MIDNIGHT])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION SIGN])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION SIN])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION SQRT])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION STANDARD-DEVIATION])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION STORED-CHAR-LENGTH])
-AT_KEYWORDS([functions])
-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([FUNCTION SUBSTITUTE])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 Y PIC X(20).
- 01 Z PIC X(20) VALUE ALL '_'.
- PROCEDURE DIVISION.
- MOVE "abc111444555defxxabc" TO Y.
- STRING FUNCTION SUBSTITUTE ( Y "abc" "zz" "55" "666" )
- DELIMITED BY SIZE
- INTO Z
- END-STRING
- IF Z NOT = "zz1114446665defxxzz_"
- 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([FUNCTION SUBSTITUTE with reference modding])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION SUBSTITUTE-CASE])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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-CASE (Y "abc" "zz" "55" "666")
- TO Z.
- IF Z NOT = "zz1114446665defxxzz"
- 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([FUNCTION SUBSTITUTE-CASE with reference mod])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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-CASE
- ( Y "ABC" "zz" "55" "666" ) (2 : 9)
- TO Z.
- IF Z NOT = "z11144466"
- 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([FUNCTION SUM])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TAN])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TEST-DATE-YYYYMMDD])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[003
-])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TEST-DAY-YYYYDDD])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[002
-])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TEST-FORMATTED-DATETIME with dates])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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
- .
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TEST-FORMATTED-DATETIME with times])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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
- .
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TEST-FORMATTED-DATETIME with datetimes])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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
- .
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TEST-FORMATTED-DATETIME DP.COMMA])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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
- .
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TEST-NUMVAL])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TEST-NUMVAL-C])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TEST-NUMVAL-F])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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 = 0
- DISPLAY "Test 6 fail"
- END-DISPLAY
- END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1 -") NOT = 0
- DISPLAY "Test 7 fail"
- END-DISPLAY
- END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1 +-") NOT = 4
- DISPLAY "Test 8 fail"
- END-DISPLAY
- END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1 -+") NOT = 4
- 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 = 0
- DISPLAY "Test 12 fail"
- END-DISPLAY
- END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1.1 -") NOT = 0
- 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 = 6
- 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 E001") NOT = 7
- DISPLAY "Test 20 fail"
- END-DISPLAY
- END-IF.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TRIM])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[a#b.c%d+e$
- a#b.c%d+e$
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TRIM with reference modding])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[#b.
-a#b
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION TRIM zero length])
-AT_KEYWORDS([functions])
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[> <
-><
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION UPPER-CASE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION UPPER-CASE with reference modding])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION VARIANCE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION WHEN-COMPILED])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
-AT_CLEANUP
-
-
-AT_SETUP([FUNCTION YEAR-TO-YYYY])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-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])
@@ -3938,50 +102,8 @@ 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_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_SKIP_IF(false)
-AT_XFAIL_IF(true)
-# GNU -f
-
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
@@ -3993,22 +115,24 @@ AT_DATA([prog.cob], [
MOVE E TO Z.
STOP RUN.
])
-
-AT_CHECK([$COMPILE -fintrinsics=all prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
+AT_CHECK([$COMPILE prog.cob], [1], [], [prog.cob:8: syntax error: symbol 'PI' not found at 'TO'
+prog.cob:9: syntax error: symbol 'E' not found at 'TO'
+prog.cob:10: syntax error: symbol 'E' not found at 'TO'
+cobol1: error: failed compiling prog.cob
+])
AT_CLEANUP
AT_SETUP([Intrinsics without FUNCTION keyword (2)])
AT_KEYWORDS([functions])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-# GNU -f
-
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ FUNCTION PI
+ FUNCTION E.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Z PIC 99V99.
@@ -4017,10 +141,8 @@ AT_DATA([prog.cob], [
MOVE E TO Z.
STOP RUN.
])
-
-AT_CHECK([$COMPILE -fintrinsics=pi,e prog.cob], [0], [], [])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
AT_CLEANUP
@@ -4076,56 +198,8 @@ AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
AT_CLEANUP
-
-AT_SETUP([UDF in COMPUTE])
-AT_KEYWORDS([functions])
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[201
-])
-
-AT_CLEANUP
-
-
AT_SETUP([UDF replacing intrinsic function])
AT_KEYWORDS([functions SUBSTITUTE])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-# GNU -f
-
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
FUNCTION-ID. SUBSTITUTE.
@@ -4156,100 +230,11 @@ AT_DATA([prog.cob], [
.
END PROGRAM prog.
])
-
AT_CHECK([$COMPILE -fnot-intrinsic=substitute prog.cob], [0], [], [])
AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
[" _ C_O_B_O_L _ "
" - C-O-B-O-L - "
])
-
-AT_CLEANUP
-
-
-AT_SETUP([UDF with recursion])
-AT_KEYWORDS([functions LOCAL-STORAGE])
-
-AT_SKIP_IF(true) # see bug #222 and r2291 - postponed
-
-AT_DATA([prog.cob], [
- 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.
-
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
-[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'], [])
-
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/run_subscripts.at b/gcc/cobol/UAT/failsuite.src/run_subscripts.at
index e0658c774b7d0f95753eae110f7497f1afd4f3d7..d217feb8dc095e2ca058536d7b5bb51423b741aa 100644
--- a/gcc/cobol/UAT/failsuite.src/run_subscripts.at
+++ b/gcc/cobol/UAT/failsuite.src/run_subscripts.at
@@ -23,39 +23,3 @@
## 8.4.1.2.3 General rules
-AT_SETUP([383 SSRANGE and NOSSRANGE directives])
-AT_SKIP_IF([test "$COB_DIALECT" != "gnu"])
-AT_KEYWORDS([runsubscripts subscripts extensions directive])
-
-# WARNING: this testcase is "broken" as those SSRANGE may only be
-# defined before IDENTIFICATION DIVISION (iniatial $SET)
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
-
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 x.
- 03 y PIC X OCCURS 5 TIMES VALUE SPACE.
- 03 z PIC X VALUE "!".
- 01 idx PIC 99 VALUE 6.
-
- PROCEDURE DIVISION.
- $SET NOSSRANGE
- DISPLAY y (idx)
- *> Note: MF says "sets BOUND"
- $SET SSRANGE
- DISPLAY y (idx)
- .
-])
-
-AT_CHECK([$COMPILE -DTEST-SUBSCRIPT prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [1],
-[!
-], [libcob: prog.cob:17: error: subscript of 'y' out of bounds: 6
-note: maximum subscript for 'y': 5
-])
-
-AT_CLEANUP
-
\ No newline at end of file
diff --git a/gcc/cobol/UAT/failsuite.src/syn_copy.at b/gcc/cobol/UAT/failsuite.src/syn_copy.at
index 24518b765f6ed9919c7e892a395b1ee2b2ae3dec..abfdd8fa3d590bc6dff65f9ef2ee2fb177b9d6af 100644
--- a/gcc/cobol/UAT/failsuite.src/syn_copy.at
+++ b/gcc/cobol/UAT/failsuite.src/syn_copy.at
@@ -21,48 +21,3 @@
### COBOL for GCC Test Suite - testsuite adapted by Marty Heyman
## Copyright (C) 2022-23 COBOLworx, a subsidiary of Symas Corp.
-AT_SETUP([392 COPY: IN / OF / -I: 3])
-AT_KEYWORDS([copy cobc])
-AT_SKIP_IF([test "$COB_DIALECT" != "gnu"])
-# TODO: Should default to auto-folding when IN "sub2" (literal) is
-# used and therefore don't work on case-sensitive file-systems
-#
-# jkl: This test is invalid. "The implementor shall define the
-# rules for locating the library text referenced by text-name-1
-# or literal-1. When neither library-name-1 nor literal-2 is
-# specified, a default COBOL library is used. The implementor
-# defines the mechanism for identifying the default COBOL
-# library."
-#
-# This implementation consults the environment. If an environment
-# variable is defined for the library or copybook name, the value of
-# that variable is used. If not, the name from the Cobol text is
-# used. If a literal is supplied instead of a user-defined Cobol
-# word, no change is made to the name; it either exists, literally, or
-# it does not. If a user-defined Cobol word is supplied, the name is
-# tried with various suffixes (and without) using glob(3) to match.
-#
-# In no event is either name transformed to upper case. Perhaps that
-# should be a future option, but I suggest waiting for real-world
-# examples and a willing customer.
-#
-AT_DATA([prog3.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- COPY "copy.inc" IN sub2.
- PROCEDURE DIVISION.
- DISPLAY TEST-VAR.
- STOP RUN.
-])
-AT_CHECK([mkdir -p SUB/UNDER], [0], [], [])
-AT_DATA([SUB/UNDER/copy.inc], [
- 77 TEST-VAR PIC X VALUE '3'.
-])
-AT_DATA([copy.inc], [
- 77 TEST-VAR PIC X VALUE '4'.
-])
-AT_CHECK([$COMPILE_ONLY prog3.cob], [0], [], [])
-AT_CLEANUP
-
diff --git a/gcc/cobol/UAT/failsuite.src/syn_definition.at b/gcc/cobol/UAT/failsuite.src/syn_definition.at
index 3a8100269485fd038340db3103adaf8c23fbdea0..88282ffb9cc957af1afc3f90018262286eb686d8 100644
--- a/gcc/cobol/UAT/failsuite.src/syn_definition.at
+++ b/gcc/cobol/UAT/failsuite.src/syn_definition.at
@@ -18,64 +18,21 @@
### GnuCOBOL Test Suite
-###
-### Invalid PROGRAM-ID
-###
-
-AT_SETUP([401 Invalid source name])
-AT_KEYWORDS([definition])
-AT_SKIP_IF([test "$COB_DIALECT" != "gnu"])
-# FIXME: message
-
-# The message is currently inscrutable, but so is the test bogus.
-# gcobol doesn't consider "short" to be an invalid program-id because
-# it's not generating C code. The message could be better, but it's
-# tedious to fix, and there's no program.
-
-AT_DATA([short.cob], [])
-
-AT_CHECK([$COMPILE_ONLY short.cob], [1], [],
-[short.cob: error: invalid file base name 'short' - name duplicates a 'C' keyword
-])
-
-AT_CLEANUP
-
-
-AT_SETUP([402 Invalid PROGRAM-ID])
-AT_XFAIL_IF([test "$int128_to_field" != "ok"])
-AT_KEYWORDS([definition])
-
-AT_DATA([SHORT.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. short.
- PROCEDURE DIVISION.
- STOP RUN.
-])
-
-AT_CHECK([$COMPILE_ONLY SHORT.cob], [0], [], [])
-AT_CHECK([./prog], [0], [], [])
-AT_CLEANUP
-
-
AT_SETUP([Redefinition of function-prototype name])
AT_KEYWORDS([definition])
-AT_XFAIL_IF([test "UDF" != "implemented"])
-
+# This needs a better error message
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
-
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
REPOSITORY.
- FUNCTION func
- .
+ FUNCTION func .
DATA DIVISION.
WORKING-STORAGE SECTION.
01 func PIC X.
])
-
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
[prog.cob:8: warning: no definition/prototype seen for FUNCTION 'func'
prog.cob:12: error: syntax error, unexpected user function name
@@ -83,11 +40,56 @@ prog.cob:12: error: syntax error, unexpected user function name
AT_CLEANUP
-AT_SETUP([PROCEDURE DIVISION RETURNING item])
-AT_KEYWORDS([definition runmisc])
-AT_SKIP_IF([test "FUNCTION-ID" != "IMPLEMENTED"])
+AT_SETUP([Data item with same name as program-name])
+AT_KEYWORDS([definition])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ FUNCTION-ID. x.
+ DATA DIVISION.
+ LINKAGE SECTION.
+ 01 ret PIC 99.
+ PROCEDURE DIVISION RETURNING ret.
+ CONTINUE
+ .
+ END FUNCTION x.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 x PIC 999 VALUE 134.
+ PROCEDURE DIVISION.
+ DISPLAY X.
+ GOBACK.
+ END PROGRAM prog.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([./a.out], [0], [134
+], [])
+AT_CLEANUP
+
+AT_SETUP([Screen section starts with 78-level])
+AT_KEYWORDS([screen definition])
+AT_XFAIL_IF([test "SCREEN" != "implemented"])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+
+ DATA DIVISION.
+ SCREEN SECTION.
+ 78 const VALUE "x".
+])
+
+AT_CHECK([$COMPILE_ONLY prog.cob], [0], [],
+[prog.cob:6: syntax error at 'SCREEN'
+])
+AT_CLEANUP
+
+AT_SETUP([PROCEDURE DIVISION RETURNING item (1)])
+AT_KEYWORDS([definition runmisc])
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
FUNCTION-ID. func.
@@ -99,31 +101,52 @@ AT_DATA([prog.cob], [
GOBACK.
END FUNCTION func.
])
+AT_CHECK([$COMPILE_ONLY -c prog.cob], [0], [], [])
+AT_CLEANUP
+
+AT_SETUP([PROCEDURE DIVISION RETURNING item (2)])
+AT_KEYWORDS([definition runmisc])
AT_DATA([prog2.cob], [
IDENTIFICATION DIVISION.
FUNCTION-ID. func.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 PAR-OUT PIC 9.
+ *> The following line is an error, because PAR-OUT has to be in the
+ *> LINKAGE section
PROCEDURE DIVISION RETURNING PAR-OUT.
MOVE 4 TO PAR-OUT
GOBACK.
END FUNCTION func.
])
+AT_CHECK([$COMPILE_ONLY -c prog2.cob], [1], [],
+[prog2.cob:7: error: RETURNING item is not defined in LINKAGE SECTION
+])
+AT_CLEANUP
+AT_SETUP([PROCEDURE DIVISION RETURNING item (3)])
+AT_KEYWORDS([definition runmisc])
AT_DATA([prog3.cob], [
IDENTIFICATION DIVISION.
FUNCTION-ID. func.
DATA DIVISION.
LINKAGE SECTION.
+ *> The level 01 can't have an OCCURS clause
01 PAR-OUT PIC 9 OCCURS 10.
PROCEDURE DIVISION RETURNING PAR-OUT.
MOVE 4 TO PAR-OUT (1)
GOBACK.
END FUNCTION func.
])
+AT_CHECK([$COMPILE_ONLY -c prog3.cob], [0], [],
+[prog3.cob:7: error: RETURNING item should not have OCCURS
+prog3.cob:9: error: 'PAR-OUT' requires one subscript
+])
+AT_CLEANUP
+AT_SETUP([PROCEDURE DIVISION RETURNING item (4)])
+AT_KEYWORDS([definition runmisc])
AT_DATA([prog4.cob], [
IDENTIFICATION DIVISION.
FUNCTION-ID. func.
@@ -136,18 +159,34 @@ AT_DATA([prog4.cob], [
GOBACK.
END FUNCTION func.
])
+AT_CHECK([$COMPILE_ONLY -c prog4.cob], [0], [],
+[prog4.cob:8: error: RETURNING item must have level 01
+])
+AT_CLEANUP
+AT_SETUP([PROCEDURE DIVISION RETURNING item (5)])
+AT_KEYWORDS([definition runmisc])
AT_DATA([prog5.cob], [
IDENTIFICATION DIVISION.
FUNCTION-ID. func.
DATA DIVISION.
LINKAGE SECTION.
01 PAR PIC 9.
+ *> This is an error; USING and RETURNING can't be the same variable
PROCEDURE DIVISION USING PAR RETURNING PAR.
MOVE 4 TO PAR
GOBACK.
END FUNCTION func.
+])
+AT_CHECK([$COMPILE_ONLY -c prog5.cob], [1], [],
+[prog5.cob:7: error: 'PAR' USING item duplicates RETURNING item
+prog5.cob:18: error: 'PAR-OUT' REDEFINES field not allowed here
+])
+AT_CLEANUP
+AT_SETUP([PROCEDURE DIVISION RETURNING item (6)])
+AT_KEYWORDS([definition runmisc])
+AT_DATA([prog6.cob], [
IDENTIFICATION DIVISION.
FUNCTION-ID. func2.
DATA DIVISION.
@@ -159,92 +198,7 @@ AT_DATA([prog5.cob], [
GOBACK.
END FUNCTION func2.
])
-
-AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
-AT_CHECK([$COMPILE_ONLY prog2.cob], [1], [],
-[prog2.cob:7: error: RETURNING item is not defined in LINKAGE SECTION
+AT_CHECK([$COMPILE_ONLY -c prog6.cob], [1], [],
+[RETURNING item can't have REDEFINES or BASED clause
])
-AT_CHECK([$COMPILE_ONLY prog3.cob], [1], [],
-[prog3.cob:7: error: RETURNING item should not have OCCURS
-prog3.cob:9: error: 'PAR-OUT' requires one subscript
-])
-AT_CHECK([$COMPILE_ONLY prog4.cob], [1], [],
-[prog4.cob:8: error: RETURNING item must have level 01
-])
-AT_CHECK([$COMPILE_ONLY prog5.cob], [1], [],
-[prog5.cob:7: error: 'PAR' USING item duplicates RETURNING item
-prog5.cob:18: error: 'PAR-OUT' REDEFINES field not allowed here
-])
-
AT_CLEANUP
-
-
-AT_SETUP([Data item with same name as program-name])
-AT_KEYWORDS([definition])
-AT_SKIP_IF([test "FUNCTION-ID" != "IMPLEMENTED"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- FUNCTION-ID. x.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 ret PIC 99.
- PROCEDURE DIVISION RETURNING ret.
- CONTINUE
- .
- END FUNCTION x.
-
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 x PIC 999 VALUE 134.
-])
-
-AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
-AT_CLEANUP
-
-AT_SETUP([Screen section starts with 78-level])
-AT_KEYWORDS([screen definition])
-AT_XFAIL_IF([test "SCREEN" != "implemented"])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
-
- DATA DIVISION.
- SCREEN SECTION.
- 78 const VALUE "x".
-])
-
-AT_CHECK([$COMPILE_ONLY prog.cob], [0], [],
-[prog.cob:6: syntax error at 'SCREEN'
-])
-AT_CLEANUP
-
-AT_SETUP([ALPHABET definition])
-AT_KEYWORDS([definition])
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- ENVIRONMENT DIVISION.
- CONFIGURATION SECTION.
- SPECIAL-NAMES.
- ALPHABET TESTME IS
- 'A' THROUGH 'Z', x'00' thru x'05';
- x'41' ALSO x'42', ALSO x'00', x'C1' ALSO x'C2'.
- ALPHABET FINE
- 'A' also 'B' also 'C' also 'd' also 'e' ALSO 'f',
- 'g' also 'G', '1' thru '9', x'00'.
-])
-
-AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:9: error: ALPHABET , character 'A' (x'41') in position 32 already defined at position 0 at 'ALSO'
-prog.cob:10: 1 errors in DATA DIVISION, compilation ceases at 'ALPHABET'
-cobol1: error: failed compiling prog.cob
-])
-AT_CLEANUP
-
-
diff --git a/gcc/cobol/UAT/failsuite.src/syn_misc.at b/gcc/cobol/UAT/failsuite.src/syn_misc.at
index 1cb7ccf94ea82a2eefc95449a1294fab25bdf1ed..9c4e1cd40b66be8af979fa6e2c7593ba5146f12c 100644
--- a/gcc/cobol/UAT/failsuite.src/syn_misc.at
+++ b/gcc/cobol/UAT/failsuite.src/syn_misc.at
@@ -98,3 +98,22 @@ AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([./a.out], [0], [], [])
AT_CLEANUP
+AT_SETUP([X literals])
+AT_KEYWORDS([misc])
+# TODO - Needs better error messages
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ *> Valid form
+ DISPLAY X"0123456789ABCDEF"
+
+ *> invalid form
+ DISPLAY X"GH"
+ X"1"
+ END-DISPLAY.
+])
+AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [])
+AT_CLEANUP
+
+
diff --git a/gcc/cobol/UAT/failsuite.src/syn_move.at b/gcc/cobol/UAT/failsuite.src/syn_move.at
index cc9878d78774946bc1a93709ced2ced79f78d466..010e2acae0da823001e0b07588ab250b6e690ef8 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 7f90546d28cfb71a3f48e67f02143edd606328f0..8ec5ef129ae4de7e03e22bfc4274fb5c82b11985 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 0000000000000000000000000000000000000000..3b2cd37ed2666c07926f2080731b86cf4ec8351f
--- /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/skipsuite.src/run_fundamental.at b/gcc/cobol/UAT/skipsuite.src/run_fundamental.at
index c3a46a12e195ddfac6c4d9e5a57cd4530a60c1b0..ec7563a660e7da69ccb3998441e5016a8324dc97 100644
--- a/gcc/cobol/UAT/skipsuite.src/run_fundamental.at
+++ b/gcc/cobol/UAT/skipsuite.src/run_fundamental.at
@@ -441,31 +441,6 @@ AT_CHECK([./a.out], [0],
])
AT_CLEANUP
-
-AT_SETUP([Context sensitive words (5)])
-AT_KEYWORDS([fundamental recursive])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-# TODO NOT IMPLEMENTED "RECURSIVE"
-
-AT_DATA([prog.cob], [
- 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.
-])
-
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([./a.out], [0], [0], [])
-AT_CLEANUP
-
AT_SETUP([SYNC in OCCURS])
AT_KEYWORDS([fundamental CDF SYNCHRONIZE])
AT_SKIP_IF(false)
diff --git a/gcc/cobol/UAT/skipsuite.src/run_misc.at b/gcc/cobol/UAT/skipsuite.src/run_misc.at
index 4066cdc881803579181f36ca9e07261fbbd027ee..1b7505cfad0bbfa675f71097eb26955778ea70a7 100644
--- a/gcc/cobol/UAT/skipsuite.src/run_misc.at
+++ b/gcc/cobol/UAT/skipsuite.src/run_misc.at
@@ -235,158 +235,8 @@ AT_CHECK([$COBCRUN_DIRECT ./a.out3], [0], [], [])
AT_CLEANUP
-AT_SETUP([240. Recursive CALL of RECURSIVE program])
-AT_KEYWORDS([misc CANCEL EXTERNAL])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-AT_DATA([caller.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. caller IS RECURSIVE.
- ENVIRONMENT DIVISION.
- CONFIGURATION SECTION.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 77 STOPPER PIC S9 EXTERNAL.
- PROCEDURE DIVISION.
- MOVE 0 TO STOPPER
- CALL "callee"
- DISPLAY 'OK' NO ADVANCING END-DISPLAY
- *> FIXME: CANCEL broken on special environments
- *> CANCEL "callee" , "callee2"
- DISPLAY ' + FINE' NO ADVANCING END-DISPLAY
- STOP RUN.
-])
-AT_DATA([callee.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee IS RECURSIVE.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 77 STOPPER PIC S9 EXTERNAL.
- PROCEDURE DIVISION.
- IF STOPPER = 9
- MOVE -1 TO STOPPER
- ELSE
- ADD 1 TO STOPPER
- CALL "callee2"
- END-IF
- GOBACK.
-])
-AT_DATA([callee2.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee2 IS RECURSIVE.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 77 STOPPER PIC S9 EXTERNAL.
- PROCEDURE DIVISION.
- IF STOPPER NOT EQUAL -1
- CALL "callee"
- END-IF
- GOBACK.
-])
-
-AT_CHECK([$COMPILE -c callee.cob], [0], [], [])
-AT_CHECK([$COMPILE -c callee2.cob], [0], [], [])
-AT_CHECK([$COMPILE -o caller caller.cob callee.o callee2.o], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [OK + FINE], [])
-AT_CLEANUP
-
-
-AT_SETUP([241. Recursive CALL of INITIAL program])
-AT_KEYWORDS([misc])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-AT_DATA([caller.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. caller.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 77 STOPPER PIC 9 EXTERNAL.
- PROCEDURE DIVISION.
- MOVE 0 TO STOPPER
- CALL "callee" END-CALL.
- GOBACK.
-])
-AT_DATA([callee.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee IS INITIAL.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 77 STOPPER PIC 9 EXTERNAL.
- PROCEDURE DIVISION.
- IF STOPPER = 1
- DISPLAY 'INITIAL prog was called RECURSIVE'
- END-DISPLAY
- * Following statement not ISO, corrected below
- * STOP RUN RETURNING 1
- MOVE 1 TO RETURN-CODE
- STOP RUN
- ELSE
- MOVE 1 TO STOPPER
- CALL "callee2" END-CALL
- END-IF.
- GOBACK.
-])
-AT_DATA([callee2.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee2.
- PROCEDURE DIVISION.
- CALL "callee" END-CALL.
- GOBACK.
-])
-AT_CHECK([$COMPILE -c callee.cob], [0], [], [])
-AT_CHECK([$COMPILE -c callee2.cob], [0], [], [])
-AT_CHECK([$COMPILE -o caller caller.cob callee.o callee2.o], [0], [], [])
-AT_CHECK([./caller], [1], [INITIAL prog was called RECURSIVE
-], [])
-AT_CLEANUP
-
-
-AT_SETUP([Recursive CALL with RECURSIVE assumed])
-AT_KEYWORDS([misc])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-AT_DATA([caller.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. caller.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 77 STOPPER PIC 9 EXTERNAL.
- PROCEDURE DIVISION.
- MOVE 0 TO STOPPER
- CALL "callee" END-CALL.
- GOBACK.
-])
-AT_DATA([callee.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee IS INITIAL.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 77 STOPPER PIC 9 EXTERNAL.
- PROCEDURE DIVISION.
- IF STOPPER = 8
- DISPLAY 'OK' NO ADVANCING END-DISPLAY.
- IF STOPPER NOT = 9
- ADD 1 TO STOPPER END-ADD
- CALL "callee2" END-CALL.
- GOBACK.
-])
-AT_DATA([callee2.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee2.
- PROCEDURE DIVISION.
- CALL "callee" END-CALL.
- GOBACK.
-])
-AT_CHECK([$COMPILE -c callee.cob], [0], [], [])
-AT_CHECK([$COMPILE -c callee2.cob], [0], [], [])
-AT_CHECK([$COMPILE -o caller caller.cob callee.o callee2.o], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [OK], [])
-AT_CLEANUP
-
-
AT_SETUP([Recursive CALL with ON EXCEPTION])
AT_KEYWORDS([misc EXCEPTION-STATUS])
-AT_SKIP_IF(false)
AT_XFAIL_IF(true)
AT_DATA([caller.cob], [
IDENTIFICATION DIVISION.
@@ -440,7 +290,6 @@ AT_CLEANUP
AT_SETUP([Multiple calls of INITIAL program])
AT_KEYWORDS([misc CALL])
-AT_SKIP_IF(false)
AT_XFAIL_IF(true)
AT_DATA([caller.cob], [
IDENTIFICATION DIVISION.
@@ -820,181 +669,6 @@ AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
AT_CLEANUP
-AT_SETUP([PERFORM inline (1)])
-AT_KEYWORDS([misc])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-AT_DATA([prog.cob], [
- 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
- .
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([PERFORM inline (2)])
-AT_KEYWORDS([misc])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-AT_DATA([prog.cob], [
- 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
- .
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([UNSTRING DELIMITER IN])
-AT_KEYWORDS([misc])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([PERFORM type OSVS])
-AT_KEYWORDS([misc])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-AT_DATA([prog.cob], [
- 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.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-AT_CLEANUP
-
-
-AT_SETUP([Sticky LINKAGE])
-AT_KEYWORDS([misc])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-AT_DATA([callee.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 P1 PIC X.
- 01 P2 PIC X(6).
- 01 P3 PIC X(6).
- PROCEDURE DIVISION USING P1 P2.
- IF P1 = "A"
- SET ADDRESS OF P3 TO ADDRESS OF P2
- ELSE
- IF P3 NOT = "OKOKOK"
- DISPLAY P3
- END-DISPLAY
- END-IF
- END-IF.
- EXIT PROGRAM.
-])
-AT_DATA([caller.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. caller.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 P1 PIC X VALUE "A".
- 01 P2 PIC X(6) VALUE "NOT OK".
- PROCEDURE DIVISION.
- CALL "callee" USING P1 P2
- END-CALL.
- MOVE "B" TO P1.
- MOVE "OKOKOK" TO P2.
- CALL "callee" USING P1
- END-CALL.
- STOP RUN.
-])
-AT_CHECK([$COMPILE -c callee.cob], [0], [], [])
-AT_CHECK([$COMPILE -o caller caller.cob callee.o], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], [])
-AT_CLEANUP
AT_SETUP([COB_PRE_LOAD with entry points])
diff --git a/gcc/cobol/UAT/skipsuite.src/run_subscripts.at b/gcc/cobol/UAT/skipsuite.src/run_subscripts.at
index 6a7563469323acafd129b492314ee6f4637fcdd6..b9166cde6e4b1609d7c30bd822c02afb94ecc438 100644
--- a/gcc/cobol/UAT/skipsuite.src/run_subscripts.at
+++ b/gcc/cobol/UAT/skipsuite.src/run_subscripts.at
@@ -194,7 +194,37 @@ note: maximum subscript for 'y': 5
])
AT_CHECK([$COBCRUN_DIRECT ./a.outn], [0], [!], [])
AT_CHECK([$COBCRUN_DIRECT ./a.outn2], [0], [!], [])
-
AT_CLEANUP
+AT_SETUP([SSRANGE/NOSSRANGE directives (IBM, not ISO)])
+AT_KEYWORDS([runsubscripts subscripts extensions directive])
+AT_XFAIL_IF(true)
+# WARNING: this testcase is "broken" as those SSRANGE may only be
+# defined before IDENTIFICATION DIVISION (iniatial $SET)
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 x.
+ 03 y PIC X OCCURS 5 TIMES VALUE SPACE.
+ 03 z PIC X VALUE "!".
+ 01 idx PIC 99 VALUE 6.
+
+ PROCEDURE DIVISION.
+ $SET NOSSRANGE
+ DISPLAY y (idx)
+ *> Note: MF says "sets BOUND"
+ $SET SSRANGE
+ DISPLAY y (idx)
+ .
+])
+AT_CHECK([$COMPILE -DTEST-SUBSCRIPT prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [1],
+[!
+], [libcob: prog.cob:17: error: subscript of 'y' out of bounds: 6
+note: maximum subscript for 'y': 5
+])
+AT_CLEANUP
diff --git a/gcc/cobol/UAT/skipsuite.src/syn_copy.at b/gcc/cobol/UAT/skipsuite.src/syn_copy.at
index 891607bdf31b3630f6830de2964ef8ce787cc656..ffc89c97356233e0ec4a829d58d7c24dd5250758 100644
--- a/gcc/cobol/UAT/skipsuite.src/syn_copy.at
+++ b/gcc/cobol/UAT/skipsuite.src/syn_copy.at
@@ -481,3 +481,48 @@ AT_CHECK([./prog], [0], [OK], [])
AT_CLEANUP
+AT_SETUP([392 COPY: IN / OF / -I: 3])
+AT_KEYWORDS([copy cobc])
+AT_XFAIL_IF(true)
+# TODO: Should default to auto-folding when IN "sub2" (literal) is
+# used and therefore don't work on case-sensitive file-systems
+#
+# jkl: This test is invalid. "The implementor shall define the
+# rules for locating the library text referenced by text-name-1
+# or literal-1. When neither library-name-1 nor literal-2 is
+# specified, a default COBOL library is used. The implementor
+# defines the mechanism for identifying the default COBOL
+# library."
+#
+# This implementation consults the environment. If an environment
+# variable is defined for the library or copybook name, the value of
+# that variable is used. If not, the name from the Cobol text is
+# used. If a literal is supplied instead of a user-defined Cobol
+# word, no change is made to the name; it either exists, literally, or
+# it does not. If a user-defined Cobol word is supplied, the name is
+# tried with various suffixes (and without) using glob(3) to match.
+#
+# In no event is either name transformed to upper case. Perhaps that
+# should be a future option, but I suggest waiting for real-world
+# examples and a willing customer.
+#
+AT_DATA([prog3.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ COPY "copy.inc" IN sub2.
+ PROCEDURE DIVISION.
+ DISPLAY TEST-VAR.
+ STOP RUN.
+])
+AT_CHECK([mkdir -p SUB/UNDER], [0], [], [])
+AT_DATA([SUB/UNDER/copy.inc], [
+ 77 TEST-VAR PIC X VALUE '3'.
+])
+AT_DATA([copy.inc], [
+ 77 TEST-VAR PIC X VALUE '4'.
+])
+AT_CHECK([$COMPILE_ONLY prog3.cob], [0], [], [])
+AT_CLEANUP
+
diff --git a/gcc/cobol/UAT/skipsuite.src/syn_definition.at b/gcc/cobol/UAT/skipsuite.src/syn_definition.at
index 742409a929f32857892441cefc19b15bb07f9c83..1037a93d2935b0c3d383ef1a37ff91785df5c62e 100644
--- a/gcc/cobol/UAT/skipsuite.src/syn_definition.at
+++ b/gcc/cobol/UAT/skipsuite.src/syn_definition.at
@@ -38,34 +38,7 @@ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
AT_CLEANUP
-AT_SETUP([405 INITIAL / RECURSIVE before COMMON])
-AT_KEYWORDS([PROGRAM-ID definition])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-# RECURSIVE not implemented.
-
-AT_DATA([containing-prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. containing-prog.
-
- PROCEDURE DIVISION.
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog-1 IS INITIAL COMMON.
- PROCEDURE DIVISION.
- STOP RUN.
- END PROGRAM prog-1.
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog-2 IS RECURSIVE COMMON.
- PROCEDURE DIVISION.
- STOP RUN.
- END PROGRAM prog-2.
-])
-
-AT_CHECK([$COMPILE_ONLY containing-prog.cob], [0], [], [])
-
-AT_CLEANUP
AT_SETUP([406 Undefined data name])
diff --git a/gcc/cobol/UAT/skipsuite.src/syn_misc.at b/gcc/cobol/UAT/skipsuite.src/syn_misc.at
index 44eb8d06c3453583193f02f0592d7d7ff466a45e..7613b1b7b2fea7f092a7496cfb18221a4883c728 100644
--- a/gcc/cobol/UAT/skipsuite.src/syn_misc.at
+++ b/gcc/cobol/UAT/skipsuite.src/syn_misc.at
@@ -2533,36 +2533,6 @@ prog3.cob:26: error: syntax error, unexpected +
AT_CLEANUP
-AT_SETUP([X literals])
-AT_KEYWORDS([misc])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-# TODO - NOT IMPLEMENTED - diagnostic messages
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- PROCEDURE DIVISION.
- *> Valid form
- DISPLAY X"0123456789ABCDEF"
-
- *> invalid form
- DISPLAY X"GH"
- X"1"
- END-DISPLAY.
-])
-
-AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:9: error: invalid X literal: 'GH'
-prog.cob:9: error: literal contains invalid character 'G'
-prog.cob:9: error: literal contains invalid character 'H'
-prog.cob:10: error: invalid X literal: '1'
-prog.cob:10: error: literal does not have an even number of digits
-])
-
-AT_CLEANUP
-
-
AT_SETUP([national literals])
AT_KEYWORDS([misc])
AT_SKIP_IF(false)
@@ -2768,30 +2738,6 @@ AT_CHECK([$COMPILE_ONLY -fnot-reserved=DISPLAY -freserved=COMP-1=DISPLAY prog2.c
AT_CLEANUP
-AT_SETUP([swapped SOURCE- and OBJECT-COMPUTER])
-AT_KEYWORDS([misc extensions])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-# TODO - NOT IMPLEMENTED - Diagnostic messages
-# This is a test for statement order.
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
-
- ENVIRONMENT DIVISION.
- CONFIGURATION SECTION.
- OBJECT-COMPUTER. a.
- SOURCE-COMPUTER. b.
-])
-
-# MF extension, supported by GnuCOBOL
-AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
-# note: testing with lax configuration, otherwise there would be an error
-
-AT_CLEANUP
-
-
AT_SETUP([CONF. SECTION paragraphs in wrong order])
AT_KEYWORDS([misc extensions])
AT_SKIP_IF(false)
diff --git a/gcc/cobol/UAT/skipsuite.src/syn_occurs.at b/gcc/cobol/UAT/skipsuite.src/syn_occurs.at
index 8c4b0d14290e56ab0ab4f45433a3b8229c2438f4..32efee69fadf000ee375106486f44dd000c4cc2b 100644
--- a/gcc/cobol/UAT/skipsuite.src/syn_occurs.at
+++ b/gcc/cobol/UAT/skipsuite.src/syn_occurs.at
@@ -243,32 +243,6 @@ AT_CLEANUP
# 9) DONE
-AT_SETUP([Nested OCCURS clause])
-AT_KEYWORDS([occurs])
-AT_SKIP_IF(false)
-AT_XFAIL_IF(true)
-# NOT IMPLEMENTED: Diagnostic messages
-
-AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 G-1.
- 02 G-2 OCCURS 2.
- 03 G-3 OCCURS 2.
- 04 G-4 OCCURS 2.
- 05 G-5 OCCURS 2.
- 06 G-6 OCCURS 2.
- 07 G-7 OCCURS 2.
- 08 G-8 OCCURS 2.
- 09 X PIC X.
-])
-
-AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
-
-AT_CLEANUP
-
# 10) TODO
diff --git a/gcc/cobol/UAT/testsuite.at b/gcc/cobol/UAT/testsuite.at
index bac6ddf18e2e6038859f2f3d4fad215297bc8fcb..2b27be5d29c42408d0af83a569c4651056c1a693 100644
--- a/gcc/cobol/UAT/testsuite.at
+++ b/gcc/cobol/UAT/testsuite.at
@@ -48,9 +48,8 @@ m4_include([run_evaluate.at])
AT_BANNER([FILE])
m4_include([run_file.at])
-# functions DEFERRED
-# AT_BANNER([FUNCTIONS])
-# m4_include([functions.at])
+AT_BANNER([FUNCTIONS])
+m4_include([run_functions.at])
AT_BANNER([FUNDAMENTAL])
m4_include([run_fundamental.at])
diff --git a/gcc/cobol/UAT/testsuite.src/run_evaluate.at b/gcc/cobol/UAT/testsuite.src/run_evaluate.at
index 63a5f7ba280edd30004e9581f1e998f0a8cd6fa5..25aa6e2f219d14adfd25d14d07f3f2fe762eeb3a 100644
--- a/gcc/cobol/UAT/testsuite.src/run_evaluate.at
+++ b/gcc/cobol/UAT/testsuite.src/run_evaluate.at
@@ -31,6 +31,52 @@ AT_CHECK([./a.out], [0], [not
], [])
AT_CLEANUP
+AT_SETUP([EVALUATE condition (2)])
+AT_KEYWORDS([evaluate condition])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([./a.out], [0], [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
+], [])
+AT_CLEANUP
+
AT_SETUP([EVALUATE with WHEN using condition-1])
# Gnu DOES NOT support condition names as Evaluate object
diff --git a/gcc/cobol/UAT/testsuite.src/run_functions.at b/gcc/cobol/UAT/testsuite.src/run_functions.at
new file mode 100644
index 0000000000000000000000000000000000000000..5eeb33f51782d3b697df33116ff545ed663f560e
--- /dev/null
+++ b/gcc/cobol/UAT/testsuite.src/run_functions.at
@@ -0,0 +1,4008 @@
+## 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 ABS])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[+0001.2345
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION ACOS])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION ANNUITY])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.002932551319648093841642228739002
+ 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([FUNCTION ASIN])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION ATAN])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION BYTE-LENGTH])
+AT_KEYWORDS([functions length])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [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
+], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION CHAR])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION COMBINED-DATETIME])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION CONCAT / CONCATENATE])
+AT_KEYWORDS([functions])
+
+# note: CONCAT was added in COBOL 202x with GnuCOBOL's CONCATENATE
+# as blueprint
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION CONCAT with reference modding])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+
+# Invalid test.
+# prog.cob:18: ANY LENGTH valid only for 01 in LIKAGE SECTION of a contained program
+# "subprog", so called, is not contained.
+
+AT_SETUP([FUNCTION as CALL parameter BY CONTENT])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [AbcD
+], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION COS])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION CURRENT-DATE])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION DATE-OF-INTEGER])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION DATE-TO-YYYYMMDD])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION DAY-OF-INTEGER])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION DAY-TO-YYYYDDD])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION E])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION EXCEPTION-FILE])
+AT_KEYWORDS([functions exceptions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[00|35TEST-FILE], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION EXCEPTION-LOCATION])
+AT_KEYWORDS([functions exceptions])
+AT_DATA([prog.cob], [
+ 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.
+ DECLARATIVES.
+ EC-ALL-SECTION SECTION.
+ USE EC EC-ALL
+ RESUME NEXT STATEMENT.
+ END DECLARATIVES.
+ A00-MAIN SECTION.
+ A00.
+ SET LAST EXCEPTION TO OFF
+ DISPLAY "EXCEPTION-LOCATION before open attempt: "
+ """" FUNCTION EXCEPTION-LOCATION """".
+ B00-MAIN SECTION.
+ B00.
+ SET LAST EXCEPTION TO OFF
+ OPEN INPUT TEST-FILE.
+ DISPLAY "EXCEPTION-LOCATION after open attempt: "
+ """" FUNCTION EXCEPTION-LOCATION """".
+ C00-MAIN SECTION.
+ C00.
+ >>TURN EC-ALL CHECKING ON
+ SET LAST EXCEPTION TO OFF
+ OPEN INPUT TEST-FILE.
+ DISPLAY "EXCEPTION-LOCATION after CHECKED open attempt: "
+ """" FUNCTION EXCEPTION-LOCATION """".
+ STOP RUN.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[EXCEPTION-LOCATION before open attempt: " "
+EXCEPTION-LOCATION after open attempt: "prog; B00 OF B00-MAIN; prog.cob:29 "
+EXCEPTION-LOCATION after CHECKED open attempt: "prog; C00 OF C00-MAIN; prog.cob:36 "
+], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION EXCEPTION-STATEMENT])
+AT_KEYWORDS([functions exceptions])
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[EXCEPTION-STATEMENT before bad OPEN: " "
+EXCEPTION-STATEMENT after bad OPEN: "OPEN"
+], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION EXCEPTION-STATUS])
+AT_KEYWORDS([functions exceptions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[EXCEPTION STATUS before bad open: " "
+EXCEPTION STATUS after bad open: "EC-I-O-PERMANENT-ERROR"
+], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION EXP])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION EXP10])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FACTORIAL])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FORMATTED-CURRENT-DATE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 Datetime-Format CONSTANT "YYYYMMDDThhmmss.ss+hhmm".
+ 01 str PIC X(25).
+ PROCEDURE DIVISION.
+ *> Test normal inputs.
+ MOVE FUNCTION FORMATTED-CURRENT-DATE ( Datetime-Format )
+ TO str
+ IF FUNCTION TEST-FORMATTED-DATETIME ( Datetime-Format, str)
+ <> 0
+ DISPLAY "Test 1 failed: " str END-DISPLAY
+ END-IF.
+
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FORMATTED-DATE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FORMATTED-DATE with ref modding])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FORMATTED-DATETIME])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FORMATTED-DATETIME with ref modding])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FORMATTED-TIME])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 str PIC X(20).
+ PROCEDURE DIVISION.
+ *> Test normal inputs.
+ MOVE FUNCTION FORMATTED-TIME ( "hhmmss", 45296 ) TO str
+ IF str <> "123456"
+ DISPLAY "Test 1 failed: " str END-DISPLAY
+ END-IF
+
+ MOVE FUNCTION FORMATTED-TIME ( "hh:mm:ss", 45296 ) TO str
+ IF str <> "12:34:56"
+ DISPLAY "Test 2 failed: " str END-DISPLAY
+ END-IF
+
+ MOVE FUNCTION FORMATTED-TIME ( "hhmmssZ", 86399, -1 ) TO str
+ IF str <> "000059Z"
+ DISPLAY "Test 3 failed: " str END-DISPLAY
+ END-IF
+
+ MOVE FUNCTION FORMATTED-TIME ( "hh:mm:ssZ", 45296)
+ TO str
+ IF str <> "12:34:56Z"
+ DISPLAY "Test 4 failed: " str END-DISPLAY
+ END-IF
+
+ MOVE FUNCTION FORMATTED-TIME ( "hhmmss.ss", 45296.78 ) TO str
+ IF str <> "123456.78"
+ DISPLAY "Test 5 failed: " str END-DISPLAY
+ END-IF
+
+ MOVE FUNCTION FORMATTED-TIME ( "hh:mm:ss.ssZ", 0, 120)
+ TO str
+ IF str <> "22:00:00.00Z"
+ DISPLAY "Test 6 failed: " str END-DISPLAY
+ END-IF
+
+ MOVE FUNCTION FORMATTED-TIME ( "hhmmss+hhmm", 45296)
+ TO str
+ IF str <> "123456+0000"
+ DISPLAY "Test 7 failed: " str END-DISPLAY
+ END-IF
+
+ MOVE FUNCTION FORMATTED-TIME ( "hh:mm:ss+hh:mm", 45296, 0 )
+ TO str
+ IF str <> "12:34:56+00:00"
+ DISPLAY "Test 8 failed: " str END-DISPLAY
+ END-IF
+
+ MOVE FUNCTION FORMATTED-TIME ( "hhmmss+hhmm", 45296, -754)
+ TO str
+ IF str <> "123456-1234"
+ DISPLAY "Test 9 failed: " str END-DISPLAY
+ END-IF
+
+ *> Test with invalid/missing offset times.
+ MOVE FUNCTION FORMATTED-TIME ( "hhmmss+hhmm", 1, 3000 )
+ TO str
+ DISPLAY "Test 10 " """" str """"
+ DISPLAY "Test 10 " """" FUNCTION EXCEPTION-STATUS """"
+ DISPLAY "Test 10 " """" FUNCTION EXCEPTION-LOCATION """"
+
+ MOVE FUNCTION FORMATTED-TIME ( "hhmmss+hhmm", 1, -3000 )
+ TO str
+ DISPLAY "Test 11 " """" str """"
+ DISPLAY "Test 11 " """" FUNCTION EXCEPTION-STATUS """"
+ DISPLAY "Test 11 " """" FUNCTION EXCEPTION-LOCATION """"
+
+ STOP RUN.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [Test 10 " "
+Test 10 "EC-ARGUMENT-FUNCTION"
+Test 10 "prog; ; prog.cob:60 "
+Test 11 " "
+Test 11 "EC-ARGUMENT-FUNCTION"
+Test 11 "prog; ; prog.cob:66 "
+], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FORMATTED-TIME DP.COMMA])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FORMATTED-TIME with ref modding])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION FRACTION-PART])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+AT_SETUP([FUNCTION HEX-OF])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [48656C6C6F2C20776F726C6421
+12345F
+], [])
+AT_CLEANUP
+
+AT_SETUP([FUNCTION HIGHEST-ALGEBRAIC])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+AT_SETUP([FUNCTION INTEGER])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION INTEGER-OF-DATE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION INTEGER-OF-DAY])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION INTEGER-OF-FORMATTED-DATE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION INTEGER-PART])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LENGTH])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LOCALE-COMPARE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LOCALE-DATE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[OK
+])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LOCALE-TIME])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[OK
+])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LOCALE-TIME-FROM-SECONDS])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[OK
+])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LOG])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LOG10])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LOWER-CASE])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LOWER-CASE with reference modding])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION LOWEST-ALGEBRAIC])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MAX])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ DISPLAY FUNCTION MAX ( 3 -14 0 8 -3 )
+ END-DISPLAY.
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[8
+], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MEAN])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[-001.200
+])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MEDIAN])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ DISPLAY FUNCTION MEDIAN ( 3 -14 0 8 -3 )
+ END-DISPLAY.
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[0
+])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MIDRANGE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[-003.000
+])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MIN])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ DISPLAY FUNCTION MIN ( 3 -14 0 8 -3 )
+ END-DISPLAY.
+ STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[-14
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MOD (valid)])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION MOD (invalid)])
+AT_KEYWORDS([functions exceptions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+
+
+AT_SETUP([FUNCTION NUMVAL])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION NUMVAL-C])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION NUMVAL-C DP.COMMA])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION NUMVAL-F])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[" - 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
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION ORD])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[108
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION ORD-MAX])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[004
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION ORD-MIN])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[002
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION PI])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION PRESENT-VALUE])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[00000.5625
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION RANDOM])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION RANGE])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION REM (valid)])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION REM (invalid)])
+AT_KEYWORDS([functions exceptions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION REVERSE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION REVERSE with reference modding])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SECONDS-FROM-FORMATTED-TIME])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SECONDS-PAST-MIDNIGHT])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SIGN])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SIN])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SQRT])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION STANDARD-DEVIATION])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SUBSTITUTE])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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")
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[zz1114446665defxxzz
+FILLERBobZJimFILLERBobZJim
+FILLERBobZJimbobBobZJim
+bobBobZJimFILLERBobZJim
+FILLERFILLERZZFILLERFILLERZZ
+], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SUBSTITUTE with reference modding])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SUBSTITUTE-CASE])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SUBSTITUTE-CASE with reference mod])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION SUM])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TAN])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TEST-DATE-YYYYMMDD])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[003
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TEST-DAY-YYYYDDD])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[002
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TEST-FORMATTED-DATETIME with dates])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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
+ .
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TEST-FORMATTED-DATETIME with times])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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
+ .
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TEST-FORMATTED-DATETIME with datetimes])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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
+ .
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TEST-FORMATTED-DATETIME DP.COMMA])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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
+ .
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TEST-NUMVAL])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TEST-NUMVAL-C])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+AT_SETUP([FUNCTION TEST-NUMVAL-F])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TRIM])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[a#b.c%d+e$
+ a#b.c%d+e$
+])
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TRIM with reference modding])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[#b.
+a#b
+])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION TRIM zero length])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[> <
+><
+])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION UPPER-CASE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION UPPER-CASE with reference modding])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION VARIANCE])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+
+AT_CLEANUP
+
+
+AT_SETUP([FUNCTION WHEN-COMPILED])
+AT_KEYWORDS([functions])
+
+AT_DATA([prog.cob], [
+ 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.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+AT_SETUP([FUNCTION YEAR-TO-YYYY])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+AT_SETUP([UDF RETURNING group and PIC 9(5)])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], ["Santa Claus "
+"Santa Claus "
+54321
+54321
+], [])
+AT_CLEANUP
+
+AT_SETUP([UDF in COMPUTE])
+AT_KEYWORDS([functions])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[201
+])
+AT_CLEANUP
+
+AT_SETUP([UDF with recursion])
+AT_KEYWORDS([functions LOCAL-STORAGE])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+[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'], [])
+AT_CLEANUP
+
+AT_SETUP([Program-to-program parameters and retvals])
+AT_KEYWORDS([functions parameter])
+AT_DATA([prog.cob], [ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [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! "
+], [])
+AT_CLEANUP
+
+AT_SETUP([Recursive FUNCTION with local-storage])
+AT_KEYWORDS([functions parameter])
+AT_DATA([prog.cob], [ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [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
+], [])
+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
+
+AT_SETUP([FUNCTION BIGGER-POINTER])
+AT_KEYWORDS([functions POINTER ])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE -dialect ibm prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [ABC.
+ABC.
+ABC.
+], [])
+AT_CLEANUP
+
+AT_SETUP([FUNCTION BIGGER-POINTER (2)])
+AT_KEYWORDS([functions POINTER ])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE -dialect ibm prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [P4 and P8 before: 0xffffffffffffffff 0xffffffffffffffff
+Increment N4 and N8
+P4 and P8 after: 0x0000000000000000 0x0000000000000000
+], [])
+AT_CLEANUP
+
diff --git a/gcc/cobol/UAT/testsuite.src/run_fundamental.at b/gcc/cobol/UAT/testsuite.src/run_fundamental.at
index 018a815e963abdd299cd89b87c4d52221d665105..7c9465117718a7536adb7f0065af3e204127e60b 100644
--- a/gcc/cobol/UAT/testsuite.src/run_fundamental.at
+++ b/gcc/cobol/UAT/testsuite.src/run_fundamental.at
@@ -914,6 +914,25 @@ AT_CHECK([./a.out], [0], [0], [])
AT_CLEANUP
+AT_SETUP([Context sensitive words (5)])
+AT_KEYWORDS([fundamental recursive])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([./a.out], [0], [0], [])
+AT_CLEANUP
+
AT_SETUP([Context sensitive words (6)])
AT_KEYWORDS([fundamental normal])
AT_DATA([prog.cob], [
diff --git a/gcc/cobol/UAT/testsuite.src/run_misc.at b/gcc/cobol/UAT/testsuite.src/run_misc.at
index 8b01f5d16f34b83987f807daf6fc97ac95d6d35c..b9bdc50d834e617431e6b5d251b08a8e76a080a7 100644
--- a/gcc/cobol/UAT/testsuite.src/run_misc.at
+++ b/gcc/cobol/UAT/testsuite.src/run_misc.at
@@ -3213,7 +3213,6 @@ AT_DATA([prog.cob], [
])
AT_CHECK([$COMPILE prog.cob], [1], [],
[prog.cob:18: error: literal 'SUB ' must be a COBOL or C identifier at '"'
-prog.cob:22: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
@@ -3338,3 +3337,396 @@ AT_CHECK([$COMPILE -c callee2.cob], [0], [], [])
AT_CHECK([$COMPILE -o prog caller.cob callee.o callee2.o], [0], [], [])
AT_CHECK([./prog], [0], [abc000], [])
AT_CLEANUP
+
+AT_SETUP([LOCAL-STORAGE (3) with recursive PROGRAM-ID])
+AT_KEYWORDS([misc])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE -o prog prog.cob], [0], [], [])
+AT_CHECK([./prog], [0], [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
+], [])
+AT_CLEANUP
+
+AT_SETUP([LOCAL-STORAGE (4) with recursive PROGRAM-ID ... USING])
+AT_KEYWORDS([misc])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE -o prog prog.cob], [0], [], [])
+AT_CHECK([./prog], [0], [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
+], [])
+AT_CLEANUP
+
+AT_SETUP([Recursive CALL of RECURSIVE program])
+AT_KEYWORDS([misc CANCEL EXTERNAL])
+AT_DATA([caller.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. caller IS RECURSIVE.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 STOPPER PIC S9 EXTERNAL.
+ PROCEDURE DIVISION.
+ MOVE 0 TO STOPPER
+ CALL "callee"
+ DISPLAY 'OK' NO ADVANCING END-DISPLAY
+ *> FIXME: CANCEL broken on special environments
+ *> CANCEL "callee" , "callee2"
+ DISPLAY ' + FINE' NO ADVANCING END-DISPLAY
+ STOP RUN.
+])
+AT_DATA([callee.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. callee IS RECURSIVE.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 STOPPER PIC S9 EXTERNAL.
+ PROCEDURE DIVISION.
+ IF STOPPER = 9
+ MOVE -1 TO STOPPER
+ ELSE
+ ADD 1 TO STOPPER
+ CALL "callee2"
+ END-IF
+ GOBACK.
+])
+AT_DATA([callee2.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. callee2 IS RECURSIVE.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 STOPPER PIC S9 EXTERNAL.
+ PROCEDURE DIVISION.
+ IF STOPPER NOT EQUAL -1
+ CALL "callee"
+ END-IF
+ GOBACK.
+])
+
+AT_CHECK([$COMPILE -c callee.cob], [0], [], [])
+AT_CHECK([$COMPILE -c callee2.cob], [0], [], [])
+AT_CHECK([$COMPILE -o caller caller.cob callee.o callee2.o], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [OK + FINE], [])
+AT_CLEANUP
+
+
+AT_SETUP([Recursive CALL of INITIAL program])
+AT_KEYWORDS([misc])
+AT_DATA([caller.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. caller.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 STOPPER PIC 9 EXTERNAL.
+ PROCEDURE DIVISION.
+ MOVE 0 TO STOPPER
+ CALL "callee" END-CALL.
+ GOBACK.
+])
+AT_DATA([callee.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. callee IS INITIAL.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 STOPPER PIC 9 EXTERNAL.
+ PROCEDURE DIVISION.
+ IF STOPPER = 1
+ DISPLAY 'INITIAL prog was called RECURSIVE'
+ END-DISPLAY
+ * Following statement not ISO, corrected below
+ * STOP RUN RETURNING 1
+ MOVE 1 TO RETURN-CODE
+ STOP RUN
+ ELSE
+ MOVE 1 TO STOPPER
+ CALL "callee2" END-CALL
+ END-IF.
+ GOBACK.
+])
+AT_DATA([callee2.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. callee2.
+ PROCEDURE DIVISION.
+ CALL "callee" END-CALL.
+ GOBACK.
+])
+AT_CHECK([$COMPILE -c callee.cob], [0], [], [])
+AT_CHECK([$COMPILE -c callee2.cob], [0], [], [])
+AT_CHECK([$COMPILE -o caller caller.cob callee.o callee2.o], [0], [], [])
+AT_CHECK([./caller], [1], [INITIAL prog was called RECURSIVE
+], [])
+AT_CLEANUP
+
+
+AT_SETUP([Recursive CALL with RECURSIVE assumed])
+AT_KEYWORDS([misc])
+AT_DATA([caller.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. caller.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 STOPPER PIC 9 EXTERNAL.
+ PROCEDURE DIVISION.
+ MOVE 0 TO STOPPER
+ CALL "callee" END-CALL.
+ GOBACK.
+])
+AT_DATA([callee.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. callee IS INITIAL.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 STOPPER PIC 9 EXTERNAL.
+ PROCEDURE DIVISION.
+ IF STOPPER = 8
+ DISPLAY 'OK' NO ADVANCING END-DISPLAY.
+ IF STOPPER NOT = 9
+ ADD 1 TO STOPPER END-ADD
+ CALL "callee2" END-CALL.
+ GOBACK.
+])
+AT_DATA([callee2.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. callee2.
+ PROCEDURE DIVISION.
+ CALL "callee" END-CALL.
+ GOBACK.
+])
+AT_CHECK([$COMPILE -c callee.cob], [0], [], [])
+AT_CHECK([$COMPILE -c callee2.cob], [0], [], [])
+AT_CHECK([$COMPILE -o caller caller.cob callee.o callee2.o], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [OK], [])
+AT_CLEANUP
+
+
+AT_SETUP([PERFORM inline (1)])
+AT_KEYWORDS([misc])
+AT_DATA([prog.cob], [
+ 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
+ .
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([PERFORM inline (2)])
+AT_KEYWORDS([misc])
+AT_DATA([prog.cob], [
+ 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
+ .
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([UNSTRING DELIMITER IN])
+AT_KEYWORDS([misc])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([PERFORM type OSVS])
+AT_KEYWORDS([misc])
+AT_DATA([prog.cob], [
+ 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.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
+AT_CLEANUP
+
+
+AT_SETUP([Sticky LINKAGE])
+AT_KEYWORDS([misc])
+AT_DATA([callee.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. callee.
+ DATA DIVISION.
+ LINKAGE SECTION.
+ 01 P1 PIC X.
+ 01 P2 PIC X(6).
+ 01 P3 PIC X(6).
+ PROCEDURE DIVISION USING P1 P2.
+ IF P1 = "A"
+ SET ADDRESS OF P3 TO ADDRESS OF P2
+ ELSE
+ IF P3 NOT = "OKOKOK"
+ DISPLAY P3
+ END-DISPLAY
+ END-IF
+ END-IF.
+ EXIT PROGRAM.
+])
+AT_DATA([caller.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. caller.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 P1 PIC X VALUE "A".
+ 01 P2 PIC X(6) VALUE "NOT OK".
+ PROCEDURE DIVISION.
+ CALL "callee" USING P1 P2
+ END-CALL.
+ MOVE "B" TO P1.
+ MOVE "OKOKOK" TO P2.
+ CALL "callee" USING P1
+ END-CALL.
+ STOP RUN.
+])
+AT_CHECK([$COMPILE -c callee.cob], [0], [], [])
+AT_CHECK([$COMPILE -o caller caller.cob callee.o], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], [])
+AT_CLEANUP
diff --git a/gcc/cobol/UAT/testsuite.src/syn_copy.at b/gcc/cobol/UAT/testsuite.src/syn_copy.at
index 81b913fce99b7b2988f418c1209157bbb1f6ee8b..c43387d4580f80ea9d5f734273f5bc456f9ac840 100644
--- a/gcc/cobol/UAT/testsuite.src/syn_copy.at
+++ b/gcc/cobol/UAT/testsuite.src/syn_copy.at
@@ -287,10 +287,6 @@ cobol1: 3 1 copy2.CPY
cobol1: 2 1 copy3.CPY
cobol1: 1 1 ./copy1.CPY
copy1.CPY:1: recursive copybook: 'copy2.CPY' includes itself detected at end of file
-copy1.CPY:3: error: could not open copybook file for 'copy2'
-copy1.CPY:3: >>CDF parser failed
-copy1.CPY:3: syntax error
-.:9: 4 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
diff --git a/gcc/cobol/UAT/testsuite.src/syn_definition.at b/gcc/cobol/UAT/testsuite.src/syn_definition.at
index a8b97b2a996f5f8ccc146c651cdd0a070ac8a6e0..37812ea0998892698f71acd412645f73b1e8bffb 100644
--- a/gcc/cobol/UAT/testsuite.src/syn_definition.at
+++ b/gcc/cobol/UAT/testsuite.src/syn_definition.at
@@ -98,6 +98,27 @@ AT_CHECK([$COMPILE_ONLY SHORT.cob], [0], [], [])
AT_CHECK([./prog], [0], [], [])
AT_CLEANUP
+AT_SETUP([INITIAL / RECURSIVE before COMMON])
+AT_KEYWORDS([PROGRAM-ID definition])
+AT_DATA([containing-prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. containing-prog.
+ PROCEDURE DIVISION.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog-1 IS INITIAL COMMON.
+ PROCEDURE DIVISION.
+ STOP RUN.
+ END PROGRAM prog-1.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog-2 IS RECURSIVE COMMON.
+ PROCEDURE DIVISION.
+ STOP RUN.
+ END PROGRAM prog-2.
+])
+AT_CHECK([$COMPILE_ONLY containing-prog.cob], [0], [], [])
+AT_CLEANUP
+
AT_SETUP([Invalid PROGRAM-ID type clause (1)])
AT_KEYWORDS([definition])
@@ -111,7 +132,6 @@ AT_DATA([prog.cob], [
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
[prog.cob:3: error: COMMON may be used only in a contained program at 'COMMON'
-prog.cob:4: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog.cob
])
@@ -665,6 +685,28 @@ badprog.cob:12: error: 77 OUTPUT-NAME SAME AS MESSAGE-TEXT-2: must be elementary
.:13: 5 errors in DATA DIVISION, compilation ceases detected at end of file
cobol1: error: failed compiling badprog.cob
])
+AT_CLEANUP
+AT_SETUP([ALPHABET definition])
+AT_KEYWORDS([definition])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ SPECIAL-NAMES.
+ ALPHABET TESTME IS
+ 'A' THROUGH 'Z', x'00' thru x'05';
+ x'41' ALSO x'42', ALSO x'00', x'C1' ALSO x'C2'.
+ ALPHABET FINE
+ 'A' also 'B' also 'C' also 'd' also 'e' ALSO 'f',
+ 'g' also 'G', '1' thru '9', x'00'.
+])
+AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
+[prog.cob:9: error: ALPHABET , character 'A' (x'41') in position 32 already defined at position 0 at 'ALSO'
+prog.cob:10: 1 errors in DATA DIVISION, compilation ceases at 'ALPHABET'
+cobol1: error: failed compiling prog.cob
+])
AT_CLEANUP
+
diff --git a/gcc/cobol/UAT/testsuite.src/syn_misc.at b/gcc/cobol/UAT/testsuite.src/syn_misc.at
index 564e459cbcbaa2d5cc9222b20984e703a00bc852..2901cc0580e49db156ddc72664eec3bb936f65e7 100644
--- a/gcc/cobol/UAT/testsuite.src/syn_misc.at
+++ b/gcc/cobol/UAT/testsuite.src/syn_misc.at
@@ -477,12 +477,12 @@ AT_DATA([prog2.cob], [
.
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:7: ANY LENGTH valid only for 01 in LIKAGE SECTION of a contained program at 'LENGTH'
+[prog.cob:7: ANY LENGTH valid only for 01 in LINKAGE SECTION of a contained program at 'LENGTH'
prog.cob:9: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog.cob
])
AT_CHECK([$COMPILE_ONLY prog2.cob], [1], [],
-[prog2.cob:7: ANY LENGTH valid only for 01 in LIKAGE SECTION of a contained program at 'LENGTH'
+[prog2.cob:7: ANY LENGTH valid only for 01 in LINKAGE SECTION of a contained program at 'LENGTH'
prog2.cob:9: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog2.cob
])
@@ -505,7 +505,7 @@ AT_DATA([prog.cob], [
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:7: ANY LENGTH valid only for 01 in LIKAGE SECTION of a contained program at 'LENGTH'
+[prog.cob:7: ANY LENGTH valid only for 01 in LINKAGE SECTION of a contained program at 'LENGTH'
prog.cob:9: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog.cob
])
@@ -841,3 +841,16 @@ cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
+AT_SETUP([swapped SOURCE- and OBJECT-COMPUTER])
+AT_KEYWORDS([misc extensions])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ OBJECT-COMPUTER. a.
+ SOURCE-COMPUTER. b.
+])
+AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
+AT_CLEANUP
diff --git a/gcc/cobol/UAT/testsuite.src/syn_move.at b/gcc/cobol/UAT/testsuite.src/syn_move.at
index 7bd6a7815f64d2bb2cfd63f3165d522bf871d7b9..962bddfc2ceeb134b39550ea881e88d49dec35ae 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/UAT/testsuite.src/syn_occurs.at b/gcc/cobol/UAT/testsuite.src/syn_occurs.at
index 729bcb0bf2cbdead353ece9266a3e4e1890ea45d..33842c9480b65e9fb09438285877faeadc2a1cb9 100644
--- a/gcc/cobol/UAT/testsuite.src/syn_occurs.at
+++ b/gcc/cobol/UAT/testsuite.src/syn_occurs.at
@@ -21,3 +21,23 @@
### ISO+IEC+1989-2002 13.16.36 OCCURS clause
### ISO+IEC+1989-202x 3rd WD 13.18.38 OCCURS clause
+AT_SETUP([Nested OCCURS clause])
+AT_KEYWORDS([occurs])
+# NOT IMPLEMENTED: Diagnostic messages
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G-1.
+ 02 G-2 OCCURS 2.
+ 03 G-3 OCCURS 2.
+ 04 G-4 OCCURS 2.
+ 05 G-5 OCCURS 2.
+ 06 G-6 OCCURS 2.
+ 07 G-7 OCCURS 2.
+ 08 G-8 OCCURS 2.
+ 09 X PIC X.
+])
+AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
+AT_CLEANUP
diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y
index 9995f806a30833385670db2cda138a9d3b846b30..428ed9d59f7e24b0c45ace22b4096e4052947cf8 100644
--- a/gcc/cobol/cdf.y
+++ b/gcc/cobol/cdf.y
@@ -259,39 +259,39 @@ apply_cdf_turn( exception_turns_t& turns ) {
%type <file> filename
%type <files> filenames
-%token BY 467
-%token COPY 356
-%token CDF_DISPLAY 378
-%token IN 578
+%token BY 470
+%token COPY 358
+%token CDF_DISPLAY 380
+%token IN 583
%token NAME 286
%token NUMSTR 304
-%token OF 650
-%token PSEUDOTEXT 686
-%token REPLACING 708
+%token OF 662
+%token PSEUDOTEXT 698
+%token REPLACING 720
%token LITERAL 297
-%token SUPPRESS 373
+%token SUPPRESS 375
-%token LSUB 361 SUBSCRIPT 372 RSUB 366
+%token LSUB 363 SUBSCRIPT 374 RSUB 368
-%token CDF_DEFINE 377
-%token CDF_IF 379 CDF_ELSE 380 CDF_END_IF 381
-%token CDF_EVALUATE 382 CDF_WHEN 383 CDF_END_EVALUATE 384
+%token CDF_DEFINE 379
+%token CDF_IF 381 CDF_ELSE 382 CDF_END_IF 383
+%token CDF_EVALUATE 384 CDF_WHEN 385 CDF_END_EVALUATE 386
-%token AS 451 CONSTANT 355 DEFINED 357
+%token AS 454 CONSTANT 357 DEFINED 359
%type <boolean> DEFINED
-%token OTHER 662 PARAMETER_kw 362 OFF 651 OVERRIDE 363
-%token THRU 897
-%token TRUE_kw 772
+%token OTHER 674 PARAMETER_kw 364 OFF 663 OVERRIDE 365
+%token THRU 910
+%token TRUE_kw 785
-%token TURN 774 CHECKING 475 LOCATION 614 ON 653 WITH 798
+%token TURN 787 CHECKING 478 LOCATION 626 ON 665 WITH 811
-%left OR 898
-%left AND 899
-%right NOT 900
-%left '<' '>' '=' NE 901 LE 902 GE 903
+%left OR 911
+%left AND 912
+%right NOT 913
+%left '<' '>' '=' NE 914 LE 915 GE 916
%left '-' '+'
%left '*' '/'
-%right NEG 904
+%right NEG 917
%define api.prefix {ydf}
%define api.token.prefix{YDF_}
diff --git a/gcc/cobol/cdf_text.h b/gcc/cobol/cdf_text.h
index 396fc44cd23a71bd76da25abf32eae2807dbcfaa..8c86bc770db7d034d01462523099a9d0904850dc 100644
--- a/gcc/cobol/cdf_text.h
+++ b/gcc/cobol/cdf_text.h
@@ -28,7 +28,51 @@
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
+static const char *
+find_filter( const char filter[] ) {
+
+ if( 0 == access(filter, X_OK) ) {
+ return filter;
+ }
+
+ const char *path = getenv("PATH");
+ if( ! path ) return NULL;
+ char *p = strdup(path), *eopath = p + strlen(p);
+
+ while( *p != '\0' ) {
+ auto pend = std::find( p, eopath, ':' );
+ if( *pend == ':' ) *pend++ = '\0';
+
+ static char name[PATH_MAX];
+
+ snprintf( name, sizeof(name), "%s/%s", p, filter );
+
+ if( 0 == access(name, X_OK) ) {
+ return name;
+ }
+ p = pend;
+ }
+ return NULL;
+}
+
+bool verbose_file_reader = false;
+static std::list<char *> preprocessor_filters;
+
#include "lexio.h"
+
+#include <sys/types.h>
+#include <sys/wait.h>
+
+bool preprocess_filter_add( const char filter[] ) {
+ auto filename = find_filter(filter);
+ if( !filename ) {
+ warnx("error: preprocessor '%s/%s' not found", getcwd(NULL, 0), filter);
+ return false;
+ }
+ preprocessor_filters.push_back( strdup(filename) );
+ return true;
+}
+
FILE *
cdftext::lex_open( const char filename[] ) {
int input = open_input( filename );
@@ -39,6 +83,29 @@ cdftext::lex_open( const char filename[] ) {
cobol_filename(filename);
process_file( mfile, output );
+ for( auto filter : preprocessor_filters ) {
+ input = output;
+ output = open_output();
+
+ pid_t pid = fork();
+
+ switch(pid){
+ case -1: err(EXIT_FAILURE, "%s", __func__);
+ case 0: // child
+ if( -1 == dup2(input, STDIN_FILENO) ) {
+ errx(EXIT_FAILURE, "%s: could not dup input", __func__);
+ }
+ if( -1 == dup2(output, STDOUT_FILENO) ) {
+ errx(EXIT_FAILURE, "%s: could not dup output", __func__);
+ }
+ _exit( execl( filter, filter, "/dev/stdin", NULL ) );
+ }
+ int status;
+ if( pid != wait(&status) ) {
+ err(EXIT_FAILURE, "error: %s failed with exit status %d", filter, status);
+ }
+ }
+
return fdopen( output, "r");
}
@@ -49,6 +116,12 @@ cdftext::open_input( const char filename[] ) {
if( fd == -1 ) {
if( yydebug ) warn( "error: could not open '%s'", filename );
}
+
+ verbose_file_reader = NULL != getenv("GCOBOL_TEMPDIR");
+
+ if( verbose_file_reader ) {
+ warnx("verbose: opening %s for input", filename);
+ }
return fd;
}
@@ -58,7 +131,7 @@ cdftext::open_output() {
char *name = getenv("GCOBOL_TEMPDIR");
int fd;
- if( name ) {
+ if( name && 0 != strcmp(name, "/") ) {
sprintf(stem, "%sXXXXXX", name);
if( -1 == (fd = mkstemp(stem)) ) {
err(EXIT_FAILURE,
@@ -151,6 +224,10 @@ cdftext::free_form_reference_format( int input ) {
char *indcol = indicated(mfile.cur, mfile.eol); // true only for fixed format
+ if( is_fixed_format() && !indcol ) { // short line
+ erase_source(mfile.cur, mfile.eol);
+ }
+
if( indcol ) {
// Set to blank columns 1-6 and anything past the right margin.
erase_source(mfile.cur, indcol);
diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc
index 452d29d490a94b10907dd1958cfdbb4289c5f5f0..4cc4f3c9e7e4253c549526b0e056063d5b79babc 100644
--- a/gcc/cobol/cobol1.cc
+++ b/gcc/cobol/cobol1.cc
@@ -155,6 +155,8 @@ void parser_internal_is_ebcdic(bool is_ebcdic);
bool use_static_call( bool yn );
void add_cobol_exception( int );
+bool preprocess_filter_add( const char filter[] );
+
bool max_errors_exceeded( int nerr ) {
return flag_max_errors != 0 && flag_max_errors <= nerr;
}
@@ -251,6 +253,10 @@ cobol_langhook_handle_option (size_t scode,
}
return true;
+ case OPT_preprocess:
+ preprocess_filter_add(arg);
+ return true;
+
case OPT_main:
// This isn't right. All OPT_main should be replaced
error("We should never see a non-equal dash-main in cobol1.c");
diff --git a/gcc/cobol/failures/playpen/input.txt b/gcc/cobol/failures/playpen/input.txt
index 6e4186aca58aa94ddf74133dabe2a63b25e333bd..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 100644
--- a/gcc/cobol/failures/playpen/input.txt
+++ b/gcc/cobol/failures/playpen/input.txt
@@ -1,16 +0,0 @@
-Iowa
-100000
-Georgia
-FL
-DE
-Missouri
-Indiana
-1500000
-nh
-10000000
-New Hampshirex
-Phoenixx
-Albanyx
-Salemx
-MX
-North Dakotax
diff --git a/gcc/cobol/failures/playpen/playpen.cbl b/gcc/cobol/failures/playpen/playpen.cbl
index f5c2b8f4289b8bb4231cd18f2a7493602ab68483..b7539b01fb76d903a1c39aa5826b940c77ce49ce 100644
--- a/gcc/cobol/failures/playpen/playpen.cbl
+++ b/gcc/cobol/failures/playpen/playpen.cbl
@@ -1,34 +1,17 @@
- IDENTIFICATION DIVISION.
- PROGRAM-ID. caller.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 P1 PIC X VALUE "A".
- 01 P2 PIC X(6) VALUE "NOT OK".
- PROCEDURE DIVISION.
- CALL "callee" USING P1 P2
- END-CALL.
- MOVE "B" TO P1.
- MOVE "OKOKOK" TO P2.
- CALL "callee" USING P1
- END-CALL.
- STOP RUN.
- END PROGRAM caller.
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 P1 PIC X.
- 01 P2 PIC X(6).
- 01 P3 PIC X(6).
- PROCEDURE DIVISION USING P1 P2.
- IF P1 = "A"
- SET ADDRESS OF P3 TO ADDRESS OF P2
- ELSE
- IF P3 NOT = "OKOKOK"
- DISPLAY P3
- END-DISPLAY
- END-IF
- END-IF.
- EXIT PROGRAM.
- END PROGRAM callee.
\ No newline at end of file
+ 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/cobol/failures/recursive_function/Makefile b/gcc/cobol/failures/recursive_function/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..f77e46b3451abf45cb70ed9dc161be56b3b063c7
--- /dev/null
+++ b/gcc/cobol/failures/recursive_function/Makefile
@@ -0,0 +1 @@
+include ../Makefile.inc
diff --git a/gcc/cobol/failures/playpen/known-good.txt b/gcc/cobol/failures/recursive_function/input.txt
similarity index 100%
rename from gcc/cobol/failures/playpen/known-good.txt
rename to gcc/cobol/failures/recursive_function/input.txt
diff --git a/gcc/cobol/failures/recursive_function/playpen.cbl b/gcc/cobol/failures/recursive_function/playpen.cbl
new file mode 100644
index 0000000000000000000000000000000000000000..80755fc361bdbd4613c7a34de9eb99cd5d458656
--- /dev/null
+++ b/gcc/cobol/failures/recursive_function/playpen.cbl
@@ -0,0 +1,37 @@
+ 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/cobol/gcobol.1 b/gcc/cobol/gcobol.1
index ed930fc5e0362493314a88f61af7e60d6b4c7e69..4d16622bca071bafd2f717971d6d74279041cde5 100644
--- a/gcc/cobol/gcobol.1
+++ b/gcc/cobol/gcobol.1
@@ -19,6 +19,7 @@
.Op Fl findicator-column
.Op Fl finternal-ebcdic
.Op Fl dialect Ar dialect-name
+.Op Fl preprocess Ar preprocess-filter
.Op Fl fflex-debug
.Op Fl fyacc-debug
.Ar filename Op ...
@@ -174,13 +175,17 @@ With
.Fl fno-static-call ,
.Nm
never uses static linking for
-.D1 Sy CALL Ar program Ns .
+.D1 Sy CALL Ar program
By default, or with
.Fl fstatic-call ,
+if
+.Ar program
+is an alphanumeric literal,
.Nm
-uses static linkage if
+uses static linkage, meaning the compiler produces an external symbol
.Ar program
-is an alphanumeric literal. (In the future, for
+for the linker to resolve.
+(In the future, that will work with
.Sy CONSTANT
data items, too.) With static linkage, if
.Ar program
@@ -228,6 +233,25 @@ Only a few such non-standard constructs are accepted, and
makes no claim or aspiration to emulate other compilers. But to the
extent that a feature is popular but nonstandard, this
option provides a way to support it, or add it.
+.
+.It Fl preprocess Ar preprocess-filter
+After all CDF text-manipulation has been applied, and before the
+prepared \*[lang] is sent to the cobol1 compiler, the input may be
+further altered by one or more filters. In the tradition of
+.Xr sed 1 ,
+each
+.Ar preprocess-filter
+reads from standard input and writes to standard output.
+No options or arguments are supported for
+.Ar preprocess-filter .
+.Nm
+searches the current working directory and the PATH environment
+variable directories for the existence of an executable file whose
+name matches
+.Ar preprocess-filter .
+The first one found is used. If none is found, an error is reported
+and the compiler is not invoked.
+.
.It Fl fflex-debug Ns Li , Fl fyacc-debug
produce messages useful for compiler development. The
.Fl fflex-debug
@@ -267,6 +291,26 @@ At the present time, this is an all-or-nothing setting. Support for
and
.Sy CODESET ,
which would allow conversion between encodings, remains a future goal.
+.Ss REDEFINES ... USAGE POINTER
+Per ISO, an item that
+.Sy REDEFINES
+another may not be larger than the item it redefines, unless that item
+has LEVEL 01 and is not EXTERNAL. In
+.Nm ,
+using
+.Fl dialect Ar ibm ,
+this rule is relaxed for
+.Sy REDEFINES
+with
+.Sy USAGE POINTER
+whose redefined member is a 4-byte
+.Sy USAGE COMP-5
+(usually
+.Sy PIC S9(8) Ns ).
+In that case, the redefined member is re-sized to be 8 bytes, to
+accommodate the pointer. This feature allows pointer arithmetic on a
+64-bit system with source code targeted at a 32-bit system.
+.Sy
.
.Sh IMPLEMENTATION NOTES
.Nm
@@ -277,20 +321,22 @@ specification, any such conflicts are resolved in favor of gcc.
.Ss Linking
Unlike, C, the \*[lang]
.Sy CALL
-statement implies dynamic linking, because the
-.Sy CALL
-parameter can be a variable whose value is determined at runtime.
+statement implies dynamic linking, because for
+.D1 Sy CALL Ar program
+.Ar program
+can be a variable whose value is determined at runtime.
However, the parameter may also be compile-time constant, either an
alphanumeric literal, or a
.Sy CONSTANT
data item.
.Pp
.Nm
-supports static linking where possible. If the parameter value is
-known at compile time, the compiler produces an external reference to
-be resolved by the linker. The referenced program is normally supplied
-via an object module, a static library, or a shared object. If it is
-not supplied, the linker will report an
+supports static linking where possible, unless defeated by
+.Fl no-static-call .
+If the parameter value is known at compile time, the compiler produces
+an external reference to be resolved by the linker. The referenced
+program is normally supplied via an object module, a static library,
+or a shared object. If it is not supplied, the linker will report an
.Dq "unresolved symbol"
error, either at build time or, if using a shared object, when the
program is executed. This feature informs the programmer of the error
@@ -300,6 +346,16 @@ Programs that are expected to execute
correctly in the presence of an unresolved symbol (perhaps because the
program logic won't require that particular
.Sy CALL )
+can use the
+.Fl no-static-call
+option. That forces all
+.Sy CALL
+statements to be resolved dynamically, at runtime.
+.ig
+Programs that are expected to execute
+correctly in the presence of an unresolved symbol (perhaps because the
+program logic won't require that particular
+.Sy CALL )
can use linker options to produce an executable anyway.
.Pp
One corner case yet remains. The
@@ -333,7 +389,8 @@ Should your program meet those particular conditions, all is not lost.
There are workarounds, and an option could be added to use dynamic
linking for all
.Sy CALL
-statement, regardless of compile-time constants.
+statement, regardless of compile-time constants.
+..
.
.Sh EXTENSIONS TO ISO \*[lang]
Standard \*[lang] has no provision for environment variables as defined
@@ -671,7 +728,7 @@ statement, with or without its
.Sy REPLACING
component. For any statement
.sp
-.D1 "COPY copybook"
+.D1 COPY Ar copybook
.sp
.Nm
looks first for an environment variable named
@@ -875,7 +932,8 @@ through
where 0-7 indicates a bit position. The value of the UPSI switches is
taken from the
.Ev UPSI
-environment variable, whose value is a string of up to eight 1's and 0's. The first character represents the value of
+environment variable, whose value is a string of up to eight 1's and
+0's. The first character represents the value of
.Sy UPSI-0 ,
and missing values are assigned 0. For example,
.Sy UPSI=1000011
@@ -885,6 +943,15 @@ in the environment sets bits 0, 5, and 6 on, which means that
and
.Sy UPSI-6
are on.
+.It Ev GCOBOL_TEMPDIR
+causes any temporary files created during CDF processing to be written
+to a file whose name is specified in the value of
+.Ev GCOBOL_TEMPDIR .
+If the value is just
+.Dq / ,
+the effect is different: each copybook read is reported on standard
+error. This feature is meant to help diagnose mysterious copybook
+errors.
.El
.
.Sh FILES
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 3354e1f9125363c4dbb7873939c35c63d53e652e..fe71f9b6baa5e734365323a0d6b59577f9789028 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -127,7 +127,7 @@ static bool auto_advance_is_AFTER_advancing = 0;
casts. For example, main() returns an INT, as do functions that
return the default RETURN-CODE will have */
-#define COBOL_FUNCTION_RETURN_TYPE SIZE_T
+#define COBOL_FUNCTION_RETURN_TYPE SSIZE_T
#define MAX_AFTERS 8
@@ -234,7 +234,6 @@ build_main_that_calls_something(const char *something)
TRACE1_END
}
- //gg_call(VOID, "__gg__pop_jmp_buf", 0);
gg_return(gg_cast(INT, gg_call_expr( COBOL_FUNCTION_RETURN_TYPE,
cobol_name_mangler(something),
0)));
@@ -695,7 +694,8 @@ parser_call_target_update( size_t caller,
static tree
function_handle_from_name(cbl_refer_t &name,
- size_t narg)
+ size_t narg,
+ tree function_return_type)
{
// We need to set up for narg parameters:
tree *arg_types = (tree *)xmalloc(narg * sizeof(tree));
@@ -703,7 +703,7 @@ function_handle_from_name(cbl_refer_t &name,
{
arg_types[i] = VOID_P;
};
- tree function_type = build_varargs_function_type_array (COBOL_FUNCTION_RETURN_TYPE,
+ tree function_type = build_varargs_function_type_array (function_return_type,
narg,
arg_types);
tree function_pointer = build_pointer_type(function_type);
@@ -717,7 +717,7 @@ function_handle_from_name(cbl_refer_t &name,
tree unmangled_name = gg_define_char_star();
tree mangled_name = gg_define_char_star();
- gg_assign(unmangled_name, gg_call_expr( CHAR_P,
+ gg_assign(unmangled_name, gg_call_expr( CHAR_P,
"__gg__name_not_mangled",
1,
gg_get_address_of(name.refer_decl_node)));
@@ -835,11 +835,11 @@ function_handle_from_name(cbl_refer_t &name,
// If it's a literal, call the target literally using the
// undecorated name. At END-PROGRAM, the parser will replace
// in-scope plain names with mangled names.
- if( use_static_call() && is_literal(name.field) )
+ if( use_static_call() && is_literal(name.field) )
{
// A literal name is always "found". We create a reference to
// it, which is later resolved by the linker.
- tree addr_expr = gg_get_function_address(SIZE_T, name.field->data.initial);
+ tree addr_expr = gg_get_function_address(function_return_type, name.field->data.initial);
gg_assign(function_handle, addr_expr);
if( DECL_P(function_handle) )
@@ -881,7 +881,7 @@ function_handle_from_name(cbl_refer_t &name,
{
// A literal name is always "found". We create a reference to
// it, which is later resolved by the linker.
- tree addr_expr = gg_get_function_address(SIZE_T, name.field->data.initial);
+ tree addr_expr = gg_get_function_address(function_return_type, name.field->data.initial);
gg_assign(function_handle, addr_expr);
if( DECL_P(function_handle) )
@@ -969,7 +969,7 @@ parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs)
for( size_t i=0; i<nprogs; i++ )
{
- tree function_handle = function_handle_from_name(progs[i], 0);
+ tree function_handle = function_handle_from_name(progs[i], 0, COBOL_FUNCTION_RETURN_TYPE);
gg_call(VOID,
"__gg__to_be_canceled",
1,
@@ -3018,6 +3018,7 @@ register_main_switch(const char *main_string)
if( p )
{
*p = '\0';
+ main_string = p+1;
}
main_strings[mstr] = main_string;
free(mstr);
@@ -3233,7 +3234,8 @@ enter_program_common(const char *funcname, const char *funcname_)
}
void
-parser_enter_program(const char *funcname_)
+parser_enter_program( const char *funcname_,
+ bool is_function) // True for user-defined-function
{
// The first thing we have to do is mangle this name. This is safe even
// though the end result will be mangled again, because the mangler doesn't
@@ -3262,18 +3264,21 @@ parser_enter_program(const char *funcname_)
SHOW_PARSE_END
}
- if( next_program_is_main )
+ if( !is_function )
{
- next_program_is_main = false;
- if(main_entry_point)
- {
- build_main_that_calls_something(main_entry_point);
- free(main_entry_point);
- main_entry_point = NULL;
- }
- else
+ if( next_program_is_main )
{
- build_main_that_calls_something(funcname);
+ next_program_is_main = false;
+ if(main_entry_point)
+ {
+ build_main_that_calls_something(main_entry_point);
+ free(main_entry_point);
+ main_entry_point = NULL;
+ }
+ else
+ {
+ build_main_that_calls_something(funcname);
+ }
}
}
@@ -3286,6 +3291,7 @@ parser_enter_program(const char *funcname_)
}
enter_program_common(funcname, funcname_);
+ current_function->is_function = is_function;
TRACE1
{
@@ -4722,44 +4728,92 @@ parser_move(size_t ntgt, cbl_refer_t *tgts, cbl_refer_t src, cbl_round_t rounded
static
tree
-field_type_to_tree_type(cbl_field_t *field)
+tree_type_from_field_type(cbl_field_t *field, size_t &nbytes)
{
- // This maps a Fldxxx to a C-style variable type:
- switch(field->type)
+ /* This routine is used to determine what action is taken with type of a
+ CALL ... USING <var> and the matching PROCEDURE DIVISION USING <var> of
+ a PROGRAM-ID or FUNCTION-ID
+ */
+ tree retval = COBOL_FUNCTION_RETURN_TYPE;
+ nbytes = 8;
+ if( field )
{
- case FldGroup:
- case FldAlphanumeric:
- case FldAlphaEdited:
- return CHAR_P;
+ // This maps a Fldxxx to a C-style variable type:
+ switch(field->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldAlphaEdited:
+ case FldNumericEdited:
+ retval = CHAR_P;
+ nbytes = field->data.capacity;
+ break;
- case FldNumericEdited:
- case FldNumericDisplay:
- case FldNumericBinary:
- case FldPacked:
- case FldNumericBin5:
- case FldIndex:
- case FldPointer:
- return SSIZE_T;
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldPacked:
+ if( field->data.digits > 18 )
+ {
+ retval = UINT128;
+ nbytes = 16;
+ }
+ else
+ {
+ retval = SIZE_T;
+ nbytes = 8;
+ }
+ break;
- case FldFloat:
- return DOUBLE;
+ case FldNumericBin5:
+ case FldIndex:
+ case FldPointer:
+ if( field->data.capacity > 8 )
+ {
+ retval = UINT128;
+ nbytes = 16;
+ }
+ else
+ {
+ retval = SIZE_T;
+ nbytes = 8;
+ }
+ break;
- case FldInvalid:
- case FldClass:
- case FldConditional:
- case FldForward:
- warnx( "%s(): Invalid field type %s:",
- __func__,
- cbl_field_type_str(field->type));
- gcc_assert(false);
- break;
+ case FldFloat:
+ if( field->data.capacity == 8 )
+ {
+ retval = DOUBLE;
+ nbytes = 8;
+ }
+ else if( field->data.capacity == 4 )
+ {
+ retval = FLOAT;
+ nbytes = 4;
+ }
+ else
+ {
+ retval = FLOAT128;
+ nbytes = 16;
+ }
+ break;
- default:
- warnx("%s(): Unknown field type %d:", __func__, field->type);
- gcc_assert(false);
- break;
+ default:
+ warnx( "%s(): Invalid field type %s:",
+ __func__,
+ cbl_field_type_str(field->type));
+ gcc_assert(false);
+ break;
+ }
}
- return NULL_TREE; // This shuts the compiler up.
+ if( retval == SIZE_T && field->attr & signable_e )
+ {
+ retval = SSIZE_T;
+ }
+ if( retval == UINT128 && field->attr & signable_e )
+ {
+ retval = INT128;
+ }
+ return retval;
}
static void
@@ -4832,82 +4886,75 @@ parser_exit(void)
if( current_function->returning )
{
- tree return_type = field_type_to_tree_type(current_function->returning);
+ cbl_field_type_t field_type = current_function->returning->type;
+ size_t nbytes = 0;
+ tree return_type = tree_type_from_field_type(current_function->returning,
+ nbytes);
+ tree retval = gg_define_variable(return_type);
- if( return_type == CHAR_P )
- {
- // When an external routine is called, the ->returning value has
- // to be treated as if it were in the console codeset space
+ gg_modify_function_type(current_function->function_decl,
+ return_type);
- gg_call(VOID,
- "__gg__internal_to_console_in_place",
- 2,
- member(current_function->returning, "data"),
- member(current_function->returning, "capacity"));
-
- //gg_call(VOID, "__gg__pop_jmp_buf", 0);
- restore_local_variables();
- gg_return( gg_cast(COBOL_FUNCTION_RETURN_TYPE,
- member(current_function->returning, "data")));
- }
- else if( return_type == DOUBLE )
+ if( is_numeric( field_type ) )
{
- // We need to do the equivalent of
- // return *(size_t *)&(double_thing)
- //
- // but I haven't yet investigated how to do that in GENERIC.
- //
- // By and by....
- tree dubble = gg_define_variable(DOUBLE);
- if( current_function->returning->type == FldFloat
- && current_function->returning->data.capacity == 4)
+ // The field being returned is numeric.
+ if( field_type == FldNumericBin5
+ || field_type == FldFloat
+ || field_type == FldPointer
+ || field_type == FldIndex )
{
- tree flote = gg_define_variable(FLOAT);
- gg_memcpy( gg_get_address_of(flote),
- member(current_function->returning, "data"),
- member(current_function->returning, "capacity") );
- gg_assign(dubble, gg_cast(DOUBLE, flote));
- }
- else if( current_function->returning->type == FldFloat
- && current_function->returning->data.capacity == 8)
-
- {
- gg_memcpy( gg_get_address_of(dubble),
- member(current_function->returning, "data"),
- member(current_function->returning, "capacity") );
+ // These are easily handled because they are all little-endian.
+ gg_memcpy(gg_get_address_of(retval),
+ member(current_function->returning, "data"),
+ build_int_cst_type(SIZE_T, nbytes));
}
else
{
- warnx("%s(): No use ramblin', walkin' in the shadows, trailin' a wandering star...", __func__);
- gcc_assert(false);
+ // The field_type has a PICTURE string, so we need to convert from the
+ // COBOL form to little-endian binary:
+ tree rdigits = gg_define_int();
+ tree value = gg_define_int128();
+ get_binary_value( value,
+ rdigits,
+ NULL,
+ current_function->returning);
+// gg_printf("KILROY returning %ld\n", gg_cast(LONG, value), NULL_TREE);
+ gg_memcpy(gg_get_address_of(retval),
+ gg_get_address_of(value),
+ build_int_cst_type(SIZE_T, nbytes));
}
- tree retval = gg_define_size_t();
- gg_memcpy( gg_get_address_of(retval),
- gg_get_address_of(dubble),
- sizeof_size_t );
- //gg_call(VOID, "__gg__pop_jmp_buf", 0);
- restore_local_variables();
- gg_return(retval);
- }
- else if( return_type == SSIZE_T)
- {
- tree rdigits = gg_define_int();
- tree value = gg_define_int128();
- get_binary_value( value,
- rdigits,
- NULL,
- current_function->returning);
- tree retval = gg_define_size_t();
- gg_assign(retval, gg_cast(SIZE_T, retval));
- //gg_call(VOID, "__gg__pop_jmp_buf", 0);
restore_local_variables();
gg_return(retval);
}
else
{
- //gg_call(VOID, "__gg__pop_jmp_buf", 0);
+ // The RETURNING type is a group or alphanumeric
+
+ // When an external routine is called, the ->returning value has
+ // to be treated as if it were in the console codeset space
+ gg_call(VOID,
+ "__gg__internal_to_console_in_place",
+ 2,
+ member(current_function->returning, "data"),
+ member(current_function->returning, "capacity"));
+
+ // The byte array to be returned is in returning, which is a local
+ // variable on the stack. We need to make a copy of it to avoid the
+ // error of returning a pointer to data on the stack.
+
+ tree array_type = build_array_type_nelts(UCHAR,
+ current_function->returning->data.capacity);
+ tree retval = gg_define_variable(array_type,
+ NULL,
+ vs_static);
+ gg_memcpy(gg_get_address_of(retval),
+ member(current_function->returning->var_decl_node, "data"),
+ member(current_function->returning->var_decl_node, "capacity"));
+
+ tree actual = gg_cast(COBOL_FUNCTION_RETURN_TYPE, gg_get_address_of(retval));
+
restore_local_variables();
- gg_return(gg_cast(COBOL_FUNCTION_RETURN_TYPE, integer_zero_node));
+ gg_return(actual);
}
}
else
@@ -4932,8 +4979,6 @@ parser_exit(void)
rdigits,
NULL,
our_return_code);
-
- //gg_call(VOID, "__gg__pop_jmp_buf", 0);
restore_local_variables();
gg_return(gg_cast(COBOL_FUNCTION_RETURN_TYPE,
value));
@@ -5336,21 +5381,19 @@ parser_division(cbl_division_t division,
// RETURNING variables are supposed to be in the linkage section, which
// means that we didn't assign any storage to them during
// parser_symbol_add(). We do that here.
+
+ // returning also needs to behave like local storage, even though it is
+ // in linkage.
- if( returning && !returning->data_decl_node )
+ // This counter is used to help keep track of local variables
+ gg_increment(var_decl_unique_prog_id);
+ if( returning )
{
- char achDataName[256];
- sprintf(achDataName, "..vardata_%lu", sv_data_name_counter++);
-
- tree array_type = build_array_type_nelts(UCHAR, returning->data.capacity);
- returning->data_decl_node = gg_define_variable( array_type,
- achDataName,
- vs_static);
- gg_assign( member(returning->var_decl_node, "data"),
- gg_get_address_of(returning->data_decl_node) );
+ parser_local_add(returning);
+ current_function->returning = returning;
}
-
- // Stash the returning variable for use during parser_return()
+
+ // Stash the returning variables for use during parser_return()
current_function->returning = returning;
if( gg_trans_unit.function_stack.size() == 1 )
@@ -5379,7 +5422,22 @@ parser_division(cbl_division_t division,
char ach[2*sizeof(cbl_name_t)];
sprintf(ach, "_p_%s", args[i].refer.field->name);
- chain_parameter_to_function(current_function->function_decl, VOID_P, ach);
+
+ size_t nbytes = 0;
+ tree par_type = tree_type_from_field_type(args[i].refer.field, nbytes);
+ if( par_type == FLOAT )
+ {
+ par_type = SSIZE_T;
+ }
+ if( par_type == DOUBLE )
+ {
+ par_type = SSIZE_T;
+ }
+ if( par_type == FLOAT128 )
+ {
+ par_type = INT128;
+ }
+ chain_parameter_to_function(current_function->function_decl, par_type, ach);
}
if( nusing )
@@ -5411,6 +5469,21 @@ parser_division(cbl_division_t division,
// It makes more sense if you don't think about it too hard.
+
+ // We need to be able to restore prior arguments when doing recursive
+ // calls:
+ IF( member(args[i].refer.field->var_decl_node, "data"),
+ ne_op,
+ gg_cast(UCHAR_P, null_pointer_node) )
+ {
+ gg_call(VOID,
+ "__gg__push_local_variable",
+ 1,
+ gg_get_address_of(args[i].refer.field->var_decl_node));
+ }
+ ELSE
+ ENDIF
+
tree base = gg_define_variable(UCHAR_P);
gg_assign(rt_i, build_int_cst_type(INT, i));
IF( rt_i, lt_op , var_decl_call_parameter_count )
@@ -5447,12 +5520,59 @@ parser_division(cbl_division_t division,
if( args[i].crv == by_value_e )
{
- // 'parameter' is the 64-bit value that was placed on the stack
+ // 'parameter' is the 64-bit or 128-bit value that was placed on the stack
+
+ cbl_field_t *new_var = args[i].refer.field;
+
+ size_t nbytes;
+ tree_type_from_field_type(new_var, nbytes);
+ tree parm = gg_define_variable(INT128);
+
+ if( nbytes <= 8 )
+ {
+ // Our input is a 64-bit number
+ if( new_var->attr & signable_e )
+ {
+ IF( gg_bitwise_and( gg_cast(SIZE_T, parameter),
+ build_int_cst_type(SIZE_T, 0x8000000000000000ULL)),
+ ne_op,
+ gg_cast(SIZE_T, integer_zero_node) )
+ {
+ // Our input is a negative number
+ gg_assign(parm, gg_cast(INT128, integer_minus_one_node));
+ }
+ ELSE
+ {
+ // Our input is a positive number
+ gg_assign(parm, gg_cast(INT128, integer_zero_node));
+ }
+ ENDIF
+ }
+ else
+ {
+ // This is a 64-bit positive number:
+ gg_assign(parm, gg_cast(INT128, integer_zero_node));
+ }
+ }
+ // At this point, parm has been set to 0 or -1
+
+ gg_memcpy(gg_get_address_of(parm),
+ gg_get_address_of(parameter),
+ build_int_cst_type(SIZE_T, nbytes));
+
+ tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity);
+ tree data_decl_node = gg_define_variable( array_type,
+ NULL,
+ vs_stack);
+ gg_assign( member(new_var->var_decl_node, "data"),
+ gg_get_address_of(data_decl_node) );
+
+ // And then move it into place
gg_call(VOID,
"__gg__assign_value_from_stack",
2,
- gg_get_address_of(args[i].refer.field->var_decl_node),
- parameter);
+ gg_get_address_of(new_var->var_decl_node),
+ parm);
}
else
{
@@ -5470,9 +5590,6 @@ parser_division(cbl_division_t division,
gg_assign(var_decl_call_parameter_count, build_int_cst_type(INT, A_ZILLION));
}
- // This counter is used to help keep track of local variables
- gg_increment(var_decl_unique_prog_id);
-
gg_call(VOID,
"__gg__pseudo_return_bookmark",
0);
@@ -7408,6 +7525,8 @@ parser_file_add(struct cbl_file_t *file)
file->var_decl_node = new_var_decl;
}
+static void store_location_stuff(const cbl_name_t statement_name);
+
void
parser_file_open( size_t nfiles, struct cbl_file_t *files[], int mode_char )
{
@@ -7496,6 +7615,7 @@ parser_file_open( struct cbl_file_t *file, int mode_char )
quoted_name = true;
}
+ store_location_stuff("OPEN");
gg_call(VOID,
"__gg__file_open",
4,
@@ -7547,6 +7667,7 @@ parser_file_close( struct cbl_file_t *file, file_close_how_t how )
// We are done with the filename. The library routine will free "filename"
// memory and set it back to null
+ store_location_stuff("CLOSE");
gg_call(VOID,
"__gg__file_close",
2,
@@ -7634,6 +7755,7 @@ parser_file_read( struct cbl_file_t *file,
where = 1;
}
+ store_location_stuff("READ");
gg_call(VOID,
"__gg__file_read",
2,
@@ -7769,6 +7891,7 @@ parser_file_write( cbl_file_t *file,
gg_assign(location, member(record_area, "data"));
gg_assign(length, member(record_area, "capacity"));
+ store_location_stuff("WRITE");
gg_call(VOID,
"__gg__file_write",
6,
@@ -7836,6 +7959,7 @@ parser_file_delete( struct cbl_file_t *file, bool /*sequentially*/ )
SHOW_PARSE_END
}
+ store_location_stuff("DELETE");
gg_call(VOID,
"__gg__file_delete",
2,
@@ -7892,6 +8016,7 @@ parser_file_rewrite(cbl_file_t *file,
tree length = gg_define_size_t();
gg_assign(length, member(record_area, "capacity"));
+ store_location_stuff("REWRITE");
gg_call(VOID,
"__gg__file_rewrite",
3,
@@ -7996,6 +8121,7 @@ parser_file_start(struct cbl_file_t *file,
get_binary_value(length, rdigits, &length_ref);
}
+ store_location_stuff("START");
gg_call(VOID,
"__gg__file_start",
4,
@@ -8346,265 +8472,110 @@ parser_inspect_conv(cbl_refer_t input,
gg_get_address_of(before.identifier_4.refer_decl_node) );
}
-#if 0
-static tree
-ctype_to_tree(cbl_ctype_t type)
- {
- switch(type)
- {
- case c_bool:
- return BOOL;
- case c_char:
- return CHAR;
- case c_wchar:
- return USHORT;
- case c_byte:
- return SCHAR;
- case c_ubyte:
- return UCHAR;
- case c_short:
- return SHORT;
- case c_ushort:
- return USHORT;
- case c_int:
- return INT;
- case c_uint:
- return UINT;
- case c_long:
- return LONG;
- case c_ulong:
- return ULONG;
- case c_longlong:
- return LONGLONG;
- case c_ulonglong:
- return ULONGLONG;
- case c_size_t:
- return SIZE_T;
- case c_ssize_t:
- return SSIZE_T;
- case c_int128:
- return INT128;
- case c_float:
- return FLOAT;
- case c_double:
- return DOUBLE;
- case c_longdouble:
- return LONGDOUBLE;
- case c_nts:
- case c_char_p:
- return CHAR_P;
- case c_wchar_p:
- return WCHAR_P;
- case c_void_p:
- return VOID_P;
- default:
- break;
+void
+parser_intrinsic_numval_c( cbl_field_t *f,
+ cbl_refer_t& input,
+ bool locale,
+ cbl_refer_t& currency,
+ bool anycase,
+ bool test_numval_c ) // true for TEST-NUMVAL-C
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+ refer_fill_source(input);
+ refer_fill_source(currency);
+ if( locale || anycase )
+ {
+ gcc_assert(false);
+ }
+ if( test_numval_c )
+ {
+ gg_call(INT,
+ "__gg__test_numval_c",
+ 3,
+ gg_get_address_of(f->var_decl_node),
+ gg_get_address_of(input .refer_decl_node),
+ gg_get_address_of(currency.refer_decl_node));
+ }
+ else
+ {
+ gg_call(INT,
+ "__gg__numval_c",
+ 3,
+ gg_get_address_of(f->var_decl_node),
+ gg_get_address_of(input .refer_decl_node),
+ gg_get_address_of(currency.refer_decl_node));
}
- warnx("%s(): Unhandled c_type %d", __func__, type);
- gcc_assert(false);
}
-#endif
-
-#if 0
-static void
-intrinsic_convert_return(cbl_ctype_t returned_type, cbl_field_t *dest, tree stmt)
- {
- tree intrinsic_return = gg_define_variable(ctype_to_tree(returned_type));
- gg_assign(intrinsic_return, gg_cast(ctype_to_tree(returned_type), stmt));
-
- // All integer return values have to become INT128:
- tree as_int128 = gg_define_int128();
-
- // We now have the return value. We need to go through some gyrations
- // to do the assignment.
-
- switch(returned_type)
- {
- case c_bool:
- case c_char:
- case c_wchar:
- case c_byte:
- case c_ubyte:
- case c_short:
- case c_ushort:
- case c_int:
- case c_uint:
- case c_long:
- case c_ulong:
- case c_longlong:
- case c_ulonglong:
- case c_size_t:
- case c_ssize_t:
- case c_int128:
- // Those all come back as a flavor of integer, which is in
- //intrinsic_return
-
- gg_assign(as_int128, gg_cast(INT128, intrinsic_return));
- switch( dest->type )
- {
- case FldGroup:
- case FldAlphanumeric:
- {
- // We have to convert the binary value to a string
- tree array = gg_define_array(CHAR, 128);
- tree parray = gg_define_char_star(gg_get_address_of(array));
-
- // Turn the integer value into a string:
- gg_call(VOID,
- "__gg__binary_to_string",
- 3,
- parray,
- gg_cast(INT128, as_int128),
- member(dest, "capacity"));
-
- // We need to terminate that string:
- gg_assign( gg_array_value( parray,
- member(dest, "capacity")),
- integer_zero_node);
- // Move those characters into the destination:
- move_tree_to_field( dest,
- parray);
- }
- break;
-
- case FldNumericDisplay:
- case FldNumericEdited:
- case FldNumericBinary:
- case FldNumericBin5:
- case FldIndex:
- gg_call(VOID,
- "__gg__int128_to_field",
- 5,
- gg_get_address_of(dest->var_decl_node),
- as_int128,
- integer_zero_node,
- build_int_cst_type(INT, rounded_e),
- null_pointer_node );
- // gg_call(VOID,
- // "__gg__ascii_to_internal_field",
- // 1,
- // gg_get_address_of(dest->var_decl_node));
- break;
-
- case FldAlphaEdited:
- {
- // We have to convert the binary value to a string
- tree array = gg_define_array(CHAR, 128);
- tree parray = gg_define_char_star(gg_get_address_of(array));
-
- // Turn the integer value into a string:
- gg_call(VOID,
- "__gg__binary_to_string",
- 3,
- parray,
- as_int128,
- member(dest, "capacity"));
-
- // We need to terminate that string:
- gg_assign( gg_array_value( parray,
- member(dest, "capacity")),
- integer_zero_node);
- // Move those characters into the destination:
- gg_call(VOID,
- "__gg__string_to_alpha_edited",
- 4,
- member(dest, "data"),
- parray,
- gg_strlen(parray),
- member(dest, "picture"));
- break;
- }
-
- default:
- break;
- }
-
- break;
-
- case c_float:
- // Those all come back as a floating-point number, which is in
- // intrinsic_return. We have an interim routine that does a reasonable
- // conversion of floating point numbers:
- gg_call(VOID,
- "__gg__float_to_target",
- 3,
- gg_get_address_of(dest->var_decl_node),
- gg_cast(FLOAT, intrinsic_return),
- build_int_cst_type(INT, rounded_e));
- break;
-
- case c_double:
- // Those all come back as a floating-point number, which is in
- // intrinsic_return. We have an interim routine that does a reasonable
- // conversion of floating point numbers:
- gg_call(VOID,
- "__gg__double_to_target",
- 3,
- gg_get_address_of(dest->var_decl_node),
- gg_cast(DOUBLE, intrinsic_return),
- build_int_cst_type(INT, rounded_e));
- break;
-
- case c_longdouble:
- // Those all come back as a floating-point number, which is in
- // intrinsic_return. We have an interim routine that does a reasonable
- // conversion of floating point numbers:
- gg_call(VOID,
- "__gg__long_double_to_target",
- 3,
- gg_get_address_of(dest->var_decl_node),
- gg_cast(LONGDOUBLE, intrinsic_return),
- build_int_cst_type(INT, rounded_e));
- break;
-
- case c_char_p:
- // intrinsic_return is a char pointer. Assume he actually wants
- // the string:
- move_tree_to_field( dest,
- intrinsic_return);
-
- // We have to assume that all char * pointers returned from the
- // library were allocated in the library, and thus need
- // to be sent to free().
- XXX;
- gg_free(intrinsic_return);
- break;
-
- case c_nts:
- // We are playing with fire, a little bit.
-
- // This code is designed to handle things like FUNCTION TRIM(xxx).
- // The results are being assigned to a intermediate variable that
- // was allocated with the same number of bytes as XXX. TRIM() will
- // return either the same length, or something smaller. So, we
- // are going to reduce the destination capacity to be the length
- // of the returned string.
-
- gcc_assert(dest->type == FldAlphanumeric);
- gcc_assert(dest->attr & intermediate_e);
+void
+parser_intrinsic_subst( cbl_field_t *f,
+ cbl_refer_t& ref1,
+ size_t argc,
+ cbl_substitute_t * argv )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ store_location_stuff("SUBSTITUTE");
+ unsigned char *control_bytes = (unsigned char *)xmalloc(argc * sizeof(unsigned char));
+ cbl_refer_t *arg1 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t));
+ cbl_refer_t *arg2 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t));
- gg_assign( member(dest, "capacity"),
- gg_strlen(intrinsic_return));
- move_tree_to_field( dest,
- intrinsic_return);
+ refer_fill_source(ref1);
+ for(size_t i=0; i<argc; i++)
+ {
+ control_bytes[i] = (argv[i].anycase ?
+ substitute_anycase_e : 0)
+ + (argv[i].first_last == cbl_substitute_t::subst_first_e ?
+ substitute_first_e : 0)
+ + (argv[i].first_last == cbl_substitute_t::subst_last_e ?
+ substitute_last_e : 0);
+ refer_fill_source(argv[i].orig);
+ arg1[i] = argv[i].orig;
+
+ refer_fill_source(argv[i].replacement);
+ arg2[i] = argv[i].replacement;
+ }
+
+ tree control = gg_array_of_bytes(argc, control_bytes);
+ tree arg1t = build_array_of_cblc_refer(argc, arg1);
+ tree arg2t = build_array_of_cblc_refer(argc, arg2);
- // We have to assume that all char * pointers returned from the
- // library were allocated in the library, and thus need
- // to be sent to free().
- XXX;
- gg_free(intrinsic_return);
- break;
+ gg_call(VOID,
+ "__gg__substitute",
+ 6,
+ gg_get_address_of(f->var_decl_node),
+ gg_get_address_of(ref1.refer_decl_node),
+ build_int_cst_type(SIZE_T, argc),
+ control,
+ arg1t,
+ arg2t);
+
+ gg_free(arg2t);
+ gg_free(arg1t);
+ gg_free(control);
- case c_wchar_p:
- case c_void_p:
- default:
- warnx("%s(): We don't know what to do with c_type %d", __func__, returned_type);
- gcc_assert(false);
- break;
- }
+ free(arg2);
+ free(arg1);
+ free(control_bytes);
}
-#endif
void
parser_intrinsic_callv( cbl_field_t *tgt,
@@ -8646,6 +8617,7 @@ parser_intrinsic_callv( cbl_field_t *tgt,
tree ncount = build_int_cst_type(SIZE_T, nrefs);
tree args = build_array_of_cblc_refer(nrefs, refs);
+ store_location_stuff(function_name);
gg_call(VOID,
function_name,
3,
@@ -8697,6 +8669,7 @@ parser_intrinsic_call_0(cbl_field_t *tgt,
struct timespec tp;
clock_gettime(CLOCK_REALTIME, &tp); // time_t tv_sec; long tv_nsec
+ store_location_stuff(function_name);
gg_call(VOID,
function_name,
3,
@@ -8706,6 +8679,7 @@ parser_intrinsic_call_0(cbl_field_t *tgt,
}
else
{
+ store_location_stuff(function_name);
gg_call(VOID,
function_name,
1,
@@ -8822,6 +8796,7 @@ parser_intrinsic_call_2( cbl_field_t *tgt,
TRACE1_INDENT
TRACE1_REFER("parameter 2: ", ref2, "")
}
+ store_location_stuff(function_name);
gg_call(VOID,
function_name,
3,
@@ -8868,6 +8843,7 @@ parser_intrinsic_call_3( cbl_field_t *tgt,
TRACE1_REFER("parameter 3: ", ref3, "")
}
+ store_location_stuff(function_name);
gg_call(VOID,
function_name,
4,
@@ -8919,6 +8895,8 @@ parser_intrinsic_call_4( cbl_field_t *tgt,
TRACE1_REFER("parameter 4: ", ref4, "")
}
+
+ store_location_stuff(function_name);
gg_call(VOID,
function_name,
5,
@@ -10504,11 +10482,12 @@ parser_call_exception_end( cbl_label_t *name )
void
parser_call( cbl_refer_t name,
- cbl_refer_t returning,
+ cbl_refer_t returned, // This is set by RETURNING clause
size_t narg,
cbl_ffi_arg_t args[],
cbl_label_t *except,
- cbl_label_t *not_except )
+ cbl_label_t *not_except,
+ bool /*is_function*/)
{
SHOW_PARSE
{
@@ -10587,27 +10566,23 @@ parser_call( cbl_refer_t name,
// We are getting close to establishing the function_type. To do that,
// we want to establish the function's return type.
- refer_fill_dest(returning);
- tree returning_location = gg_define_uchar_star();
- tree returning_length = gg_define_size_t();
+ refer_fill_dest(returned);
+ tree returned_location = gg_define_uchar_star();
+ tree returned_length = gg_define_size_t();
- tree returned_value_type;
- if(returning.field)
- {
- // we were given a returning::field, so find its location and length:
- gg_assign(returning_location,
- member(returning.refer_decl_node, "qual_data"));
- gg_assign(returning_length,
- member(returning.refer_decl_node, "qual_size"));
- returned_value_type = field_type_to_tree_type(returning.field);
- }
- else
+ size_t nbytes;
+ tree returned_value_type = tree_type_from_field_type(returned.field, nbytes);
+
+ if(returned.field)
{
- returned_value_type = INT;
+ // we were given a returned::field, so find its location and length:
+ gg_assign(returned_location,
+ member(returned.refer_decl_node, "qual_data"));
+ gg_assign(returned_length,
+ member(returned.refer_decl_node, "qual_size"));
}
- tree function_handle = function_handle_from_name(name, narg);
-
+ tree function_handle = function_handle_from_name(name, narg, returned_value_type);
IF( function_handle,
ne_op,
@@ -10619,7 +10594,7 @@ parser_call( cbl_refer_t name,
int *allocated = NULL;
if(narg)
{
- arguments = (tree *)xmalloc(narg * sizeof(tree));
+ arguments = (tree *)xmalloc(2*narg * sizeof(tree));
allocated = (int * )xmalloc(narg * sizeof(int));
}
@@ -10628,6 +10603,7 @@ parser_call( cbl_refer_t name,
build_int_cst_type(INT, narg));
// Put the arguments onto the stack:
+ size_t arg_count = 0;
for( size_t i=0; i<narg; i++ )
{
allocated[i] = 0;
@@ -10645,47 +10621,96 @@ parser_call( cbl_refer_t name,
{
case by_reference_e:
{
+ // CALL BY REFERENCE <group item>
+ // The pointer gets passed; 14.8.2.2 1) Requires that the
+ // receiving formal parameter has the same number or fewer
+ // bytes then the sending argument.
+ //
+ // CALL BY REFERENCE <pointer>
+ // Both the sending argument and the receiving formal parameter
+ // have to be pointers (14.8.2.3.2) (In our implementation,
+ // pointers can be handled like any other data-item)
+ //
+ // CALL BY REFERENCE <data-item>
+ // The activated element is not in the REPOSITORY paragraph:
+ // the receiving formal argument ahsll be the same length as
+ // the sending argument.
+ //
+ // UDF FUNCTION BY REFERENCE
+ // The definitions of the formal parameter and the argument
+ // shall have the same ALIGN, BLANK WHEN ZERO, DYNAMIC LENGTH,
+ // JUSTIFIED, PICTURE, SIGN, and USAGE clauses
+
// Pass the pointer to the data location, so that the called program
// can both access and change the data.
- arguments[i] = location;
- //gg_printf(">>>>>Calling %ld location is %p\n", build_int_cst_type(SIZE_T, i), arguments[i], NULL_TREE);
+ arguments[arg_count] = location;
- // BY REFERENCE variables might -- might! -- be going into an ANY LENGTH
+ // BY REFERENCE variables might be going into an ANY LENGTH
// linkage variable in the called program. So, just in case, we need
- // to provide a length through the global table.
+ // to provide a length through the global table.
gg_assign(gg_array_value(var_decl_call_parameter_lengths, i), length);
break;
}
case by_content_e:
{
+ // The ISO spec doesn't distinguish between by_content and by_value
+
+ // There are differences based on whether this is a CALL <program-id>
+ // or a user-defined function activation:
+
// BY CONTENT means that the called program gets a copy of the data.
// We'll free this copy after the called program returns.
// Allocate the memory, and make the copy:
- arguments[i] = gg_define_char_star();
+ arguments[arg_count] = gg_define_char_star();
allocated[i] = 1;
- gg_assign(arguments[i], gg_malloc(length) ) ;
- gg_memcpy(arguments[i], location, length);
+ gg_assign(arguments[arg_count], gg_malloc(length) ) ;
+ gg_memcpy(arguments[arg_count], location, length);
- //gg_printf(">>>>>Calling %ld location is %p\n", build_int_cst_type(SIZE_T, i), arguments[i], NULL_TREE);
+ //gg_printf(">>>>>Calling %ld location is %p\n", build_int_cst_type(SIZE_T, i), arguments[arg_count], NULL_TREE);
+
+ // BY CONTENT variables might be going into an ANY LENGTH
+ // linkage variable in the called program. So, just in case, we need
+ // to provide a length through the global table.
+ gg_assign(gg_array_value(var_decl_call_parameter_lengths, i), length);
break;
}
case by_value_e:
// For BY VALUE, we take whatever we've been given and do our best to
- // make a 64-bit value out of it. That value gets placed on the stack
+ // make a 64-bit value out of it, although we move to 128 bits when
+ // necessary.
- arguments[i] = gg_define_size_t();
- gg_assign(arguments[i],
- gg_call_expr(
- SIZE_T,
- "__gg__fetch_call_by_value_value",
- 1,
- gg_get_address_of(args[i].refer.refer_decl_node)));
+ if( (args[i].refer.field && args[i].refer.field->data.digits > 18)
+ || ( args[i].refer.field
+ && args[i].refer.field->type == FldFloat
+ && args[i].refer.field->data.capacity == 16 ) )
+ {
+ arguments[arg_count] = gg_define_variable(INT128);
+ gg_assign(arguments[arg_count],
+ gg_cast(INT128,
+ gg_call_expr(
+ INT128,
+ "__gg__fetch_call_by_value_value",
+ 1,
+ gg_get_address_of(args[i].refer.refer_decl_node))));
+ }
+ else
+ {
+ arguments[arg_count] = gg_define_size_t();
+ gg_assign(arguments[arg_count],
+ gg_cast(SIZE_T,
+ gg_call_expr(
+ INT128,
+ "__gg__fetch_call_by_value_value",
+ 1,
+ gg_get_address_of(args[i].refer.refer_decl_node))));
+ }
break;
}
+ arg_count += 1;
}
gg_call(VOID,
@@ -10693,26 +10718,27 @@ parser_call( cbl_refer_t name,
1,
gg_cast(SIZE_T, function_handle));
- tree call_expr = gg_call_expr_list( COBOL_FUNCTION_RETURN_TYPE,
+ tree call_expr = gg_call_expr_list( returned_value_type,
function_handle,
- narg,
+ arg_count,
arguments );
tree returned_value;
- if( returning.field )
+ if( returned.field )
{
- // We are expecting a return value:
+ // We are expecting a return value of type CHAR_P, SSIZE_T, SIZE_T,
+ // UINT128 or INT128
+
returned_value = gg_define_variable(returned_value_type);
- // Before doing the call, we save the COBOL program_state:
+
push_program_state();
gg_assign(returned_value, gg_cast(returned_value_type, call_expr));
- // And after the call, we restore it:
pop_program_state();
- // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a
- // value. So, we make sure it is zero
- cbl_field_t *return_code = cbl_field_of(symbol_at(return_code_register()));
- gg_call(VOID,
+ // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a
+ // value. So, we make sure it is zero
+ cbl_field_t *return_code = cbl_field_of(symbol_at(return_code_register()));
+ gg_call(VOID,
"__gg__int128_to_field",
5,
gg_get_address_of(return_code->var_decl_node),
@@ -10721,61 +10747,75 @@ parser_call( cbl_refer_t name,
build_int_cst_type(INT, truncation_e),
null_pointer_node );
- if(returned_value_type == CHAR_P)
+
+ if( returned_value_type == CHAR_P )
{
- // The returned value is to a null-terminated string:
+ // The returned value is a string of nbytes, which by specification
+ // has to be at least as long as the returned_length of the target:
IF( returned_value,
eq_op,
- gg_cast(TREE_TYPE(returned_value),
- null_pointer_node ) )
+ gg_cast(returned_value_type, null_pointer_node ) )
{
// Somebody was discourteous enough to return a NULL pointer
// We'll jam in spaces:
- gg_memset( returning_location,
+ gg_memset( returned_location,
char_nodes[' '],
- returning_length );
+ returned_length );
}
ELSE
{
- // There is a valid pointer
- //gg_printf("returned_value is %s\n", returned_value, NULL_TREE);
- move_tree( returning,
- returned_value);
+ // There is a valid pointer. Use move_tree to do the assignment, it
+ // does a reasonable job of handling nul-terminated strings that often
+ // are returned from C routines.
+ move_tree(returned, returned_value);
}
ENDIF
TRACE1
{
TRACE1_HEADER
- TRACE1_REFER("returned value: ", returning, "")
+ TRACE1_REFER("returned value: ", returned, "")
TRACE1_END
}
}
- else if(returned_value_type == SSIZE_T)
+ else if( returned_value_type == SSIZE_T
+ || returned_value_type == SIZE_T
+ || returned_value_type == INT128
+ || returned_value_type == UINT128)
{
- // We got back a 64-bit integer
- // Assume that the two programmers agreed on the number of rdigits
- // that were supposed to come back from the other routine:
+ // 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_refer",
5,
- gg_get_address_of(returning.refer_decl_node),
+ gg_get_address_of(returned.refer_decl_node),
gg_cast(INT128, returned_value),
- member(returning.field->var_decl_node, "rdigits"),
+ member(returned.field->var_decl_node, "rdigits"),
build_int_cst_type(INT, truncation_e),
null_pointer_node );
TRACE1
{
TRACE1_HEADER
- TRACE1_REFER("returned value: ", returning, "")
+ TRACE1_REFER("returned value: ", returned, "")
TRACE1_END
}
}
- else if(returned_value_type == DOUBLE)
+ else if( returned_value_type == FLOAT
+ || returned_value_type == DOUBLE
+ || returned_value_type == FLOAT128)
{
- warnx("%s(): We don't yet know how to handle a function"
- " that returns a double",
- __func__);
- gcc_assert(false);
+ // We are doing float-to-float, and we require that those be identical
+ // one the caller and callee sides.
+ gg_memcpy( returned_location,
+ gg_get_address_of(returned_value),
+ returned_length);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_REFER("returned value: ", returned, "")
+ TRACE1_END
+ }
}
else
{
@@ -11050,6 +11090,17 @@ parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source )
SHOW_PARSE
{
SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" source ", source.field);
+ char ach[128];
+ sprintf(ach,
+ " source.addr_of %s",
+ source.addr_of ? "TRUE" : "FALSE" );
+ SHOW_PARSE_TEXT(ach);
+ for( size_t i=0; i<ntgt; i++ )
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_FIELD("target ", tgts[i].field)
+ }
SHOW_PARSE_END
}
refer_fill_source(source);
@@ -11064,8 +11115,8 @@ parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source )
}
else
{
- // When ADDRESS OF TARGET, the target must be linkage:
- gcc_assert( tgts[i].field->attr & linkage_e );
+ // When ADDRESS OF TARGET, the target must be linkage or based
+ gcc_assert( tgts[i].field->attr & (linkage_e | based_e) );
}
if( source.field && !source.addr_of )
@@ -11595,6 +11646,48 @@ stash_exceptions( const cbl_enabled_exceptions_array_t *enabled )
}
}
+static void
+store_location_stuff(const cbl_name_t statement_name)
+ {
+ if( exception_location_active && !current_declarative_section_name() )
+ {
+ // We need to establish some stuff for EXCEPTION- function processing
+ gg_assign(var_decl_exception_source_file,
+ gg_string_literal(current_filename.back().c_str()));
+
+ gg_assign(var_decl_exception_program_id,
+ gg_string_literal(current_function->our_unmangled_name));
+
+ if( strstr(current_function->current_section->label->name, "_implicit")
+ != current_function->current_section->label->name )
+ {
+ gg_assign(var_decl_exception_section,
+ gg_string_literal(current_function->current_section->label->name));
+ }
+ else
+ {
+ gg_assign(var_decl_exception_section,
+ gg_cast(build_pointer_type(CHAR_P),null_pointer_node));
+ }
+
+ if( strstr(current_function->current_paragraph->label->name, "_implicit")
+ != current_function->current_paragraph->label->name )
+ {
+ gg_assign(var_decl_exception_paragraph,
+ gg_string_literal(current_function->current_paragraph->label->name));
+ }
+ else
+ {
+ gg_assign(var_decl_exception_paragraph,
+ gg_cast(build_pointer_type(CHAR_P), null_pointer_node));
+ }
+
+ gg_assign(var_decl_exception_line_number, build_int_cst_type(INT,
+ CURRENT_LINE_NUMBER));
+ gg_assign(var_decl_exception_statement, gg_string_literal(statement_name));
+ }
+ }
+
void
parser_exception_prepare( const cbl_name_t statement_name,
const cbl_enabled_exceptions_array_t *enabled )
@@ -11610,44 +11703,7 @@ parser_exception_prepare( const cbl_name_t statement_name,
if( enabled->nec )
{
stash_exceptions(enabled);
-
- if( exception_location_active && !current_declarative_section_name() )
- {
- // We need to establish some stuff for EXCEPTION- function processing
- gg_assign(var_decl_exception_source_file,
- gg_string_literal(current_filename.back().c_str()));
-
- gg_assign(var_decl_exception_program_id,
- gg_string_literal(current_function->our_unmangled_name));
-
- if( strstr(current_function->current_section->label->name, "_implicit")
- != current_function->current_section->label->name )
- {
- gg_assign(var_decl_exception_section,
- gg_string_literal(current_function->current_section->label->name));
- }
- else
- {
- gg_assign(var_decl_exception_section,
- gg_cast(build_pointer_type(CHAR_P),null_pointer_node));
- }
-
- if( strstr(current_function->current_paragraph->label->name, "_implicit")
- != current_function->current_paragraph->label->name )
- {
- gg_assign(var_decl_exception_paragraph,
- gg_string_literal(current_function->current_paragraph->label->name));
- }
- else
- {
- gg_assign(var_decl_exception_paragraph,
- gg_cast(build_pointer_type(CHAR_P), null_pointer_node));
- }
-
- gg_assign(var_decl_exception_line_number, build_int_cst_type(INT,
- CURRENT_LINE_NUMBER));
- }
- gg_assign(var_decl_exception_statement, gg_string_literal(statement_name));
+ store_location_stuff(statement_name);
}
}
@@ -13071,7 +13127,7 @@ move_helper(cbl_refer_t destref,
if( (sourceref.field->attr & (linkage_e | based_e))
|| ( destref.field->attr & (linkage_e | based_e)) )
{
- goto dont_be_clever;
+ //goto dont_be_clever;
}
if( !moved )
@@ -13120,7 +13176,7 @@ move_helper(cbl_refer_t destref,
size_error);
}
- dont_be_clever:
+ //dont_be_clever:
if( !moved )
{
@@ -13694,22 +13750,15 @@ initial_from_float128(cbl_field_t *field, _Float128 value)
case FldFloat:
{
retval = (char *)xmalloc(field->data.capacity);
-// char ach[128];
switch( field->data.capacity )
{
case 4:
- // strfromf128(ach, sizeof(ach), "%.9E", value);
- // *(_Float32 *)retval = strtof32(ach, NULL);
*(_Float32 *)retval = (_Float32) value;
break;
case 8:
- // strfromf128(ach, sizeof(ach), "%.14E", value);
- // *(_Float64 *)retval = strtof64(ach, NULL);
*(_Float64 *)retval = (_Float64) value;
break;
case 16:
- // strfromf128(ach, sizeof(ach), "%.33E", value);
- // *(_Float128 *)retval = strtof128(ach, NULL);
*(_Float128 *)retval = (_Float128) value;
break;
}
@@ -14034,7 +14083,7 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base)
static size_t literal_count = 1;
sprintf(base_name, "%s_%zd", "literal", literal_count++);
}
- else if( new_var->attr & (temporary_e | intermediate_e) )// | linkage_e) )
+ else if( new_var->attr & (temporary_e | intermediate_e) )
{
static size_t temp_count = 1;
sprintf(base_name, "%s_%zd", "_temporary", temp_count++);
@@ -14053,11 +14102,11 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base)
base_name,
vs_external);
}
- else if( new_var->attr & (temporary_e | intermediate_e) )// | linkage_e) )
+ else if( new_var->attr & (temporary_e | intermediate_e) )
{
new_var_decl = gg_define_variable( cblc_field_type_node,
base_name,
- vs_static); // was vs_stack
+ vs_static);
}
else
{
@@ -14079,24 +14128,27 @@ parser_local_add(struct cbl_field_t *new_var )
SHOW_PARSE_END
}
- gg_call(VOID,
- "__gg__push_local_variable",
- 1,
- gg_get_address_of(new_var->var_decl_node));
+ IF( member(new_var->var_decl_node, "data"),
+ ne_op,
+ gg_cast(UCHAR_P, null_pointer_node) )
+ {
+ gg_call(VOID,
+ "__gg__push_local_variable",
+ 1,
+ gg_get_address_of(new_var->var_decl_node));
+ }
+ ELSE
+ ENDIF
if( new_var->level == LEVEL01 || new_var->level == LEVEL77 )
{
// We need to allocate memory on the stack for this variable
- char achDataName[256];
- sprintf(achDataName, "..vardata_%lu", sv_data_name_counter++);
-
tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity);
tree data_decl_node = gg_define_variable( array_type,
- achDataName,
+ NULL,
vs_stack);
gg_assign( member(new_var->var_decl_node, "data"),
gg_get_address_of(data_decl_node) );
-
}
cbl_refer_t wrapper;
wrapper.field = new_var;
@@ -14106,7 +14158,7 @@ parser_local_add(struct cbl_field_t *new_var )
void
parser_symbol_add(struct cbl_field_t *new_var )
{
- //fprintf(stderr, ">>>>>>> parser_symbol_add %s %s \n", cbl_field_type_str(new_var->type), new_var->name);
+ // fprintf(stderr, ">>>>>>> parser_symbol_add %s %s \n", cbl_field_type_str(new_var->type), new_var->name);
// fprintf(stderr,
// "parser_symbol_add %s %s",
// new_var->name,
@@ -14116,7 +14168,7 @@ parser_symbol_add(struct cbl_field_t *new_var )
// fprintf(stderr, " %s\n", dch);
const char *new_initial = NULL;
-
+
if( !(new_var->attr & initialized_e) )
{
if( is_register_field(new_var) )
@@ -14237,6 +14289,8 @@ parser_symbol_add(struct cbl_field_t *new_var )
case FldLiteralA:
case FldNumericEdited:
case FldAlphaEdited:
+
+ case FldFloat:
figconst = normal_value_e;
break;
default:
@@ -14716,7 +14770,7 @@ parser_symbol_add(struct cbl_field_t *new_var )
free(level_88_string);
}
- if( !(new_var->attr & (linkage_e | based_e)) )
+ if( !(new_var->attr & ( linkage_e | based_e)) )
{
IF( gg_attribute_bit_get(new_var, initialized_e), eq_op, size_t_zero_node )
{
diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h
index 7a763052229319a49885df346d8808211f60f435..fe13e65f884a20dd8b70fbbc24363a484561572d 100644
--- a/gcc/cobol/genapi.h
+++ b/gcc/cobol/genapi.h
@@ -52,7 +52,7 @@ void parser_next_is_main(bool is_main);
void parser_internal_is_ebcdic(bool is_ebcdic);
void parser_division( cbl_division_t division,
cbl_field_t *ret, size_t narg, cbl_ffi_arg_t args[] );
-void parser_enter_program(const char *funcname);
+void parser_enter_program(const char *funcname, bool is_function);
void parser_leave_program();
void parser_accept( struct cbl_refer_t refer, enum special_name_t special_e);
@@ -459,6 +459,20 @@ parser_inspect_conv( cbl_refer_t input,
void
parser_exception_file( cbl_field_t *tgt, cbl_file_t* file = NULL );
+void
+parser_intrinsic_numval_c( cbl_field_t *f,
+ cbl_refer_t& input,
+ bool locale,
+ cbl_refer_t& currency,
+ bool anycases,
+ bool test_numval_c = false);
+
+void
+parser_intrinsic_subst( cbl_field_t *f,
+ cbl_refer_t& ref1,
+ size_t argc,
+ cbl_substitute_t * argv );
+
void
parser_intrinsic_callv( cbl_field_t *f,
const char name[],
@@ -556,10 +570,12 @@ size_t parser_call_target_update( size_t caller,
void parser_file_stash( struct cbl_file_t *file );
-void parser_call( cbl_refer_t name, cbl_refer_t returning,
- size_t narg, cbl_ffi_arg_t args[],
- cbl_label_t *except,
- cbl_label_t *not_except );
+void parser_call( cbl_refer_t name,
+ cbl_refer_t returning,
+ size_t narg, cbl_ffi_arg_t args[],
+ cbl_label_t *except,
+ cbl_label_t *not_except,
+ bool is_function);
void parser_entry_activate( size_t iprog, const cbl_label_t *declarative );
diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc
index b2220e6bed187c0d0955c4581783fc35c07a8305..9c779326d7574229ece49527fa5cb0b9d308092a 100644
--- a/gcc/cobol/gengen.cc
+++ b/gcc/cobol/gengen.cc
@@ -632,10 +632,6 @@ gg_start_building_a_union(const char *type_name, tree type_context)
return typedecl;
}
-
-
-
-
static tree
gg_start_building_a_struct(const char *type_name, tree type_context)
{
@@ -2629,6 +2625,18 @@ chain_parameter_to_function(tree function_decl, const tree param_type, const ch
}
}
+void
+gg_modify_function_type(tree function_decl, tree return_type)
+ {
+ tree fndecl_type = build_varargs_function_type_array( return_type,
+ 0, // No parameters yet
+ NULL); // And, hence, no types
+ TREE_TYPE(function_decl) = fndecl_type;
+ tree resdecl = build_decl (UNKNOWN_LOCATION, RESULT_DECL, NULL_TREE, return_type);
+ DECL_CONTEXT (resdecl) = function_decl;
+ DECL_RESULT (function_decl) = resdecl;
+ }
+
tree
gg_define_function_with_no_parameters(tree return_type,
const char *funcname,
@@ -3596,7 +3604,7 @@ tree
gg_array_of_size_t( size_t N, size_t *values)
{
tree retval = gg_define_variable(build_pointer_type(SIZE_T));
- gg_assign(retval, gg_cast(build_pointer_type(SIZE_T), gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(SIZE_T)))));
+ gg_assign(retval, gg_cast(build_pointer_type(SIZE_T), gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(size_t)))));
for(size_t i=0; i<N; i++)
{
gg_assign(gg_array_value(retval, i), build_int_cst_type(SIZE_T, values[i]));
@@ -3604,6 +3612,18 @@ gg_array_of_size_t( size_t N, size_t *values)
return retval;
}
+tree
+gg_array_of_bytes( size_t N, unsigned char *values)
+ {
+ tree retval = gg_define_variable(build_pointer_type(UCHAR));
+ gg_assign(retval, gg_cast(build_pointer_type(UCHAR), gg_malloc( build_int_cst_type(UCHAR, N * sizeof(unsigned char)))));
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(retval, i), build_int_cst_type(UCHAR, values[i]));
+ }
+ return retval;
+ }
+
tree
gg_string_literal(const char *string)
{
diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h
index def32c88f06c9b81ee3aaf2fa9c24c71c49c7673..9ef5dfad6378652d598e927ad301bb3dd19ad9be 100644
--- a/gcc/cobol/gengen.h
+++ b/gcc/cobol/gengen.h
@@ -119,6 +119,13 @@ enum gg_variable_scope_t {
struct gg_function_t
{
+ // Nomenclature Alert: The "function" in gg_function_t was chosen
+ // originally because a PROGRAM-ID is implemented as a C-style "function",
+ // and there are numerous tree variables that refer to "functions".
+ // Eventually the COBOL compiler grew to handle not just COBOL PROGRAM-ID
+ // "programs", but also user-defined COBOL FUNCTION-ID "functions". This
+ // inevitably is confusing. Sorry about that.
+
// This structure contains state variables for a single function.
const char *our_unmangled_name;
@@ -188,7 +195,7 @@ struct gg_function_t
// When parser_division(PROCEDURE) is called, it provides a cbl_field_t
// *returning parameter. We stash it here; it's used during parser_exit()
// to provide the data for the program's return value.
- cbl_field_t *returning;
+ cbl_field_t *returning; // This one is on the stack, like a LOCAL-STORAGE
// When a function is defined as having formal parameters (that is, there
// is a USING clause in the function definition), we need to convert
@@ -223,6 +230,10 @@ struct gg_function_t
// back to the first declarative of its immediate parent.
tree first_declarative_section;
+ // is_function is true when this structure is describing a COBOL FUNCTION-ID
+ // and is false for a PROGRAM-ID
+ bool is_function;
+
};
struct cbl_translation_unit_t
@@ -513,6 +524,7 @@ extern size_t gg_sizeof(tree decl_node);
extern tree gg_array_of_field_pointers( size_t N,
cbl_field_t **fields );
extern tree gg_array_of_size_t( size_t N, size_t *values);
+extern tree gg_array_of_bytes( size_t N, unsigned char *values);
extern tree gg_indirect(tree pointer, tree byte_offset = NULL_TREE);
extern tree gg_string_literal(const char *string);
@@ -529,4 +541,5 @@ tree gg_open(tree char_star_A, tree int_B);
tree gg_close(tree int_A);
tree gg_get_indirect_reference(tree pointer, tree offset);
void gg_insert_into_assembler(const char *format, ...);
+void gg_modify_function_type(tree function_decl, tree return_type);
#endif
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index f4e85201c503629a93e6fb8d8642c6c019d03c90..1f30c936e88eb613af1acf6658fd17de3d935460 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -91,8 +91,6 @@ tree var_decl_exit_address; // This is for implementing pseudo_return_
tree var_decl_call_parameter_count; // int __gg__call_parameter_count
tree var_decl_call_parameter_lengths; // size_t *__gg__call_parameter_count
-
-
int
get_scaled_rdigits(cbl_field_t *field)
{
@@ -1999,7 +1997,10 @@ refer_fill_refmod(cbl_refer_t &refer)
}
}
- if( have_offset && !any_length )
+ bool temp_alpha = refer.field->type == FldAlphanumeric
+ && (refer.field->attr & temporary_e);
+
+ if( have_offset && !any_length && !refmod_error && !temp_alpha )
{
if( offset_val < 1
|| offset_val > (int)refer.field->data.capacity )
@@ -2011,7 +2012,7 @@ refer_fill_refmod(cbl_refer_t &refer)
}
}
- if( have_length && !any_length )
+ if( have_length && !any_length && !refmod_error && !temp_alpha )
{
if( length_val < 1
|| length_val > (int)refer.field->data.capacity )
@@ -2023,7 +2024,7 @@ refer_fill_refmod(cbl_refer_t &refer)
}
}
- if( have_offset && have_length && !refmod_error && !any_length )
+ if( have_offset && have_length && !any_length && !refmod_error && !temp_alpha )
{
if( offset_val-1 + length_val > (int)refer.field->data.capacity )
{
diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h
index f2c13d3c6efe16684588c4483a1e1b9315b710c5..8c85c9fa17d79827233ca3f9a09e40b1d3f1e16c 100644
--- a/gcc/cobol/genutil.h
+++ b/gcc/cobol/genutil.h
@@ -66,7 +66,7 @@ extern tree var_decl_entry_location; // This is for managing ENTRY state
extern tree var_decl_exit_address; // This is for implementing pseudo_return_pop
extern tree var_decl_call_parameter_count; // int __gg__call_parameter_count
-extern tree var_decl_call_parameter_lengths; // size_t *__gg__call_parameter_count
+extern tree var_decl_call_parameter_lengths; // size_t *var_decl_call_parameter_lengths
int get_scaled_rdigits(cbl_field_t *field);
int get_scaled_digits(cbl_field_t *field);
diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h
index 1fde026899f3b519ed78fa23aa37cf043d2cfc9d..8d7bd1ddd649d8273a0f8369bbd68fb62723e85b 100644
--- a/gcc/cobol/lang-specs.h
+++ b/gcc/cobol/lang-specs.h
@@ -38,6 +38,7 @@
"%{fcobol-exceptions*} "
"%{fstatic-call} "
"%{ffixed-form} %{ffree-form} "
+ "%{preprocess} "
"%{dialect} "
"%{!fsyntax-only:%(invoke_as)} "
, 0, 0, 0},
diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt
index 867a619575903f0ebe8a9cd6d9ca1b055b4b2b6e..1cc4b3f1da85bc1a89370c5497d745c1e13c2148 100644
--- a/gcc/cobol/lang.opt
+++ b/gcc/cobol/lang.opt
@@ -114,6 +114,10 @@ fyacc-debug
Cobol Var(yy_debug, 1) Init(0)
Enable Cobol yacc debugging
+preprocess
+Cobol Joined Separate Var(cobol_preprocess)
+preprocess <source_filter> before compiling
+
main
Cobol
-main Next source_file/PROGRAM-ID is called by main()
diff --git a/gcc/cobol/lexio.h b/gcc/cobol/lexio.h
index e619d853abfd4e80ae6ba0ced714b356c4870e45..2deca53c15c92f6bfc077f87c119111e6a45ac3d 100644
--- a/gcc/cobol/lexio.h
+++ b/gcc/cobol/lexio.h
@@ -230,13 +230,6 @@ struct replace_t {
#include <list>
class cdftext {
- ////std::stack< std::list<replace_t> > replace_directives;
-
- //// bool parse_copy_directive( filespan_t& mfile );
- //// bool parse_replace_last_off( filespan_t& mfile );
- //// bool parse_replace_text( filespan_t& mfile, size_t current_lineno );
- //// parse_replace_directive( filespan_t& mfile, size_t current_lineno );
-
static filespan_t free_form_reference_format( int fd );
static void process_file( filespan_t, int output, bool second_pass = false );
diff --git a/gcc/cobol/libgcobol.h b/gcc/cobol/libgcobol.h
index 9ae955cf52dd58bb553f4d2134c07731fe06bdc8..c957905b88253e0ad213ad8872d272e21a73e91b 100644
--- a/gcc/cobol/libgcobol.h
+++ b/gcc/cobol/libgcobol.h
@@ -78,6 +78,13 @@ typedef struct cblc_field_t
* the original value
*/
+enum substitute_flags_t
+ {
+ substitute_anycase_e = 1,
+ substitute_first_e = 2, // first and last are mutually exclusive
+ substitute_last_e = 4,
+ };
+
enum cblc_file_flags_t
{
file_flag_optional_e = 0x00001,
@@ -121,7 +128,6 @@ class supplemental_t
std::vector<file_index_t> indexes;
std::vector<int> uniques;
};
-
typedef struct cblc_file_t
{
char *name; // This is the name of the structure; might be the name of an environment variable
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 26c53222503132ff7bb541235ec6e7077595e438..ab2e387f2da85ebe449337609ce52e3da69c6cc7 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -58,6 +58,7 @@
set_data(len, data);
return *this;
}
+
literal_t&
set( const cbl_field_t * field ) {
assert(has_field_attr(field->attr, constant_e));
@@ -134,6 +135,29 @@
typedef std::map<data_category_t, struct cbl_refer_t*> category_map_t;
+ struct substitution_t {
+ enum subst_fl_t { subst_all_e, subst_first_e = 'F', subst_last_e = 'L' };
+ bool anycase;
+ subst_fl_t first_last;
+ cbl_refer_t *orig, *replacement;
+
+ substitution_t& init( bool anycase, char first_last,
+ cbl_refer_t *orig, cbl_refer_t *replacement ) {
+ this->anycase = anycase;
+ switch(first_last) {
+ case 'F': this->first_last = subst_first_e; break;
+ case 'L': this->first_last = subst_last_e; break;
+ default:
+ this->first_last = subst_all_e;
+ break;
+ }
+ this->orig = orig;
+ this->replacement = replacement;
+ return *this;
+ }
+ };
+ typedef std::list<substitution_t> substitutions_t;
+
struct init_statement_t {
bool to_value;
bool to_default;
@@ -274,7 +298,7 @@
/* intrinsics */
%token <string> LIST MAP NOLIST NOMAP NOSOURCE
-%token <number> MIGHT_BE
+%token <number> MIGHT_BE FUNCTION_UDF FUNCTION_UDF_0
%token <string> DATE_FMT TIME_FMT DATETIME_FMT
@@ -293,7 +317,7 @@
%type <number> true_false posneg
%type <number> open_io alphabet_etc
%type <special_type> env_name1
-%type <string> numed collating_sequence context_word ctx_name
+%type <string> numed collating_sequence context_word ctx_name locale_spec
%type <literal> namestr alphabet_lit program_as repo_as
%type <field> perform_cond kind_of_name alloc_ret
%type <refer> simple_cond
@@ -330,7 +354,7 @@
%type <refer> expr expr_term compute_expr free_tgt by_value_arg
%type <refer> selected_name read_key read_into vary_by
%type <refer> accept_refer num_operand envar search_expr any_arg
-%type <refers> expr_list subscripts arg_list free_tgts
+%type <refers> expr_list subscripts arg_list free_tgts udf_args
%type <targets> move_tgts set_tgts
%type <field> search_varying
%type <field> search_term search_terms
@@ -361,14 +385,14 @@
%type <arith> divide_into divide_by
%type <refer> intrinsic_call
-%type <field> intrinsic
+%type <field> intrinsic intrinsic_locale
%type <field> intrinsic0
%type <number> intrinsic_v intrinsic_I intrinsic_N intrinsic_X
%type <number> intrinsic_I2 intrinsic_N2 intrinsic_X2
%type <number> lopper_case
%type <number> return_body return_file
-%type <field> trim_trailing
+%type <field> trim_trailing function_udf
%type <refer> str_input str_size
%type <refer2> str_into
@@ -396,9 +420,8 @@
%type <number> /* addr_len_of */ alphanum_pic
%type <pic_part> alphanum_part
-%type <ffi_arg> ffi_by_ref ffi_by_con ffi_by_val
-%type <ffi_args> ffi_by_refs ffi_by_cons ffi_by_vals
-%type <ffi_args> parameter parameters
+%type <ffi_arg> parameter ffi_by_ref ffi_by_con ffi_by_val
+%type <ffi_args> parameters
%type <ffi_impl> call_body call_impl
%type <ffi_arg> procedure_use
@@ -408,8 +431,8 @@
%type <error_clauses> io_invalids read_eofs write_eops
%type <boolean> io_invalid read_eof write_eop
- global is_global
-%type <number> mistake globally
+ global is_global anycase
+%type <number> mistake globally first_last
%type <use_culprit> culprits
%type <labels> labels
@@ -431,6 +454,9 @@
%type <refer> init_data stop_how stop_status
%type <float128> cce_expr cce_factor const_value
%type <prog_end> end_program1
+%type <substitution> subst_input
+%type <substitutions> subst_inputs
+%type <numval_locale_t> numval_locale
%union {
bool boolean;
@@ -519,15 +545,20 @@
category_map_t *replacements;
init_statement_t *init_stmt;
struct { cbl_special_name_t *special; vargs_t *vargs; } display;
+ substitution_t substitution;
+ substitutions_t *substitutions;
+ struct { bool is_locale; cbl_refer_t *arg2; } numval_locale_t;
+
}
%printer { fprintf(yyo, "clauses: 0x%04x", $$); } data_clauses
%printer { fprintf(yyo, "%s %s", refer_type_str($$), $$? $$->name() : "<none>"); } <refer>
%printer { fprintf(yyo, "%s", $$? name_of($$) : "[omitted]"); } alloc_ret
%printer { fprintf(yyo, "%s %s '%s' (%s)",
- cbl_field_type_str($$->type), name_of($$),
- $$->data.initial? $$->data.initial : "<nil>",
- $$->value_str() ); } <field>
+ $$? cbl_field_type_str($$->type) : "<%empty>",
+ $$? name_of($$) : "",
+ $$? $$->data.initial? $$->data.initial : "<nil>" : "",
+ $$? $$->value_str() : "" ); } <field>
%printer { fprintf(yyo, "%s {%c%s %s}",
$$.cond->field->name,
$$.ante.invert? '!' : ' ',
@@ -600,7 +631,7 @@
ALLOCATE
ALPHABET ALPHABETIC ALPHABETIC_LOWER
ALPHABETIC_UPPER ALPHANUMERIC ALPHANUMERIC_EDITED
- ALPHED ALSO ALTERNATE ANNUITY ANY APPLY ARE
+ ALPHED ALSO ALTERNATE ANNUITY ANY ANYCASE APPLY ARE
AREA AREAS AS
ASCENDING ASIN ASSIGN AT ATAN AUTHOR
@@ -635,10 +666,12 @@
FACTORIAL FALSE_kw FD FILENAME FILE_CONTROL FILE_KW
FILE_LIMIT FINAL FIRST FIXED FOOTING FOR
FORMATTED_CURRENT_DATE FORMATTED_DATE FORMATTED_DATETIME
- FORMATTED_TIME FORM_OVERFLOW FREE FROM FUNCTION
+ FORMATTED_TIME FORM_OVERFLOW FREE
+ FRACTION_PART FROM FUNCTION FUNCTION_UDF
GENERATE GIVING GLOBAL GO GROUP
- HEADING HEX_OF HEX_TO_CHAR HIGH_VALUE HIGH_VALUES HOLD
+ HEADING HEX_OF HEX_TO_CHAR
+ HIGH_VALUE HIGH_VALUES HIGHEST_ALGEBRAIC HOLD
IBM_360 IN INCLUDE INDEX INDEXED INDICATE INITIAL_kw
INITIATE INPUT INSTALLATION INTERFACE
@@ -648,11 +681,13 @@
KANJI KEY
- LABEL LAST LEADING LEFT LENGTH LEVEL LEVEL66
+ LABEL LAST LEADING LEFT LENGTH LENGTH_OF LEVEL LEVEL66
LEVEL88 LIMIT LIMITS LINE LINES LINE_COUNTER
- LINAGE LINKAGE LOCATION LOCAL_STORAGE
+ LINAGE LINKAGE LOCALE LOCALE_COMPARE
+ LOCALE_DATE LOCALE_TIME LOCALE_TIME_FROM_SECONDS
+ LOCAL_STORAGE LOCATION
LOCK LOCK_ON LOG LOG10 LOWER_CASE LOW_VALUE LOW_VALUES
- LPAREN
+ LOWEST_ALGEBRAIC LPAREN
MANUAL MAX MEAN MEDIAN MIDRANGE
MIGHT_BE MIN MULTIPLE MOD MODE
@@ -688,7 +723,7 @@
SPACES SPECIAL_NAMES SQRT STANDARD STANDARD_ALPHABET
STANDARD_1 STANDARD_DEVIATION STATUS
STDERR STDIN STDOUT
- LITERAL SUM SWITCH SYMBOL SYMBOLIC SYNCHRONIZED
+ LITERAL SUBSTITUTE SUM SWITCH SYMBOL SYMBOLIC SYNCHRONIZED
SYSIN SYSIPT SYSLST SYSOUT SYSPCH SYSPUNCH
TALLY TALLYING TAN TERMINATE TEST TEST_DATE_YYYYMMDD
@@ -822,7 +857,7 @@ statement_begin( const YYLTYPE& loc, int token ) {
return perf;
}
- static int close_out_program( const char name[] );
+ static bool close_out_program( const char name[] );
static void
initialize_statement( std::list<cbl_refer_t> tgts,
@@ -911,7 +946,7 @@ program_id: PROGRAM_ID dot namestr[name] program_as program_attrs[attr] dot
current_division = identification_div_e;
parser_division( identification_div_e, NULL, 0, NULL );
location_set(@1);
- parser_enter_program( name );
+ parser_enter_program( name, false );
if( symbols_begin() == symbols_end() ) {
symbol_table_init();
}
@@ -920,6 +955,7 @@ program_id: PROGRAM_ID dot namestr[name] program_as program_attrs[attr] dot
if(false && yydebug) {
warnx("current program is now %s", name);
}
+ if( nparse_error > 0 ) YYABORT;
}
;
dot: %empty
@@ -934,7 +970,7 @@ function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.'
current_division = identification_div_e;
parser_division( identification_div_e, NULL, 0, NULL );
statement_begin(@1, FUNCTION);
- parser_enter_program( $NAME );
+ parser_enter_program( $NAME, true );
if( symbols_begin() == symbols_end() ) {
symbol_table_init();
}
@@ -943,10 +979,7 @@ function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.'
if(false && yydebug) {
warnx("current program is now %s", $NAME);
}
- {
- yyerror("error: FUNCTION-ID: almost implemented");
- YYERROR;
- }
+ if( nparse_error > 0 ) YYABORT;
}
| FUNCTION '.' NAME program_as is PROTOTYPE '.'
{
@@ -1642,15 +1675,18 @@ repo_func: FUNCTION func_names INTRINSIC
current.repository_add_all();
}
| FUNCTION func_names
+ ;
+func_names: func_name
+ | func_names func_name
+ ;
+func_name: FUNCTION_UDF[udf]
{
- yyerrorv("syntax error: "
- "user-defined functions ('%s') are unimplemented",
- names.front());
- names.clear();
+ current.repository_udf($udf);
+ }
+ | FUNCTION_UDF_0[udf]
+ {
+ current.repository_udf($udf);
}
- ;
-func_names: NAME { names.clear(); names.push_back($NAME); }
- | func_names NAME { names.push_back($NAME); }
;
repo_program: PROGRAM_kw NAME repo_as
@@ -1659,7 +1695,7 @@ repo_program: PROGRAM_kw NAME repo_as
auto program = symbol_label( PROGRAM, LblProgram, 0, $NAME );
if( ! program ) {
if( $repo_as.empty() ) {
- yyerrorv("'%s' does not name an earlier program", $NAME);
+ yyerrorv("error: '%s' does not name an earlier program", $NAME);
YYERROR;
}
program = symbol_label( PROGRAM, LblProgram, 0,
@@ -1757,6 +1793,13 @@ special_name: env_name
{
symbol_decimal_point_set(',');
}
+ | LOCALE NAME is locale_spec
+ {
+ current.locale($NAME, $locale_spec);
+ yyerrorv("%s:%d: LOCALE syntax not implemented",
+ __FILE__, __LINE__);
+ }
+ ;
| upsi
| SYMBOLIC characters symbolic is_alphabet
{
@@ -1764,6 +1807,10 @@ special_name: env_name
__FILE__, __LINE__);
}
;
+locale_spec: NAME { $$ = $1; }
+ | LITERAL { $$ = string_of($1); }
+
+ ;
symbolic: NAME
| NUMSTR
;
@@ -1918,7 +1965,7 @@ alphabet_etc: alphabet_lit
yyerrorv("'%c' can be only a single letter", $1.data);
YYERROR;
}
- $$ = $1.data[0];
+ $$ = (unsigned char)$1.data[0];
}
| spaces_etc {
// For figurative constants, pass the synmbol table index,
@@ -2156,7 +2203,6 @@ data_section: FILE_SECT '.'
| LINKAGE_SECT '.' {
current_data_section_set(linkage_datasect_e);
} fields_maybe
- | cdf
;
file_descrs: file_descr
@@ -2417,7 +2463,8 @@ fields: field
| fields field
;
-field: data_descr '.'
+field: cdf
+ | data_descr '.'
{
if( in_file_section() && $data_descr->level == 1 ) {
if( !file_section_parent_set($data_descr) ) {
@@ -2657,6 +2704,7 @@ data_descr: data_descr1
const_value: cce_expr
| BYTE_LENGTH of name { $$ = $name->data.capacity; }
| LENGTH of name { $$ = $name->data.capacity; }
+ | LENGTH_OF of name { $$ = $name->data.capacity; }
;
value78: literalism
@@ -2884,14 +2932,17 @@ data_descr1: level_name
| level_name[field] data_clauses
{
+#ifndef YYNOMEM
+# define YYNOMEM YYERROR
+#endif
assert($field == current_field());
if( $data_clauses == value_clause_e ) { // only VALUE, no PIC
// Error unless VALUE is a figurative constant or (quoted) string.
- if( !has_field_attr($field->attr, quoted_e) &&
+ if( $field->type != FldPointer &&
+ ! has_field_attr($field->attr, quoted_e) &&
normal_value_e == cbl_figconst_of($field->data.initial) )
{
- yyerrorv("syntax error: "
- "%s numeric VALUE %s requires PICTURE",
+ yyerrorv("error: %s numeric VALUE %s requires PICTURE",
$field->name, $field->data.initial);
}
$field->type = FldAlphanumeric;
@@ -2975,16 +3026,19 @@ data_descr1: level_name
if( ! ($field->data.capacity + 1 == strlen($field->data.initial) &&
p[-1] == '!') ) {
char *msg;
- asprintf(&msg, "warning: VALUE of %s "
- "has length %zu, exceeding its size (%u)",
- $field->name, strlen($field->data.initial),
- $field->data.capacity);
+ if( -1 == asprintf(&msg, "warning: VALUE of %s "
+ "has length %zu, exceeding its size (%u)",
+ $field->name, strlen($field->data.initial),
+ $field->data.capacity) ) {
+ yyerror("could not allocate VALUE size error message");
+ YYNOMEM;
+ }
yywarn(msg);
}
}
}
// Ensure signed initial VALUE is for signed numeric type
- if( is_numeric($field) && $field->data.initial ) {
+ if( is_numeric($field) && $field->data.initial && $field->type != FldFloat) {
switch( $field->data.initial[0] ) {
case '-': case '+':
if( !has_field_attr($field->attr, signable_e) ) {
@@ -3118,10 +3172,11 @@ data_clauses: data_clause
YYERROR;
}
cbl_field_t *field = current_field();
+#if 0
if( symbol_redefines(field) ) {
redefine_field(field);
}
-
+#endif
const int globex = (global_e | external_e);
if( (($$ | $2) & globex) == globex ) {
yyerror("GLOBAL and EXTERNAL specified");
@@ -3459,7 +3514,38 @@ usage_clause1: usage COMPUTATIONAL[comp] native
$$ = symbol_field_index_set( current_field() )->type;
}
// We should enforce data/code pointers with a different type.
- | usage POINTER { $$ = FldPointer; }
+ | usage POINTER
+ {
+ $$ = FldPointer;
+ auto field = current_field();
+ auto redefined = symbol_redefines(field);
+
+ field->data.capacity = sizeof(void *);
+
+ if( dialect_ibm() && redefined &&
+ is_numeric(redefined->type) && redefined->size() == 4) {
+ // For now, we allow POINTER to expand a 32-bit item to 64 bits.
+ if( yydebug ) {
+ warnx("%s: expanding #%zu %s capacity %u => %u", __func__,
+ field_index(redefined), redefined->name,
+ redefined->data.capacity, field->data.capacity);
+ }
+
+ redefined->data.capacity = field->data.capacity;
+
+ if( redefined->data.initial ) {
+ char *s = new char[1 + redefined->data.capacity];
+ if( !s ) {
+ yyerrorv("error: could not expand initial value of %s", field->name);
+ YYERROR;
+ }
+ (void)! snprintf(s, 1 + redefined->data.capacity,
+ "%s ", redefined->data.initial);
+ std::replace(s, s + strlen(s), '!', char(0x20));
+ redefined->data.initial = s;
+ }
+ }
+ }
| usage POINTER TO error
{
yyerror("error: unimplemented: TYPEDEF");
@@ -3572,6 +3658,7 @@ redefines_clause: REDEFINES NAME[orig]
orig->level, name_of(orig),
field->level, name_of(field));
}
+
if( valid_redefine(field, orig) ) {
/*
* Defer "inheriting" the parent's description until the
@@ -3591,7 +3678,7 @@ any_length: ANY LENGTH
current_data_section == linkage_datasect_e &&
1 < current.program_level()) ) {
yyerror("ANY LENGTH valid only "
- "for 01 in LIKAGE SECTION of a contained program");
+ "for 01 in LINKAGE SECTION of a contained program");
YYERROR;
}
field->attr |= any_length_e;
@@ -3703,13 +3790,13 @@ procedure_args: USING procedure_uses[args]
{
if( !procedure_division_ready(NULL, $args) ) YYABORT;
}
- | USING procedure_uses[args] RETURNING scalar[ret]
+ | USING procedure_uses[args] RETURNING name[ret]
{
- if( !procedure_division_ready($ret->field, $args) ) YYABORT;
+ if( !procedure_division_ready($ret, $args) ) YYABORT;
}
- | RETURNING scalar[ret]
+ | RETURNING name[ret]
{
- if( !procedure_division_ready($ret->field, NULL) ) YYABORT;
+ if( !procedure_division_ready($ret, NULL) ) YYABORT;
}
;
procedure_uses: procedure_use { $$ = new ffi_args_t($1); }
@@ -3811,7 +3898,7 @@ sentence: statements '.'
{
if( nparse_error > 0 ) YYABORT;
do {
- if( 0 != close_out_program(NULL) ) YYABORT; // no recovery
+ if( ! close_out_program(NULL) ) YYABORT; // no recovery
} while( current.program_level() > 0 );
YYACCEPT;
}
@@ -5101,7 +5188,7 @@ refmod: LPAREN expr[from] ':' expr[len] ')' %prec NAME
| LPAREN expr[from] ':' ')' %prec NAME
{
$$.from = $from;
- $$.len = &null_reference;
+ $$.len = cbl_refer_t::empty();
}
;
@@ -5371,7 +5458,7 @@ move: MOVE scalar TO move_tgts[tgts]
| MOVE intrinsic_call TO move_tgts[tgts]
{
statement_begin(@1, MOVE);
- if( !parser_move2($tgts, $2->field) ) { YYERROR; }
+ if( !parser_move2($tgts, *$2) ) { YYERROR; }
}
| MOVE CORRESPONDING scalar[from] TO scalar[to]
@@ -5565,6 +5652,17 @@ num_value: scalar
| num_literal { $$ = new_reference($1); }
| ADDRESS OF scalar {$$ = $scalar; $$->addr_of = true; }
| DETAIL OF scalar {$$ = $scalar; }
+ | LENGTH_OF scalar[val] {
+ location_set(@1);
+ $$ = new cbl_refer_t( new_tempnumeric_float() );
+ auto r1 = $val;
+ if( ! dialect_ibm() ) {
+ yyerrorv("LENGTH OF %s requires '-dialect ibm' option",
+ $val->field->name);
+ }
+ if( ! intrinsic_call_1($$->field, LENGTH, r1) ) YYERROR;
+ }
+
;
@@ -5690,8 +5788,7 @@ stop: STOP RUN stop_how
;
stop_how: %empty
{
- static cbl_refer_t nothing;
- $$ = ¬hing;
+ $$ = cbl_refer_t::empty();
}
| with NORMAL stop_status
{
@@ -6100,16 +6197,16 @@ varg: varg1
| ALL varg1 { $$ = $2; $$->all = true; }
;
-varg1: literal
+varg1: scalar
+ | intrinsic_call
+ | literal
{
$$ = new_reference($1);
}
- | scalar
| reserved_value
{
$$ = new_reference(constant_of(constant_index($1)));
}
- | intrinsic_call
;
literal: LITERAL
@@ -6713,7 +6810,7 @@ set_operand: set_tgt
| signed_literal { $$ = new_reference($1); }
;
set_tgt: scalar
- | ADDRESS OF scalar { $$ = $scalar; $$->addr_of = true; }
+ | ADDRESS of scalar { $$ = $scalar; $$->addr_of = true; }
;
set: SET set_tgts[tgts] TO set_operand[src]
@@ -6751,6 +6848,14 @@ set: SET set_tgts[tgts] TO set_operand[src]
YYERROR;
}
}
+ | SET set_tgts[tgts] TO NULLS[src]
+ {
+ statement_begin(@1, SET);
+ if( !valid_set_targets(*$tgts, true) ) {
+ YYERROR;
+ }
+ ast_set_pointers($tgts->targets, constant_of(constant_index(NULLS)));
+ }
| SET set_tgts TO spaces_etc[error]
{
yyerror("syntax error: invalid value for SET TO");
@@ -6786,7 +6891,7 @@ set: SET set_tgts[tgts] TO set_operand[src]
// send the signal to clear the stashed exception values
parser_exception_raise(ec_none_e);
}
- | SET LENGTH OF scalar TO scalar
+ | SET LENGTH_OF scalar TO scalar
{
statement_begin(@1, SET);
yyerror("SET LENGTH OF is not implemented");
@@ -7519,8 +7624,7 @@ first_leading: FIRST { $$ = bound_first_e; }
| LEADING { $$ = bound_leading_e; }
;
-alphaval: /* scalar */
- /* | */LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
+alphaval: LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
| reserved_value
{
$$ = new_reference( constant_of(constant_index($1)) );
@@ -7649,19 +7753,21 @@ call: call_impl end_call
call_impl: CALL call_body[body]
{
ffi_args_t *params = $body.using_params;
+ if( yydebug ) params->dump();
size_t narg = params? params->elems.size() : 0;
cbl_ffi_arg_t args[1 + narg], *pargs = NULL;
if( narg > 0 ) {
pargs = use_list(params, args);
}
parser_call( *$body.ffi_name,
- *$body.ffi_returning, narg, pargs, NULL, NULL );
+ *$body.ffi_returning, narg, pargs, NULL, NULL, false );
current.declaratives_evaluate();
}
;
call_cond: CALL call_body[body] call_excepts[except]
{
ffi_args_t *params = $body.using_params;
+ if( yydebug ) params->dump();
size_t narg = params? params->elems.size() : 0;
cbl_ffi_arg_t args[1 + narg], *pargs = NULL;
if( narg > 0 ) {
@@ -7669,7 +7775,7 @@ call_cond: CALL call_body[body] call_excepts[except]
}
parser_call( *$body.ffi_name,
*$body.ffi_returning, narg, pargs,
- $except.on_error, $except.not_error );
+ $except.on_error, $except.not_error, false );
auto handled = ec_type_t( static_cast<size_t>(ec_program_e) |
static_cast<size_t>(ec_external_e));
current.declaratives_evaluate(handled);
@@ -7683,14 +7789,14 @@ call_body: ffi_name
{ statement_begin(@1, CALL);
$$.ffi_name = $ffi_name;
$$.using_params = NULL;
- $$.ffi_returning = &null_reference;
+ $$.ffi_returning = cbl_refer_t::empty();
}
| ffi_name USING parameters
{ statement_begin(@1, CALL);
$$.ffi_name = $ffi_name;
$$.using_params = $parameters;
- $$.ffi_returning = &null_reference;
+ $$.ffi_returning = cbl_refer_t::empty();
}
| ffi_name RETURNING scalar[ret]
{ statement_begin(@1, CALL);
@@ -7737,23 +7843,17 @@ ffi_name: name
| LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
;
-parameters: parameter
+parameters: parameter { $$ = new ffi_args_t($1); }
| parameters parameter
{
- $1->elems.splice($1->elems.end(), $2->elems);
+ $1->push_back($2);
$$ = $1;
}
;
-parameter: ffi_by_ref { $$ = new ffi_args_t($1); }
- | by REFERENCE ffi_by_refs { $$ = $3; }
- | by CONTENT ffi_by_cons { $$ = $3; }
- | by VALUE ffi_by_vals { $$ = $3; }
- ;
-ffi_by_refs: ffi_by_ref { $$ = new ffi_args_t($1); }
- | ffi_by_refs ffi_by_ref[ref]
- {
- $$ = $1->push_back($ref);
- }
+parameter: ffi_by_ref { $$ = $1; $$->crv = cbl_ffi_crv_t(0); }
+ | by REFERENCE ffi_by_ref { $$ = $3; }
+ | by CONTENT ffi_by_con { $$ = $3; }
+ | by VALUE ffi_by_val { $$ = $3; }
;
ffi_by_ref: scalar_arg[refer]
{
@@ -7770,20 +7870,10 @@ ffi_by_ref: scalar_arg[refer]
}
;
-ffi_by_cons: ffi_by_con { $$ = new ffi_args_t($1); }
- | ffi_by_cons ffi_by_con { $$ = $1->push_back($2); }
- ;
-ffi_by_con: scalar_arg
- {
- $$ = new cbl_ffi_arg_t(by_content_e, $1);
- }
- | ADDRESS OF scalar_arg[arg]
- {
- $$ = new cbl_ffi_arg_t(by_content_e, $arg, address_of_e);
- }
- | LENGTH OF scalar_arg[arg]
+ffi_by_con: expr
{
- $$ = new cbl_ffi_arg_t(by_content_e, $arg, length_of_e);
+ cbl_refer_t *r = new cbl_refer_t(*$1);
+ $$ = new cbl_ffi_arg_t(by_content_e, r);
}
| LITERAL
{
@@ -7797,9 +7887,6 @@ ffi_by_con: scalar_arg
}
;
-ffi_by_vals: ffi_by_val { $$ = new ffi_args_t($1); }
- | ffi_by_vals ffi_by_val { $$ = $1->push_back($2); }
- ;
ffi_by_val: by_value_arg
{
$$ = new cbl_ffi_arg_t(by_value_e, $1);
@@ -7813,7 +7900,7 @@ ffi_by_val: by_value_arg
{
$$ = new cbl_ffi_arg_t(by_value_e, $scalar, address_of_e);
}
- | LENGTH OF scalar
+ | LENGTH_OF scalar
{
$$ = new cbl_ffi_arg_t(by_value_e, $scalar, length_of_e);
}
@@ -8283,6 +8370,38 @@ function: %empty %prec FUNCTION
}
;
+function_udf: FUNCTION_UDF '(' udf_args[args] ')' {
+ auto L = cbl_label_of(symbol_at($1));
+ cbl_field_t *returning_as = symbol_valid_udf_args( $1, $args->refers );
+ if( ! returning_as ) YYERROR;
+ $$ = new_temporary_clone(returning_as);
+ auto narg = $args->refers.size();
+ cbl_ffi_arg_t args[narg];
+ std::transform( $args->refers.begin(), $args->refers.end(),
+ args, []( cbl_refer_t& arg ) {
+ auto ar = new cbl_refer_t(arg);
+ return cbl_ffi_arg_t(ar); } );
+
+ auto name = new_literal(L->name, quoted_e);
+ parser_call( name, $$, narg, args, NULL, NULL, true );
+ }
+ | FUNCTION_UDF_0 {
+ static const size_t narg = 0;
+ static cbl_ffi_arg_t *args = NULL;
+
+ auto L = cbl_label_of(symbol_at($1));
+ cbl_field_t *returning_as = symbol_valid_udf_args( $1 );
+ if( ! returning_as ) YYERROR;
+ $$ = new_temporary_clone(returning_as);
+
+ auto name = new_literal(L->name, quoted_e);
+ parser_call( name, $$, narg, args, NULL, NULL, true );
+ }
+ ;
+udf_args: %empty { static refer_list_t empty(NULL); $$ = ∅ }
+ | arg_list
+ ;
+
/*
* The scanner returns a function-token (e.g. NUMVAL) if it was
* preceded by FUNCTION, or if the name is in the program's
@@ -8299,7 +8418,8 @@ function: %empty %prec FUNCTION
* alpahaval: LITERAL, reserved_value, instrinsic, or scalar
* Probably any numeric argument could be an expression.
*/
-intrinsic: intrinsic0
+intrinsic: function_udf
+ | intrinsic0
| intrinsic_v '(' arg_list[args] ')' {
location_set(@1);
size_t n = $args->size();
@@ -8365,16 +8485,6 @@ intrinsic: intrinsic0
parser_exception_file( $$, $filename );
}
- | LENGTH OF name {
- location_set(@1);
- $$ = new_tempnumeric_float();
- auto r1 = new cbl_refer_t($name);
- if( ! intrinsic_call_1($$, LENGTH, r1) ) YYERROR;
- if( ! dialect_ibm() ) {
- yyerrorv("LENGTH OF %s requires '-dialect ibm' option", $name->name);
- }
- }
-
| FORMATTED_DATE '(' DATE_FMT[r1] expr[r2] ')' {
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE);
@@ -8388,8 +8498,9 @@ intrinsic: intrinsic0
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
auto r1 = new_reference(new_literal($r1, quoted_e));
+ static cbl_refer_t r3(literally_zero);
if( ! intrinsic_call_4($$, FORMATTED_DATETIME,
- r1, $r2, $r3, NULL) ) YYERROR;
+ r1, $r2, $r3, &r3) ) YYERROR;
}
| FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
expr[r3] expr[r4] ')' {
@@ -8422,21 +8533,21 @@ intrinsic: intrinsic0
if( ! intrinsic_call_1($$, FORMATTED_CURRENT_DATE, r1) )
YYERROR;
}
- | TEST_FORMATTED_DATETIME '(' DATE_FMT[r1] num_operand[r2] ')' {
+ | TEST_FORMATTED_DATETIME '(' DATE_FMT[r1] varg[r2] ')' {
location_set(@1);
$$ = new_tempnumeric();
auto r1 = new_reference(new_literal($r1, quoted_e));
if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
r1, $r2) ) YYERROR;
}
- | TEST_FORMATTED_DATETIME '(' TIME_FMT[r1] num_operand[r2] ')' {
+ | TEST_FORMATTED_DATETIME '(' TIME_FMT[r1] varg[r2] ')' {
location_set(@1);
$$ = new_tempnumeric();
auto r1 = new_reference(new_literal($r1, quoted_e));
if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
r1, $r2) ) YYERROR;
}
- | TEST_FORMATTED_DATETIME '(' DATETIME_FMT[r1] num_operand[r2] ')'
+ | TEST_FORMATTED_DATETIME '(' DATETIME_FMT[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_tempnumeric();
@@ -8444,14 +8555,14 @@ intrinsic: intrinsic0
if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
r1, $r2) ) YYERROR;
}
- | INTEGER_OF_FORMATTED_DATE '(' DATE_FMT[r1] num_operand[r2] ')' {
+ | INTEGER_OF_FORMATTED_DATE '(' DATE_FMT[r1] varg[r2] ')' {
location_set(@1);
$$ = new_tempnumeric();
auto r1 = new_reference(new_literal($r1, quoted_e));
if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE,
r1, $r2) ) YYERROR;
}
- | INTEGER_OF_FORMATTED_DATE '(' DATETIME_FMT[r1] num_operand[r2] ')'
+ | INTEGER_OF_FORMATTED_DATE '(' DATETIME_FMT[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_tempnumeric();
@@ -8459,14 +8570,14 @@ intrinsic: intrinsic0
if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE,
r1, $r2) ) YYERROR;
}
- | SECONDS_FROM_FORMATTED_TIME '(' TIME_FMT[r1] num_operand[r2] ')' {
+ | SECONDS_FROM_FORMATTED_TIME '(' TIME_FMT[r1] varg[r2] ')' {
location_set(@1);
$$ = new_tempnumeric();
auto r1 = new_reference(new_literal($r1, quoted_e));
if( ! intrinsic_call_2($$, SECONDS_FROM_FORMATTED_TIME,
r1, $r2) ) YYERROR;
}
- | SECONDS_FROM_FORMATTED_TIME '(' DATETIME_FMT[r1] num_operand[r2] ')'
+ | SECONDS_FROM_FORMATTED_TIME '(' DATETIME_FMT[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_tempnumeric();
@@ -8485,16 +8596,11 @@ intrinsic: intrinsic0
if( ! intrinsic_call_1($$, $func, $r1 )) YYERROR;
}
;
- | NUMVAL_C '(' varg[r1] varg[r2] ')' {
- location_set(@1);
- $$ = new_tempnumeric_float();
- if( ! intrinsic_call_2($$, NUMVAL_C, $r1, $r2) ) YYERROR;
- }
- | NUMVAL_C '(' varg[r1] ')' {
+ | NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
location_set(@1);
- $$ = new_tempnumeric_float();
- cbl_refer_t dummy = {};
- if( ! intrinsic_call_2($$, NUMVAL_C, $r1, &dummy) ) YYERROR;
+ $$ = new_tempnumeric();
+ parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
+ *$r2.arg2, $anycase );
}
| ORD '(' alpha_val[r1] ')'
{
@@ -8514,15 +8620,29 @@ intrinsic: intrinsic0
$$ = new_tempnumeric_float();
if( ! intrinsic_call_1($$, RANDOM, $r1) ) YYERROR;
}
- | TEST_NUMVAL_C '(' varg[r1] varg[r2] ')' {
+
+ | SUBSTITUTE '(' varg[r1] subst_inputs[inputs] ')' {
location_set(@1);
- $$ = new_alphanumeric(64); // how long?
- if( ! intrinsic_call_2($$, TEST_NUMVAL_C, $r1, $r2) ) YYERROR;
+ $$ = new_alphanumeric(64);
+ auto narg = $inputs->size();
+ cbl_substitute_t args[narg];
+ std::transform( $inputs->begin(), $inputs->end(), args,
+ []( const substitution_t& arg ) {
+ cbl_substitute_t output( arg.anycase,
+ char(arg.first_last),
+ arg.orig,
+ arg.replacement );
+ return output; } );
+
+ parser_intrinsic_subst($$, *$r1, narg, args);
}
- | TEST_NUMVAL_C '(' varg[r1] ')' {
+
+
+ | TEST_NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
location_set(@1);
- $$ = new_alphanumeric(64); // how long?
- if( ! intrinsic_call_2($$, TEST_NUMVAL_C, $r1, NULL) ) YYERROR;
+ $$ = new_tempnumeric();
+ parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
+ *$r2.arg2, $anycase, true );
}
| TRIM '(' error ')' {
yyerrorv("error: invalid TRIM argument");
@@ -8531,15 +8651,21 @@ intrinsic: intrinsic0
| TRIM '(' expr[r1] trim_trailing ')'
{
location_set(@1);
- if( $r1->field->type != FldGroup &&
- $r1->field->type != FldAlphanumeric &&
- $r1->field->type != FldLiteralA &&
- $r1->field->type != FldAlphaEdited &&
- $r1->field->type != FldNumericEdited ) {
- if( 0 == ($r1->field->attr & blank_zero_e) ) {
- yyerrorv("error: TRIM argument must be alphanumeric");
- YYERROR;
- }
+ switch( $r1->field->type ) {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ case FldAlphaEdited:
+ case FldNumericEdited:
+ break; // alphanumeric OK
+ default:
+ // BLANK WHEN ZERO implies numeric-edited, so OK
+ if( has_field_attr($r1->field->attr, blank_zero_e) ) {
+ break;
+ }
+ yyerrorv("error: TRIM argument must be alphanumeric");
+ YYERROR;
+ break;
}
$$ = new_alphanumeric($r1->field->data.capacity);
cbl_refer_t * how = new_reference($trim_trailing);
@@ -8576,7 +8702,7 @@ intrinsic: intrinsic0
$$ = new_alphanumeric($r1->field->data.capacity);
break;
default:
- if( $1 == NUMVAL )
+ if( $1 == NUMVAL || $1 == NUMVAL_F )
{
$$ = new_temporary(FldFloat);
}
@@ -8585,6 +8711,21 @@ intrinsic: intrinsic0
$$ = new_temporary(type);
}
}
+ if( $1 == NUMVAL_F ) {
+ if( is_literal($r1->field) ) {
+ _Float128 output __attribute__ ((__unused__));
+ auto input = $r1->field->data.initial;
+ auto local = strdup(input), pend = local;
+ if( !local ) { warn("%s: %s", __func__, input); return false; }
+ std::replace(local, local + strlen(local), ',', '.');
+ std::remove_if(local, local + strlen(local), isspace);
+ output = strtof128(local, &pend);
+ // bad if strtof128 could not convert input
+ if( *pend != '\0' ) {
+ yyerrorv("error: '%s' is not a numeric string", input);
+ }
+ }
+ }
if( ! intrinsic_call_1($$, $1, $r1) ) YYERROR;
}
@@ -8679,7 +8820,6 @@ intrinsic: intrinsic0
$r1, $r2, $r3) ) YYERROR;
}
-
| YEAR_TO_YYYY '(' expr[r1] ')'
{
location_set(@1);
@@ -8722,8 +8862,6 @@ intrinsic: intrinsic0
$r1, $r2, $r3) ) YYERROR;
}
-
-
| intrinsic_N2 '(' expr[r1] expr[r2] ')'
{
location_set(@1);
@@ -8748,8 +8886,83 @@ intrinsic: intrinsic0
$$ = new_alphanumeric($r1->field->data.capacity);
if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
}
+ | intrinsic_locale
;
+numval_locale: %empty {
+ $$.is_locale = false;
+ $$.arg2 = cbl_refer_t::empty();
+ }
+ | LOCALE NAME { $$.is_locale = true; $$.arg2 = NULL;
+ yyerror("unimplemented: NUMVAL_C LOCALE"); YYERROR;
+ }
+ | varg { $$.is_locale = false; $$.arg2 = $1; }
+ ;
+
+subst_inputs: subst_input { $$ = new substitutions_t; $$->push_back($1); }
+ | subst_inputs subst_input { $$ = $1; $$->push_back($2); }
+ ;
+subst_input: anycase first_last varg[v1] varg[v2] {
+ $$.init( $anycase, $first_last, $v1, $v2 );
+ }
+ ;
+
+intrinsic_locale:
+ LOCALE_COMPARE '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, &dummy) ) YYERROR;
+ }
+ | LOCALE_COMPARE '(' varg[r1] varg[r2] varg[r3] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, $r3) ) YYERROR;
+ }
+
+ | LOCALE_DATE '(' varg[r1] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, &dummy) ) YYERROR;
+ }
+ | LOCALE_DATE '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, $r2) ) YYERROR;
+ }
+ | LOCALE_TIME '(' varg[r1] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, &dummy) ) YYERROR;
+ }
+ | LOCALE_TIME '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, $r2) ) YYERROR;
+ }
+ | LOCALE_TIME_FROM_SECONDS '(' varg[r1] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, &dummy) ) YYERROR;
+ }
+ | LOCALE_TIME_FROM_SECONDS '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, $r2) ) YYERROR;
+ }
+ ;
+
lopper_case: LOWER_CASE { $$ = LOWER_CASE; }
| UPPER_CASE { $$ = UPPER_CASE; }
;
@@ -8807,6 +9020,11 @@ intrinsic0: CURRENT_DATE {
$$ = new_tempnumeric_float();
parser_intrinsic_call_0( $$, "__gg__pi" );
}
+ | SECONDS_PAST_MIDNIGHT {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ intrinsic_call_0( $$, SECONDS_PAST_MIDNIGHT );
+ }
| UUID4 {
location_set(@1);
$$ = new_alphanumeric(32); // don't know correct size
@@ -8819,19 +9037,19 @@ intrinsic0: CURRENT_DATE {
}
;
-intrinsic_I: BYTE_LENGTH { $$ = BYTE_LENGTH; }
- | DATE_OF_INTEGER { $$ = DATE_OF_INTEGER; }
+intrinsic_I: DATE_OF_INTEGER { $$ = DATE_OF_INTEGER; }
| DAY_OF_INTEGER { $$ = DAY_OF_INTEGER; }
| FACTORIAL { $$ = FACTORIAL; }
+ | FRACTION_PART { $$ = FRACTION_PART; }
+ | HIGHEST_ALGEBRAIC { $$ = HIGHEST_ALGEBRAIC; }
| INTEGER { $$ = INTEGER; }
| INTEGER_OF_DATE { $$ = INTEGER_OF_DATE; }
| INTEGER_OF_DAY { $$ = INTEGER_OF_DAY; }
| INTEGER_PART { $$ = INTEGER_PART; }
+ | LOWEST_ALGEBRAIC { $$ = LOWEST_ALGEBRAIC; }
| SIGN { $$ = SIGN; }
| TEST_DATE_YYYYMMDD { $$ = TEST_DATE_YYYYMMDD; }
| TEST_DAY_YYYYDDD { $$ = TEST_DAY_YYYYDDD; }
- | TEST_NUMVAL { $$ = TEST_NUMVAL; }
- | TEST_NUMVAL_F { $$ = TEST_NUMVAL_F; }
| ULENGTH { $$ = ULENGTH; }
| UPOS { $$ = UPOS; }
| USUPPLEMENTARY { $$ = USUPPLEMENTARY; }
@@ -8862,11 +9080,14 @@ intrinsic_N2: ANNUITY { $$ = ANNUITY; }
;
intrinsic_X: BIT_TO_CHAR { $$ = BIT_TO_CHAR; }
+ | BYTE_LENGTH { $$ = BYTE_LENGTH; }
| HEX_TO_CHAR { $$ = HEX_TO_CHAR; }
| LENGTH { $$ = LENGTH; }
| NUMVAL { $$ = NUMVAL; }
| NUMVAL_F { $$ = NUMVAL_F; }
| REVERSE { $$ = REVERSE; }
+ | TEST_NUMVAL { $$ = TEST_NUMVAL; }
+ | TEST_NUMVAL_F { $$ = TEST_NUMVAL_F; }
;
intrinsic_X2: NATIONAL_OF { $$ = NATIONAL_OF; }
@@ -8890,6 +9111,10 @@ all: %empty { $$ = false; }
| ALL { $$ = true; }
;
+anycase: %empty { $$ = false; }
+ | ANYCASE { $$ = true; }
+ ;
+
as: %empty
| AS
;
@@ -8926,6 +9151,11 @@ file: %empty
| FILE_KW
;
+first_last: %empty { $$ = 0; }
+ | FIRST { $$ = 'F'; }
+ | LAST { $$ = 'L'; }
+ ;
+
is_global: %empty %prec GLOBAL { $$ = false; }
| is GLOBAL { $$ = true; }
;
@@ -9050,7 +9280,7 @@ cdf_use: %empty
YYERROR;
}
static const cbl_label_t all = {
- LblNone, 0,0, false,false,false, 0, ":all:" };
+ LblNone, 0,0, false,false,false, 0,0, ":all:" };
add_debugging_declarative(&all);
}
| USE globally mistake procedure on culprits
@@ -9135,7 +9365,11 @@ procedure: %empty
;
cdf_listing: STAR_CBL star_cbl_opts
- | EJECT
+ | EJECT {
+ if( ! dialect_ibm() ) {
+ yyerror("error: EJECT is not ISO syntax, requires -dialect ibm");
+ }
+ }
| SKIP1
| SKIP2
| SKIP3
@@ -9180,7 +9414,8 @@ cdf_call_convention:
void parser_call2( cbl_refer_t name, cbl_refer_t returning,
size_t narg, cbl_ffi_arg_t args[],
cbl_label_t *except,
- cbl_label_t *not_except )
+ cbl_label_t *not_except,
+ bool is_function)
{
if( is_literal(name.field) ) {
cbl_field_t called = { 0, FldLiteralA, FldInvalid, quoted_e | constant_e,
@@ -9208,7 +9443,7 @@ void parser_call2( cbl_refer_t name, cbl_refer_t returning,
i, crv, args[i].refer.field, args[i].refer.field->name);
}
}
- parser_call( name, returning, narg, args, except, not_except );
+ parser_call( name, returning, narg, args, except, not_except, is_function );
}
@@ -9343,6 +9578,7 @@ constant_index( int token ) {
case HIGH_VALUE :
case HIGH_VALUES : return verify_figconst(high_value_e, 4);
case QUOTES : return 5;
+ case NULLS : return 6;
}
errx(EXIT_FAILURE, "%s:%d: no such constant %d", __func__, __LINE__, token);
return (size_t)-1;
@@ -9849,7 +10085,7 @@ stringify( refer_collection_t *inputs,
stringify_src_t sources[n];
if( inputs->lists.back().marker == NULL ) {
- inputs->lists.back().marker = &null_reference;
+ inputs->lists.back().marker = cbl_refer_t::empty();
}
assert( inputs->lists.back().marker );
std::copy( inputs->lists.begin(), inputs->lists.end(), sources );
@@ -10229,7 +10465,7 @@ symbol_group_data_members( cbl_refer_t refer, bool with_filler ) {
return refers;
}
-static int
+static bool
close_out_program( const char name[] ) {
const cbl_label_t *prog = current.program();
assert(prog);
@@ -10237,7 +10473,7 @@ close_out_program( const char name[] ) {
if( 0 != strcasecmp(prog->name, name) ) {
yyerrorv( "END PROGRAM '%s' does not match PROGRAM-ID '%s'",
name, prog->name);
- return -1;
+ return false;
}
}
@@ -10249,7 +10485,7 @@ close_out_program( const char name[] ) {
// pointer still valid because name is in symbol table
ast_end_program(prog->name);
- return 0;
+ return true;
}
struct expand_group : public std::list<cbl_refer_t> {
@@ -10612,9 +10848,6 @@ void parser_add_declaratives( size_t n, cbl_declarative_t *declaratives) {
os << "};\n" << std::endl;
}
-cbl_field_t *
-new_temporary_imply( enum cbl_field_type_t type );
-
cbl_field_t *
new_literal( const literal_t& lit, enum cbl_field_attr_t attr ) {
cbl_field_t *field = new_temporary_imply(FldLiteral);
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index 542f95c9e306f3235a56e5e391b2bb84d4287a41..fe83e582df5f1a9b7a48d9b774092b5d6a14fb22 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -1143,23 +1143,36 @@ struct ffi_args_t {
list<cbl_ffi_arg_t> elems;
ffi_args_t( cbl_ffi_arg_t *arg ) {
- elems.push_back(*arg);
- delete arg;
+ this->push_back(arg);
}
+ // set explicitly, or assume
ffi_args_t * push_back( cbl_ffi_arg_t *arg ) {
+ if( arg->crv == cbl_ffi_crv_t(0) ) {
+ arg->crv = elems.empty()? by_reference_e : elems.back().crv;
+ }
elems.push_back(*arg);
delete arg;
return this;
}
+ // infer reference/content/value from previous
ffi_args_t * push_back( cbl_refer_t* refer,
cbl_ffi_arg_attr_t attr = none_of_e ) {
- assert(!elems.empty());
- cbl_ffi_arg_t arg( elems.back().crv, refer, attr );
+ cbl_ffi_crv_t crv = elems.empty()? by_reference_e : elems.back().crv;
+ cbl_ffi_arg_t arg( crv, refer, attr );
elems.push_back(arg);
return this;
}
+ void dump() const {
+ int i=0;
+ for( const auto& arg : elems ) {
+ warnx( "%8d) %-10s %-16s %s", i++,
+ cbl_ffi_crv_str(arg.crv),
+ 3 + cbl_field_type_str(arg.refer.field->type),
+ arg.refer.field->pretty_name() );
+ }
+ }
};
struct relop_abbr_t {
@@ -1252,9 +1265,17 @@ class prog_descr_t {
std::set<std::string> call_targets, subprograms;
public:
std::set<intrinsic_args_t> function_repository;
+ std::set<size_t> udfs;
size_t program_index, declaratives_index;
cbl_label_t *declaratives_eval;
const char *collating_sequence;
+ struct locale_t {
+ cbl_name_t name; const char *os_name;
+ locale_t(const cbl_name_t name = NULL, const char *os_name = NULL)
+ : name(""), os_name(os_name) {
+ if( name ) namcpy(this->name, name);
+ }
+ } locale;
cbl_call_convention_t call_convention;
cbl_options_t options;
@@ -1365,7 +1386,7 @@ static class current_t {
yyerrorv("not implemented: Global declarative %s for %s",
eval->name, name);
parser_call( new_literal(name, quoted_e),
- cbl_refer_t(), 0, NULL, NULL, NULL );
+ cbl_refer_t(), 0, NULL, NULL, NULL, false );
}
}
@@ -1429,6 +1450,10 @@ static class current_t {
void repository_add_all();
bool repository_add( const char name[] );
int repository_in( const char name[] );
+ bool repository_udf( size_t isym ) {
+ auto result = programs.top().udfs.insert(isym);
+ return result.second;
+ }
size_t declarative_section() const {
return section;
@@ -1478,13 +1503,32 @@ static class current_t {
return programs.top().call_convention = convention;
}
+ const char *
+ locale() {
+ return programs.empty()? NULL : programs.top().locale.os_name;
+ }
+ const char *
+ locale( const cbl_name_t name ) {
+ if( programs.empty() ) return NULL;
+ const prog_descr_t::locale_t& locale = programs.top().locale;
+ return 0 == strcmp(name, locale.name)? locale.name : NULL;
+ }
+ const prog_descr_t::locale_t&
+ locale( const cbl_name_t name, const char os_name[] ) {
+ if( programs.empty() ) {
+ static prog_descr_t::locale_t empty;
+ return empty;
+ }
+ return programs.top().locale = prog_descr_t::locale_t(name, os_name);
+ }
+
bool new_program ( cbl_label_type_t type,
const char name[], const char os_name[],
bool common, bool initial )
{
size_t parent = programs.empty()? 0 : programs.top().program_index;
cbl_label_t label = {
- type, parent, yylineno, common, initial, false, 0, "", os_name
+ type, parent, yylineno, common, initial, false, 0,0, "", os_name
};
if( !namcpy(label.name, name) ) { assert(false); return false; }
@@ -1655,7 +1699,7 @@ static class current_t {
parser_entry_activate( iprog, eval );
auto name = cbl_label_of(symbol_at(iprog))->name;
parser_call( new_literal(name, quoted_e),
- cbl_refer_t(), 0, NULL, NULL, NULL );
+ cbl_refer_t(), 0, NULL, NULL, NULL, false );
}
}
}
@@ -1793,15 +1837,24 @@ new_tempnumeric(void) { return new_temporary(FldNumericBin5); }
static inline cbl_field_t *
new_tempnumeric_float(void) { return new_temporary(FldFloat); }
+static inline cbl_field_t *
+new_temporary_clone( const cbl_field_t *orig) {
+ cbl_field_type_t type = is_literal(orig)? FldAlphanumeric : orig->type;
+ auto f = new_temporary_imply(type);
+ f->data = orig->data;
+ if( f->type == FldNumericBin5 ) f->type = orig->type;
+ f->attr = temporary_e;
+
+ parser_symbol_add(f);
+ return f;
+}
+
uint32_t
type_capacity( enum cbl_field_type_t type, uint32_t digits );
bool
valid_picture( enum cbl_field_type_t type, const char picture[] );
-bool
-valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src );
-
bool
move_corresponding( cbl_refer_t& tgt, cbl_refer_t& src );
@@ -1907,6 +1960,7 @@ intrinsic_call_1( cbl_field_t *output, int token, cbl_refer_t *r1 ) {
yyerrorv("syntax error: invalid parameter '%s'", bad->name);
return false;
}
+
const char *name = intrinsic_cname(token);
if( !name ) return false;
parser_intrinsic_call_1( output, name, *r1 );
@@ -2112,12 +2166,17 @@ valid_redefine( const cbl_field_t *field, const cbl_field_t *orig ) {
*/
if( field->type != FldGroup && orig->type != FldGroup ) {
if( orig->size() < field->size() ) {
- if( orig->level > 1 || has_field_attr(orig->attr, external_e) )
+ if( orig->level > 1 || has_field_attr(orig->attr, external_e) ) {
+ if( yydebug ) {
+ yyerrorv( "size error orig: %s", field_str(orig) );
+ yyerrorv( "size error redef: %s", field_str(field) );
+ }
yyerrorv( "error: %s (%s size %u) larger than REDEFINES %s (%s size %u)",
field->name,
3 + cbl_field_type_str(field->type), field->size(),
orig->name,
3 + cbl_field_type_str(orig->type), orig->size() );
+ }
}
}
@@ -2480,6 +2539,7 @@ parser_move_carefully( const char */*F*/, int /*L*/,
static void
ast_set_pointers( const list<cbl_num_result_t>& tgts, cbl_refer_t src ) {
assert(!tgts.empty());
+ assert(src.field);
size_t nptr = tgts.size();
cbl_refer_t ptrs[nptr];
@@ -2567,6 +2627,14 @@ procedure_division_ready( cbl_field_t *returning, ffi_args_t *ffi_args ) {
auto prog = cbl_label_of(symbols_begin(current.program_index()));
+ if( prog->type == LblFunction ) {
+ if( ! returning ) {
+ yyerrorv("error: FUNCTION %s requires RETURNING", prog->name);
+ } else {
+ prog->returning = field_index(returning);
+ }
+ }
+
// Create program initialization section. We build it on an island,
// that gets executed only if the program is IS INITIAL, or when the
// program is the subject of a CANCEL statement.
@@ -2689,10 +2757,11 @@ file_section_parent_set( cbl_field_t *field ) {
void parser_call2( cbl_refer_t name, cbl_refer_t returning,
size_t narg, cbl_ffi_arg_t args[],
cbl_label_t *except,
- cbl_label_t *not_except );
+ cbl_label_t *not_except,
+ bool is_function );
-#define parser_call( name, returning, narg, args, except, not_except ) \
- parser_call2(name, returning, narg, args, except, not_except )
+#define parser_call( name, returning, narg, args, except, not_except, is_function ) \
+ parser_call2(name, returning, narg, args, except, not_except, is_function )
cbl_field_t *
ast_file_status_between( file_status_t lower, file_status_t upper );
diff --git a/gcc/cobol/parse_util.h b/gcc/cobol/parse_util.h
index b814add14156fcefcb49b6e8ebb269d5c0eb771b..59093ed807a1e4890af8a07e44d30886968b86c2 100644
--- a/gcc/cobol/parse_util.h
+++ b/gcc/cobol/parse_util.h
@@ -113,10 +113,14 @@ static const intrinsic_args_t intrinsic_args[] = {
"__gg__formatted_datetime", "XINI", FldAlphanumeric },
{ FORMATTED_TIME, "FORMATTED-TIME",
"__gg__formatted_time", "INI", FldNumericBin5 },
+ { FRACTION_PART, "FRACTION-PART",
+ "__gg__fraction_part", "N", FldNumericBin5 },
{ HEX_OF, "HEX-OF",
"__gg__hex_of", "X", FldAlphanumeric },
{ HEX_TO_CHAR, "HEX-TO-CHAR",
"__gg__hex_to_char", "X", FldAlphanumeric },
+ { HIGHEST_ALGEBRAIC, "HIGHEST-ALGEBRAIC",
+ "__gg__highest_algebraic", "N", FldNumericBin5 },
{ INTEGER, "INTEGER",
"__gg__integer", "N", FldNumericBin5 },
{ INTEGER_OF_DATE, "INTEGER-OF-DATE",
@@ -129,12 +133,24 @@ static const intrinsic_args_t intrinsic_args[] = {
"__gg__integer_part", "N", FldNumericBin5 },
{ LENGTH, "LENGTH",
"__gg__length", "X", FldNumericBin5 },
+ { LOCALE_COMPARE, "LOCALE-COMPARE",
+ "__gg__locale_compare", "XXX", FldNumericBin5 },
+ { LOCALE_DATE, "LOCALE-DATE",
+ "__gg__locale_date", "XX", FldNumericBin5 },
+ { LOCALE_TIME, "LOCALE-TIME",
+ "__gg__locale_time", "XX", FldNumericBin5 },
+ { LOCALE_TIME_FROM_SECONDS, "LOCALE-TIME-FROM-SECONDS",
+ "__gg__locale_time_from_seconds", "NX", FldNumericBin5 },
+
{ LOG, "LOG",
"__gg__log", "N", FldNumericBin5 },
{ LOG10, "LOG10",
"__gg__log10", "N", FldNumericBin5 },
{ LOWER_CASE, "LOWER-CASE",
"__gg__lower_case", "X", FldAlphanumeric },
+ { LOWEST_ALGEBRAIC, "LOWEST-ALGEBRAIC",
+ "__gg__lowest_algebraic", "N", FldNumericBin5 },
+
{ MAX, "MAX",
"__gg__max", "n", FldAlphanumeric },
{ MEAN, "MEAN",
@@ -192,9 +208,9 @@ static const intrinsic_args_t intrinsic_args[] = {
{ TEST_DAY_YYYYDDD, "TEST-DAY-YYYYDDD",
"__gg__test_day_yyyyddd", "I", FldNumericBin5 },
{ TEST_FORMATTED_DATETIME, "TEST-FORMATTED-DATETIME",
- "__gg__test_formatted_datetime", "XX", FldAlphanumeric },
+ "__gg__test_formatted_datetime", "XX", FldNumericBin5 },
{ TEST_NUMVAL, "TEST-NUMVAL",
- "__gg__test_numval", "X", FldAlphanumeric },
+ "__gg__test_numval", "X", FldNumericBin5 },
{ TEST_NUMVAL_C, "TEST-NUMVAL-C",
"__gg__test_numval_c", "XXU", FldNumericBin5 },
{ TEST_NUMVAL_F, "TEST-NUMVAL-F",
@@ -229,20 +245,19 @@ static const
intrinsic_args_t *eoargs = intrinsic_args + COUNT_OF(intrinsic_args);
static const char intrinsic_unimplemented[][40] = {
- "__gg__bit_of",
- "__gg__bit_to_char",
- "__gg__display_of",
- "__gg__hex_of",
- "__gg__hex_to_char",
- "__gg__national_of",
- "__gg__numval_f",
- "__gg__test_numval_f",
- "__gg__ulength",
- "__gg__upos",
- "__gg__usubstr",
- "__gg__usupplementary",
- "__gg__uvalid",
- "__gg__uwidth",
+ "argle-bargle", // gives ::find something to chew on
+ // "__gg__bit_of",
+ // "__gg__bit_to_char",
+ // "__gg__display_of",
+ // "__gg__hex_to_char",
+ // "__gg__national_of",
+ // "__gg__test_numval_f",
+ // "__gg__ulength",
+ // "__gg__upos",
+ // "__gg__usubstr",
+ // "__gg__usupplementary",
+ // "__gg__uvalid",
+ // "__gg__uwidth",
};
diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l
index 39fd3e99ea4c1d18bdd0f540db5864659b2fef64..f893f51915733b731bbe4c2946ab33805d7333cc 100644
--- a/gcc/cobol/scan.l
+++ b/gcc/cobol/scan.l
@@ -164,6 +164,7 @@ POP_FILE \f?[#]FILE{SPC}POP\f
%x para_state picture picture_count integer_count
%x basis copy_state sort_state
%x cdf_state bool_state hex_state subscripts numstr_state exception
+%x datetime_fmt
%option debug noyywrap stack yylineno case-insensitive
%%
@@ -330,6 +331,8 @@ LC_MONETARY { return LC_MONETARY_kw; }
LC_NUMERIC { return LC_NUMERIC_kw; }
LC_TIME { return LC_TIME_kw; }
LENGTH { return LENGTH; }
+LENGTH{SPC}OF { return LENGTH_OF; }
+LOCALE { return LOCALE; }
LOWLIGHT { return LOWLIGHT; }
NEAREST-AWAY-FROM-ZERO { return NEAREST_AWAY_FROM_ZERO; }
NEAREST-EVEN { return NEAREST_EVEN; }
@@ -799,6 +802,7 @@ AREAS { return AREAS; }
AREA { return AREA; }
ARE { return ARE; }
APPLY { return APPLY; }
+ANYCASE { return ANYCASE; }
ANY { return ANY; }
ALTERNATE { return ALTERNATE; }
@@ -901,6 +905,7 @@ USE([[:space:]]+FOR)? { return USE; }
ANY { return ANY; }
LENGTH { return LENGTH; }
+ LENGTH{SPC}OF { return LENGTH_OF; }
BASED { return BASED; }
USAGE { return USAGE; }
COMP(UTATIONAL)?-5 { return ucomputable(FldNumericBin5, 0); }
@@ -984,9 +989,10 @@ USE([[:space:]]+FOR)? { return USE; }
CONSTANT { return CONSTANT; }
CONTAINS { return CONTAINS; }
DATA { return DATA; }
- DEPENDING { return DEPENDING; }
+ DEPENDING { return DEPENDING; }
DESCENDING { return DESCENDING; }
DISPLAY { return DISPLAY; }
+ EJECT { return EJECT; }
EXTERNAL { return EXTERNAL; }
FALSE { return FALSE_kw; }
FROM { return FROM; }
@@ -1178,16 +1184,6 @@ USE([[:space:]]+FOR)? { return USE; }
}
<quoted2>{
- {DATETIME_FMT}[""] { yylval.string = strdup(yytext);
- yylval.string[yyleng-1] = '\0';
- pop_return DATETIME_FMT; }
- {DATE_FMT}[""] { yylval.string = strdup(yytext);
- yylval.string[yyleng-1] = '\0';
- pop_return DATE_FMT; }
- {TIME_FMT}[""] { yylval.string = strdup(yytext);
- yylval.string[yyleng-1] = '\0';
- pop_return TIME_FMT; }
-
{STRING}$ { tmpstring_append(yyleng); }
^-[ ]{4,}[""]/.+ /* ignore continuation mark */
{STRING}?[""]{2} { tmpstring_append(yyleng - 1); }
@@ -1204,15 +1200,6 @@ USE([[:space:]]+FOR)? { return USE; }
}
<quoted1>{
- {DATETIME_FMT}[''] { yylval.string = strdup(yytext);
- yylval.string[yyleng-1] = '\0';
- pop_return DATETIME_FMT; }
- {DATE_FMT}[''] { yylval.string = strdup(yytext);
- yylval.string[yyleng-1] = '\0';
- pop_return DATE_FMT; }
- {TIME_FMT}[''] { yylval.string = strdup(yytext);
- yylval.string[yyleng-1] = '\0';
- pop_return TIME_FMT; }
{STRING1}$ { tmpstring_append(yyleng); }
^-[ ]{4,}['']/.+ /* ignore continuation mark */
{STRING1}?['']{2} { tmpstring_append(yyleng - 1); }
@@ -1502,106 +1489,157 @@ USE([[:space:]]+FOR)? { return USE; }
}
}
+<datetime_fmt>{
+ [(] { return *yytext; }
+
+ ['']{DATETIME_FMT}[''] { yylval.string = strdup(yytext + 1);
+ yylval.string[yyleng-2] = '\0';
+ pop_return DATETIME_FMT; }
+ [""]{DATETIME_FMT}[""] { yylval.string = strdup(yytext + 1);
+ yylval.string[yyleng-2] = '\0';
+ pop_return DATETIME_FMT; }
+
+ ['']{DATE_FMT}[''] { yylval.string = strdup(yytext + 1);
+ yylval.string[yyleng-2] = '\0';
+ pop_return DATE_FMT; }
+ [""]{DATE_FMT}[""] { yylval.string = strdup(yytext + 1);
+ yylval.string[yyleng-2] = '\0';
+ pop_return DATE_FMT; }
+
+ ['']{TIME_FMT}[''] { yylval.string = strdup(yytext + 1);
+ yylval.string[yyleng-2] = '\0';
+ pop_return TIME_FMT; }
+ [""]{TIME_FMT}[""] { yylval.string = strdup(yytext + 1);
+ yylval.string[yyleng-2] = '\0';
+ pop_return TIME_FMT; }
+
+ {SPC} // ignore
+ . { return NO_CONDITION; }
+}
+
<function>{
- ABS { pop_return ABS; }
- ACOS { pop_return ACOS; }
- ANNUITY { pop_return ANNUITY; }
- ASIN { pop_return ASIN; }
- ATAN { pop_return ATAN; }
- BIT-OF { pop_return BIT_OF; }
- BIT-TO-CHAR { pop_return BIT_TO_CHAR; }
- BYTE-LENGTH { pop_return BYTE_LENGTH; }
- CHAR { pop_return CHAR; }
- COMBINED-DATETIME { pop_return COMBINED_DATETIME; }
- CONCAT { pop_return CONCAT; }
- CONTENT-LENGTH { pop_return NO_CONDITION; /* GNU only*/ }
- CONTENT-OF { pop_return NO_CONDITION; /* GNU only*/ }
- COS { pop_return COS; }
- CURRENCY-SYBOL { pop_return NO_CONDITION; /* GNU only*/ }
- CURRENT-DATE { pop_return CURRENT_DATE; }
- DATE-OF-INTEGER { pop_return DATE_OF_INTEGER; }
- DATE-TO-YYYYMMDD { pop_return DATE_TO_YYYYMMDD; }
- DAY-OF-INTEGER { pop_return DAY_OF_INTEGER; }
- DAY-TO-YYYYDDD { pop_return DAY_TO_YYYYDDD; }
- DISPLAY-OF { pop_return DISPLAY_OF; }
- E { pop_return E; }
-
- EXCEPTION-FILE-N { pop_return EXCEPTION_FILE_N; }
- EXCEPTION-FILE { pop_return EXCEPTION_FILE; }
- EXCEPTION-LOCATION-N { pop_return EXCEPTION_LOCATION_N; }
- EXCEPTION-LOCATION { pop_return EXCEPTION_LOCATION; }
- EXCEPTION-STATEMENT { pop_return EXCEPTION_STATEMENT; }
- EXCEPTION-STATUS { pop_return EXCEPTION_STATUS; }
-
- EXP { pop_return EXP; }
- EXP10 { pop_return EXP10; }
- FACTORIAL { pop_return FACTORIAL; }
-
- FORMATTED-CURRENT-DATE { pop_return FORMATTED_CURRENT_DATE; }
- FORMATTED-DATE { pop_return FORMATTED_DATE; }
- FORMATTED-DATETIME { pop_return FORMATTED_DATETIME; }
- FORMATTED-TIME { pop_return FORMATTED_TIME; }
-
- HEX-OF { pop_return HEX_OF; }
- HEX-TO-CHAR { pop_return HEX_TO_CHAR; }
- INTEGER { pop_return INTEGER; }
- INTEGER-OF-DATE { pop_return INTEGER_OF_DATE; }
- INTEGER-OF-DAY { pop_return INTEGER_OF_DAY; }
- INTEGER-OF-FORMATTED-DATE { pop_return INTEGER_OF_FORMATTED_DATE; }
- INTEGER-PART { pop_return INTEGER_PART; }
- LENGTH { pop_return LENGTH; }
- LOG { pop_return LOG; }
- LOG10 { pop_return LOG10; }
- LOWER-CASE { pop_return LOWER_CASE; }
- MAX { pop_return MAX; }
- MEAN { pop_return MEAN; }
- MEDIAN { pop_return MEDIAN; }
- MIDRANGE { pop_return MIDRANGE; }
- MIN { pop_return MIN; }
- MOD { pop_return MOD; }
- NATIONAL-OF { pop_return NATIONAL_OF; }
- NUMVAL { pop_return NUMVAL; }
- NUMVAL-C { pop_return NUMVAL_C; }
- NUMVAL-F { pop_return NUMVAL_F; }
- ORD { pop_return ORD; }
- ORD-MAX { pop_return ORD_MAX; }
- ORD-MIN { pop_return ORD_MIN; }
- PI { pop_return PI; }
- PRESENT-VALUE { pop_return PRESENT_VALUE; }
-
- RANDOM{OSPC}{PARENS} { pop_return RANDOM; }
- RANDOM{OSPC}[(] { pop_return RANDOM_SEED; }
- RANDOM { pop_return RANDOM; }
-
- RANGE { pop_return RANGE; }
- REM { pop_return REM; }
- REVERSE { pop_return REVERSE; }
- SECONDS-FROM-FORMATTED-TIME { pop_return SECONDS_FROM_FORMATTED_TIME; }
- SECONDS-PAST-MIDNIGHT { pop_return SECONDS_PAST_MIDNIGHT; }
- SIGN { pop_return SIGN; }
- SIN { pop_return SIN; }
- SQRT { pop_return SQRT; }
- STANDARD-DEVIATION { pop_return STANDARD_DEVIATION; }
- SUM { pop_return SUM; }
- TAN { pop_return TAN; }
- TEST-DATE-YYYYMMDD { pop_return TEST_DATE_YYYYMMDD; }
- TEST-DAY-YYYYDDD { pop_return TEST_DAY_YYYYDDD; }
- TEST-FORMATTED-DATETIME { pop_return TEST_FORMATTED_DATETIME; }
- TEST-NUMVAL { pop_return TEST_NUMVAL; }
- TEST-NUMVAL-C { pop_return TEST_NUMVAL_C; }
- TEST-NUMVAL-F { pop_return TEST_NUMVAL_F; }
- TRIM { pop_return TRIM; }
- ULENGTH { pop_return ULENGTH; }
- UPOS { pop_return UPOS; }
- UPPER-CASE { pop_return UPPER_CASE; }
- USUBSTR { pop_return USUBSTR; }
- USUPPLEMENTARY { pop_return USUPPLEMENTARY; }
- UUID4 { pop_return UUID4; }
- UVALID { pop_return UVALID; }
- UWIDTH { pop_return UWIDTH; }
- VARIANCE { pop_return VARIANCE; }
- WHEN-COMPILED { pop_return WHEN_COMPILED; }
- YEAR-TO-YYYY { pop_return YEAR_TO_YYYY; }
+ ABS{OSPC}/[(]? { pop_return ABS; }
+ ACOS{OSPC}/[(]? { pop_return ACOS; }
+ ANNUITY{OSPC}/[(]? { pop_return ANNUITY; }
+ ASIN{OSPC}/[(]? { pop_return ASIN; }
+ ATAN{OSPC}/[(]? { pop_return ATAN; }
+ BIT-OF{OSPC}/[(]? { pop_return BIT_OF; }
+ BIT-TO-CHAR{OSPC}/[(]? { pop_return BIT_TO_CHAR; }
+ BYTE-LENGTH{OSPC}/[(]? { pop_return BYTE_LENGTH; }
+ CHAR{OSPC}/[(]? { pop_return CHAR; }
+ COMBINED-DATETIME{OSPC}/[(]? { pop_return COMBINED_DATETIME; }
+ CONCAT{OSPC}/[(]? { pop_return CONCAT; }
+ CONTENT-LENGTH{OSPC}/[(]? { pop_return NO_CONDITION; /* GNU only*/ }
+ CONTENT-OF{OSPC}/[(]? { pop_return NO_CONDITION; /* GNU only*/ }
+ COS{OSPC}/[(]? { pop_return COS; }
+ CURRENCY-SYBOL{OSPC}/[(]? { pop_return NO_CONDITION; /* GNU only*/ }
+ CURRENT-DATE{OSPC}/[(]? { pop_return CURRENT_DATE; }
+ DATE-OF-INTEGER{OSPC}/[(]? { pop_return DATE_OF_INTEGER; }
+ DATE-TO-YYYYMMDD{OSPC}/[(]? { pop_return DATE_TO_YYYYMMDD; }
+ DAY-OF-INTEGER{OSPC}/[(]? { pop_return DAY_OF_INTEGER; }
+ DAY-TO-YYYYDDD{OSPC}/[(]? { pop_return DAY_TO_YYYYDDD; }
+ DISPLAY-OF{OSPC}/[(]? { pop_return DISPLAY_OF; }
+ E{OSPC}/[(]? { pop_return E; }
+
+ EXCEPTION-FILE-N{OSPC}/[(]? { pop_return EXCEPTION_FILE_N; }
+ EXCEPTION-FILE{OSPC}/[(]? { pop_return EXCEPTION_FILE; }
+ EXCEPTION-LOCATION-N{OSPC}/[(]? { pop_return EXCEPTION_LOCATION_N; }
+ EXCEPTION-LOCATION{OSPC}/[(]? { pop_return EXCEPTION_LOCATION; }
+ EXCEPTION-STATEMENT{OSPC}/[(]? { pop_return EXCEPTION_STATEMENT; }
+ EXCEPTION-STATUS{OSPC}/[(]? { pop_return EXCEPTION_STATUS; }
+
+ EXP{OSPC}/[(]? { pop_return EXP; }
+ EXP10{OSPC}/[(]? { pop_return EXP10; }
+ FACTORIAL{OSPC}/[(]? { pop_return FACTORIAL; }
+
+ FORMATTED-CURRENT-DATE{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_CURRENT_DATE; }
+ FORMATTED-DATE{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_DATE; }
+ FORMATTED-DATETIME{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_DATETIME; }
+ FORMATTED-TIME{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_TIME; }
+ FRACTION-PART{OSPC}/[(]? { pop_return FRACTION_PART; }
+
+ HEX-OF{OSPC}/[(]? { pop_return HEX_OF; }
+ HEX-TO-CHAR{OSPC}/[(]? { pop_return HEX_TO_CHAR; }
+ HIGHEST-ALGEBRAIC{OSPC}/[(]? { pop_return HIGHEST_ALGEBRAIC; }
+
+ INTEGER{OSPC}/[(]? { pop_return INTEGER; }
+ INTEGER-OF-DATE{OSPC}/[(]? { pop_return INTEGER_OF_DATE; }
+ INTEGER-OF-DAY{OSPC}/[(]? { pop_return INTEGER_OF_DAY; }
+ INTEGER-OF-FORMATTED-DATE{OSPC}/[(]? { BEGIN(datetime_fmt); return INTEGER_OF_FORMATTED_DATE; }
+ INTEGER-PART{OSPC}/[(]? { pop_return INTEGER_PART; }
+ LENGTH{OSPC}/[(]? { pop_return LENGTH; }
+ LOCALE-COMPARE{OSPC}/[(]? { pop_return LOCALE_COMPARE; }
+ LOCALE-DATE{OSPC}/[(]? { pop_return LOCALE_DATE; }
+ LOCALE-TIME{OSPC}/[(]? { pop_return LOCALE_TIME; }
+ LOCALE-TIME-FROM-SECONDS{OSPC}/[(]? { pop_return LOCALE_TIME_FROM_SECONDS; }
+ LOG{OSPC}/[(]? { pop_return LOG; }
+ LOG10{OSPC}/[(]? { pop_return LOG10; }
+ LOWER-CASE{OSPC}/[(]? { pop_return LOWER_CASE; }
+ LOWEST-ALGEBRAIC{OSPC}/[(]? { pop_return LOWEST_ALGEBRAIC; }
+ MAX{OSPC}/[(]? { pop_return MAX; }
+ MEAN{OSPC}/[(]? { pop_return MEAN; }
+ MEDIAN{OSPC}/[(]? { pop_return MEDIAN; }
+ MIDRANGE{OSPC}/[(]? { pop_return MIDRANGE; }
+ MIN{OSPC}/[(]? { pop_return MIN; }
+ MOD{OSPC}/[(]? { pop_return MOD; }
+ NATIONAL-OF{OSPC}/[(]? { pop_return NATIONAL_OF; }
+ NUMVAL{OSPC}/[(]? { pop_return NUMVAL; }
+ NUMVAL-C{OSPC}/[(]? { pop_return NUMVAL_C; }
+ NUMVAL-F{OSPC}/[(]? { pop_return NUMVAL_F; }
+ ORD{OSPC}/[(]? { pop_return ORD; }
+ ORD-MAX{OSPC}/[(]? { pop_return ORD_MAX; }
+ ORD-MIN{OSPC}/[(]? { pop_return ORD_MIN; }
+ PI{OSPC}/[(]? { pop_return PI; }
+ PRESENT-VALUE{OSPC}/[(]? { pop_return PRESENT_VALUE; }
+
+ RANDOM{OSPC}{PARENS} { pop_return RANDOM; }
+ RANDOM{OSPC}[(] { pop_return RANDOM_SEED; }
+ RANDOM { pop_return RANDOM; }
+
+ RANGE{OSPC}/[(]? { pop_return RANGE; }
+ REM{OSPC}/[(]? { pop_return REM; }
+ REVERSE{OSPC}/[(]? { pop_return REVERSE; }
+ SECONDS-FROM-FORMATTED-TIME{OSPC}/[(]? { BEGIN(datetime_fmt);
+ return SECONDS_FROM_FORMATTED_TIME; }
+ SECONDS-PAST-MIDNIGHT{OSPC}/[(]? { pop_return SECONDS_PAST_MIDNIGHT; }
+ SIGN{OSPC}/[(]? { pop_return SIGN; }
+ SIN{OSPC}/[(]? { pop_return SIN; }
+ SQRT{OSPC}/[(]? { pop_return SQRT; }
+ STANDARD-DEVIATION{OSPC}/[(]? { pop_return STANDARD_DEVIATION; }
+ SUBSTITUTE{OSPC}/[(]? { pop_return SUBSTITUTE; }
+ SUM{OSPC}/[(]? { pop_return SUM; }
+ TAN{OSPC}/[(]? { pop_return TAN; }
+ TEST-DATE-YYYYMMDD{OSPC}/[(]? { pop_return TEST_DATE_YYYYMMDD; }
+ TEST-DAY-YYYYDDD{OSPC}/[(]? { pop_return TEST_DAY_YYYYDDD; }
+ TEST-FORMATTED-DATETIME{OSPC}/[(]? { BEGIN(datetime_fmt); return TEST_FORMATTED_DATETIME; }
+ TEST-NUMVAL{OSPC}/[(]? { pop_return TEST_NUMVAL; }
+ TEST-NUMVAL-C{OSPC}/[(]? { pop_return TEST_NUMVAL_C; }
+ TEST-NUMVAL-F{OSPC}/[(]? { pop_return TEST_NUMVAL_F; }
+ TRIM{OSPC}/[(]? { pop_return TRIM; }
+ ULENGTH{OSPC}/[(]? { pop_return ULENGTH; }
+ UPOS{OSPC}/[(]? { pop_return UPOS; }
+ UPPER-CASE{OSPC}/[(]? { pop_return UPPER_CASE; }
+ USUBSTR{OSPC}/[(]? { pop_return USUBSTR; }
+ USUPPLEMENTARY{OSPC}/[(]? { pop_return USUPPLEMENTARY; }
+ UUID4{OSPC}/[(]? { pop_return UUID4; }
+ UVALID{OSPC}/[(]? { pop_return UVALID; }
+ UWIDTH{OSPC}/[(]? { pop_return UWIDTH; }
+ VARIANCE{OSPC}/[(]? { pop_return VARIANCE; }
+ WHEN-COMPILED{OSPC}/[(]? { pop_return WHEN_COMPILED; }
+ YEAR-TO-YYYY{OSPC}/[(]? { pop_return YEAR_TO_YYYY; }
+
+ {NAME}{OSPC}/[(] { /* If /{OSPC}, "dangerous trailing context" "*/
+ auto& token(yylval.number);
+ auto name = null_trim(strdup(yytext));
+ if( 0 != (token = symbol_function_token(name)) ) {
+ pop_return FUNCTION_UDF;
+ }
+ pop_return NO_CONDITION;
+ }
+
+ {NAME} { auto token = typed_name(yytext);
+ pop_return (token == FUNCTION_UDF_0? token : NO_CONDITION);
+ }
}
/*
@@ -1639,6 +1677,10 @@ COPY {
ydflval.string = yylval.string = strdup(yytext);
int token = keyword_tok(null_trim(yylval.string));
if( token ) return token;
+ if( 0 != (token = symbol_function_token(yylval.string)) ) {
+ yylval.number = token;
+ return FUNCTION_UDF;
+ }
token = typed_name(yylval.string);
switch(token) {
case NAME:
diff --git a/gcc/cobol/scan_ante.h b/gcc/cobol/scan_ante.h
index 08c852dc254b21c2e870dfa5d3e8685a4c29a360..96d5883f4aeb11a06d9cd61fa857674688e88dc4 100644
--- a/gcc/cobol/scan_ante.h
+++ b/gcc/cobol/scan_ante.h
@@ -403,6 +403,13 @@ bool need_nume_set( bool tf ) {
return need_nume = tf;
}
+static int datetime_format_of( const char input[] );
+
+static int symbol_function_token( const char name[] ) {
+ auto e = symbol_function( 0, name );
+ return e ? symbol_index(e) : 0;
+}
+
static int
typed_name( const char name[] ) {
if( 0 == PROGRAM ) return NAME;
@@ -414,12 +421,32 @@ typed_name( const char name[] ) {
struct symbol_elem_t *e = symbol_special( PROGRAM, name );
if( e ) return cbl_special_name_of(e)->token;
+ e = symbol_function( 0, name );
+ if( e ) {
+ auto L = cbl_label_of(e);
+ assert( L->type == LblFunction );
+ yylval.number = symbol_index(e);
+ return FUNCTION_UDF_0;
+ }
+
e = symbol_field( PROGRAM, 0, name );
+
auto type = e && e->type == SymField? cbl_field_of(e)->type : FldInvalid;
switch(type) {
case FldLiteral:
case FldLiteralA:
+ {
+ auto f = cbl_field_of(e);
+ if( is_constant(f) ) {
+ int token = datetime_format_of(f->data.initial);
+ if( token ) {
+ yylval.string = strdup(f->data.initial);
+ return token;
+ }
+ }
+ }
+ __attribute__((fallthrough));
case FldLiteralN:
{
auto f = cbl_field_of(e);
diff --git a/gcc/cobol/scan_post.h b/gcc/cobol/scan_post.h
index 44b39195e124d693523f792994854f922bcd08f7..9c15eff76a7224036c679eb50020fa54e8dbc8d7 100644
--- a/gcc/cobol/scan_post.h
+++ b/gcc/cobol/scan_post.h
@@ -28,6 +28,82 @@
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
+
+/*
+ * Match datetime constants.
+ *
+ * A 78 or CONSTANT could have a special literal for formatted
+ * date/time functions.
+ */
+
+static int
+datetime_format_of( const char input[] ) {
+
+ static const char date_fmt_b[] = "YYYYMMDD|YYYYDDD|YYYYWwwD";
+ static const char date_fmt_e[] = "YYYY-MM-DD|YYYY-DDD|YYYY-Www-D";
+
+ static const char time_fmt_b[] =
+ "hhmmss([.,]s+)?|hhmmss([.,]s+)?Z|hhmmss([.,]s+)?[+]hhmm|";
+ static const char time_fmt_e[] =
+ "hh:mm:ss([.,]s+)?|hh:mm:ss([.,]s+)?Z|hh:mm:ss([.,]s+)?[+]hh:mm";
+
+ static char date_pattern[ 3 * sizeof(date_fmt_e) ];
+ static char time_pattern[ 3 * sizeof(time_fmt_e) ];
+ static char datetime_pattern[ 6 * sizeof(time_fmt_e) ];
+
+ static struct pattern_t {
+ regex_t re;
+ const char *regex;
+ int token;
+ } patterns[] = {
+ { {}, datetime_pattern, DATETIME_FMT },
+ { {}, date_pattern, DATE_FMT },
+ { {}, time_pattern, TIME_FMT },
+ }, * eopatterns = patterns + COUNT_OF(patterns);;
+
+ // compile patterns
+ if( ! date_pattern[0] ) {
+ sprintf(date_pattern, "%s|%s", date_fmt_b, date_fmt_e);
+ sprintf(time_pattern, "%s|%s", time_fmt_b, time_fmt_e);
+
+ sprintf(datetime_pattern, "(%sT%s)|(%sT%s)",
+ date_fmt_b, time_fmt_b,
+ date_fmt_e, time_fmt_e);
+
+ for( auto p = patterns; p < eopatterns; p++ ) {
+ static const int cflags = REG_EXTENDED | REG_ICASE;
+ static char msg[80];
+ int erc;
+
+ if( 0 != (erc = regcomp(&p->re, p->regex, cflags)) ) {
+ regerror(erc, &p->re, msg, sizeof(msg));
+ warnx("%s:%d: %s: %s", __func__, __LINE__, keyword_str(p->token), msg);
+ }
+ }
+ }
+
+ // applies only in the datetime_fmt start condition
+ if( datetime_fmt == YY_START ) {
+ yy_pop_state();
+ if( input == NULL ) return 0;
+
+ // See if the input is a date, time, or datetime pattern string.
+ static const int nmatch = 3;
+ regmatch_t matches[nmatch];
+
+ auto p = std::find_if( patterns, eopatterns,
+ [input, &matches]( auto& pattern ) {
+ auto erc = regexec( &pattern.re, input,
+ COUNT_OF(matches), matches, 0 );
+ return erc == 0;
+ } );
+
+ return p != eopatterns? p->token : 0;
+ }
+ return 0;
+}
+
+
/*
* >>DEFINE, >>IF, and >>EVALUATE
*/
@@ -201,10 +277,10 @@ yylex(void) {
token = prelex();
if( yy_flex_debug ) {
if( lexing.parser == ydfparse ) {
- warnx( "%s%d: routing %s to CDF parser", __func__, __LINE__,
+ warnx( "%s:%d: routing %s to CDF parser", __func__, __LINE__,
keyword_str(token) );
} else if( !lexing.on() ) {
- warnx( "%s%d: eating %s because conditional compilatiion is FALSE",
+ warnx( "%s:%d: eating %s because conditional compilatiion is FALSE",
__func__, __LINE__, keyword_str(token) );
}
}
diff --git a/gcc/cobol/show_parse.h b/gcc/cobol/show_parse.h
index 911890cffb13372cee3810da2e66830a1f21afe9..12e030307b8b215a66c04a113fa71c21361d50a8 100644
--- a/gcc/cobol/show_parse.h
+++ b/gcc/cobol/show_parse.h
@@ -207,6 +207,11 @@ extern bool cursor_at_sol;
parser_display_internal_field(trace_handle, field, false); \
gg_fprintf(trace_handle, 1, "\" %s", gg_string_literal(b)); \
} \
+ else if( field->type == FldLiteral ) \
+ { \
+ gg_fprintf(trace_handle, 1, "%s [", gg_string_literal(a)); \
+ gg_fprintf(trace_handle, 1, "] %s", gg_string_literal(b)); \
+ } \
else \
{ \
gg_fprintf(trace_handle, 1, "%s [", gg_string_literal(a)); \
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index ea008106c2d0c86ad52a4d1f501504ffc6a0e77f..ff5c0b507ed100a9324f4fe4e75bb83991a65a40 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -181,6 +181,12 @@ size_t file_status_register() { return symbols.registers.file_status; }
size_t return_code_register() { return symbols.registers.return_code; }
size_t ec_register() { return symbols.registers.exception_condition; }
+cbl_refer_t *
+cbl_refer_t::empty() {
+ static cbl_refer_t empty;
+ return ∅
+}
+
cbl_ffi_arg_t::
cbl_ffi_arg_t( cbl_refer_t* refer, cbl_ffi_arg_attr_t attr )
: optional(false)
@@ -188,7 +194,7 @@ cbl_ffi_arg_t( cbl_refer_t* refer, cbl_ffi_arg_attr_t attr )
, attr(attr)
, refer(refer? *refer : cbl_refer_t())
{
- if( refer ) delete refer;
+ if( refer && refer != refer->empty() ) delete refer;
}
cbl_ffi_arg_t::
@@ -199,7 +205,40 @@ cbl_ffi_arg_t( cbl_ffi_crv_t crv,
, attr(attr)
, refer(refer? *refer : cbl_refer_t())
{
- if( refer ) delete refer;
+ if( refer && refer != refer->empty() ) delete refer;
+}
+
+cbl_field_t *
+symbol_valid_udf_args( size_t function, std::list<cbl_refer_t> args ) {
+ auto L = cbl_label_of(symbol_at(function));
+ if( ! L->returning ) {
+ yyerrorv("logic error: %s does not define RETURNING", L->name);
+ return NULL;
+ }
+ size_t isym = function + 1;
+ for( auto arg : args ) {
+ auto e = symbol_at(++isym); // skip over linkage_sect_e, which appears after the function
+ if( e->type != SymField ) {
+ yyerrorv( "error: FUNCTION %s has no defined parameter matching arg %zu, '%s'",
+ L->name, isym - function, arg.field->name );
+ return NULL;
+ }
+
+ auto tgt = cbl_field_of(e);
+
+ if( ! has_field_attr(tgt->attr, linkage_e) ) if( e->type != SymField ) {
+ yyerrorv( "error: FUNCTION %s has no LINKAGE parameter matching arg %zu, '%s'",
+ L->name, isym - function, arg.field->name );
+ return NULL;
+ }
+ if( ! valid_move(tgt, arg.field) ) {
+ yyerrorv( "error: FUNCTION %s arg %zu, '%s' cannot be passed to %s, type %s",
+ L->name, isym - function, arg.field->pretty_name(),
+ tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) );
+ return NULL;
+ }
+ }
+ return cbl_field_of(symbol_at(L->returning));
}
/*
@@ -673,6 +712,44 @@ symbol_program( size_t parent, const char name[] )
return e;
}
+extern int yydebug;
+
+static size_t
+symbols_dump( size_t first, bool header );
+
+struct symbol_elem_t *
+symbol_function( size_t parent, const char name[] )
+{
+ // TODO: not sure of rules about contained functions
+ auto p = std::find_if( symbols_begin(), symbols_end(),
+ [parent, name]( const auto& elem ) {
+ if( elem.type == SymLabel ) {
+ auto L = cbl_label_of(&elem);
+ if( L->type == LblFunction ) {
+ return 0 == strcasecmp(L->name, name);
+ }
+ }
+ return false;
+ } );
+ if( yydebug && p == symbols_end() ) symbols_dump( symbols.first_program, true);
+
+ return p == symbols_end()? NULL : p;
+
+ cbl_label_t label = {};
+ label.type = LblFunction;
+ label.parent = parent;
+ assert(strlen(name) < sizeof label.name);
+ strcpy(label.name, name);
+
+ struct symbol_elem_t key = { SymLabel, 0, { NULL } }, *e;
+ key.elem.label = label;
+
+ e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems,
+ &symbols.nelem, sizeof(key),
+ symbol_elem_cmp ) );
+ return e;
+}
+
struct symbol_elem_t *
symbol_special( size_t program, const char name[] )
{
@@ -999,8 +1076,6 @@ name88_find( cbl_name_t name, cbl_field_t *field ) {
static inline bool
is_index( const cbl_field_type_t type ) { return type == FldIndex; }
-extern int yydebug;
-
static size_t
symbols_dump( size_t first, bool header ) {
size_t ninvalid = 0;
@@ -1087,6 +1162,42 @@ symbols_dump( size_t first, bool header ) {
return ninvalid;
}
+static bool
+grow_redefined_group( cbl_field_t *redefined, const cbl_field_t *field ) {
+ assert(redefined);
+ assert(field);
+ assert(redefined == symbol_redefines(field));
+
+ /*
+ * When this function is called, redefined elementary items are
+ * already resized, if eligible.
+ */
+ if( redefined->type != FldGroup ) return false;
+
+ /*
+ * 8) The storage area required for the subject of the entry
+ * shall not be larger than the storage area required for the
+ * data item referenced by data-name-2, unless the data item
+ * referenced by data- name-2 has been specified with level
+ * number 1 and without the EXTERNAL clause.
+ */
+ if( 1 < redefined->level ) {
+ if( field_memsize(redefined) < field_memsize(field) ) {
+ yyerrorv("error: line %d: %s (size %u) larger than REDEFINES %s (size %u)",
+ field->line,
+ field->name, field_memsize(field),
+ redefined->name, field_memsize(redefined));
+ return false;
+ }
+ }
+
+ redefined->data.memsize = std::max(field_memsize(redefined),
+ field_memsize(field));
+
+ return true;
+}
+
+
/*
* Input is a symbol-table element, always a field.
* For elementary fields, return the input.
@@ -1182,6 +1293,7 @@ static struct symbol_elem_t *
e--; // set e to last symbol processed (not next one, because ++e)
}
+#if 0
cbl_field_t *redefined = symbol_redefines(field);
/*
@@ -1191,8 +1303,8 @@ static struct symbol_elem_t *
* referenced by data- name-2 has been specified with level
* number 1 and without the EXTERNAL clause.
*/
- if( redefined && redefined->type == FldGroup && redefined->level > 1 ) {
- if( field->type != FldGroup && redefined->type != FldGroup ) {
+ if( redefined ) {
+ if( redefined->type == FldGroup && redefined->level > 1 ) {
if( field_memsize(redefined) < field_memsize(field) ) {
yyerrorv("error: line %d: %s (size %u) larger than REDEFINES %s (size %u)",
field->line,
@@ -1200,24 +1312,24 @@ static struct symbol_elem_t *
redefined->name, field_memsize(redefined));
}
}
- }
+
+ if( redefined != group) {
+ if( group->our_index != redefined->parent ) {
+ if( yydebug ) yyerrorv("%s:%d: our index %zu != redefined parent %zu",
+ __func__, __LINE__, group->our_index, redefined->parent);
+ continue;
+ }
- if( redefined && redefined != group) {
- if( group->our_index != redefined->parent ) {
- if( yydebug ) yyerrorv("%s:%d: our index %zu != redefined parent %zu",
- __func__, __LINE__, group->our_index, redefined->parent);
+ redefined->data.memsize = std::max(field_memsize(redefined),
+ field_memsize(field));
+ field->data.memsize = 0;
+ if( redefined->data.memsize == redefined->data.capacity ) {
+ redefined->data.memsize = 0;
+ }
continue;
}
-
- redefined->data.memsize = std::max(field_memsize(redefined),
- field_memsize(field));
- field->data.memsize = 0;
- if( redefined->data.memsize == redefined->data.capacity ) {
- redefined->data.memsize = 0;
- }
- continue;
}
-
+#endif
members.push_back(field);
}
@@ -1235,9 +1347,16 @@ static struct symbol_elem_t *
for( auto field : members ) {
cbl_field_t *redefined = symbol_redefines(field);
if( redefined ) {
- assert( group == redefined );
+ if( group != redefined ) {
+ grow_redefined_group(redefined, field);
+ }
max_memsize = std::max(max_memsize, field_memsize(field));
+
field->data.memsize = 0;
+
+ if( redefined->data.memsize == redefined->data.capacity ) {
+ redefined->data.memsize = 0;
+ }
continue;
}
group->data.capacity += field_size(field);
@@ -1253,7 +1372,9 @@ static struct symbol_elem_t *
if( group->data.memsize == group->data.capacity ) group->data.memsize = 0;
if( 0 < group->data.memsize && group->data.memsize < group->data.capacity ) {
- warnx( "%s:%d: small capacity?\n\t%s", __func__, __LINE__, field_str(group) );
+ if( yydebug ) {
+ warnx( "%s:%d: small capacity?\n\t%s", __func__, __LINE__, field_str(group) );
+ }
group->data.memsize = group->data.capacity;
}
@@ -2125,7 +2246,7 @@ symbol_add( struct symbol_elem_t *elem )
symbol_elem_cmp ) );
assert(symbols.nelem > 1);
- if( p->type == SymLabel && p->elem.label.type == LblProgram ) {
+ if( is_program(*p) ) {
assert(p->program == 0 || p->elem.label.os_name != NULL);
p->program = p - symbols.elems;
}
@@ -2779,11 +2900,11 @@ new_temporary_impl( enum cbl_field_type_t type )
struct cbl_field_t *f = new cbl_field_t;
switch(type) {
+ case FldGroup:
case FldAlphanumeric:
*f = empty_alpha;
break;
case FldInvalid:
- case FldGroup:
case FldClass:
case FldForward:
case FldIndex:
@@ -2945,7 +3066,7 @@ symbol_program_programs() {
for( const auto& elem : common_callables ) {
if( elem.first == 0 ) continue;
assert(symbol_at(elem.first)->type == SymLabel);
- assert(cbl_label_of(symbol_at(elem.first))->type == LblProgram);
+ assert(is_program(*symbol_at(elem.first))); // might be a function
programs.insert(elem.first);
}
return programs;
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index 75e29d696acf00dad9f1193f07771536dd9a1fbf..bddd5f3154f573d5a048052b099d37ddcfae9d6e 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -189,18 +189,22 @@ is_numeric( cbl_field_type_t type ) {
case FldClass:
case FldConditional:
case FldForward:
- case FldIndex:
case FldSwitch:
case FldDisplay:
- case FldPointer:
case FldBlob:
return false;
+ // Dubner's definition of is_numeric are variable types that have to be
+ // converted from their COBOL form to a little-endian binary representation
+ // so that they can be conveyed BY CONTENT/BY VALUE in a CALL or
+ // user-defined function activation.
case FldNumericDisplay:
case FldNumericBinary:
case FldFloat:
case FldPacked:
case FldNumericBin5:
case FldLiteralN:
+ case FldPointer:
+ case FldIndex:
return true;
}
warnx( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type );
@@ -553,8 +557,15 @@ struct cbl_field_t {
data.capacity;
}
uint32_t size() const; // table capacity or capacity
+
+ const char * pretty_name() const {
+ if( name[0] == '_' && data.initial ) return data.initial;
+ return name;
+ }
};
+bool valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src );
+
#define record_area_name_stem "_ra_"
static inline bool
@@ -798,6 +809,8 @@ struct cbl_refer_t {
std::copy(subscripts, subscripts + nsubscript, this->subscripts);
}
+ static cbl_refer_t *empty();
+
cbl_refer_t * name( const char name[] ) {
assert(name);
assert(strlen(name) < sizeof(field->name));
@@ -811,7 +824,6 @@ struct cbl_refer_t {
}
bool is_pointer() const { return addr_of || field->type == FldPointer; }
-
bool is_reference() const { return nsubscript > 0 || refmod.is_active(); }
bool is_table_reference() const { return nsubscript > 0; }
bool is_refmod_reference() const { return refmod.is_active(); }
@@ -832,6 +844,21 @@ struct cbl_refer_t {
}
};
+struct cbl_substitute_t {
+ enum subst_fl_t { subst_all_e, subst_first_e = 'F', subst_last_e = 'L'};
+ bool anycase;
+ subst_fl_t first_last;
+ cbl_refer_t orig, replacement;
+
+ cbl_substitute_t( bool anycase = false, char first_last = 0,
+ cbl_refer_t *orig = NULL, cbl_refer_t *replacement = NULL )
+ : anycase(anycase)
+ , first_last(subst_fl_t(first_last))
+ , orig( orig? *orig : cbl_refer_t() )
+ , replacement( replacement? *replacement : cbl_refer_t() )
+ {}
+};
+
static inline const char *
field_name( const cbl_field_t *f ) { return f? f->name : "(void)"; }
@@ -864,7 +891,19 @@ struct cbl_num_result_t {
* CALL
*/
enum cbl_ffi_arg_attr_t { none_of_e, address_of_e, length_of_e };
-enum cbl_ffi_crv_t { by_reference_e, by_content_e, by_value_e };
+enum cbl_ffi_crv_t { by_reference_e = 'R', by_content_e = 'C', by_value_e = 'E' };
+
+static inline const char *
+cbl_ffi_crv_str( cbl_ffi_crv_t crv ) {
+ switch (crv) {
+ case by_reference_e: return "REFERENCE";
+ case by_content_e: return "CONTENT";
+ case by_value_e: return "VALUE";
+ }
+ if( crv == cbl_ffi_crv_t(0) ) return "<none>";
+ return "???";
+}
+
void parser_symbol_add( struct cbl_field_t *new_var );
void parser_local_add( struct cbl_field_t *new_var );
@@ -975,7 +1014,7 @@ struct cbl_label_t {
size_t parent;
int line;
bool common, initial, recursive;
- size_t initial_section;
+ size_t initial_section, returning;
cbl_name_t name;
const char *os_name, *mangled_name;
union
@@ -1074,6 +1113,8 @@ struct label_cmp_lessthan {
size_t field_index( const cbl_field_t *f );
+cbl_field_t * new_temporary_imply( enum cbl_field_type_t type ); // for parser
+
cbl_field_t * new_temporary( enum cbl_field_type_t type );
cbl_field_t * new_literal( const char initial[],
enum cbl_field_attr_t attr = none_e );
@@ -1919,6 +1960,7 @@ struct symbol_elem_t * symbol_field( size_t program,
struct cbl_label_t * symbol_label( size_t program, cbl_label_type_t type,
size_t section, const char name[],
const char os_name[] = NULL );
+struct symbol_elem_t * symbol_function( size_t parent, const char name[] );
struct symbol_elem_t * symbol_literal( size_t program, const char name[] );
struct symbol_elem_t * symbol_literalA( size_t program, const char name[] );
@@ -2046,8 +2088,11 @@ symbol_field_alias2( struct symbol_elem_t *e,
struct symbol_elem_t *
symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src );
-size_t
-symbol_file_same_record_area( std::list<cbl_file_t*>& files );
+size_t symbol_file_same_record_area( std::list<cbl_file_t*>& files );
+
+cbl_field_t *
+symbol_valid_udf_args( size_t function,
+ std::list<cbl_refer_t> args = std::list<cbl_refer_t>() );
bool symbol_currency_add( const char symbol[], const char sign[] = NULL );
const char * symbol_currency( char symbol );
diff --git a/gcc/cobol/symfind.cc b/gcc/cobol/symfind.cc
index 178b92ff9da6c50849a0d499ed1bad436898e906..6c884ff2718c917ec5e27cdf020424f87575be09 100644
--- a/gcc/cobol/symfind.cc
+++ b/gcc/cobol/symfind.cc
@@ -381,7 +381,10 @@ symbol_match2( size_t program,
{
std::vector<size_t> fields;
- for( auto e = symbols_begin(program); e != symbols_end(); e++ ) {
+ auto e = symbols_begin(program);
+ if( is_program(*e) ) e++;
+
+ for( ; e != symbols_end(); e++ ) {
if( e->program != program ) break;
if( e->type != SymField ) continue;
diff --git a/gcc/cobol/tests/c-to-cobol/c_sub.c b/gcc/cobol/tests/c-to-cobol/c_sub.c
index 637c0dab90f3bf5dbaa250384a56b10bb0446b6b..5b2bf906bc50b9fa196f7b9c7ff143a151aa6f01 100644
--- a/gcc/cobol/tests/c-to-cobol/c_sub.c
+++ b/gcc/cobol/tests/c-to-cobol/c_sub.c
@@ -36,3 +36,15 @@ Routine_B()
extern void routine_c();
routine_c();
}
+
+void
+routine_128(__int128 x)
+ {
+ while(x)
+ {
+ int digit = x % 10;
+ x /= 10;
+ printf("%c", digit + '0');
+ }
+ printf("\n");
+ }
\ No newline at end of file
diff --git a/gcc/cobol/tests/c-to-cobol/call_stuff.cbl b/gcc/cobol/tests/c-to-cobol/call_stuff.cbl
index 86dd88cd10c6f1822aca764a27368860a99ce76c..a76c2919a856fbd4e184206b239dc8932e974aef 100644
--- a/gcc/cobol/tests/c-to-cobol/call_stuff.cbl
+++ b/gcc/cobol/tests/c-to-cobol/call_stuff.cbl
@@ -6,14 +6,18 @@ WORKING-STORAGE SECTION.
01 CWD PIC X(100).
01 RETURNED-CWD PIC X(100).
01 LEN_OF_CWD PIC 999 VALUE 100.
-01 USR-LOCAL-BIN PIC X(14) VALUE "/usr/local/bin".
+01 USR-LOCAL-BIN PIC X(15) VALUE "/usr/local/bin".
01 CHDIR_RETURN PIC S999 BINARY.
01 var1 pic x(24) VALUE "I shouldn't change".
01 var2 pic x(24) VALUE "I should change".
+01 var128 pic 9(30) VALUE 987654321098765432109876543210.
+01 var128-2 pic 9(30) .
+
PROCEDURE DIVISION.
+ MOVE X'00' TO USR-LOCAL-BIN(15:1)
CALL "chdir"
USING BY CONTENT USR-LOCAL-BIN
RETURNING CHDIR_RETURN
@@ -78,6 +82,14 @@ PROCEDURE DIVISION.
DISPLAY var1
display var2
+ DISPLAY "pass 128-bit value to a C routine"
+ call "routine_128" USING BY VALUE var128
+
+ *> DISPLAY "pass 128-bit value to a COBOL routine and get it back"
+ *> MOVE ZERO to var128-2
+ *> call "routine_128_cobol" USING BY VALUE var128 RETURNING var128-2
+ *> DISPLAY "var128-2"
+
MOVE ZERO TO RETURN-CODE
GOBACK.
END PROGRAM A.
@@ -142,3 +154,15 @@ move "Good: I changed!" TO par2
goback.
END PROGRAM callee.
+
+*> IDENTIFICATION DIVISION.
+*> PROGRAM-ID. routine_128_cobol.
+*> DATA DIVISION.
+*> LINKAGE SECTION.
+*> 01 var1 pic 9(30) .
+*> 01 var2 pic 9(30) .
+*> PROCEDURE DIVISION USING var1 RETURNING var2.
+ *> DISPLAY " I am COBOL routine_128_cobol".
+ *> DISPLAY var1
+ *> MOVE var1 TO var2
+ *> END PROGRAM routine_128_cobol.
diff --git a/gcc/cobol/tests/c-to-cobol/known-good.txt b/gcc/cobol/tests/c-to-cobol/known-good.txt
index 5860ecfdf0c5dd2681325de6fb26767cb1617643..02a050cba432553758f02a01b6d620a85429d483 100644
--- a/gcc/cobol/tests/c-to-cobol/known-good.txt
+++ b/gcc/cobol/tests/c-to-cobol/known-good.txt
@@ -34,8 +34,10 @@ I should change
after
I shouldn't change
Good: I changed!
+pass 128-bit value to a C routine
The C routine string_to_long got the string "123456" from the caller,
and is returning the 64-bit value 123456
The C code got the long integer 654321 from the caller,
and is returning the string "654321"
I am C routine_b(); I will call COBOL routine_c()
+012345678901234567890123456789
diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc
index bbc3e7824c9d56824e10f4e149eed1800de043c0..7f94c2e8d9ccc425e8f3afc7b20b89443cf51917 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -752,7 +752,7 @@ redefine_field( cbl_field_t *field ) {
}
if( field->data.capacity == 0 ) field->data = primary->data;
-
+
if( is_numeric(field->type) && field->usage == FldDisplay ) {
fOK = symbol_field_type_update(field, FldNumericDisplay, false);
}
diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc
index f216927c654ae41754249dfd649caa563bb6debf..744fce55517d6e301544ca8b28582bb9b28c435e 100644
--- a/libgcobol/intrinsic.cc
+++ b/libgcobol/intrinsic.cc
@@ -42,6 +42,8 @@
#include <math.h>
#include <algorithm>
#include <cctype>
+#include <langinfo.h>
+
#include "libgcobol.h"
#include "intrinsic.h"
@@ -75,93 +77,76 @@ struct cobol_tm
static int is_leap_year(int);
+typedef char * PCHAR;
-#if 0
-static
-double
-iYMD_to_JD(int Y, int M, int D)
+static void
+trim_trailing_spaces(PCHAR left, PCHAR &right)
+ {
+ while( right > left )
{
- // Calculates the Julian Day in an integer-ish way. The classic formula
- // in fYMD_to_JD is inefficient because of the floating point operations:
-
- int JD = 2305813; // This is Jan 0, 1601
-
- int extra_day = is_leap_year(Y) - 365;
-
- int modified_year = Y-1601; // Cycle starts are years N*400 plus 1. That
- // puts 0x00 non-leap years at the end of
- // centuries, and the years divisible by 400 at
- // the end of cycles.
- int cycle = modified_year / 400;
- int year_of_cycle = modified_year % 400;
- int century_of_cycle = year_of_cycle / 100;
- int year_of_century = year_of_cycle % 100;
- int leap_cycle = year_of_century / 4;
- int year_in_leap_cycle = year_of_century % 4;
-
- JD += cycle * 146097; // This is Jan 0 of the first year of the cycle
- JD += century_of_cycle * 36524; // This is Jan 0 of the first year of the
- // century
- JD += leap_cycle * 1461; // Jan 0 of the year xx01 for our year
- JD += year_in_leap_cycle * 365;
-
- // This is the table of day numbers for day zero of each month:
- static const int month_start_days[13] = {-1,0,31,59,90,120,151,181,212,243,273,304,334};
- JD += month_start_days[M];
- if(M > 2)
+ if( *(right-1) != internal_space )
{
- JD += extra_day;
+ break;
}
- JD += D;
+ right -= 1;
+ }
+ }
- return (double)JD - 0.5;
+static bool
+is_zulu_format(PCHAR left, PCHAR &right)
+ {
+ bool retval = false;
+ if( right > left )
+ {
+ retval = toupper(*(right-1)) == internal_Z;
}
-#endif
+ return retval;
+ }
static double
YMD_to_JD(int Y, int M, int D)
- {
- // Calculates the Julian Day
+ {
+ // Calculates the Julian Day
- if( M <= 2 )
- {
- Y -= 1 ;
- M += 12;
- }
- double A = floor(Y/100.);
- double B = 2. - A + floor(A/4.);
+ if( M <= 2 )
+ {
+ Y -= 1 ;
+ M += 12;
+ }
+ double A = floor(Y/100.);
+ double B = 2. - A + floor(A/4.);
- double JD;
- JD = floor(365.25 * double(Y + 4716) + floor((30.6001 * double(M+1)))) + D + B -1524.5 ;
+ double JD;
+ JD = floor(365.25 * double(Y + 4716) + floor((30.6001 * double(M+1)))) + D + B -1524.5 ;
- return JD;
- }
+ return JD;
+ }
static void
JD_to_YMD(int &YY, int &MM, int &DD, double JD)
+ {
+ JD += 0.5;
+ double Z = floor(JD);
+ double F = JD - Z;
+ double A;
+ if( Z < 2299161.0 )
{
- JD += 0.5;
- double Z = floor(JD);
- double F = JD - Z;
- double A;
- if( Z < 2299161.0 )
- {
- A = Z;
- }
- else
- {
- double alpha = floor( (Z-1867216.25) / 36524.25 ) ;
- A = Z + 1.0 + alpha - floor(alpha/4.0);
- }
- double B = A + 1524;
- double C = floor( (B - 122.1)/365.25 );
- double D = floor( 365.25 * C );
- double E = floor( (B-D)/30.6001 );
-
- DD = (int)( B - D - floor(30.6001 * E) + F );
- MM = (int)( E < 14 ? E - 1 : E - 13 );
- YY = (int)( MM > 2 ? C - 4716 : C - 4715 );
+ A = Z;
}
+ else
+ {
+ double alpha = floor( (Z-1867216.25) / 36524.25 ) ;
+ A = Z + 1.0 + alpha - floor(alpha/4.0);
+ }
+ double B = A + 1524;
+ double C = floor( (B - 122.1)/365.25 );
+ double D = floor( 365.25 * C );
+ double E = floor( (B-D)/30.6001 );
+
+ DD = (int)( B - D - floor(30.6001 * E) + F );
+ MM = (int)( E < 14 ? E - 1 : E - 13 );
+ YY = (int)( MM > 2 ? C - 4716 : C - 4715 );
+ }
static int
JD_to_DOW(double JD)
@@ -177,52 +162,52 @@ JD_to_DOW(double JD)
static
char *
timespec_to_string(char *retval, struct timespec &tp)
- {
- /*
- Returns a 21-character string:
-
- 1 - 4 Four numeric digits of the year in the Gregorian calendar
- 5 - 6 Two numeric digits of the month of the year, in the range 01 through 12
- 7 - 8 Two numeric digits of the day of the month, in the range 01 through 31
- 9 - 10 Two numeric digits of the hours past midnight, in the range 00 through 23
- 11 - 12 Two numeric digits of the minutes past the hour, in the range 00 through 59
- 13 - 14 Two numeric digits of the seconds past the minute, in the range 00 through 59
- 15 - 16 Two numeric digits of the hundredths of a second past the second, in the range
- 17 Either the character '-' or the character '+'.
- 18 - 19 If character position 17 is '-', two numeric digits are returned in the range 00
- through 12 indicating the number of hours that the reported time is behind
- Greenwich mean time.
-
- If character position 17 is '+', two numeric digits are
- returned in the range 00 through 13 indicating the number of hours that the
- reported time is ahead of Greenwich mean time. If character position 17 is '0', the
- value 00 is returned.
- 20 - 21 Two numeric digits are returned in the range 00 through 59 indicating the number
- of additional minutes that the reported time is ahead of or behind Greenwich
- mean time, depending on whether character position 17
- */
-
- const int size_of_buffer = DATE_STRING_BUFFER_SIZE;
- const int offset_to_hundredths = 14;
- const long nanoseconds_to_hundredths = 10000000;
-
- // Convert the nanosecond fraction to hundredths of a second:
- char achCentiseconds[3];
- snprintf(achCentiseconds, 3, "%2.2ld", (tp.tv_nsec/nanoseconds_to_hundredths) );
-
- // Convert the epoch seconds to broken-down time:
- struct tm tm = {};
- localtime_r(&tp.tv_sec, &tm);
+ {
+ /*
+ Returns a 21-character string:
+
+ 1 - 4 Four numeric digits of the year in the Gregorian calendar
+ 5 - 6 Two numeric digits of the month of the year, in the range 01 through 12
+ 7 - 8 Two numeric digits of the day of the month, in the range 01 through 31
+ 9 - 10 Two numeric digits of the hours past midnight, in the range 00 through 23
+ 11 - 12 Two numeric digits of the minutes past the hour, in the range 00 through 59
+ 13 - 14 Two numeric digits of the seconds past the minute, in the range 00 through 59
+ 15 - 16 Two numeric digits of the hundredths of a second past the second, in the range
+ 17 Either the character '-' or the character '+'.
+ 18 - 19 If character position 17 is '-', two numeric digits are returned in the range 00
+ through 12 indicating the number of hours that the reported time is behind
+ Greenwich mean time.
+
+ If character position 17 is '+', two numeric digits are
+ returned in the range 00 through 13 indicating the number of hours that the
+ reported time is ahead of Greenwich mean time. If character position 17 is '0', the
+ value 00 is returned.
+ 20 - 21 Two numeric digits are returned in the range 00 through 59 indicating the number
+ of additional minutes that the reported time is ahead of or behind Greenwich
+ mean time, depending on whether character position 17
+ */
+
+ const int size_of_buffer = DATE_STRING_BUFFER_SIZE;
+ const int offset_to_hundredths = 14;
+ const long nanoseconds_to_hundredths = 10000000;
+
+ // Convert the nanosecond fraction to hundredths of a second:
+ char achCentiseconds[3];
+ snprintf(achCentiseconds, 3, "%2.2ld", (tp.tv_nsec/nanoseconds_to_hundredths) );
+
+ // Convert the epoch seconds to broken-down time:
+ struct tm tm = {};
+ localtime_r(&tp.tv_sec, &tm);
- // Format the time as per COBOL specifications, leaving two spaces for the
- // hundredths of seconds:
- strftime(retval, size_of_buffer, "%Y%m%d%H%M%S %z", &tm);
+ // Format the time as per COBOL specifications, leaving two spaces for the
+ // hundredths of seconds:
+ strftime(retval, size_of_buffer, "%Y%m%d%H%M%S %z", &tm);
- // Copy the 100ths into place:
- memcpy(retval+offset_to_hundredths, achCentiseconds, 2);
+ // Copy the 100ths into place:
+ memcpy(retval+offset_to_hundredths, achCentiseconds, 2);
- return retval;
- }
+ return retval;
+ }
static
void
@@ -236,133 +221,133 @@ string_to_dest(cblc_field_t *dest, const char *psz)
}
struct input_state
- {
- size_t nsubscript;
- bool *subscript_alls;
- size_t *subscripts;
- size_t *subscript_limits;
- bool done;
+ {
+ size_t nsubscript;
+ bool *subscript_alls;
+ size_t *subscripts;
+ size_t *subscript_limits;
+ bool done;
- void allocate(size_t N)
- {
- nsubscript = N;
- if(N)
- {
- subscript_alls = (bool *) MALLOC(nsubscript);
- subscripts = (size_t *)MALLOC(nsubscript);
- subscript_limits = (size_t *)MALLOC(nsubscript);
- }
- done = false;
- }
- void deallocate()
- {
- if(nsubscript)
- {
- FREE(subscript_alls);
- FREE(subscripts);
- FREE(subscript_limits);
- }
- }
- };
+ void allocate(size_t N)
+ {
+ nsubscript = N;
+ if(N)
+ {
+ subscript_alls = (bool *) MALLOC(nsubscript);
+ subscripts = (size_t *)MALLOC(nsubscript);
+ subscript_limits = (size_t *)MALLOC(nsubscript);
+ }
+ done = false;
+ }
+ void deallocate()
+ {
+ if(nsubscript)
+ {
+ FREE(subscript_alls);
+ FREE(subscripts);
+ FREE(subscript_limits);
+ }
+ }
+ };
struct refer_state_for_all
- {
- size_t nflags;
- size_t coefficients [MAXIMUM_TABLE_DIMENSIONS];
- size_t capacities [MAXIMUM_TABLE_DIMENSIONS];
- size_t limits [MAXIMUM_TABLE_DIMENSIONS];
- };
+ {
+ size_t nflags;
+ size_t coefficients [MAXIMUM_TABLE_DIMENSIONS];
+ size_t capacities [MAXIMUM_TABLE_DIMENSIONS];
+ size_t limits [MAXIMUM_TABLE_DIMENSIONS];
+ };
static
void
build_refer_state_for_all( refer_state_for_all &state,
cblc_refer_t *refer)
+ {
+ memset(&state, 0, sizeof(refer_state_for_all) );
+ if( refer->all_flags )
{
- memset(&state, 0, sizeof(refer_state_for_all) );
- if( refer->all_flags )
+ // At this point, refer points to the very first element of
+ // an array specification that includes at least one ALL subscript. At
+ // this time, those ALLs were calculated as if they had been replaced
+ // with one.
+
+ // We are going to walk the reference up to its ultimate parent, picking
+ // up what we need along the way.
+
+ size_t current_bit = 1;
+ size_t current_index = 0;
+ cblc_field_t *current_sizer = refer->field;
+ while( current_sizer )
+ {
+ while( current_sizer && !current_sizer->occurs_upper )
{
- // At this point, refer points to the very first element of
- // an array specification that includes at least one ALL subscript. At
- // this time, those ALLs were calculated as if they had been replaced
- // with one.
+ // current_sizer isn't a table, which isn't unusual.
+ current_sizer = current_sizer->parent;
+ }
- // We are going to walk the reference up to its ultimate parent, picking
- // up what we need along the way.
+ if( !current_sizer )
+ {
+ // We have found all of the elements in this data description
+ // that have OCCURS clauses
+ break;
+ }
- size_t current_bit = 1;
- size_t current_index = 0;
- cblc_field_t *current_sizer = refer->field;
- while( current_sizer )
- {
- while( current_sizer && !current_sizer->occurs_upper )
- {
- // current_sizer isn't a table, which isn't unusual.
- current_sizer = current_sizer->parent;
- }
-
- if( !current_sizer )
- {
- // We have found all of the elements in this data description
- // that have OCCURS clauses
- break;
- }
-
- // We are sitting on an occurs clause:
-
- if( current_bit & refer->all_flags )
- {
- // It is an ALL subscript:
- state.nflags += 1;
- state.coefficients[current_index] = 1;
- state.capacities[current_index] = current_sizer->capacity;
- state.limits[current_index] = current_sizer->occurs_upper;
- if( current_sizer->depending_on )
- {
- int rdigits;
- state.limits[current_index]
- = (size_t)__gg__binary_value_from_field(&rdigits,
- current_sizer->depending_on);
- }
- current_index += 1 ;
- }
-
- current_bit <<= 1;
- current_sizer = current_sizer->parent;
- }
+ // We are sitting on an occurs clause:
+
+ if( current_bit & refer->all_flags )
+ {
+ // It is an ALL subscript:
+ state.nflags += 1;
+ state.coefficients[current_index] = 1;
+ state.capacities[current_index] = current_sizer->capacity;
+ state.limits[current_index] = current_sizer->occurs_upper;
+ if( current_sizer->depending_on )
+ {
+ int rdigits;
+ state.limits[current_index]
+ = (size_t)__gg__binary_value_from_field(&rdigits,
+ current_sizer->depending_on);
+ }
+ current_index += 1 ;
}
+
+ current_bit <<= 1;
+ current_sizer = current_sizer->parent;
+ }
}
+ }
static
bool
update_refer_state_for_all( refer_state_for_all &state,
cblc_refer_t *refer)
- {
- bool retval = false; // Means there is nothing left
-
- for(size_t i=0; i<state.nflags; i++)
- {
- state.coefficients[i] += 1;
- refer->qual_data += state.capacities[i];
- if( state.coefficients[i] <= state.limits[i] )
- {
- // This coefficient is within range:
- retval = true;
- break;
- }
+ {
+ bool retval = false; // Means there is nothing left
- // We have used up this coefficient.
+ for(size_t i=0; i<state.nflags; i++)
+ {
+ state.coefficients[i] += 1;
+ refer->qual_data += state.capacities[i];
+ if( state.coefficients[i] <= state.limits[i] )
+ {
+ // This coefficient is within range:
+ retval = true;
+ break;
+ }
- // Remove the effects of incrementing this coefficient:
- refer->qual_data -= state.limits[i] * state.capacities[i];
- // Reset the coefficient back to one:
- state.coefficients[i] = 1;
+ // We have used up this coefficient.
- // And continue on to the next coefficient.
- }
+ // Remove the effects of incrementing this coefficient:
+ refer->qual_data -= state.limits[i] * state.capacities[i];
+ // Reset the coefficient back to one:
+ state.coefficients[i] = 1;
- return retval;
+ // And continue on to the next coefficient.
}
+ return retval;
+ }
+
static
int
year_to_yyyy(int arg1, int arg2, int arg3)
@@ -399,9 +384,9 @@ get_value_as_double_from_refer(cblc_refer_t *input)
default:
retval = __gg__binary_value_from_refer(&rdigits, input);
for(int i=0; i<rdigits; i++)
- {
- retval /= 10.0;
- }
+ {
+ retval /= 10.0;
+ }
break;
}
@@ -479,7 +464,7 @@ variance(size_t ncount, cblc_refer_t *source)
refer_state_for_all state;
cblc_refer_t *next_input = &source[i];
build_refer_state_for_all(state, next_input);
-
+
for(;;)
{
newValue = __gg__float128_from_refer(next_input);
@@ -515,7 +500,7 @@ get_all_time( char *stime,
// 1111111111222222222233333333334
// 01234567890123456789012345678901234567890
// Returns YYYYMMDDThhmmss.sssssssss+hhmmWwwdDDDZZZZ
- //
+ //
// YYYY is the year
// MM is the month
// DD is the day of the month
@@ -538,13 +523,17 @@ get_all_time( char *stime,
"W%2.2u" // Www
"%1u" // DOW [1-7], 1 for Monday
"%3.3u" // DDD day of year, 001 - 365,366
- "%4.4u", // ZZZZ Year for YYYY-Www-D
- ctm.YYYY, ctm.MM, ctm.DD,
- ctm.hh, ctm.mm, ctm.ss,
+ "%4.4u", // ZZZZ Year for YYYY-Www-D
+ ctm.YYYY,
+ ctm.MM,
+ ctm.DD,
+ ctm.hh,
+ ctm.mm,
+ ctm.ss,
ctm.nanoseconds,
- ctm.tz_offset < 0 ? '-' : '+' ,
- abs(ctm.tz_offset) / 60 ,
- abs(ctm.tz_offset) % 60 ,
+ ctm.tz_offset < 0 ? '-' : '+',
+ abs(ctm.tz_offset) / 60,
+ abs(ctm.tz_offset) % 60,
ctm.week_of_year,
ctm.day_of_week+1,
ctm.day_of_year,
@@ -553,53 +542,6 @@ get_all_time( char *stime,
ascii_to_internal_str(stime, strlen(stime));
}
-#if 0
-static
-int
-is_leap_yearx(int yyyy)
- {
- int days_in_year;
- if( !(yyyy%4) && ((yyyy%100) || !(yyyy%400)) )
- {
- days_in_year = 366;
- }
- else
- {
- days_in_year = 365;
- }
-
-#if 0
- static bool once = true;
- if( once )
- {
- once = false;
-
- int ncount = 0;
- unsigned char i;
- for(int y = 1600; y<2000; y++)
- {
- i >>= 1;
- if( is_leap_yearx(y) == 366 )
- {
- i |= 0x80;
- }
- ncount += 1;
- if((ncount & 7) == 0)
- {
- fprintf(stderr, "0x%2.2x, ", i);
- if( ((ncount>>3) % 10 ) == 0 )
- {
- fprintf(stderr, "\n");
- }
- }
- }
- exit(1);
- }
-#endif
- return days_in_year;
- }
-#endif
-
static
int
is_leap_year(int yyyy)
@@ -612,14 +554,14 @@ is_leap_year(int yyyy)
0x11, 0x11, 0x11, 0x11, 0x11, 0x11, 0x11, 0x01, 0x11, 0x11,
0x11, 0x11, 0x11, 0x11, 0x11, 0x11, 0x11, 0x11, 0x11, 0x11,
};
-
- static const unsigned char mask[8] =
+
+ static const unsigned char mask[8] =
{ 1, 2, 4, 8, 0x10, 0x20, 0x40, 0x80 };
int days_in_year;
int year_in_cycle = yyyy % 400;
-
+
if( leap_year_bits[year_in_cycle/8] & mask[year_in_cycle & 0x07] )
{
days_in_year = 366;
@@ -667,7 +609,7 @@ populate_ctm_from_tm(struct cobol_tm &ctm, const struct tm &tm)
double JD_Jan4 = YMD_to_JD(ctm.YYYY, 1, 4);
ctm.day_of_year = (int)(JD - (JD_Jan4-4));
-
+
int dow_Jan4 = JD_to_DOW(JD_Jan4);
double adjusted_starting_date = JD_Jan4 - dow_Jan4;
@@ -695,12 +637,8 @@ populate_ctm_from_tm(struct cobol_tm &ctm, const struct tm &tm)
static
void
-populate_ctm_from_date( struct cobol_tm &ctm, cblc_refer_t *pdate )
+populate_ctm_from_JD(struct cobol_tm &ctm, double JD )
{
- // Get the date as an integer
- int rdigits;
- double JD = (double)__gg__binary_value_from_refer(&rdigits, pdate);
-
// Extract the year, month, and day
int Y;
int M;
@@ -717,12 +655,18 @@ populate_ctm_from_date( struct cobol_tm &ctm, cblc_refer_t *pdate )
static
void
-populate_ctm_from_time( struct cobol_tm &ctm,
- cblc_refer_t *ptime,
- cblc_refer_t *poffset )
+populate_ctm_from_date( struct cobol_tm &ctm, cblc_refer_t *pdate )
{
- double time = get_value_as_double_from_refer(ptime);
+ // Get the date as an integer
+ int rdigits;
+ double JD = (double)__gg__binary_value_from_refer(&rdigits, pdate);
+ populate_ctm_from_JD(ctm, JD);
+ }
+static
+void
+populate_ctm_from_double_time(struct cobol_tm &ctm, double time)
+ {
// Get hours, minutes, and seconds
double intpart;
double fracpart = modf(time, &intpart);
@@ -735,7 +679,17 @@ populate_ctm_from_time( struct cobol_tm &ctm,
ctm.mm = minute;
ctm.hh = hour;
ctm.nanoseconds = (int)(fracpart * 1000000000 + 0.5);
-
+ }
+
+static
+void
+populate_ctm_from_time( struct cobol_tm &ctm,
+ cblc_refer_t *ptime,
+ cblc_refer_t *poffset )
+ {
+ double time = get_value_as_double_from_refer(ptime);
+ populate_ctm_from_double_time(ctm, time);
+
if( poffset )
{
int rdigits;
@@ -746,6 +700,46 @@ populate_ctm_from_time( struct cobol_tm &ctm,
rdigits = 0;
}
ctm.tz_offset = value;
+ if( abs(value) >= 1440 )
+ {
+ exception_raise(ec_argument_function_e);
+ }
+ }
+ else
+ {
+ ctm.tz_offset = 0;
+ }
+ }
+
+static void
+convert_to_zulu(cobol_tm &ctm)
+ {
+ // Get the Julian Day
+ double JD = YMD_to_JD(ctm.YYYY,
+ ctm.MM,
+ ctm.DD);
+ // Get the time in seconds past midnight
+ double seconds_past_midnight = ctm.hh * 3600
+ + ctm.mm * 60
+ + ctm.ss;
+ // Subtract the UTC offset, which is given in minutes
+ seconds_past_midnight -= ctm.tz_offset * 60;
+ if( seconds_past_midnight < 0 )
+ {
+ JD -= 1;
+ seconds_past_midnight += 86400;
+ }
+ else if( seconds_past_midnight >= 86400 )
+ {
+ JD += 1;
+ seconds_past_midnight -= 86400;
+ }
+ JD -= JD_OF_1601_01_02;
+ populate_ctm_from_JD(ctm, JD);
+ populate_ctm_from_double_time(ctm, seconds_past_midnight);
+ if( ctm.YYYY < 1601 )
+ {
+ ctm.YYYY = ctm.MM = ctm.DD = 0;
}
}
@@ -949,9 +943,9 @@ __gg__acos(cblc_field_t *dest, cblc_refer_t *source)
}
__gg__float128_to_field( dest,
- value,
- truncation_e,
- NULL);
+ value,
+ truncation_e,
+ NULL);
}
extern "C"
@@ -976,7 +970,7 @@ __gg__annuity(cblc_field_t *dest, cblc_refer_t *arg1, cblc_refer_t *arg2)
}
else
{
- retval = val1 / (1- powf128( (1+val1) , -val2 ));
+ retval = val1 / (1- powf128( (1+val1), -val2 ));
}
}
else
@@ -1009,9 +1003,9 @@ __gg__asin(cblc_field_t *dest, cblc_refer_t *source)
}
__gg__float128_to_field( dest,
- value,
- truncation_e,
- NULL);
+ value,
+ truncation_e,
+ NULL);
}
extern "C"
@@ -1025,9 +1019,9 @@ __gg__atan(cblc_field_t *dest, cblc_refer_t *source)
value = atanf128(value);
__gg__float128_to_field( dest,
- value,
- truncation_e,
- NULL);
+ value,
+ truncation_e,
+ NULL);
}
extern "C"
@@ -1046,50 +1040,62 @@ __gg__byte_length(cblc_field_t *dest, cblc_refer_t *source)
extern "C"
void
__gg__char(cblc_field_t *dest, cblc_refer_t *source )
- {
- int rdigits;
+ {
+ int rdigits;
- // The CHAR function takes an integer, the ordinal position. It
- // returns a single-character string, which is the character at that
- // ordinal position.
+ // The CHAR function takes an integer, the ordinal position. It
+ // returns a single-character string, which is the character at that
+ // ordinal position.
- // 'A', with the ascii value of 65, is at the ordinal position 66.
+ // 'A', with the ascii value of 65, is at the ordinal position 66.
- int ordinal = (int)(__gg__binary_value_from_refer( &rdigits,
- source));
- ordinal /= __gg__power_of_ten(rdigits);
- int ch = ordinal-1;
- memset(dest->data, internal_space, dest->capacity);
- dest->data[0] = ch;
- }
+ int ordinal = (int)(__gg__binary_value_from_refer( &rdigits,
+ source));
+ ordinal /= __gg__power_of_ten(rdigits);
+ int ch = ordinal-1;
+ memset(dest->data, internal_space, dest->capacity);
+ dest->data[0] = ch;
+ }
extern "C"
void
__gg__combined_datetime(cblc_field_t *dest, cblc_refer_t *arg1, cblc_refer_t *arg2)
- {
- int rdigits;
+ {
+ int rdigits;
- __int128 val1 = (int)(__gg__binary_value_from_refer(&rdigits,
- arg1));
- __int128 val2 = (int)(__gg__binary_value_from_refer(&rdigits,
- arg2));
- __int128 value = val1 * 1000000 + val2;
+ __int128 val1 = (int)(__gg__binary_value_from_refer(&rdigits,
+ arg1));
+ __int128 val2 = (int)(__gg__binary_value_from_refer(&rdigits,
+ arg2));
+ __int128 value = val1 * 1000000 + val2;
__gg__int128_to_field(dest,
value,
6,
truncation_e,
NULL);
- }
+ }
extern "C"
void
-__gg__concat(cblc_field_t *dest, size_t ncount, cblc_refer_t inputs[] )
-{
- warnx("%s: not implemented", __func__);
-}
+__gg__concat(cblc_field_t *dest, size_t ncount, cblc_refer_t inputs[])
+ {
+ size_t bytes = 0;
+ size_t offset = 0;
+ for(size_t i=0; i<ncount; i++)
+ {
+ bytes += inputs[i].qual_size;
+ }
+ __gg__adjust_dest_size(dest, bytes);
+ for(size_t i=0; i<ncount; i++)
+ {
+ memcpy( dest->data + offset,
+ inputs[i].qual_data,
+ inputs[i].qual_size);
+ offset += inputs[i].qual_size;
+ }
+ }
-
extern "C"
void
__gg__cos(cblc_field_t *dest, cblc_refer_t *source)
@@ -1109,36 +1115,36 @@ __gg__cos(cblc_field_t *dest, cblc_refer_t *source)
extern "C"
void
__gg__current_date(cblc_field_t *dest)
- {
- // FUNCTION CURRENT-DATE
- struct timespec tp = {};
- __gg__clock_gettime(CLOCK_REALTIME, &tp); // time_t tv_sec; long tv_nsec
-
- char retval[DATE_STRING_BUFFER_SIZE];
- timespec_to_string(retval, tp);
- ascii_to_internal_str(retval, strlen(retval));
- string_to_dest(dest, retval);
- }
+ {
+ // FUNCTION CURRENT-DATE
+ struct timespec tp = {};
+ __gg__clock_gettime(CLOCK_REALTIME, &tp); // time_t tv_sec; long tv_nsec
+
+ char retval[DATE_STRING_BUFFER_SIZE];
+ timespec_to_string(retval, tp);
+ ascii_to_internal_str(retval, strlen(retval));
+ string_to_dest(dest, retval);
+ }
extern "C"
void
__gg__date_of_integer(cblc_field_t *dest, cblc_refer_t *source)
- {
- // FUNCTION DATE-OF-INTEGER
- int rdigits;
- double JD = (double)__gg__binary_value_from_refer(&rdigits, source);
- JD += JD_OF_1601_01_02;
- int Y;
- int M;
- int D;
- JD_to_YMD(Y, M, D, JD);
- int retval = Y*10000 + M*100 + D;
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
- }
+ {
+ // FUNCTION DATE-OF-INTEGER
+ int rdigits;
+ double JD = (double)__gg__binary_value_from_refer(&rdigits, source);
+ JD += JD_OF_1601_01_02;
+ int Y;
+ int M;
+ int D;
+ JD_to_YMD(Y, M, D, JD);
+ int retval = Y*10000 + M*100 + D;
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
extern "C"
void
@@ -1159,44 +1165,44 @@ __gg__date_to_yyyymmdd( cblc_field_t *dest,
int retval = year_to_yyyy(yy, arg2, arg3) * 10000 + mmdd;
__gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
}
extern "C"
void
__gg__day_of_integer(cblc_field_t *dest, cblc_refer_t *source)
- {
- // FUNCTION DAY-OF_INTEGER
- int rdigits;
- double JD = (double)__gg__binary_value_from_refer(&rdigits, source);
- JD += JD_OF_1601_01_02;
- int Y;
- int M;
- int D;
- JD_to_YMD(Y, M, D, JD);
-
- double start_of_year = YMD_to_JD(Y, 1, 1);
-
- __int128 retval = Y * 1000 + int(JD - start_of_year) + 1;
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
- }
-
-extern "C"
-void
-__gg__day_to_yyyyddd( cblc_field_t *dest,
- cblc_refer_t *par1,
- cblc_refer_t *par2,
- cblc_refer_t *par3)
{
- // FUNCTION DAY-TO-YYYYDDD
- // See the discussion in ISO/IEC 2014-1989 Section 15.20
+ // FUNCTION DAY-OF_INTEGER
+ int rdigits;
+ double JD = (double)__gg__binary_value_from_refer(&rdigits, source);
+ JD += JD_OF_1601_01_02;
+ int Y;
+ int M;
+ int D;
+ JD_to_YMD(Y, M, D, JD);
+
+ double start_of_year = YMD_to_JD(Y, 1, 1);
+
+ __int128 retval = Y * 1000 + int(JD - start_of_year) + 1;
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
+
+extern "C"
+void
+__gg__day_to_yyyyddd( cblc_field_t *dest,
+ cblc_refer_t *par1,
+ cblc_refer_t *par2,
+ cblc_refer_t *par3)
+ {
+ // FUNCTION DAY-TO-YYYYDDD
+ // See the discussion in ISO/IEC 2014-1989 Section 15.20
int rdigits;
int arg1 = (int)__gg__binary_value_from_refer(&rdigits, par1);
int arg2 = (int)__gg__binary_value_from_refer(&rdigits, par2);
@@ -1261,34 +1267,34 @@ __gg__exp10(cblc_field_t *dest, cblc_refer_t *source)
extern "C"
void
__gg__factorial(cblc_field_t *dest, cblc_refer_t *source)
+ {
+ // FUNCTION FACTORIAL
+ int rdigits;
+ int N = (int)__gg__binary_value_from_refer(&rdigits, source);
+ while(rdigits--)
{
- // FUNCTION FACTORIAL
- int rdigits;
- int N = (int)__gg__binary_value_from_refer(&rdigits, source);
- while(rdigits--)
- {
- N /= 10;
- }
+ N /= 10;
+ }
- __int128 retval = 1;
+ __int128 retval = 1;
- while( N > 1 )
- {
- retval *= N--;
- }
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ while( N > 1 )
+ {
+ retval *= N--;
}
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
extern "C"
void
__gg__formatted_current_date( cblc_field_t *dest, // Destination string
cblc_refer_t *input) // datetime format
{
- // FUNCTION FORMATTED-DATETIME
+ // FUNCTION CURRENT-DATE
// Establish the destination, and set it to spaces
char *d = (char *)dest->data;
@@ -1362,7 +1368,14 @@ __gg__formatted_date( cblc_field_t *dest, // Destination string
char achftime[64];
get_all_time(achftime, ctm);
- ftime_replace(d, dend, format, format_end, achftime);
+ if( __gg__exception_code )
+ {
+ memset(d, internal_space, dend-d);
+ }
+ else
+ {
+ ftime_replace(d, dend, format, format_end, achftime);
+ }
}
extern "C"
@@ -1374,7 +1387,7 @@ __gg__formatted_datetime( cblc_field_t *dest, // Destination string
cblc_refer_t *par4) // optional offset in seconds
{
// FUNCTION FORMATTED-DATETIME
-
+
// Establish the destination, and set it to spaces
char *d = (char *)dest->data;
char *dend = d + dest->capacity;
@@ -1383,15 +1396,29 @@ __gg__formatted_datetime( cblc_field_t *dest, // Destination string
// Establish the formatting string:
char *format = (char *)par1->qual_data;
char *format_end = format + par1->qual_size;
+ trim_trailing_spaces(format, format_end);
+ bool is_zulu = is_zulu_format(format, format_end);
struct cobol_tm ctm = {};
populate_ctm_from_date(ctm, par2);
populate_ctm_from_time(ctm, par3, par4);
+ if( is_zulu )
+ {
+ convert_to_zulu(ctm);
+ }
+
char achftime[64];
get_all_time(achftime, ctm);
- ftime_replace(d, dend, format, format_end, achftime);
+ if( __gg__exception_code )
+ {
+ memset(d, internal_space, dend-d);
+ }
+ else
+ {
+ ftime_replace(d, dend, format, format_end, achftime);
+ }
}
extern "C"
@@ -1411,13 +1438,27 @@ __gg__formatted_time( cblc_field_t *dest, // Destination string
// Establish the formatting string:
char *format = (char *)par1->qual_data;
char *format_end = format + par1->qual_size;
+ trim_trailing_spaces(format, format_end);
+ bool is_zulu = is_zulu_format(format, format_end);
struct cobol_tm ctm = {};
populate_ctm_from_time(ctm, par3, par4);
+ if( is_zulu )
+ {
+ convert_to_zulu(ctm);
+ }
+
char achftime[64];
get_all_time(achftime, ctm);
- ftime_replace(d, dend, format, format_end, achftime);
+ if( __gg__exception_code )
+ {
+ memset(d, internal_space, dend-d);
+ }
+ else
+ {
+ ftime_replace(d, dend, format, format_end, achftime);
+ }
}
extern "C"
@@ -1437,50 +1478,50 @@ __gg__integer(cblc_field_t *dest, cblc_refer_t *source)
extern "C"
void
__gg__integer_of_date(cblc_field_t *dest, cblc_refer_t *source)
- {
- // FUNCTION INTEGER-OF-DATE
- int rdigits;
- long argument_1 = (long)(__gg__binary_value_from_refer(&rdigits, source));
+ {
+ // FUNCTION INTEGER-OF-DATE
+ int rdigits;
+ long argument_1 = (long)(__gg__binary_value_from_refer(&rdigits, source));
- int retval = 0;
- static const int max_days[13] = {0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31};
+ int retval = 0;
+ static const int max_days[13] = {0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31};
- int year = (long)argument_1/10000;
- int month = (long)argument_1/100 % 100;
- int day = (long)argument_1 % 100;
+ int year = (long)argument_1/10000;
+ int month = (long)argument_1/100 % 100;
+ int day = (long)argument_1 % 100;
- // We need to check for validity in the proleptic Gregorian calendar.
+ // We need to check for validity in the proleptic Gregorian calendar.
- int max_day = 0;
- if( month >= 1 && month <= 12 )
- {
- max_day = max_days[month];
- }
- if( max_day == 28 && (((year%4) == 0 && ((year)%100) != 0) || ((year%400) == 0) ))
- {
- // Year is divisible by four, but is not divisible by 100, so this
- // is a leap year.
- max_day += 1;
- }
- if( day < 1 || day > max_day )
- {
- max_day = 0;
- }
- if( max_day && year >= 1601 && year <= 9999 )
- {
- // It's a valid Y/M/D:
- double JD = YMD_to_JD(year, month, day);
+ int max_day = 0;
+ if( month >= 1 && month <= 12 )
+ {
+ max_day = max_days[month];
+ }
+ if( max_day == 28 && (((year%4) == 0 && ((year)%100) != 0) || ((year%400) == 0) ))
+ {
+ // Year is divisible by four, but is not divisible by 100, so this
+ // is a leap year.
+ max_day += 1;
+ }
+ if( day < 1 || day > max_day )
+ {
+ max_day = 0;
+ }
+ if( max_day && year >= 1601 && year <= 9999 )
+ {
+ // It's a valid Y/M/D:
+ double JD = YMD_to_JD(year, month, day);
- // Offset result so that 1601-01-01 comes back as the first day of
- // the Gregorian Calendar
- retval = (int)(JD - JD_OF_1601_01_02);
- }
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ // Offset result so that 1601-01-01 comes back as the first day of
+ // the Gregorian Calendar
+ retval = (int)(JD - JD_OF_1601_01_02);
}
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
extern "C"
void
@@ -1511,10 +1552,32 @@ __gg__integer_part(cblc_field_t *dest, cblc_refer_t *source)
_Float128 value = __gg__float128_from_refer(source);
_Float128 retval = floorf128(fabsf128(value));
- char ach[64];
- strfromf128(ach, sizeof(ach), "%f", value);
+ if( value < 0 )
+ {
+ retval = -retval;
+ }
+ __gg__float128_to_field(dest,
+ retval,
+ truncation_e,
+ NULL);
+ }
+extern "C"
+void
+__gg__fraction_part(cblc_field_t *dest, cblc_refer_t *source)
+ {
+ // FUNCTION INTEGER-PART
+ _Float128 value = __gg__float128_from_refer(source);
+ bool is_negative = false;
if( value < 0 )
+ {
+ is_negative = true;
+ value = -value;
+ }
+
+ _Float128 retval = value - floorf128(value);
+
+ if( is_negative )
{
retval = -retval;
}
@@ -1571,7 +1634,7 @@ __gg__max(cblc_field_t *dest, size_t ncount, cblc_refer_t inputs[])
// FUNCTION MAX
if( ( inputs[0].field->type == FldAlphanumeric
- || inputs[0].field->type == FldLiteralA) )
+ || inputs[0].field->type == FldLiteralA) )
{
cblc_field_t *best_field ;
unsigned char *best_location ;
@@ -1611,19 +1674,19 @@ __gg__max(cblc_field_t *dest, size_t ncount, cblc_refer_t inputs[])
bool candidate_address_of = inputs[i].address_of;
int compare_result = __gg__compare_2(
- candidate_field,
- candidate_location,
- candidate_length,
- candidate_attr,
- candidate_move_all,
- candidate_address_of,
- best_field,
- best_location,
- best_length,
- best_attr,
- best_move_all,
- best_address_of,
- 0);
+ candidate_field,
+ candidate_location,
+ candidate_length,
+ candidate_attr,
+ candidate_move_all,
+ candidate_address_of,
+ best_field,
+ best_location,
+ best_length,
+ best_attr,
+ best_move_all,
+ best_address_of,
+ 0);
if( compare_result >= 0 )
{
best_field = candidate_field ;
@@ -1679,25 +1742,25 @@ __gg__max(cblc_field_t *dest, size_t ncount, cblc_refer_t inputs[])
}
}
}
- __gg__float128_to_field(dest,
- retval,
- truncation_e,
- NULL);
+ __gg__float128_to_field(dest,
+ retval,
+ truncation_e,
+ NULL);
}
}
extern "C"
void
__gg__lower_case(cblc_field_t *dest, cblc_refer_t *input )
- {
- size_t dest_length = dest->capacity;
- size_t source_length = input->qual_size;
- memset(dest->data, internal_space, dest_length);
- memcpy(dest->data, input->qual_data, std::min(dest_length, source_length));
- internal_to_ascii((char *)dest->data, dest_length);
- std::transform(dest->data, dest->data + dest_length, dest->data, tolower);
- ascii_to_internal_str((char *)dest->data, dest_length);
- }
+ {
+ size_t dest_length = dest->capacity;
+ size_t source_length = input->qual_size;
+ memset(dest->data, internal_space, dest_length);
+ memcpy(dest->data, input->qual_data, std::min(dest_length, source_length));
+ internal_to_ascii((char *)dest->data, dest_length);
+ std::transform(dest->data, dest->data + dest_length, dest->data, tolower);
+ ascii_to_internal_str((char *)dest->data, dest_length);
+ }
extern "C"
void
@@ -1720,8 +1783,8 @@ __gg__median(cblc_field_t *dest, size_t ncount, cblc_refer_t *source)
// FUNCTION MEDIAN
// This is wasteful, because it allocates N values in order to sort them. It
- // is also an O(NlogN) solution, when there are O(N) solutions available.
-
+ // is also an O(NlogN) solution, when there are O(N) solutions available.
+
// It has the merit of being very simple.
// The future beckons, but not today.
@@ -1777,7 +1840,7 @@ extern "C"
void
__gg__midrange(cblc_field_t *dest, size_t ncount, cblc_refer_t *source)
{
- // FUNCTION MIDRANGE
+ // FUNCTION MIDRANGE
_Float128 val;
_Float128 min=0;
_Float128 max=0;
@@ -1818,9 +1881,9 @@ void
__gg__min(cblc_field_t *dest, size_t ncount, cblc_refer_t inputs[])
{
// FUNCTION MIN
-
+
if( ( inputs[0].field->type == FldAlphanumeric
- || inputs[0].field->type == FldLiteralA) )
+ || inputs[0].field->type == FldLiteralA) )
{
cblc_field_t *best_field ;
unsigned char *best_location ;
@@ -1859,19 +1922,19 @@ __gg__min(cblc_field_t *dest, size_t ncount, cblc_refer_t inputs[])
bool candidate_address_of = inputs[i].address_of;
int compare_result = __gg__compare_2(
- candidate_field,
- candidate_location,
- candidate_length,
- candidate_attr,
- candidate_move_all,
- candidate_address_of,
- best_field,
- best_location,
- best_length,
- best_attr,
- best_move_all,
- best_address_of,
- 0);
+ candidate_field,
+ candidate_location,
+ candidate_length,
+ candidate_attr,
+ candidate_move_all,
+ candidate_address_of,
+ best_field,
+ best_location,
+ best_length,
+ best_attr,
+ best_move_all,
+ best_address_of,
+ 0);
if( compare_result < 0 )
{
best_field = candidate_field ;
@@ -1889,7 +1952,7 @@ __gg__min(cblc_field_t *dest, size_t ncount, cblc_refer_t inputs[])
}
}
}
-
+
__gg__adjust_dest_size(dest, best_length);
dest->type = FldAlphanumeric;
memcpy(dest->data, best_location, best_length);
@@ -1927,10 +1990,10 @@ __gg__min(cblc_field_t *dest, size_t ncount, cblc_refer_t inputs[])
}
}
}
- __gg__float128_to_field(dest,
- retval,
- truncation_e,
- NULL);
+ __gg__float128_to_field(dest,
+ retval,
+ truncation_e,
+ NULL);
}
}
@@ -1969,192 +2032,291 @@ __gg__mod(cblc_field_t *dest, cblc_refer_t *source1, cblc_refer_t *source2)
NULL);
}
-static
-int
+static int
numval(cblc_field_t *dest, cblc_refer_t *input)
{
- size_t errcode = 0;
+ // Returns the one-based character position of a bad character
+ // returns zero if it is okay
+
+ char *p = (char *)input->qual_data;
+ char *pend = p + input->qual_size;
- char *p = (char *)input->qual_data;
- char *pstart = p;
- char *pend = p + input->qual_size;
+ int errpos = 0;
+ __int128 retval = 0;
+ int retval_rdigits = 0;
- _Float128 retval = 0;
- int sign = 0;
- int rdigits = 0;
- int rdigit_bump = 0;
+ bool saw_digit= false;
char decimal_point = __gg__get_decimal_point();
-
- // We will do this as a state machine:
-
- enum
+ bool in_fraction = false;
+ bool leading_sign = false;
+ bool is_negative = false;
+ enum
{
- first_space ,
- first_sign ,
- before_digits ,
- in_digits ,
- after_digits ,
- second_sign ,
- final_space ,
- } state = first_space;
+ SPACE1,
+ SPACE2,
+ DIGITS,
+ SPACE3,
+ SPACE4,
+ } state = SPACE1;
+ if( input->qual_size == 0 )
+ {
+ errpos = 1;
+ goto done;
+ }
while( p < pend )
{
char ch = *p++;
+ errpos += 1;
switch( state )
{
- case first_space :
- if( ch != internal_space )
+ case SPACE1:
+ // We tolerate spaces, and expect to end with a sign, digit,
+ // or decimal point:
+ if( ch == internal_space )
{
- state = first_sign;
- p -= 1;
+ continue;
}
- break;
-
- case first_sign :
if( ch == internal_plus )
{
- sign = 1;
- state = before_digits;
+ leading_sign = true;
+ state = SPACE2;
+ break;
}
- else if( ch == internal_minus )
+ if( ch == internal_minus )
{
- sign = -1;
- state = before_digits;
+ leading_sign = true;
+ is_negative = true;
+ state = SPACE2;
+ break;
}
- else if( (ch >= internal_0 && ch <= internal_9)
- || ch == decimal_point )
+ if( ch >= internal_0 && ch <= internal_9 )
{
- state = in_digits;
- p -= 1;
+ saw_digit = true;
+ retval = ch & 0xF;
+ state = DIGITS;
+ break;
}
- else
+ if( ch == decimal_point )
{
- // We have a bad character:
- errcode = p - pstart;
- state = final_space;
- p = pend;
+ in_fraction = true;
+ state = DIGITS;
+ break;
}
+ // This is a bad character; errpos is correct
+ goto done;
break;
- case before_digits :
- if( ch != internal_space )
+ case SPACE2:
+ // We tolerate spaces, and expect to end with a digit or decimal point:
+ if( ch == internal_space )
{
- state = in_digits;
- p -= 1;
+ break;
}
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ saw_digit = true;
+ retval = ch & 0xF;
+ state = DIGITS;
+ break;
+ }
+ if( ch == decimal_point )
+ {
+ in_fraction = true;
+ state = DIGITS;
+ break;
+ }
+ // This is a bad character; errpos is correct
+ goto done;
break;
- case in_digits :
- // The only thing allowed here are digits and the decimal separator:
+ case DIGITS:
+ // We tolerate digits. We tolerate one decimal point. We expect to
+ // end with a space, a sign, "DB" or "CR", or the the end of the string
+ // It's a bit complicated
+
if( ch >= internal_0 && ch <= internal_9 )
{
- // We have a digit.
- rdigits += rdigit_bump;
+ saw_digit = true;
retval *= 10;
- retval += ch & 0x0F;
- }
- else if( ch == decimal_point && rdigit_bump)
- {
- // We have a decimal_point, which is against the rules:
- errcode = p - pstart;
- state = final_space;
- p = pend;
+ retval += ch & 0xF;
+ if( in_fraction )
+ {
+ retval_rdigits += 1;
+ }
+ break;
}
- else if( ch == decimal_point )
+ if( ch == decimal_point && in_fraction )
{
- rdigit_bump = 1;
+ // Only one decimal is allowed
+ goto done;
}
- else
+ if( ch == decimal_point )
{
- // We something that isn't a digit or decimal separator:
- state = after_digits;
- p -= 1;
+ in_fraction = true;
+ break;
}
- break;
-
- case after_digits :
if( ch == internal_space )
{
- continue;
+ state = SPACE3;
+ break;
}
- if( sign )
+ if( ch == internal_plus && leading_sign)
{
- // We already saw a sign character
- state = final_space;
+ // We are allowed leading or trailing signs, but not both
+ goto done;
}
- else
+ if( ch == internal_minus && leading_sign)
{
- state = second_sign;
+ // We are allowed leading or trailing signs, but not both
+ goto done;
}
- p -= 1;
- break;
-
- case second_sign :
if( ch == internal_plus )
{
- sign = 1;
+ state = SPACE4;
+ break;
}
- else if( ch == internal_minus )
+ if( ch == internal_minus )
{
- sign = -1;
+ is_negative = true;
+ state = SPACE4;
+ break;
}
- else if( (ch == internal_D || ch == internal_d)
- && p < pend
- && (*p == internal_B || *p == internal_b) )
+ if( tolower(ch) == 'd' )
{
- sign = -1;
- p += 1;
+ if( leading_sign )
+ {
+ goto done;
+ }
+ ch = *p++;
+ errpos += 1;
+ if( p > pend || tolower(ch) != 'b' )
+ {
+ goto done;
+ }
+ is_negative = true;
+ state = SPACE4;
+ break;
}
- else if( (ch == internal_C || ch == internal_c)
- && p < pend
- && (*p == internal_R || *p == internal_r) )
+ if( tolower(ch) == 'c' )
{
- sign = -1;
- p += 1;
+ if( leading_sign )
+ {
+ goto done;
+ }
+ ch = *p++;
+ errpos += 1;
+ if( p > pend || tolower(ch) != 'r' )
+ {
+ goto done;
+ }
+ is_negative = true;
+ state = SPACE4;
+ break;
}
- else
+ // This is a bad character; errpos is correct
+ goto done;
+ break;
+
+ case SPACE3:
+ // We tolerate spaces, or we end with a sign:
+ if( ch == internal_space )
{
- // We have an invalid character
- errcode = p - pstart;
- state = final_space;
- p = pend;
+ break;
}
- state = final_space;
+ if( ch == internal_plus && leading_sign)
+ {
+ // We are allowed leading or trailing signs, but not both
+ goto done;
+ }
+ if( ch == internal_minus && leading_sign)
+ {
+ // We are allowed leading or trailing signs, but not both
+ goto done;
+ }
+ if( ch == internal_plus )
+ {
+ state = SPACE4;
+ break;
+ }
+ if( ch == internal_minus )
+ {
+ is_negative = true;
+ state = SPACE4;
+ break;
+ }
+ if( tolower(ch) == 'd' )
+ {
+ if( leading_sign )
+ {
+ goto done;
+ }
+ ch = *p++;
+ errpos += 1;
+ if( p > pend || tolower(ch) != 'b' )
+ {
+ goto done;
+ }
+ is_negative = true;
+ state = SPACE4;
+ break;
+ }
+ if( tolower(ch) == 'c' )
+ {
+ if( leading_sign )
+ {
+ goto done;
+ }
+ ch = *p++;
+ errpos += 1;
+ if( p > pend || tolower(ch) != 'r' )
+ {
+ goto done;
+ }
+ is_negative = true;
+ state = SPACE4;
+ break;
+ }
+ goto done;
break;
-
- case final_space :
+ case SPACE4:
if( ch == internal_space )
{
- continue;
+ break;
}
- // We have a non-space where there should be only space
- errcode = p - pstart;
- p = pend;
+ goto done;
break;
}
}
- if( sign == 0 )
+ if( saw_digit )
{
- sign = 1;
+ errpos = 0;
}
- retval *= sign;
-
- if( state != after_digits && state != final_space && state != in_digits )
+ else if( p == pend )
{
- errcode = pend - pstart + 1;
+ // If we got to the end without seeing adigit, we need to bump the
+ // error pointer:
+ errpos += 1;
}
- if( dest )
+ done:
+ if(errpos)
{
- retval /= __gg__power_of_ten(rdigits);
-
- __gg__float128_to_field(dest,
- retval,
- truncation_e,
- NULL);
+ retval = 0;
}
- return (int)errcode;
+ if( is_negative )
+ {
+ retval = -retval;
+ }
+ if(dest)
+ {
+ __gg__int128_to_field(dest,
+ retval,
+ retval_rdigits,
+ truncation_e,
+ NULL);
+ }
+ return errpos;
}
static
@@ -2204,15 +2366,15 @@ numval_c( cblc_field_t *dest,
enum
{
- first_space ,
- first_sign ,
- second_space ,
- currency ,
- before_digits ,
- digits ,
- after_digits ,
- second_sign ,
- final_space ,
+ first_space,
+ first_sign,
+ second_space,
+ currency,
+ before_digits,
+ digits,
+ after_digits,
+ second_sign,
+ final_space,
} state = first_space;
while( p < pend )
@@ -2238,7 +2400,7 @@ numval_c( cblc_field_t *dest,
p -= 1;
}
else if( (ch >= internal_0 && ch <= internal_9)
- || ch == decimal_point )
+ || ch == decimal_point )
{
state = digits;
p -= 1;
@@ -2262,7 +2424,7 @@ numval_c( cblc_field_t *dest,
sign = 1;
state = second_space;
}
- else
+ else
{
sign = -1;
state = second_space;
@@ -2280,7 +2442,7 @@ numval_c( cblc_field_t *dest,
p -= 1;
}
else if( (ch >= internal_0 && ch <= internal_9)
- || ch == decimal_point )
+ || ch == decimal_point )
{
state = digits;
p -= 1;
@@ -2323,7 +2485,7 @@ numval_c( cblc_field_t *dest,
if( ch != internal_space )
{
if( (ch >= internal_0 && ch <= internal_9)
- || ch == decimal_point )
+ || ch == decimal_point )
{
state = digits;
p -= 1;
@@ -2378,11 +2540,11 @@ numval_c( cblc_field_t *dest,
if( ch != internal_space )
{
if( ch == internal_plus
- || ch == internal_minus
- || ch == internal_D
- || ch == internal_d
- || ch == internal_C
- || ch == internal_c )
+ || ch == internal_minus
+ || ch == internal_D
+ || ch == internal_d
+ || ch == internal_C
+ || ch == internal_c )
{
state = second_sign;
p -= 1;
@@ -2407,15 +2569,15 @@ numval_c( cblc_field_t *dest,
sign = -1;
}
else if( (ch == internal_D || ch == internal_d)
- && p < pend
- && (*p == internal_B || *p == internal_b) )
+ && p < pend
+ && (*p == internal_B || *p == internal_b) )
{
sign = -1;
p += 1;
}
else if( (ch == internal_C || ch == internal_c)
- && p < pend
- && (*p == internal_R || *p == internal_r) )
+ && p < pend
+ && (*p == internal_R || *p == internal_r) )
{
sign = -1;
p += 1;
@@ -2463,7 +2625,23 @@ extern "C"
void
__gg__numval(cblc_field_t *dest, cblc_refer_t *source)
{
- numval(dest, source);
+ int errpos = numval(dest, source);
+ if( errpos )
+ {
+ exception_raise(ec_argument_function_e);
+ }
+ }
+
+extern "C"
+void
+__gg__test_numval(cblc_field_t *dest, cblc_refer_t *source)
+ {
+ int retval = numval(NULL, source);
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
}
extern "C"
@@ -2473,217 +2651,229 @@ __gg__numval_c(cblc_field_t *dest, cblc_refer_t *source, cblc_refer_t *currency)
numval_c(dest, source, currency);
}
+extern "C"
+void
+__gg__test_numval_c(cblc_field_t *dest, cblc_refer_t *source, cblc_refer_t *currency)
+ {
+ int retval = numval_c(NULL, source, currency);
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
+
extern "C"
void
__gg__ord(cblc_field_t *dest, cblc_refer_t *input )
- {
- // We get our input in internal_character form.
- char *arg = (char *)input->qual_data;
+ {
+ // We get our input in internal_character form.
+ char *arg = (char *)input->qual_data;
- // The ORD function takes a single-character string and returns the
- // ordinal position of that character.
+ // The ORD function takes a single-character string and returns the
+ // ordinal position of that character.
- // In ASCII mode, an A is 0x41, so we return 0x42
- // In EBCDIC mode, an A is 0xC1, so we return 0xC2
+ // In ASCII mode, an A is 0x41, so we return 0x42
+ // In EBCDIC mode, an A is 0xC1, so we return 0xC2
- size_t retval = (arg[0]&0xFF) + 1;
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
- }
+ size_t retval = (arg[0]&0xFF) + 1;
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
extern "C"
void
__gg__ord_min(cblc_field_t *dest, size_t ninputs, cblc_refer_t inputs[])
- {
- // Sets dest to the one-based ordinal position of the first occurrence
- // of the biggest element in the list of refs[]
+ {
+ // Sets dest to the one-based ordinal position of the first occurrence
+ // of the biggest element in the list of refs[]
- int retval = -1;
- int running_position = -1;
+ int retval = -1;
+ int running_position = -1;
- cblc_field_t *best;
- unsigned char *best_location;
- size_t best_length;
- int best_attr;
- bool best_move_all;
- bool best_address_of ;
+ cblc_field_t *best;
+ unsigned char *best_location;
+ size_t best_length;
+ int best_attr;
+ bool best_move_all;
+ bool best_address_of ;
- unsigned char *candidate_location;
- size_t candidate_length;
- int candidate_attr;
- bool candidate_move_all;
- bool candidate_address_of;
+ unsigned char *candidate_location;
+ size_t candidate_length;
+ int candidate_attr;
+ bool candidate_move_all;
+ bool candidate_address_of;
- for( size_t i=0; i<ninputs; i++ )
- {
- refer_state_for_all state;
+ for( size_t i=0; i<ninputs; i++ )
+ {
+ refer_state_for_all state;
- cblc_refer_t *input = &inputs[i];
- build_refer_state_for_all(state, input);
- for(;;)
- {
- running_position += 1;
- if( retval == -1)
- {
- // We have to initialize the comparisons:
- retval = running_position;
- best = input->field;
- best_location = input->qual_data;
- best_length = input->qual_size;
- best_attr = input->field->attr;
- best_move_all = inputs[i].move_all;
- best_address_of = inputs[i].address_of;
- }
- else
- {
- // We need to save the current adjustments, because __gg__compare
- // is free to modify .location
- candidate_location = input->qual_data;
- candidate_length = input->qual_size;
- candidate_attr = input->field->attr;
- candidate_move_all = inputs[i].move_all;
- candidate_address_of = inputs[i].address_of;
-
- int compare_result =
- __gg__compare_2(
- input->field,
- candidate_location,
- candidate_length,
- candidate_attr,
- candidate_move_all,
- candidate_address_of,
- best,
- best_location,
- best_length,
- best_attr,
- best_move_all,
- best_address_of,
- 0);
- if( compare_result < 0 )
- {
- retval = running_position;
- best = input->field;
- best_location = candidate_location;
- best_length = candidate_length;
- best_attr = candidate_attr;
- best_move_all = candidate_move_all;
- best_address_of = candidate_address_of;
- }
- }
- if( !update_refer_state_for_all(state, input) )
- {
- // There is nothing left to do for that input.
- break;
- }
- }
+ cblc_refer_t *input = &inputs[i];
+ build_refer_state_for_all(state, input);
+ for(;;)
+ {
+ running_position += 1;
+ if( retval == -1)
+ {
+ // We have to initialize the comparisons:
+ retval = running_position;
+ best = input->field;
+ best_location = input->qual_data;
+ best_length = input->qual_size;
+ best_attr = input->field->attr;
+ best_move_all = inputs[i].move_all;
+ best_address_of = inputs[i].address_of;
}
-
- retval += 1;
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ else
+ {
+ // We need to save the current adjustments, because __gg__compare
+ // is free to modify .location
+ candidate_location = input->qual_data;
+ candidate_length = input->qual_size;
+ candidate_attr = input->field->attr;
+ candidate_move_all = inputs[i].move_all;
+ candidate_address_of = inputs[i].address_of;
+
+ int compare_result =
+ __gg__compare_2(
+ input->field,
+ candidate_location,
+ candidate_length,
+ candidate_attr,
+ candidate_move_all,
+ candidate_address_of,
+ best,
+ best_location,
+ best_length,
+ best_attr,
+ best_move_all,
+ best_address_of,
+ 0);
+ if( compare_result < 0 )
+ {
+ retval = running_position;
+ best = input->field;
+ best_location = candidate_location;
+ best_length = candidate_length;
+ best_attr = candidate_attr;
+ best_move_all = candidate_move_all;
+ best_address_of = candidate_address_of;
+ }
+ }
+ if( !update_refer_state_for_all(state, input) )
+ {
+ // There is nothing left to do for that input.
+ break;
+ }
+ }
}
+ retval += 1;
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
+
extern "C"
void
__gg__ord_max(cblc_field_t *dest, size_t ninputs, cblc_refer_t inputs[])
- {
- // Sets dest to the one-based ordinal position of the first occurrence
- // of the biggest element in the list of refs[]
+ {
+ // Sets dest to the one-based ordinal position of the first occurrence
+ // of the biggest element in the list of refs[]
- int retval = -1;
- int running_position = -1;
+ int retval = -1;
+ int running_position = -1;
- cblc_field_t *best;
- unsigned char *best_location;
- size_t best_length;
- int best_attr;
- bool best_move_all;
- bool best_address_of ;
+ cblc_field_t *best;
+ unsigned char *best_location;
+ size_t best_length;
+ int best_attr;
+ bool best_move_all;
+ bool best_address_of ;
- unsigned char *candidate_location;
- size_t candidate_length;
- int candidate_attr;
- bool candidate_move_all;
- bool candidate_address_of;
+ unsigned char *candidate_location;
+ size_t candidate_length;
+ int candidate_attr;
+ bool candidate_move_all;
+ bool candidate_address_of;
- for( size_t i=0; i<ninputs; i++ )
- {
- refer_state_for_all state;
+ for( size_t i=0; i<ninputs; i++ )
+ {
+ refer_state_for_all state;
- cblc_refer_t *input = &inputs[i];
- build_refer_state_for_all(state, input);
- for(;;)
- {
- running_position += 1;
- if( retval == -1)
- {
- // We have to initialize the comparisons:
- retval = running_position;
- best = input->field;
- best_location = input->qual_data;
- best_length = input->qual_size;
- best_attr = input->field->attr;
- best_move_all = inputs[i].move_all;
- best_address_of = inputs[i].address_of;
- }
- else
- {
- // We need to save the current adjustments, because __gg__compare
- // is free to modify .location
- candidate_location = input->qual_data;
- candidate_length = input->qual_size;
- candidate_attr = input->field->attr;
- candidate_move_all = inputs[i].move_all;
- candidate_address_of = inputs[i].address_of;
-
- int compare_result =
- __gg__compare_2(
- input->field,
- candidate_location,
- candidate_length,
- candidate_attr,
- candidate_move_all,
- candidate_address_of,
- best,
- best_location,
- best_length,
- best_attr,
- best_move_all,
- best_address_of,
- 0);
- if( compare_result > 0 )
- {
- retval = running_position;
- best = input->field;
- best_location = candidate_location;
- best_length = candidate_length;
- best_attr = candidate_attr;
- best_move_all = candidate_move_all;
- best_address_of = candidate_address_of;
- }
- }
- if( !update_refer_state_for_all(state, input) )
- {
- // There is nothing left to do for that input.
- break;
- }
- }
+ cblc_refer_t *input = &inputs[i];
+ build_refer_state_for_all(state, input);
+ for(;;)
+ {
+ running_position += 1;
+ if( retval == -1)
+ {
+ // We have to initialize the comparisons:
+ retval = running_position;
+ best = input->field;
+ best_location = input->qual_data;
+ best_length = input->qual_size;
+ best_attr = input->field->attr;
+ best_move_all = inputs[i].move_all;
+ best_address_of = inputs[i].address_of;
}
-
- retval += 1;
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ else
+ {
+ // We need to save the current adjustments, because __gg__compare
+ // is free to modify .location
+ candidate_location = input->qual_data;
+ candidate_length = input->qual_size;
+ candidate_attr = input->field->attr;
+ candidate_move_all = inputs[i].move_all;
+ candidate_address_of = inputs[i].address_of;
+
+ int compare_result =
+ __gg__compare_2(
+ input->field,
+ candidate_location,
+ candidate_length,
+ candidate_attr,
+ candidate_move_all,
+ candidate_address_of,
+ best,
+ best_location,
+ best_length,
+ best_attr,
+ best_move_all,
+ best_address_of,
+ 0);
+ if( compare_result > 0 )
+ {
+ retval = running_position;
+ best = input->field;
+ best_location = candidate_location;
+ best_length = candidate_length;
+ best_attr = candidate_attr;
+ best_move_all = candidate_move_all;
+ best_address_of = candidate_address_of;
+ }
+ }
+ if( !update_refer_state_for_all(state, input) )
+ {
+ // There is nothing left to do for that input.
+ break;
+ }
+ }
}
+ retval += 1;
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
+
extern "C"
void
__gg__pi(cblc_field_t *dest)
@@ -2822,90 +3012,90 @@ __gg__rem( cblc_field_t *dest, cblc_refer_t *input1, cblc_refer_t *input2 )
extern "C"
void
__gg__trim(cblc_field_t *dest, cblc_refer_t *arg1, cblc_refer_t *arg2)
- {
- int rdigits;
- __int128 type = __gg__binary_value_from_refer( &rdigits,
- arg2);
- //static const int BOTH = 0;
- static const int LEADING = 1; // Remove leading spaces
- static const int TRAILING = 2; // Remove trailing spaces
+ {
+ int rdigits;
+ __int128 type = __gg__binary_value_from_refer( &rdigits,
+ arg2);
+ //static const int BOTH = 0;
+ static const int LEADING = 1; // Remove leading spaces
+ static const int TRAILING = 2; // Remove trailing spaces
- if( dest->type != FldAlphanumeric ||
+ if( dest->type != FldAlphanumeric ||
!(dest->attr & temporary_e) ||
!(dest->attr & intermediate_e) )
- {
- fprintf(stderr,
- "We expect the target of a FUNCTION TIME to "
- "be an intermediate alphanumeric\n");
- abort();
- }
- dest->capacity = dest->offset;
+ {
+ fprintf(stderr,
+ "We expect the target of a FUNCTION TIME to "
+ "be an intermediate alphanumeric\n");
+ abort();
+ }
+ dest->capacity = dest->offset;
- // No matter what, we want to find the leftmost non-space and the
- // rightmost non-space:
+ // No matter what, we want to find the leftmost non-space and the
+ // rightmost non-space:
- char *left = (char *)arg1->qual_data;
- char *right = left + arg1->qual_size-1;
+ char *left = (char *)arg1->qual_data;
+ char *right = left + arg1->qual_size-1;
- // Find left and right: the first and last non-spaces
- while( left <= right )
- {
- if( *left != internal_space && *right != internal_space )
- {
- break;
- }
- if( *left == internal_space )
- {
- left += 1;
- }
- if( *right == internal_space )
- {
- right -= 1;
- }
- }
- if( type == LEADING )
+ // Find left and right: the first and last non-spaces
+ while( left <= right )
+ {
+ if( *left != internal_space && *right != internal_space )
{
- // We want to leave any trailing spaces, so we return 'right' to its
- // original value:
- right = (char *)arg1->qual_data + arg1->qual_size-1;
+ break;
}
- else if( type == TRAILING )
+ if( *left == internal_space )
{
- // We want to leave any leading spaces, so we return 'left' to its
- // original value:
- left = (char *)arg1->qual_data;
+ left += 1;
}
-
- if( left > right )
+ if( *right == internal_space )
{
- // When the arg1 input string was empty, we want left to be right+1.
- // The left/right loop can sometimes end up with left equal to right+2.
- // That needs to be fixed:
- left = right+1;
+ right -= 1;
}
+ }
+ if( type == LEADING )
+ {
+ // We want to leave any trailing spaces, so we return 'right' to its
+ // original value:
+ right = (char *)arg1->qual_data + arg1->qual_size-1;
+ }
+ else if( type == TRAILING )
+ {
+ // We want to leave any leading spaces, so we return 'left' to its
+ // original value:
+ left = (char *)arg1->qual_data;
+ }
- size_t ncount = right+1 - left;
- __gg__adjust_dest_size(dest, ncount);
+ if( left > right )
+ {
+ // When the arg1 input string was empty, we want left to be right+1.
+ // The left/right loop can sometimes end up with left equal to right+2.
+ // That needs to be fixed:
+ left = right+1;
+ }
- // Because it's a temporary, we are weakly confident that we can change
- // the capacity to match what we want. At this writing, we aren't 100%
- // sure of the implications of the run-time capacity not matching what the
- // compiler believes the capacity to be at compile-time. But we obviously
- // think it'll be okay.
+ size_t ncount = right+1 - left;
+ __gg__adjust_dest_size(dest, ncount);
- char *dest_left = (char *)dest->data;
- char *dest_right = dest_left + dest->capacity - 1;
- char *dest_end = dest_left + dest->capacity;
+ // Because it's a temporary, we are weakly confident that we can change
+ // the capacity to match what we want. At this writing, we aren't 100%
+ // sure of the implications of the run-time capacity not matching what the
+ // compiler believes the capacity to be at compile-time. But we obviously
+ // think it'll be okay.
- while( dest_left <= dest_right && left <= right )
- {
- *dest_left++ = *left++;
- }
- while(dest_left < dest_end)
- {
- *dest_left++ = internal_space;
- }
+ char *dest_left = (char *)dest->data;
+ char *dest_right = dest_left + dest->capacity - 1;
+ char *dest_end = dest_left + dest->capacity;
+
+ while( dest_left <= dest_right && left <= right )
+ {
+ *dest_left++ = *left++;
}
+ while(dest_left < dest_end)
+ {
+ *dest_left++ = internal_space;
+ }
+ }
static struct random_data *buf = NULL;
static char *state = NULL;
@@ -2914,76 +3104,76 @@ static const size_t state_len = 256;
extern "C"
void
__gg__random(cblc_field_t *dest, cblc_refer_t *input )
- {
- // This creates a thread-safe pseudo-random number generator
- // using input as the seed
+ {
+ // This creates a thread-safe pseudo-random number generator
+ // using input as the seed
- // The return value is between zero and not quite one
+ // The return value is between zero and not quite one
- if( !buf )
- {
- // This is the very first time through
- buf = (random_data *)MALLOC(sizeof(struct random_data));
- buf->state = NULL;
- state = (char *)MALLOC(state_len);
-
- struct timespec ts;
- __gg__clock_gettime(CLOCK_REALTIME, &ts);
- initstate_r( ts.tv_nsec, state, state_len, buf);
- }
+ if( !buf )
+ {
+ // This is the very first time through
+ buf = (random_data *)MALLOC(sizeof(struct random_data));
+ buf->state = NULL;
+ state = (char *)MALLOC(state_len);
- int rdigits;
- int seed = (int)__gg__binary_value_from_refer(&rdigits, input);
- srandom_r(seed, buf);
-
- int32_t retval_31;
- random_r(buf, &retval_31);
- // We are going to convert this to a value between zero and not quite one:
- double retval = double(retval_31) / double(0x80000000UL);
- __gg__double_to_target( dest,
- retval,
- truncation_e);
+ struct timespec ts;
+ __gg__clock_gettime(CLOCK_REALTIME, &ts);
+ initstate_r( ts.tv_nsec, state, state_len, buf);
}
+ int rdigits;
+ int seed = (int)__gg__binary_value_from_refer(&rdigits, input);
+ srandom_r(seed, buf);
+
+ int32_t retval_31;
+ random_r(buf, &retval_31);
+ // We are going to convert this to a value between zero and not quite one:
+ double retval = double(retval_31) / double(0x80000000UL);
+ __gg__double_to_target( dest,
+ retval,
+ truncation_e);
+ }
+
extern "C"
void
__gg__random_next(cblc_field_t *dest)
- {
- // The return value is between zero and not quite one
-
- if( !buf )
- {
- // This is the very first time through
- buf = (random_data *)MALLOC(sizeof(struct random_data));
- buf->state = NULL;
- state = (char *)MALLOC(state_len);
- struct timespec ts;
- __gg__clock_gettime(CLOCK_REALTIME, &ts);
- initstate_r( ts.tv_nsec, state, state_len, buf);
- }
- int32_t retval_31;
- random_r(buf, &retval_31);
+ {
+ // The return value is between zero and not quite one
- // We are going to convert this to a value between zero and not quite one:
- double retval = double(retval_31) / double(0x80000000UL);
- __gg__double_to_target( dest,
- retval,
- truncation_e);
+ if( !buf )
+ {
+ // This is the very first time through
+ buf = (random_data *)MALLOC(sizeof(struct random_data));
+ buf->state = NULL;
+ state = (char *)MALLOC(state_len);
+ struct timespec ts;
+ __gg__clock_gettime(CLOCK_REALTIME, &ts);
+ initstate_r( ts.tv_nsec, state, state_len, buf);
}
+ int32_t retval_31;
+ random_r(buf, &retval_31);
+
+ // We are going to convert this to a value between zero and not quite one:
+ double retval = double(retval_31) / double(0x80000000UL);
+ __gg__double_to_target( dest,
+ retval,
+ truncation_e);
+ }
extern "C"
void
__gg__reverse( cblc_field_t *dest, cblc_refer_t *input )
+ {
+ size_t dest_length = dest->capacity;
+ size_t source_length = input->qual_size;
+ size_t length = std::min(dest_length, source_length);
+ memset(dest->data, internal_space, dest_length);
+ for(size_t i=0; i<length; i++)
{
- size_t dest_length = dest->capacity;
- size_t source_length = input->qual_size;
- size_t length = std::min(dest_length, source_length);
- memset(dest->data, internal_space, dest_length);
- for(size_t i=0; i<length; i++)
- {
- dest->data[i] = input->qual_data[source_length-1-i];
- }
+ dest->data[i] = input->qual_data[source_length-1-i];
}
+ }
extern "C"
void
@@ -3101,7 +3291,7 @@ __gg__test_date_yyyymmdd( cblc_field_t *dest, cblc_refer_t *source)
{
int rdigits;
int yyyymmdd = (int)__gg__binary_value_from_refer(&rdigits,
- source);
+ source);
int retval;
int dd = yyyymmdd % 100;
int mmdd = yyyymmdd % 10000;
@@ -3136,10 +3326,10 @@ __gg__test_date_yyyymmdd( cblc_field_t *dest, cblc_refer_t *source)
}
}
__gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
}
extern "C"
@@ -3148,7 +3338,7 @@ __gg__test_day_yyyyddd( cblc_field_t *dest, cblc_refer_t *source)
{
int rdigits;
int yyyyddd = (int)__gg__binary_value_from_refer( &rdigits,
- source);
+ source);
int retval;
int ddd = yyyyddd % 1000;
int yyyy = yyyyddd / 1000;
@@ -3169,55 +3359,31 @@ __gg__test_day_yyyyddd( cblc_field_t *dest, cblc_refer_t *source)
retval = 0;
}
__gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
}
extern "C"
void
-__gg__test_numval(cblc_field_t *dest, cblc_refer_t *source)
+__gg__upper_case(cblc_field_t *dest, cblc_refer_t *input )
{
- int retval = numval(NULL, source);
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ size_t dest_length = dest->capacity;
+ size_t source_length = input->qual_size;
+ memset(dest->data, internal_space, dest_length);
+ memcpy(dest->data, input->qual_data, std::min(dest_length, source_length));
+ internal_to_ascii((char *)dest->data, dest_length);
+ std::transform(dest->data, dest->data + dest_length, dest->data, toupper);
+ ascii_to_internal_str((char *)dest->data, dest_length);
}
extern "C"
void
-__gg__test_numval_c(cblc_field_t *dest, cblc_refer_t *source, cblc_refer_t *currency)
+__gg__variance(cblc_field_t *dest, size_t ncount, cblc_refer_t *source)
{
- int retval = numval_c(NULL, source, currency);
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
- }
-
-extern "C"
-void
-__gg__upper_case(cblc_field_t *dest, cblc_refer_t *input )
- {
- size_t dest_length = dest->capacity;
- size_t source_length = input->qual_size;
- memset(dest->data, internal_space, dest_length);
- memcpy(dest->data, input->qual_data, std::min(dest_length, source_length));
- internal_to_ascii((char *)dest->data, dest_length);
- std::transform(dest->data, dest->data + dest_length, dest->data, toupper);
- ascii_to_internal_str((char *)dest->data, dest_length);
- }
-
-extern "C"
-void
-__gg__variance(cblc_field_t *dest, size_t ncount, cblc_refer_t *source)
- {
- // FUNCTION VARIANCE
- _Float128 retval = variance(ncount, source);
+ // FUNCTION VARIANCE
+ _Float128 retval = variance(ncount, source);
__gg__float128_to_field(dest,
retval,
@@ -3228,15 +3394,15 @@ __gg__variance(cblc_field_t *dest, size_t ncount, cblc_refer_t *source)
extern "C"
void
__gg__when_compiled(cblc_field_t *dest, size_t tv_sec, long tv_nsec)
- {
- struct timespec tp = {};
- tp.tv_sec = tv_sec;
- tp.tv_nsec = tv_nsec;
- char retval[DATE_STRING_BUFFER_SIZE];
- timespec_to_string(retval, tp);
- ascii_to_internal_str(retval, strlen(retval));
- string_to_dest(dest, retval);
- }
+ {
+ struct timespec tp = {};
+ tp.tv_sec = tv_sec;
+ tp.tv_nsec = tv_nsec;
+ char retval[DATE_STRING_BUFFER_SIZE];
+ timespec_to_string(retval, tp);
+ ascii_to_internal_str(retval, strlen(retval));
+ string_to_dest(dest, retval);
+ }
extern "C"
void
@@ -3254,21 +3420,22 @@ __gg__year_to_yyyy( cblc_field_t *dest,
int retval = year_to_yyyy(yy, arg2, arg3);
__gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
}
static
int
-gets_int(int digits, char *p, char *pend)
+gets_int(int ndigits, char *p, char *pend, int *digits)
{
// This routine returns the value of the integer at p. If there is something
// wrong with the integer, it returns a negative number, the value being the
// position (starting at 1) where the problem is.
int retval = 0;
- for(int i=1; i<=digits; i++)
+ memset(digits, 0xFF, ndigits * sizeof(int));
+ for(int i=1; i<=ndigits; i++)
{
if(p >= pend)
{
@@ -3284,7 +3451,8 @@ gets_int(int digits, char *p, char *pend)
break;
}
retval *= 10;
- retval += ch - internal_0;
+ retval += ch & 0xF;
+ digits[i-1] = ch & 0xF;
}
return retval;
}
@@ -3300,7 +3468,29 @@ gets_year(char *p, char *pend, struct cobol_tm &ctm)
// where a four-character range with a year value of 1601 became impossible.
int retval = 0;
- int YYYY = gets_int(4, p, pend);
+ int digits[4];
+ int YYYY = gets_int(4, p, pend, digits);
+
+ if( digits[0] == -1 || digits[0] == 0 )
+ {
+ return 1;
+ }
+ if( digits[1] == -1 )
+ {
+ return 2;
+ }
+ if( digits[0] == 0 && digits[1] < 5)
+ {
+ return 2;
+ }
+ if( digits[2] == -1 )
+ {
+ return 4;
+ }
+ if( digits[3] == -1 )
+ {
+ return 4;
+ }
if( YYYY >= 0 )
{
@@ -3344,8 +3534,18 @@ gets_month(char *p, char *pend, struct cobol_tm &ctm)
// Returns either zero, or else the ordinal position of where the input
// processing failed.
+ int digits[2];
int retval = 0;
- int MM = gets_int(2, p, pend);
+ int MM = gets_int(2, p, pend, digits);
+
+ if( digits[0] == -1 || digits[0] > 1)
+ {
+ return 1;
+ }
+ if( digits[1] == -1 )
+ {
+ return 2;
+ }
if( MM >= 0 )
{
if( MM == 0 )
@@ -3380,8 +3580,18 @@ gets_day(char *p, char *pend, struct cobol_tm &ctm)
// The assumption is that YYYY and MM were populated before arriving here
+ int digits[2];
int retval = 0;
- int DD = gets_int(2, p, pend);
+ int DD = gets_int(2, p, pend, digits);
+
+ if( digits[0] == -1 || digits[0] > 3)
+ {
+ return 1;
+ }
+ if( digits[1] == -1 )
+ {
+ return 2;
+ }
if(DD >= 0)
{
if( DD >= 0 )
@@ -3440,7 +3650,8 @@ gets_day_of_week(char *p, char *pend, struct cobol_tm &ctm)
{
// This is just a simple D, for day-of-week. The COBOL spec is that
// it be 1 to 7, 1 being Monday
- int day_of_week = gets_int(1, p, pend);
+ int digits[1];
+ int day_of_week = gets_int(1, p, pend, digits);
if( day_of_week<0 || day_of_week >7)
{
// The single character at source is no good:
@@ -3460,7 +3671,7 @@ gets_day_of_week(char *p, char *pend, struct cobol_tm &ctm)
int day_of_year = (int)(JD - JD_Jan0);
- // It's possible for the year/week/day_of_week to be
+ // It's possible for the year/week/day_of_week to be
// before Jan 1. This is the case for 1900-12-31, as one example; that
// date gets converted to 1901-W01-01
if( day_of_year <= 0 )
@@ -3487,7 +3698,20 @@ int
gets_day_of_year(char *p, char *pend, struct cobol_tm &ctm)
{
// This is a three-digit day-of-year, 001 through 365,366
- int DDD = gets_int(3, p, pend);
+ int digits[3];
+ int DDD = gets_int(3, p, pend, digits);
+ if( digits[0] == -1 || digits[0] > 3)
+ {
+ return 1;
+ }
+ if( digits[1] == -1 )
+ {
+ return 2;
+ }
+ if( digits[2] == -1 )
+ {
+ return 3;
+ }
if( DDD < 0 )
{
return -DDD;
@@ -3531,7 +3755,16 @@ int
gets_week(char *p, char *pend, struct cobol_tm &ctm)
{
// This is a two-digit value, 01 through 52,53
- int ww = gets_int(2, p, pend);
+ int digits[2];
+ int ww = gets_int(2, p, pend, digits);
+ if( digits[0] == -1 || digits[0] > 5 )
+ {
+ return 1;
+ }
+ if( digits[1] == -1 )
+ {
+ return 2;
+ }
if( ww < 0 )
{
return -ww;
@@ -3562,7 +3795,18 @@ int
gets_hours(char *p, char *pend, struct cobol_tm &ctm, bool in_offset)
{
// This is a two-digit value, 01 through 23
- int hh = gets_int(2, p, pend);
+ int digits[2];
+ int hh = gets_int(2, p, pend, digits);
+
+ if( digits[0] == -1 || digits[0] > 2 )
+ {
+ return 1;
+ }
+ if( digits[1] == -1 )
+ {
+ return 2;
+ }
+
if( hh < 0 )
{
return -hh;
@@ -3596,7 +3840,17 @@ int
gets_minutes(char *p, char *pend, struct cobol_tm &ctm, bool in_offset)
{
// This is a two-digit value, 01 through 59
- int mm = gets_int(2, p, pend);
+ int digits[2];
+ int mm = gets_int(2, p, pend, digits);
+ if( digits[0] == -1 || digits[0] > 5 )
+ {
+ return 1;
+ }
+ if( digits[1] == -1 )
+ {
+ return 2;
+ }
+
if( mm < 0 )
{
return -mm;
@@ -3624,7 +3878,16 @@ int
gets_seconds(char *p, char *pend, struct cobol_tm &ctm)
{
// This is a two-digit value, 01 through 59
- int ss = gets_int(2, p, pend);
+ int digits[2];
+ int ss = gets_int(2, p, pend, digits);
+ if( digits[0] == -1 || digits[0] > 5 )
+ {
+ return 1;
+ }
+ if( digits[1] == -1 )
+ {
+ return 2;
+ }
if( ss < 0 )
{
return -ss;
@@ -3642,7 +3905,7 @@ gets_seconds(char *p, char *pend, struct cobol_tm &ctm)
static
int
-gets_nanoseconds(char *p, char *pend, struct cobol_tm &ctm)
+gets_nanoseconds(char *f, char *f_end, char *p, char *pend, struct cobol_tm &ctm)
{
// Because nanoseconds digits to the right of the decimal point can vary from
// one digit to our implementation-specific limit of nine characters, this
@@ -3655,8 +3918,9 @@ gets_nanoseconds(char *p, char *pend, struct cobol_tm &ctm)
int nanoseconds = 0;
char *pinit = p;
- while( *p == internal_s && p < pend )
+ while( f < f_end && *f == internal_s && p < pend )
{
+ f += 1;
int ch = *p++;
errpos += 1;
@@ -3694,7 +3958,11 @@ fill_cobol_tm(cobol_tm &ctm,
// Establish the string to be checked:
char *source = (char *)par2->qual_data;
- char *source_end = format + par2->qual_size;
+ char *source_end = source + par2->qual_size;
+
+ // Let's eliminate trailing spaces...
+ trim_trailing_spaces(format, format_end);
+ trim_trailing_spaces(source, source_end);
bool in_offset = false;
bool in_nanoseconds = false;
@@ -3714,9 +3982,9 @@ fill_cobol_tm(cobol_tm &ctm,
char ch = *format;
if( ch == internal_T
- || ch == internal_colon
- || ch == internal_minus
- || ch == internal_W)
+ || ch == internal_colon
+ || ch == internal_minus
+ || ch == internal_W)
{
// These are just formatting characters. They need to be duplicated,
// but are otherwise ignored.
@@ -3731,10 +3999,37 @@ fill_cobol_tm(cobol_tm &ctm,
if( ch == internal_plus )
{
// This flags a following hhmm offset. It needs to match a '+' or '-'
- if( *source != internal_plus && *source != internal_minus )
+ if( *source != internal_plus
+ && *source != internal_minus
+ && *source != internal_zero)
{
break;
}
+ if( *source == internal_zero )
+ {
+ // The next four characters have to be zeroes
+ if( source[1] != internal_zero )
+ {
+ retval += 1;
+ break;
+ }
+ if( source[2] != internal_zero )
+ {
+ retval += 2;
+ break;
+ }
+ if( source[3] != internal_zero )
+ {
+ retval += 3;
+ break;
+ }
+ if( source[4] != internal_zero )
+ {
+ retval += 4;
+ break;
+ }
+ }
+
in_offset = true;
bump = 1;
goto proceed;
@@ -3866,28 +4161,45 @@ fill_cobol_tm(cobol_tm &ctm,
if( ch == internal_s && in_nanoseconds )
{
- errpos = gets_nanoseconds(source, source_end, ctm);
+ // Peel off digits to the right of the decimal point one at a time
+ errpos = gets_nanoseconds(format, format_end, source, source_end, ctm);
if( errpos > 0 )
{
retval += errpos - 1;
break;
}
- bump = errpos;
+ bump = -errpos;
+ goto proceed;
+ }
+
+ if( ch == internal_Z || ch == internal_z )
+ {
+ // This has to be the end of the road
+ if( toupper(source[0]) != 'Z' )
+ {
+ retval += 0;
+ break;
+ }
+
+ convert_to_zulu(ctm);
+ bump = 1;
goto proceed;
}
assert(false);
- proceed:
+proceed:
retval += bump;
format += bump;
source += bump;
}
- if( format >= format_end )
+ if( format >= format_end && source >= source_end)
{
// This means we processed the entire format string without seeing an error
retval = 0;
+
+ // Otherwise, either the format or source was too short
}
return retval;
}
@@ -3905,10 +4217,10 @@ __gg__test_formatted_datetime(cblc_field_t *dest,
par2);
__gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
}
extern "C"
@@ -3937,10 +4249,10 @@ __gg__integer_of_formatted_date(cblc_field_t *dest,
}
__gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
}
extern "C"
@@ -3952,8 +4264,8 @@ __gg__seconds_from_formatted_time(cblc_field_t *dest,
struct cobol_tm ctm = {};
double retval = fill_cobol_tm( ctm,
- par1,
- par2);
+ par1,
+ par2);
if(retval > 0)
{
retval = 0; // Indicates there was a problem with the input data
@@ -3967,3 +4279,747 @@ __gg__seconds_from_formatted_time(cblc_field_t *dest,
truncation_e);
}
+extern "C"
+void
+__gg__hex_of(cblc_field_t *dest,
+ cblc_refer_t *par1)
+ {
+ static const char hex[17] = "0123456789ABCDEF";
+ size_t bytes = par1->qual_size;
+ __gg__adjust_dest_size(dest, 2*bytes);
+ for(size_t i=0; i<bytes; i++)
+ {
+ unsigned char byte = par1->qual_data[i];
+ dest->data[2*i] = hex[byte>>4];
+ dest->data[2*i+1] = hex[byte&0xF];
+ }
+ }
+
+extern "C"
+void
+__gg__highest_algebraic(cblc_field_t *dest,
+ cblc_refer_t *var_)
+ {
+ cblc_field_t *var = var_->field;
+ __int128 result = 0;
+ __int128 result_rdigits = 0;
+
+ if( var->attr & scaled_e )
+ {
+ result = __gg__power_of_ten(var->digits) - 1;
+ if( var->rdigits<0 )
+ {
+ result *= __gg__power_of_ten(-var->rdigits);
+ }
+ else
+ {
+ result_rdigits = var->digits + var->rdigits;
+ }
+ }
+ else if( var->digits == 0 )
+ {
+ result = (1<<(var->capacity*8)) -1 ;
+ if( var->attr & signable_e )
+ {
+ result >>=1 ;
+ }
+ }
+ else
+ {
+ result_rdigits = var->rdigits;
+ result = __gg__power_of_ten(var->digits) - 1;
+ }
+ __gg__int128_to_field(dest,
+ result,
+ result_rdigits,
+ truncation_e,
+ NULL);
+ }
+
+extern "C"
+void
+__gg__lowest_algebraic(cblc_field_t *dest,
+ cblc_refer_t *var_)
+ {
+ cblc_field_t *var = var_->field;
+ __int128 result = 0;
+ __int128 result_rdigits = 0;
+
+ if( var->attr & scaled_e )
+ {
+ result = __gg__power_of_ten(var->digits) - 1;
+ if( var->rdigits<0 )
+ {
+ result *= __gg__power_of_ten(-var->rdigits);
+ }
+ else
+ {
+ result_rdigits = var->digits + var->rdigits;
+ }
+ if( var->attr & signable_e )
+ {
+ result = -result;
+ }
+ else
+ {
+ result = 0;
+ }
+ }
+ else if( var->digits == 0 )
+ {
+ result = (1<<(var->capacity*8)) -1 ;
+ if( var->attr & signable_e )
+ {
+ result >>=1 ;
+ result += 1;
+ result = -result;
+ }
+ else
+ {
+ result = 0;
+ }
+ }
+ else
+ {
+ result_rdigits = var->rdigits;
+ result = __gg__power_of_ten(var->digits) - 1;
+ if( var->attr & signable_e )
+ {
+ result = -result;
+ }
+ else
+ {
+ result = 0;
+ }
+ }
+ __gg__int128_to_field(dest,
+ result,
+ result_rdigits,
+ truncation_e,
+ NULL);
+ }
+
+static int
+floating_format_tester(char const * const f, char * const f_end)
+ {
+ int retval = -1;
+ char decimal_point = __gg__get_decimal_point();
+
+ enum
+ {
+ SPACE1,
+ SPACE2,
+ DIGITS1,
+ DIGITS2,
+ SPACE3,
+ SPACE4,
+ SPACE5,
+ DIGITS3,
+ SPACE6,
+ } state = SPACE1;
+ ssize_t index = 0;
+ while(index < f_end - f)
+ {
+ char ch = f[index];
+ switch(state)
+ {
+ case SPACE1:
+ if( ch == internal_space )
+ {
+ // Just keep looking
+ break;
+ }
+ if( ch == internal_minus
+ || ch == internal_plus)
+ {
+ state = SPACE2;
+ break;
+ }
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ state = DIGITS1;
+ break;
+ }
+ if( decimal_point )
+ {
+ state = DIGITS2;
+ break;
+ }
+ // Disallowed character
+ retval = index;
+ break;
+
+ case SPACE2:
+ if( ch == internal_space )
+ {
+ break;
+ }
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ state = DIGITS1;
+ break;
+ }
+ if( ch == decimal_point )
+ {
+ state = DIGITS2;
+ break;
+ }
+ retval = index;
+ break;
+
+ case DIGITS1:
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ break;
+ }
+ if( ch == decimal_point )
+ {
+ state = DIGITS2;
+ break;
+ }
+ if( ch == internal_space )
+ {
+ state = SPACE3;
+ break;
+ }
+ retval = index;
+ break;
+
+ case DIGITS2:
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ break;
+ }
+ if( ch == internal_space )
+ {
+ state = SPACE3;
+ break;
+ }
+ if( ch == internal_E || ch == internal_e )
+ {
+ state = SPACE4;
+ break;
+ }
+ retval = index;
+ break;
+
+ case SPACE3:
+ if( ch == internal_space )
+ {
+ break;
+ }
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ retval = index;
+ break;
+ }
+ if( ch == internal_E || ch == internal_e )
+ {
+ state = SPACE4;
+ break;
+ }
+ retval = index;
+ break;
+
+ case SPACE4:
+ if( ch == internal_space )
+ {
+ break;
+ }
+ if( ch == internal_minus || ch == internal_plus )
+ {
+ state = SPACE5;
+ break;
+ }
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ state = DIGITS3;
+ break;
+ }
+ retval = index;
+ break;
+
+ case SPACE5:
+ if( ch == internal_space )
+ {
+ break;
+ }
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ state = DIGITS3;
+ break;
+ }
+ retval = index;
+ break;
+
+ case DIGITS3:
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ break;
+ }
+ if( ch == internal_space )
+ {
+ state = SPACE6;
+ break;
+ }
+ retval = index;
+ break;
+
+ case SPACE6:
+ if( ch == internal_space )
+ {
+ break;
+ }
+ retval = index;
+ break;
+ }
+
+ if( retval > -1 )
+ {
+ break;
+ }
+ index += 1;
+ }
+
+ retval += 1;
+ return retval;
+ }
+
+extern "C"
+void
+__gg__numval_f( cblc_field_t *dest,
+ cblc_refer_t *var)
+ {
+ _Float128 value = 0;
+ char *data = (char * )var->qual_data;
+ char *data_end = data + var->qual_size;
+
+ int error = floating_format_tester(data, data_end);
+
+ if( error || var->qual_size >= 256 )
+ {
+ exception_raise(ec_argument_function_e);
+ }
+ else
+ {
+ // Get rid of any spaces in the string
+ char ach[256];
+ char *p = ach;
+ while( data < data_end )
+ {
+ char ch = *data++;
+ if( ch != internal_space )
+ {
+ *p++ = ch;
+ }
+ }
+ *p++ = '\0';
+ value = strtof128(ach, NULL);
+ }
+ __gg__float128_to_field(dest,
+ value,
+ truncation_e,
+ NULL);
+ }
+
+extern "C"
+void
+__gg__test_numval_f(cblc_field_t *dest,
+ cblc_refer_t *var)
+ {
+ char *data = (char * )var->qual_data;
+ char *data_end = data + var->qual_size;
+
+ int error = floating_format_tester(data, data_end);
+
+ __gg__int128_to_field(dest,
+ error,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
+
+static bool
+ismatch(char *a1, char *a2, char *b1, char *b2)
+ {
+ bool retval = true;
+ while( a1 < a2 && b1 < b2 )
+ {
+ if( *a1++ != *b1++ )
+ {
+ retval = false;
+ }
+ }
+ return retval;
+ }
+
+static bool
+iscasematch(char *a1, char *a2, char *b1, char *b2)
+ {
+ bool retval = true;
+ while( a1 < a2 && b1 < b2 )
+ {
+ if( tolower(*a1++) != tolower(*b1++) )
+ {
+ retval = false;
+ }
+ }
+ return retval;
+ }
+
+static char *
+strstr(char *haystack, char *haystack_e, char *needle, char *needle_e)
+ {
+ char *retval = NULL;
+ char *pend = haystack_e - (needle_e - needle);
+ while( haystack <= pend )
+ {
+ if(ismatch(haystack, haystack_e, needle, needle_e))
+ {
+ retval = haystack;
+ break;
+ }
+ haystack += 1;
+ }
+ return retval;
+ }
+
+static char *
+strcasestr(char *haystack, char *haystack_e, char *needle, char *needle_e)
+ {
+ char *retval = NULL;
+ char *pend = haystack_e - (needle_e - needle);
+ while( haystack <= pend )
+ {
+ if(iscasematch(haystack, haystack_e, needle, needle_e))
+ {
+ retval = haystack;
+ break;
+ }
+ haystack += 1;
+ }
+ return retval;
+ }
+
+static char *
+strlaststr(char *haystack, char *haystack_e, char *needle, char *needle_e)
+ {
+ char *retval = NULL;
+ char *pend = haystack_e - (needle_e - needle);
+ while( haystack <= pend )
+ {
+ if(ismatch(haystack, haystack_e, needle, needle_e))
+ {
+ retval = haystack;
+ }
+ haystack += 1;
+ }
+ return retval;
+ }
+
+static char *
+strcaselaststr(char *haystack, char *haystack_e, char *needle, char *needle_e)
+ {
+ char *retval = NULL;
+ char *pend = haystack_e - (needle_e - needle);
+ while( haystack <= pend )
+ {
+ if(iscasematch(haystack, haystack_e, needle, needle_e))
+ {
+ retval = haystack;
+ }
+ haystack += 1;
+ }
+ return retval;
+ }
+
+
+extern "C"
+void __gg__substitute(cblc_field_t *dest,
+ cblc_refer_t *arg1,
+ size_t N,
+ uint8_t *control,
+ cblc_refer_t *arg2,
+ cblc_refer_t *arg3)
+ {
+ // When EBCDIC becomes an issue, this will have to be modified heavily
+ ssize_t retval_size = 256;
+ char *retval = (char *)malloc(retval_size);
+ *retval = '\0';
+
+ char *haystack = (char *)arg1->qual_data;
+ char *haystack_e = (char *)arg1->qual_data + arg1->qual_size;
+
+ ssize_t outdex = 0;
+
+ char **pflasts = (char **)malloc(N * sizeof(char *));
+
+ if( arg1->qual_size == 0 )
+ {
+ exception_raise(ec_argument_function_e);
+ goto bugout;
+ }
+
+ for( size_t i=0; i<N; i++ )
+ {
+ if( arg2[i].qual_size == 0 )
+ {
+ exception_raise(ec_argument_function_e);
+ goto bugout;
+ }
+ if( control[i] & substitute_anycase_e )
+ {
+ if( control[i] & substitute_first_e )
+ {
+ pflasts[i] = strcasestr(haystack,
+ haystack_e,
+ (char *)arg2[i].qual_data,
+ (char *)arg2[i].qual_data + arg2[i].qual_size);
+ }
+ else if( control[i] & substitute_last_e)
+ {
+ pflasts[i] = strcaselaststr(haystack,
+ haystack_e,
+ (char *)arg2[i].qual_data,
+ (char *)arg2[i].qual_data + arg2[i].qual_size);
+ }
+ else
+ {
+ pflasts[i] = NULL;
+ }
+ }
+ else
+ {
+ if( control[i] & substitute_first_e )
+ {
+ pflasts[i] = strstr(haystack,
+ haystack_e,
+ (char *)arg2[i].qual_data,
+ (char *)arg2[i].qual_data + arg2[i].qual_size);
+ }
+ else if( control[i] & substitute_last_e)
+ {
+ pflasts[i] = strlaststr(haystack,
+ haystack_e,
+ (char *)arg2[i].qual_data,
+ (char *)arg2[i].qual_data + arg2[i].qual_size);
+ }
+ else
+ {
+ pflasts[i] = NULL;
+ }
+ }
+ }
+
+ while( haystack < haystack_e )
+ {
+ bool did_something = false;
+ for( size_t i=0; i<N; i++ )
+ {
+ // Let's make sure that there is enough room in the case that we add this
+ // arg
+ while( outdex - (ssize_t)arg2[i].qual_size + (ssize_t)arg3[i].qual_size
+ > retval_size )
+ {
+ retval_size *= 2;
+ retval = (char *)realloc(retval, retval_size);
+ }
+
+ // We checked earlier for FIRST/LAST matches
+ bool matched = pflasts[i] == haystack;
+ if( !matched )
+ {
+ // It didn't match. But if it was flagged as FIRST or LAST, we need
+ // to skip it
+
+ if( control[i] & (substitute_first_e|substitute_last_e) )
+ {
+ continue;
+ }
+
+ char *needle = (char *)arg2[i].qual_data;
+ char *needle_e = (char *)arg2[i].qual_data + arg2[i].qual_size;
+ matched = (control[i] & substitute_anycase_e) && iscasematch(
+ haystack,
+ haystack_e,
+ needle,
+ needle_e);
+ if( !matched )
+ {
+ matched = !(control[i] & substitute_anycase_e) && ismatch(haystack,
+ haystack_e,
+ needle,
+ needle_e) ;
+ }
+ }
+ if( matched )
+ {
+ haystack += arg2[i].qual_size;
+ memcpy(retval + outdex, arg3[i].qual_data, arg3[i].qual_size);
+ outdex += arg3[i].qual_size;
+ did_something = true;
+ break;
+ }
+ }
+ if( !did_something )
+ {
+ while( outdex + 1 > retval_size )
+ {
+ retval_size *= 2;
+ retval = (char *)realloc(retval, retval_size);
+ }
+ retval[outdex++] = *haystack++;
+ }
+ }
+
+ bugout:
+ __gg__adjust_dest_size(dest, outdex);
+ memcpy(dest->data, retval, outdex);
+
+ free(pflasts);
+ free(retval);
+ }
+
+extern "C"
+void
+__gg__locale_compare( cblc_field_t *dest,
+ cblc_refer_t *arg1,
+ cblc_refer_t *arg2,
+ cblc_refer_t *arg_locale)
+ {
+ char achretval[2] = "?";
+
+ if( arg_locale && arg_locale->field )
+ {
+ // We don't yet know what to do with a locale
+ exception_raise(ec_locale_missing_e);
+ }
+ else
+ {
+ // Default locale
+ achretval[0] = '=';
+ size_t length = std::min(arg1->qual_size, arg2->qual_size);
+ for(size_t i=0; i<length; i++ )
+ {
+ if( arg1->qual_data[i] < arg2->qual_data[i] )
+ {
+ achretval[0] = '<';
+ break;
+ }
+ if( arg1->qual_data[i] > arg2->qual_data[i] )
+ {
+ achretval[0] = '>';
+ break;
+ }
+ }
+ if( achretval[0] == '=' )
+ {
+ if( arg1->qual_size < arg2->qual_size )
+ {
+ achretval[0] = '<';
+ }
+ else if( arg1->qual_size > arg2->qual_size )
+ {
+ achretval[0] = '>';
+ }
+ }
+ }
+
+ __gg__adjust_dest_size(dest, 1);
+ ascii_to_internal_str(achretval, 1);
+ dest->data[0] = *achretval;
+ }
+
+extern "C"
+void
+__gg__locale_date(cblc_field_t *dest,
+ cblc_refer_t *arg1,
+ cblc_refer_t *arg_locale)
+ {
+ char ach[256] = " ";
+
+ if( arg_locale && arg_locale->field )
+ {
+ // We don't yet know what to do with a locale
+ exception_raise(ec_locale_missing_e);
+ }
+ else
+ {
+ // Default locale
+ tm tm;
+ memcpy(ach, arg1->qual_data, 8);
+ ach[8] = '\0';
+ long ymd = atoi(ach);
+ tm.tm_year = ymd/10000 - 1900;
+ tm.tm_mon = ymd/100 % 100;
+ tm.tm_mday = ymd % 100;
+ strcpy(ach, nl_langinfo(D_FMT));
+ strftime(ach, sizeof(ach), nl_langinfo(D_FMT), &tm);
+ }
+
+ __gg__adjust_dest_size(dest, strlen(ach));
+ ascii_to_internal_str(ach, strlen(ach));
+ memcpy(dest->data, ach, strlen(ach));
+ }
+
+extern "C"
+void
+__gg__locale_time(cblc_field_t *dest,
+ cblc_refer_t *arg1,
+ cblc_refer_t *arg_locale)
+ {
+ char ach[256] = " ";
+
+ if( arg_locale && arg_locale->field )
+ {
+ // We don't yet know what to do with a locale
+ exception_raise(ec_locale_missing_e);
+ }
+ else
+ {
+ // Default locale
+ tm tm = {};
+ memcpy(ach, arg1->qual_data, 8);
+ ach[8] = '\0';
+ long hms = atoi(ach);
+ tm.tm_hour = hms/10000;
+ tm.tm_min = hms/100 % 100;
+ tm.tm_sec = hms % 100;
+ strftime(ach, sizeof(ach), nl_langinfo(T_FMT), &tm);
+ }
+
+ __gg__adjust_dest_size(dest, strlen(ach));
+ ascii_to_internal_str(ach, strlen(ach));
+ memcpy(dest->data, ach, strlen(ach));
+ }
+
+extern "C"
+void
+__gg__locale_time_from_seconds( cblc_field_t *dest,
+ cblc_refer_t *arg1,
+ cblc_refer_t *arg_locale)
+ {
+ char ach[256] = " ";
+
+ if( arg_locale && arg_locale->field )
+ {
+ // We don't yet know what to do with a locale
+ exception_raise(ec_locale_missing_e);
+ }
+ else
+ {
+ // Default locale
+ tm tm = {};
+
+ int rdigits;
+ long seconds = (long)__gg__binary_value_from_refer(&rdigits, arg1);
+ tm.tm_hour = seconds/3600;
+ tm.tm_min = ((seconds%3600) / 60) % 100;
+ tm.tm_sec = seconds % 100;
+ strftime(ach, sizeof(ach), nl_langinfo(T_FMT), &tm);
+ }
+
+ __gg__adjust_dest_size(dest, strlen(ach));
+ ascii_to_internal_str(ach, strlen(ach));
+ memcpy(dest->data, ach, strlen(ach));
+ }
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 6111989fa2180de83f6e6859dea977cddb4d1237..860e460c72158bbf7c6863168d6db58cd3ca5cd3 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -99,6 +99,7 @@ static const char *stashed_exception_source_file;
static int stashed_exception_line_number;
static const char *stashed_exception_statement;
+
int __gg__call_parameter_count = A_ZILLION;
static int sv_from_raise_statement = 0;
@@ -3945,8 +3946,6 @@ __gg__initialize_variable(cblc_refer_t *var_ref,
// Make a copy of the field pointer we're working with as a convenience:
cblc_field_t *var = var_ref->field;
- // fprintf(stderr, "__gg__initialize_variable %s\n", var->name);
-
// Set the "initialized" bit, which is tested in parser_symbol_add to make
// sure this code gets executed only once.
var->attr |= initialized_e;
@@ -6602,11 +6601,21 @@ __gg__display( cblc_refer_t *var,
static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
static char *display_string = (char *)MALLOC(display_string_size);
- format_for_display_internal(&display_string,
- &display_string_size,
- var->field,
- var->qual_data,
- var->qual_size );
+ // if( var->qual_data )
+ // {
+ format_for_display_internal(&display_string,
+ &display_string_size,
+ var->field,
+ var->qual_data,
+ var->qual_size );
+ // }
+ // else
+ // {
+ // // This can happen during TRACE1=2 with LOCAL=STORAGE
+ // char achmsg[] = "<NULL>";
+ // strcpy(display_string, achmsg);
+ // display_string_size = strlen(display_string);
+ // }
// Let's honor the locale of the system, as best we can:
static size_t converted_size = MINIMUM_ALLOCATION_SIZE;
@@ -6617,6 +6626,18 @@ __gg__display( cblc_refer_t *var,
ssize_t ss = write( file_descriptor,
converted,
strlen(converted));
+ if(ss == -1)
+ {
+ fprintf(stderr, "__gg__display() %s %p\n", var->field->name, var->qual_data);
+ fprintf(stderr, "__gg__display() %zd\n", converted_size);
+ fprintf(stderr, "__gg__display() ");
+ for(size_t i=0; i<converted_size; i++)
+ {
+ fprintf(stderr, "%c(%2.2x) ", converted[i]<32 ? '?' : converted[i], converted[i]);
+ }
+ fprintf(stderr, "\n");
+ }
+
assert(ss != -1);
if( advance )
@@ -8115,12 +8136,12 @@ __gg__routine_to_call(char *name,
}
extern "C"
-ssize_t
+__int128
__gg__fetch_call_by_value_value(cblc_refer_t *var)
{
int rdigits;
- ssize_t retval = 0;
+ __int128 retval = 0;
switch(var->field->type)
{
case FldGroup:
@@ -8143,7 +8164,7 @@ __gg__fetch_call_by_value_value(cblc_refer_t *var)
break;
case 16:
- *(double *)(&retval) = double(*(_Float128 *)var->qual_data);
+ *(_Float128 *)(&retval) = double(*(_Float128 *)var->qual_data);
break;
}
break;
@@ -8157,8 +8178,7 @@ __gg__fetch_call_by_value_value(cblc_refer_t *var)
case FldLiteralN:
case FldIndex:
case FldPointer:
- retval = (ssize_t) __gg__binary_value_from_refer(&rdigits,
- var);
+ retval = __gg__binary_value_from_refer(&rdigits, var);
default:
break;
}
@@ -8167,19 +8187,18 @@ __gg__fetch_call_by_value_value(cblc_refer_t *var)
extern "C"
void
-__gg__assign_value_from_stack(cblc_field_t *dest, size_t parameter)
+__gg__assign_value_from_stack(cblc_field_t *dest, __int128 parameter)
{
switch(dest->type)
{
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
+ case FldNumericEdited:
if( dest->capacity >= 1)
{
- memset(dest->data, internal_space, dest->capacity);
- // A single 8-bit character was placed in the 64-bit entry on the
- // stack.
- *(char *)dest->data = *(char *)parameter;
+ warnx("%s is not valid for BY VALUE", dest->name);
+ exit(1);
}
break;
@@ -8188,15 +8207,15 @@ __gg__assign_value_from_stack(cblc_field_t *dest, size_t parameter)
switch(dest->capacity)
{
case 4:
- *(float *)(dest->data) = *(float *)parameter;
+ *(float *)(dest->data) = *(float *)¶meter;
break;
case 8:
- *(double *)(dest->data) = *(double *)parameter;
+ *(double *)(dest->data) = *(double *)¶meter;
break;
case 16:
- *(_Float128 *)(dest->data) = *(_Float128 *)parameter;
+ *(_Float128 *)(dest->data) = *(_Float128 *)¶meter;
break;
}
break;
@@ -8206,7 +8225,6 @@ __gg__assign_value_from_stack(cblc_field_t *dest, size_t parameter)
case FldPacked:
case FldNumericBin5:
case FldNumericDisplay:
- case FldNumericEdited:
case FldLiteralN:
case FldIndex:
case FldPointer:
@@ -9060,11 +9078,10 @@ __gg__func_exception_location(cblc_field_t *dest)
}
else
{
- // In actual production, this should be a single space
- strcpy(ach, "<did you mean to turn LOCATION on?>");
+ strcpy(ach, " ");
}
- __gg__adjust_dest_size(dest, strlen(ach));
}
+ __gg__adjust_dest_size(dest, strlen(ach));
memcpy(dest->data, ach, strlen(ach));
}
@@ -9072,14 +9089,14 @@ extern "C"
void
__gg__func_exception_statement(cblc_field_t *dest)
{
- char ach[128];
+ char ach[128] = " ";
if(stashed_exception_statement)
{
snprintf(ach, sizeof(ach), "%s", stashed_exception_statement);
ach[sizeof(ach)-1] = '\0';
- __gg__adjust_dest_size(dest, strlen(ach));
- memcpy(dest->data, ach, strlen(ach));
}
+ __gg__adjust_dest_size(dest, strlen(ach));
+ memcpy(dest->data, ach, strlen(ach));
}
extern "C"
@@ -9099,15 +9116,13 @@ __gg__func_exception_status(cblc_field_t *dest)
}
p += 1;
}
- __gg__adjust_dest_size(dest, strlen(ach));
- memcpy(dest->data, ach, strlen(ach));
}
else
{
strcpy(ach, " ");
- __gg__adjust_dest_size(dest, strlen(ach));
- memcpy(dest->data, ach, strlen(ach));
}
+ __gg__adjust_dest_size(dest, strlen(ach));
+ memcpy(dest->data, ach, strlen(ach));
}
static cblc_file_t *recent_file = NULL;