diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.out b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.out new file mode 100644 index 00000000000..1d68884fb4d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.out @@ -0,0 +1,21 @@ +Alphanumeric literal 10 +" 8888 " +"8888 " +" 8888" +"8888" +National literal 20 +" 1616 " +"1616 " +" 1616" +"1616" +Alphanumeric data item 10 +" 8888 " +"8888 " +" 8888 " +"8888 " +National data item 20 +" 1616 " +"1616 " +" 1616 " +"1616 " + diff --git a/gcc/testsuite/cobol.dg/group2/Intrinsic_Function_ABS.cob b/gcc/testsuite/cobol.dg/group2/Intrinsic_Function_ABS.cob index a4b971f8cbe..b4d8b2187ce 100644 --- a/gcc/testsuite/cobol.dg/group2/Intrinsic_Function_ABS.cob +++ b/gcc/testsuite/cobol.dg/group2/Intrinsic_Function_ABS.cob @@ -16,6 +16,6 @@ END-IF. IF FUNCTION ABS(000.0) NOT EQUAL TO ZERO MOVE 1 TO RETURN-CODE - DISPLAY "FUNCTION ABS(-000.0) FAILS." + DISPLAY "FUNCTION ABS(000.0) FAILS." END-IF. diff --git a/gcc/testsuite/cobol.dg/group2/Large_PIC_10000000_.cob b/gcc/testsuite/cobol.dg/group2/Large_PIC_10000000_.cob new file mode 100644 index 00000000000..1cd78ed1a33 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Large_PIC_10000000_.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + *> { dg-output-file "group2/Large_PIC_10000000_.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 uppered pic x(10000000) value all "A". + 01 lowered pic x(10000000). + procedure division. + move function lower-case(uppered) to lowered + move 'X' to lowered(1:1) + move 'Z' to lowered(10000000:1) + display lowered(1:10) + display lowered(9999991:10) + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Large_PIC_10000000_.out b/gcc/testsuite/cobol.dg/group2/Large_PIC_10000000_.out new file mode 100644 index 00000000000..dad84c7016d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Large_PIC_10000000_.out @@ -0,0 +1,3 @@ +Xaaaaaaaaa +aaaaaaaaaZ + diff --git a/gcc/testsuite/cobol.dg/group2/Nested_PERFORM.cob b/gcc/testsuite/cobol.dg/group2/Nested_PERFORM.cob new file mode 100644 index 00000000000..e69e74b0e83 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Nested_PERFORM.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/Nested_PERFORM.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + PERFORM 2 TIMES + DISPLAY "X" NO ADVANCING + END-DISPLAY + PERFORM 2 TIMES + DISPLAY "Y" NO ADVANCING + END-DISPLAY + END-PERFORM + END-PERFORM. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Nested_PERFORM.out b/gcc/testsuite/cobol.dg/group2/Nested_PERFORM.out new file mode 100644 index 00000000000..3c3d159fa1a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Nested_PERFORM.out @@ -0,0 +1 @@ +XYYXYY diff --git a/gcc/testsuite/cobol.dg/group2/Overlapping_MOVE.cob b/gcc/testsuite/cobol.dg/group2/Overlapping_MOVE.cob new file mode 100644 index 00000000000..fd3cc8341ee --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Overlapping_MOVE.cob @@ -0,0 +1,28 @@ + *> { dg-do run } + *> { dg-output-file "group2/Overlapping_MOVE.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 structure. + 05 field1 pic x(5). + 05 field2 pic x(10). + procedure division. + move "Hallo" to field1. + move "1234567890" to field2. + *> The ISO specification says specifically that when an overlapping + *> move takes place in a single data descriptor, that it behaves + *> like a memmove(3), and not a memcopy(3): + move field2 to structure. + display """" structure """" + if field1 not = "12345" + display "error:1: " field1 + end-display + end-if + if field2 not = "67890 " + display "error:2: " field2 + end-display + end-if + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Overlapping_MOVE.out b/gcc/testsuite/cobol.dg/group2/Overlapping_MOVE.out new file mode 100644 index 00000000000..9a638557820 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Overlapping_MOVE.out @@ -0,0 +1,2 @@ +"1234567890 " + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_TIMES_subscripted.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_TIMES_subscripted.cob new file mode 100644 index 00000000000..2c1a0f34e8f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_TIMES_subscripted.cob @@ -0,0 +1,21 @@ + *> { dg-do run } + *> { dg-output-file "group2/PERFORM_TIMES_subscripted.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 idx pic 9. + 01 cnt-tab. + 05 cnt-val occurs 3 times pic 9. + procedure division. + move 1 to cnt-val (1) + move 2 to cnt-val (2) + move 3 to cnt-val (3) + perform varying idx from 1 by 1 until idx > 3 + perform cnt-val (idx) times + display idx + end-perform + end-perform + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_TIMES_subscripted.out b/gcc/testsuite/cobol.dg/group2/PERFORM_TIMES_subscripted.out new file mode 100644 index 00000000000..8f19cda69a9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_TIMES_subscripted.out @@ -0,0 +1,7 @@ +1 +2 +2 +3 +3 +3 + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_VARYING_BY_-0.2.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_VARYING_BY_-0.2.cob new file mode 100644 index 00000000000..3168d50b6dc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_VARYING_BY_-0.2.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + *> { dg-output-file "group2/PERFORM_VARYING_BY_-0.2.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 X PIC 9v9. + PROCEDURE DIVISION. + PERFORM VARYING X FROM 0.8 BY -0.2 + UNTIL X < 0.4 + DISPLAY "X" NO ADVANCING + END-DISPLAY + END-PERFORM. + IF X NOT = 0.2 + DISPLAY "WRONG X: " X END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_VARYING_BY_-0.2.out b/gcc/testsuite/cobol.dg/group2/PERFORM_VARYING_BY_-0.2.out new file mode 100644 index 00000000000..dd6d86a43dc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_VARYING_BY_-0.2.out @@ -0,0 +1 @@ +XXX diff --git a/gcc/testsuite/cobol.dg/group2/REDEFINES__chained.cob b/gcc/testsuite/cobol.dg/group2/REDEFINES__chained.cob new file mode 100644 index 00000000000..16a761b28e7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/REDEFINES__chained.cob @@ -0,0 +1,36 @@ + *> { dg-do run } + *> { dg-output-file "group2/REDEFINES__chained.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. chained_REDEFINES. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 REC. + 10 ZIP-9 PIC 9(9). + 10 ZIP-RED REDEFINES ZIP-9. + 12 ZIP-5 PIC 9(5). + 12 ZIP-PLUS-4 PIC 9(4). + 10 POSTAL-CORRECT-IND REDEFINES ZIP-9. + 12 FILLER PIC X(8). + 12 POST-CORRT-IND PIC X(1). + PROCEDURE DIVISION. + MOVE 123456789 TO ZIP-9 + DISPLAY """" ZIP-9 """" + IF ZIP-5 NOT = 12345 + DISPLAY "ZIP-5 wrong: " ZIP-5 + END-DISPLAY + END-IF + DISPLAY """" ZIP-PLUS-4 """" + IF ZIP-PLUS-4 NOT = 6789 + DISPLAY "ZIP-PLUS-4 wrong: " ZIP-PLUS-4 + END-DISPLAY + END-IF + MOVE "X" TO POST-CORRT-IND + DISPLAY """" ZIP-9 """" + DISPLAY """" POSTAL-CORRECT-IND """" + DISPLAY """" POST-CORRT-IND """" + IF POST-CORRT-IND NOT = "X" + DISPLAY "POST-CORRT-IND wrong: " POST-CORRT-IND + END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/REDEFINES__chained.out b/gcc/testsuite/cobol.dg/group2/REDEFINES__chained.out new file mode 100644 index 00000000000..56f7d295638 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/REDEFINES__chained.out @@ -0,0 +1,6 @@ +"123456789" +"6789" +"123456780" +"12345678X" +"X" + diff --git a/gcc/testsuite/cobol.dg/group2/RETURN-CODE_moving.cob b/gcc/testsuite/cobol.dg/group2/RETURN-CODE_moving.cob index 7d3c9956de3..a79e43b4110 100644 --- a/gcc/testsuite/cobol.dg/group2/RETURN-CODE_moving.cob +++ b/gcc/testsuite/cobol.dg/group2/RETURN-CODE_moving.cob @@ -1,5 +1,6 @@ *> { dg-do run } *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-options "-dialect ibm" } IDENTIFICATION DIVISION. PROGRAM-ID. prog. diff --git a/gcc/testsuite/cobol.dg/group2/RETURN-CODE_with_INITIAL_and_RECURSIVE.cob b/gcc/testsuite/cobol.dg/group2/RETURN-CODE_with_INITIAL_and_RECURSIVE.cob new file mode 100644 index 00000000000..904743ecbf3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/RETURN-CODE_with_INITIAL_and_RECURSIVE.cob @@ -0,0 +1,47 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + *> { dg-output-file "group2/RETURN-CODE_with_INITIAL_and_RECURSIVE.out" } + identification division. + program-id. prog. + procedure division. + display "prog starting return code should be +0000: " return-code + call "prog-a" + display "prog first return code from prog-a should be +0123: " return-code + call "prog-a" + display "prog second return code from prog-a should be +0246: " return-code + + call "prog-i" + display "prog first return code from prog-i should be +0321: " return-code + call "prog-i" + display "prog second return code from prog-i should be +0321: " return-code + + call "prog-r" + display "prog first return code from prog-r should be -0123: " return-code + call "prog-r" + display "prog second return code from prog-r should be -0123: " return-code + + move zero to return-code + goback. + end program prog. + + identification division. + program-id. prog-a. + procedure division. + add 123 to return-code + goback. + end program prog-a. + + identification division. + program-id. prog-i INITIAL. + procedure division. + add 321 to return-code + goback. + end program prog-i. + + identification division. + program-id. prog-r RECURSIVE. + procedure division. + add -123 to return-code + goback. + end program prog-r. + diff --git a/gcc/testsuite/cobol.dg/group2/RETURN-CODE_with_INITIAL_and_RECURSIVE.out b/gcc/testsuite/cobol.dg/group2/RETURN-CODE_with_INITIAL_and_RECURSIVE.out new file mode 100644 index 00000000000..0331bd354ce --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/RETURN-CODE_with_INITIAL_and_RECURSIVE.out @@ -0,0 +1,8 @@ +prog starting return code should be +0000: +0000 +prog first return code from prog-a should be +0123: +0123 +prog second return code from prog-a should be +0246: +0246 +prog first return code from prog-i should be +0321: +0321 +prog second return code from prog-i should be +0321: +0321 +prog first return code from prog-r should be -0123: -0123 +prog second return code from prog-r should be -0123: -0123 + diff --git a/gcc/testsuite/cobol.dg/group2/Sanity_check_for_ENTRY.cob b/gcc/testsuite/cobol.dg/group2/Sanity_check_for_ENTRY.cob new file mode 100644 index 00000000000..eb20f3d5224 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Sanity_check_for_ENTRY.cob @@ -0,0 +1,25 @@ + *> { dg-do run } + *> { dg-output-file "group2/Sanity_check_for_ENTRY.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 foo pic x(12). + procedure division. + loop. + go to dispatch. + dispatch. + go to pass_1. + pass_1. + display "I am the first pass" + alter dispatch to pass_2. + go to loop. + pass_2. + display "I am the second pass" + alter dispatch to pass_3. + go to loop. + pass_3. + display "I am the third and final pass" + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Sanity_check_for_ENTRY.out b/gcc/testsuite/cobol.dg/group2/Sanity_check_for_ENTRY.out new file mode 100644 index 00000000000..97fc5a0b450 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Sanity_check_for_ENTRY.out @@ -0,0 +1,4 @@ +I am the first pass +I am the second pass +I am the third and final pass + diff --git a/gcc/testsuite/cobol.dg/group2/Simple_COMP-X.cob b/gcc/testsuite/cobol.dg/group2/Simple_COMP-X.cob new file mode 100644 index 00000000000..c26a4da0b36 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Simple_COMP-X.cob @@ -0,0 +1,32 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/Simple_COMP-X.out" } + identification division. + program-id. compx. + data division. + working-storage section. + 01 byte. + 02 byte-val pic x(1) comp-x. + 01 short. + 02 short-val pic x(2) comp-x. + 01 long. + 02 long-val pic x(4) comp-x. + 01 longlong. + 02 longlong-val pic x(8) comp-x. + 01 sixteenbytes. + 02 sixteenbytes-val pic x(16) comp-x. + procedure division. + move high-values to byte short long longlong sixteenbytes + display function hex-of(byte) + display function hex-of(short) + display function hex-of(long) + display function hex-of(longlong) + display function hex-of(sixteenbytes) + display "byte-val is: " byte-val. + display "short-val is: " short-val. + display "long-val is: " long-val. + display "longlong-val is: " longlong-val. + display "sixteenbytes-val is: " sixteenbytes-val. + goback. + end program compx. + diff --git a/gcc/testsuite/cobol.dg/group2/Simple_COMP-X.out b/gcc/testsuite/cobol.dg/group2/Simple_COMP-X.out new file mode 100644 index 00000000000..f88e182cb5b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Simple_COMP-X.out @@ -0,0 +1,11 @@ +FF +FFFF +FFFFFFFF +FFFFFFFFFFFFFFFF +FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF +byte-val is: 255 +short-val is: 65535 +long-val is: 4294967295 +longlong-val is: 8446744073709551615 +sixteenbytes-val is: 340282366920938463463374607431768211455 + diff --git a/gcc/testsuite/cobol.dg/group2/compare_alpha_to_all__literal_.cob b/gcc/testsuite/cobol.dg/group2/compare_alpha_to_all__literal_.cob new file mode 100644 index 00000000000..1687585e724 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/compare_alpha_to_all__literal_.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/compare_alpha_to_all__literal_.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 var1 pic x(64) value all "Bob". + procedure division. + if var1 equal all "Bob" + display "It's all Bob." + else + display "It's not Bob." + end-if + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/compare_alpha_to_all__literal_.out b/gcc/testsuite/cobol.dg/group2/compare_alpha_to_all__literal_.out new file mode 100644 index 00000000000..e5cebef4065 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/compare_alpha_to_all__literal_.out @@ -0,0 +1,2 @@ +It's all Bob. + diff --git a/gcc/testsuite/cobol.dg/group2/compare_national_to_display.cob b/gcc/testsuite/cobol.dg/group2/compare_national_to_display.cob new file mode 100644 index 00000000000..d34cd8b4f64 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/compare_national_to_display.cob @@ -0,0 +1,58 @@ + *> { dg-do run } + *> { dg-output-file "group2/compare_national_to_display.out" } + identification division. + program-id. prog. + environment division. + configuration section. + special-names. + locale greek is "cyrillic" + locale unicode is "utf16le". + object-computer. + xerox-parc-star + character classification + for alphanumeric is greek + for national is unicode. + data division. + working-storage section. + 01 aaa pic x(16). + 01 bbb pic n(16). + procedure division. + move "aaa" to aaa + move n"aaa" to bbb + if aaa equal bbb + display "1 - correct" + else + display "1 -- bad" + end-if + if bbb equal aaa + display "2 - correct" + else + display "2 -- bad" + end-if + move "aaa" to aaa + move n"bbb" to bbb + if aaa < bbb + display "3 - correct" + else + display "3 -- bad" + end-if + if bbb > aaa + display "4 - correct" + else + display "4 -- bad" + end-if + move "bbb" to aaa + move n"aaa" to bbb + if aaa > bbb + display "5 - correct" + else + display "5 -- bad" + end-if + if bbb < aaa + display "6 - correct" + else + display "6 -- bad" + end-if + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/compare_national_to_display.out b/gcc/testsuite/cobol.dg/group2/compare_national_to_display.out new file mode 100644 index 00000000000..05de6222e51 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/compare_national_to_display.out @@ -0,0 +1,7 @@ +1 - correct +2 - correct +3 - correct +4 - correct +5 - correct +6 - correct + diff --git a/gcc/testsuite/cobol.dg/group2/comprensive_compare_comp-1_comp-5.cob b/gcc/testsuite/cobol.dg/group2/comprensive_compare_comp-1_comp-5.cob new file mode 100644 index 00000000000..7f9d4517c50 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/comprensive_compare_comp-1_comp-5.cob @@ -0,0 +1,107 @@ + *> { dg-do run } + *> { dg-output-file "group2/comprensive_compare_comp-1_comp-5.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 aaa comp-1. + 01 bbb pic S999 comp-5. + 01 known pic xxxx. + 01 result pic xxxx. + procedure division. + move -1 to aaa move 1 to bbb move ".lt." to known + perform checker. + move 1 to aaa move 1 to bbb move ".eq." to known + perform checker. + move 1 to aaa move -1 to bbb move ".gt." to known + perform checker. + goback. + checker. + display "checking " space aaa space known space bbb + perform lt + perform le + perform eq + perform ge + perform gt + perform ne + continue. + lt. + display " .lt. " with no advancing + move "xxxx" to result + evaluate true + when known equal ".lt." if aaa < bbb move "Good" to result + else move "BAD!" to result end-if + when known equal ".eq." if aaa < bbb move "BAD!" to result + else move "Good" to result end-if + when known equal ".gt." if aaa < bbb move "BAD!" to result + else move "Good" to result end-if + end-evaluate + display space result + continue. + le. + display " .le. " with no advancing + move "xxxx" to result + evaluate true + when known equal ".lt." if aaa <= bbb + move "Good" to result else move "BAD!" to result end-if + when known equal ".eq." if aaa <= bbb + move "Good" to result else move "BAD!" to result end-if + when known equal ".gt." if aaa <= bbb + move "BAD!" to result else move "Good" to result end-if + end-evaluate + display space result + continue. + eq. + display " .eq. " with no advancing + move "xxxx" to result + evaluate true + when known equal ".lt." if aaa = bbb + move "BAD!" to result else move "Good" to result end-if + when known equal ".eq." if aaa = bbb + move "Good" to result else move "BAD!" to result end-if + when known equal ".gt." if aaa = bbb + move "BAD!" to result else move "Good" to result end-if + end-evaluate + display space result + continue. + ge. + display " .ge. " with no advancing + move "xxxx" to result + evaluate true + when known equal ".lt." if aaa >= bbb + move "BAD!" to result else move "Good" to result end-if + when known equal ".eq." if aaa >= bbb + move "Good" to result else move "BAD!" to result end-if + when known equal ".gt." if aaa >= bbb + move "Good" to result else move "BAD!" to result end-if + end-evaluate + display space result + continue. + gt. + display " .gt. " with no advancing + move "xxxx" to result + evaluate true + when known equal ".lt." if aaa > bbb + move "BAD!" to result else move "Good" to result end-if + when known equal ".eq." if aaa > bbb + move "BAD!" to result else move "Good" to result end-if + when known equal ".gt." if aaa > bbb + move "Good" to result else move "BAD!" to result end-if + end-evaluate + display space result + continue. + ne. + display " .ne. " with no advancing + move "xxxx" to result + evaluate true + when known equal ".lt." if aaa <> bbb + move "Good" to result else move "BAD!" to result end-if + when known equal ".eq." if aaa <> bbb + move "BAD!" to result else move "Good" to result end-if + when known equal ".gt." if aaa <> bbb + move "Good" to result else move "BAD!" to result end-if + end-evaluate + display space result + continue. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/comprensive_compare_comp-1_comp-5.out b/gcc/testsuite/cobol.dg/group2/comprensive_compare_comp-1_comp-5.out new file mode 100644 index 00000000000..bef4cbbf92d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/comprensive_compare_comp-1_comp-5.out @@ -0,0 +1,22 @@ +checking -1 .lt. +001 + .lt. Good + .le. Good + .eq. Good + .ge. Good + .gt. Good + .ne. Good +checking 1 .eq. +001 + .lt. Good + .le. Good + .eq. Good + .ge. Good + .gt. Good + .ne. Good +checking 1 .gt. -001 + .lt. Good + .le. Good + .eq. Good + .ge. Good + .gt. Good + .ne. Good + diff --git a/gcc/testsuite/cobol.dg/group2/refmod_with_nested_parentheses.cob b/gcc/testsuite/cobol.dg/group2/refmod_with_nested_parentheses.cob new file mode 100644 index 00000000000..02ab56d0cfd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/refmod_with_nested_parentheses.cob @@ -0,0 +1,20 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + *> { dg-output-file "group2/refmod_with_nested_parentheses.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. refmod_nested_paren_expr. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TXT PIC X(10) VALUE 'ABCDEFGHIJ'. + 01 N PIC 9 VALUE 2. + 01 OUT-CH PIC X. + 01 stride PIC 9. + PROCEDURE DIVISION. + *> LENGTH OF is bytes, so we need stride to handle UTF-16 + move length of out-ch to stride + display TXT(((LENGTH OF TXT / (2*stride)) - (N / 2)):1) + MOVE TXT(((LENGTH OF TXT / (2*stride)) - (N / 2)):1) + TO OUT-CH + display OUT-CH + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/refmod_with_nested_parentheses.out b/gcc/testsuite/cobol.dg/group2/refmod_with_nested_parentheses.out new file mode 100644 index 00000000000..1fc2ca8e9de --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/refmod_with_nested_parentheses.out @@ -0,0 +1,3 @@ +D +D + diff --git a/gcc/testsuite/cobol.dg/group2/signed_unsigned_compare.cob b/gcc/testsuite/cobol.dg/group2/signed_unsigned_compare.cob new file mode 100644 index 00000000000..bc66e7362dd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/signed_unsigned_compare.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + *> { dg-output-file "group2/signed_unsigned_compare.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 aaa binary-long signed value -1. + 01 bbb binary-long unsigned value 1. + procedure division. + if aaa < bbb + display "-1 is properly .LT. than +1" + else + display "-1 is IMPROPERLY .GE. than +1" + end-if + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/signed_unsigned_compare.out b/gcc/testsuite/cobol.dg/group2/signed_unsigned_compare.out new file mode 100644 index 00000000000..b2d25c4482f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/signed_unsigned_compare.out @@ -0,0 +1,2 @@ +-1 is properly .LT. than +1 + diff --git a/libgcobol/charmaps.h b/libgcobol/charmaps.h index 477553cd370..5c0af01f921 100644 --- a/libgcobol/charmaps.h +++ b/libgcobol/charmaps.h @@ -536,7 +536,7 @@ class charmap_t switch(figconst) { case normal_value_e : - abort(); + // Just leave it at zero break; case low_value_e : const_char = low_value_character(); diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h index 5cc341c4669..fe3ec7b3265 100644 --- a/libgcobol/common-defs.h +++ b/libgcobol/common-defs.h @@ -160,6 +160,11 @@ enum cbl_field_type_t { FldPointer, }; +/* In some places, I use SUPERTYPE for things like MOVES and COMPARES to + avoid lots of conditionals or complex multi-level switch() statements. */ + +#define SUPERTYPE(a, b) ((static_cast(a)<<5)+(static_cast(b))) + /* BINARY, COMP, COMPUTATIONAL, COMP-4, COMPUTATIONAL-4 are the same: * Storage, by default, is big-endian. @@ -427,7 +432,7 @@ cbl_file_mode_str( cbl_file_mode_t mode ) { case file_mode_any_e: return "file_mode_any_e"; } return "???"; -}; +} enum module_type_t { module_activating_e, diff --git a/libgcobol/gcobolio.h b/libgcobol/gcobolio.h index e97803ee50b..13e3160c958 100644 --- a/libgcobol/gcobolio.h +++ b/libgcobol/gcobolio.h @@ -65,6 +65,21 @@ typedef struct cblc_field_t int alphabet; // Same as cbl_field_t::codeset::language } cblc_field_t; +typedef struct cblc_referlet_t + { + cblc_field_t *field; + size_t offset; + size_t size; + } cblc_referlet_t; + +typedef struct cblc_refer_t + { + cblc_field_t *field; + size_t offset; + size_t size; + int flags; + } cblc_refer_t; + /* * Implementation details */ @@ -133,26 +148,4 @@ typedef struct cblc_file_t int alphabet; // Actually cbl_encoding_t } cblc_file_t; - -/* In various arithmetic routines implemented in libgcobol, it is oftent the - case that complicates lists of variables need to be conveyed. For example, - "ADD A B C D GIVING E" and "ADD A TO B C D" are valid instructions. - - These treeplets (triplets of trees) were created to handle that. */ - -extern cblc_field_t ** __gg__treeplet_1f; -extern size_t * __gg__treeplet_1o; -extern size_t * __gg__treeplet_1s; -extern cblc_field_t ** __gg__treeplet_2f; -extern size_t * __gg__treeplet_2o; -extern size_t * __gg__treeplet_2s; -extern cblc_field_t ** __gg__treeplet_3f; -extern size_t * __gg__treeplet_3o; -extern size_t * __gg__treeplet_3s; -extern cblc_field_t ** __gg__treeplet_4f; -extern size_t * __gg__treeplet_4o; -extern size_t * __gg__treeplet_4s; - -extern int * __gg__fourplet_flags; - #endif diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index 9419986d9be..105d79e030e 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -257,25 +257,18 @@ extern "C" void __gg__pow( cbl_arith_format_t, size_t, + const cblc_referlet_t *A, size_t, + const cblc_referlet_t *B, size_t, + const cblc_referlet_t *C, const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; - const size_t *A_o = __gg__treeplet_1o; - const size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; - const size_t *B_o = __gg__treeplet_2o; - const size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - - GCOB_FP128 avalue = __gg__float128_from_qualified_field(A[0], A_o[0], A_s[0]); - GCOB_FP128 bvalue = __gg__float128_from_qualified_field(B[0], B_o[0], B_s[0]); + GCOB_FP128 avalue = __gg__float128_from_qualified_field(A[0].field, A[0].offset, A[0].size); + GCOB_FP128 bvalue = __gg__float128_from_qualified_field(B[0].field, B[0].offset, B[0].size); GCOB_FP128 tgt_value; if( avalue == 0 && bvalue == 0 ) @@ -310,9 +303,9 @@ __gg__pow( cbl_arith_format_t, } if( !(*compute_error & compute_error_exp_minus_by_frac) ) { - *compute_error |= conditional_stash(C[0], - C_o[0], - C_s[0], + *compute_error |= conditional_stash(C[0].field, + C[0].offset, + C[0].size, (on_error_flag & ON_SIZE_ERROR), tgt_value, *rounded); @@ -584,8 +577,11 @@ extern "C" void __gg__add_fixed_phase1( cbl_arith_format_t , size_t nA, + const cblc_referlet_t *AA, size_t , + cblc_referlet_t *, size_t , + cblc_referlet_t *, const cbl_round_t *, int , int *compute_error @@ -595,12 +591,8 @@ __gg__add_fixed_phase1( cbl_arith_format_t , // The result goes into the temporary phase1_result. - cblc_field_t **A = __gg__treeplet_1f; - const size_t *A_o = __gg__treeplet_1o; - const size_t *A_s = __gg__treeplet_1s; - // Let us prime the pump with the first value of A[] - get_int256_from_qualified_field(phase1_result, phase1_rdigits, A[0], A_o[0], A_s[0]); + get_int256_from_qualified_field(phase1_result, phase1_rdigits, AA[0].field, AA[0].offset, AA[0].size); // We now go into a loop adding each of the A[] values to phase1_result: @@ -608,7 +600,7 @@ __gg__add_fixed_phase1( cbl_arith_format_t , { int temp_rdigits; int256 temp = {}; - get_int256_from_qualified_field(temp, temp_rdigits, A[i], A_o[i], A_s[i]); + get_int256_from_qualified_field(temp, temp_rdigits, AA[i].field, AA[i].offset, AA[i].size); // We have to scale the one with fewer rdigits to match the one with greater // rdigits: @@ -640,23 +632,22 @@ extern "C" void __gg__addf1_fixed_phase2( cbl_arith_format_t , size_t , + cblc_referlet_t *, size_t , + cblc_referlet_t *, size_t , + const cblc_referlet_t *C, const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - // This is the assignment phase of an ADD Format 1 // We take phase1_result and accumulate it into C bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); - if( C[0]->type == FldFloat) + if( C[0].field->type == FldFloat) { // The target we need to accumulate into is a floating-point number, so we // need to convert our fixed-point intermediate into floating point and @@ -667,12 +658,16 @@ __gg__addf1_fixed_phase2( cbl_arith_format_t , value_a /= __gg__power_of_ten(phase1_rdigits); // Pick up the target - GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[0], C_o[0], C_s[0]); + GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); value_a += value_b; // At this point, we assign running_sum to *C. - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, + C[0].offset, + C[0].size, on_size_error, value_a, *rounded++); @@ -687,10 +682,14 @@ __gg__addf1_fixed_phase2( cbl_arith_format_t , int256 value_b = {}; int rdigits_b; - get_int256_from_qualified_field(value_b, rdigits_b, C[0], C_o[0], C_s[0]); + get_int256_from_qualified_field(value_b, + rdigits_b, + C[0].field, + C[0].offset, + C[0].size); - // We have to scale the one with fewer rdigits to match the one with greater - // rdigits: + // We have to scale the one with fewer rdigits to match the one with + // greater rdigits: if( rdigits_a > rdigits_b ) { scale_int256_by_digits(value_b, rdigits_a - rdigits_b); @@ -712,7 +711,9 @@ __gg__addf1_fixed_phase2( cbl_arith_format_t , } // At this point, we assign running_sum to *C. - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, + C[0].offset, + C[0].size, on_size_error, value_a.i128[0], rdigits_a, @@ -724,8 +725,11 @@ extern "C" void __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , size_t , + cblc_referlet_t *, size_t , + cblc_referlet_t *, size_t , + const cblc_referlet_t *CC, const cbl_round_t *rounded, int on_error_flag, int *compute_error @@ -733,15 +737,10 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , { // This is the assignment phase of an ADD or SUBTRACT Format 2 - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - - // We take phase1_result and put it into C bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); - if( C[0]->type == FldFloat) + if( CC[0].field->type == FldFloat) { // The target we need to accumulate into is a floating-point number, so we // need to convert our fixed-point intermediate into floating point and @@ -751,7 +750,7 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , GCOB_FP128 value_a = (GCOB_FP128)phase1_result.i128[0]; value_a /= __gg__power_of_ten(phase1_rdigits); - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(CC[0].field, CC[0].offset, CC[0].size, on_size_error, value_a, *rounded++); @@ -769,7 +768,7 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , *compute_error |= compute_error_overflow; } - if( C[0]->type == FldPointer ) + if( CC[0].field->type == FldPointer ) { // In case somebody does pointer arithmetic that goes negative, we need // to make the top 64 bits positive. Otherwise, the conditional stash @@ -779,7 +778,7 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , } // At this point, we assign that value to *C. - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(CC[0].field, CC[0].offset, CC[0].size, on_size_error, value_a.i128[0], rdigits_a, @@ -791,8 +790,11 @@ extern "C" void __gg__add_float_phase1( cbl_arith_format_t , size_t nA, + const cblc_referlet_t *A, size_t , + cblc_referlet_t *, size_t , + cblc_referlet_t *, const cbl_round_t *, int , int *compute_error @@ -802,18 +804,14 @@ __gg__add_float_phase1( cbl_arith_format_t , // The result goes into the temporary phase1_result_ffloat. - cblc_field_t **A = __gg__treeplet_1f; - const size_t *A_o = __gg__treeplet_1o; - const size_t *A_s = __gg__treeplet_1s; - // Let us prime the pump with the first value of A[] - phase1_result_float = __gg__float128_from_qualified_field(A[0], A_o[0], A_s[0]); + phase1_result_float = __gg__float128_from_qualified_field(A[0].field, A[0].offset, A[0].size); // We now go into a loop adding each of the A[] values to phase1_result_flt: for( size_t i=1; itype == FldFloat || C[i]->type == FldFloat ) + if( A[i].field->type == FldFloat || C[i].field->type == FldFloat ) { - GCOB_FP128 value_a = __gg__float128_from_qualified_field(A[i], A_o[i], A_s[i]); - GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[i], C_o[i], C_s[i]); + GCOB_FP128 value_a = __gg__float128_from_qualified_field(A[i].field, A[i].offset, A[i].size); + GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[i].field, C[i].offset, C[i].size); value_a = addition_helper_float(value_a, value_b, compute_error); // At this point, we assign the sum to *C. - *compute_error |= conditional_stash(C[i], C_o[i], C_s[i], + *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, value_a, *rounded++); @@ -920,8 +911,8 @@ __gg__addf3(cbl_arith_format_t , int256 value_b; int rdigits_b; - get_int256_from_qualified_field(value_a, rdigits_a, A[i], A_o[i], A_s[i]); - get_int256_from_qualified_field(value_b, rdigits_b, C[i], C_o[i], C_s[i]); + get_int256_from_qualified_field(value_a, rdigits_a, A[i].field, A[i].offset, A[i].size); + get_int256_from_qualified_field(value_b, rdigits_b, C[i].field, C[i].offset, C[i].size); // We have to scale the one with fewer rdigits to match the one with greater // rdigits: @@ -946,7 +937,7 @@ __gg__addf3(cbl_arith_format_t , } // At this point, we assign the sum to *C. - *compute_error |= conditional_stash(C[i], C_o[i], C_s[i], + *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, value_a.i128[0], rdigits_a, @@ -959,23 +950,22 @@ extern "C" void __gg__subtractf1_fixed_phase2(cbl_arith_format_t , size_t , + cblc_referlet_t *, size_t , + cblc_referlet_t *, size_t , + const cblc_referlet_t *C, const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - // This is the assignment phase of an ADD Format 1 // We take phase1_result and subtrace it from C bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); - if( C[0]->type == FldFloat) + if( C[0].field->type == FldFloat) { // The target we need to accumulate into is a floating-point number, so we // need to convert our fixed-point intermediate into floating point and @@ -986,12 +976,12 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , value_a /= __gg__power_of_ten(phase1_rdigits); // Pick up the target - GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[0], C_o[0], C_s[0]); + GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); value_b -= value_a; // At this point, we assign the difference to *C. - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, value_b, *rounded++); @@ -1006,7 +996,7 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , int256 value_b = {}; int rdigits_b; - get_int256_from_qualified_field(value_b, rdigits_b, C[0], C_o[0], C_s[0]); + get_int256_from_qualified_field(value_b, rdigits_b, C[0].field, C[0].offset, C[0].size); // We have to scale the one with fewer rdigits to match the one with greater // rdigits: @@ -1031,7 +1021,7 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , } // At this point, we assign running_sum to *C. - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, value_b.i128[0], rdigits_b, @@ -1043,8 +1033,11 @@ extern "C" void __gg__subtractf2_fixed_phase1(cbl_arith_format_t , size_t nA, + const cblc_referlet_t *AA, size_t , + const cblc_referlet_t *BB, size_t , + cblc_referlet_t *, const cbl_round_t *rounded, int on_error_flag, int *compute_error @@ -1052,15 +1045,14 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , { // This is the calculation phase of a fixed-point SUBTRACT Format 2 - cblc_field_t **B = __gg__treeplet_2f; - const size_t *B_o = __gg__treeplet_2o; - const size_t *B_s = __gg__treeplet_2s; - // Add up all the A values __gg__add_fixed_phase1( not_expected_e , nA, + AA, 0, + NULL, 0, + NULL, rounded, on_error_flag, compute_error); @@ -1073,7 +1065,7 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , int256 value_b = {}; int rdigits_b; - get_int256_from_qualified_field(value_b, rdigits_b, B[0], B_o[0], B_s[0]); + get_int256_from_qualified_field(value_b, rdigits_b, BB[0].field, BB[0].offset, BB[0].size); // We have to scale the one with fewer rdigits to match the one with greater // rdigits: @@ -1104,24 +1096,23 @@ extern "C" void __gg__subtractf1_float_phase2(cbl_arith_format_t , size_t , + cblc_referlet_t *, size_t , + cblc_referlet_t *, size_t , + const cblc_referlet_t *C, const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); // This is the assignment phase of an SUBTRACT Format 2 // We take phase1_result and subtract it from C - GCOB_FP128 temp = __gg__float128_from_qualified_field(C[0], C_o[0], C_s[0]); + GCOB_FP128 temp = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); temp = subtraction_helper_float(temp, phase1_result_float, compute_error); - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, temp, *rounded++); @@ -1131,8 +1122,11 @@ extern "C" void __gg__subtractf2_float_phase1(cbl_arith_format_t , size_t nA, + const cblc_referlet_t *A, size_t , + const cblc_referlet_t *B, size_t , + cblc_referlet_t *, const cbl_round_t *rounded, int on_error_flag, int *compute_error @@ -1140,24 +1134,21 @@ __gg__subtractf2_float_phase1(cbl_arith_format_t , { // This is the calculation phase of a fixed-point SUBTRACT Format 2 - cblc_field_t **B = __gg__treeplet_2f; - const size_t *B_o = __gg__treeplet_2o; - const size_t *B_s = __gg__treeplet_2s; - // Add up all the A values __gg__add_float_phase1( not_expected_e , nA, + A, 0, + NULL, 0, + NULL, rounded, on_error_flag, compute_error ); // Subtract that subtotal from the B value: - GCOB_FP128 value_b = __gg__float128_from_qualified_field(B[0], B_o[0], B_s[0]); - - + GCOB_FP128 value_b = __gg__float128_from_qualified_field(B[0].field, B[0].offset, B[0].size); phase1_result_float = subtraction_helper_float(value_b, phase1_result_float, compute_error); } @@ -1165,8 +1156,11 @@ extern "C" void __gg__subtractf3( cbl_arith_format_t , size_t nA, + const cblc_referlet_t *A, size_t , + cblc_referlet_t *, size_t , + const cblc_referlet_t *C, const cbl_round_t *rounded, int on_error_flag, int *compute_error @@ -1175,26 +1169,19 @@ __gg__subtractf3( cbl_arith_format_t , // This is an ADD Format 3. Each A[i] gets accumulated into each C[i]. Each // SUBTRACTION is treated separately. - cblc_field_t **A = __gg__treeplet_1f; - const size_t *A_o = __gg__treeplet_1o; - const size_t *A_s = __gg__treeplet_1s; - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); for(size_t i=0; itype == FldFloat || C[i]->type == FldFloat) + if( A[i].field->type == FldFloat || C[i].field->type == FldFloat) { - GCOB_FP128 value_a = __gg__float128_from_qualified_field(A[i], A_o[i], A_s[i]); - GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[i], C_o[i], C_s[i]); + GCOB_FP128 value_a = __gg__float128_from_qualified_field(A[i].field, A[i].offset, A[i].size); + GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[i].field, C[i].offset, C[i].size); value_b = subtraction_helper_float(value_b, value_a, compute_error); // At this point, we assign the sum to *C. - *compute_error |= conditional_stash(C[i], C_o[i], C_s[i], + *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, value_b, *rounded++); @@ -1208,8 +1195,8 @@ __gg__subtractf3( cbl_arith_format_t , int256 value_b; int rdigits_b; - get_int256_from_qualified_field(value_a, rdigits_a, A[i], A_o[i], A_s[i]); - get_int256_from_qualified_field(value_b, rdigits_b, C[i], C_o[i], C_s[i]); + get_int256_from_qualified_field(value_a, rdigits_a, A[i].field, A[i].offset, A[i].size); + get_int256_from_qualified_field(value_b, rdigits_b, C[i].field, C[i].offset, C[i].size); // We have to scale the one with fewer rdigits to match the one with greater // rdigits: @@ -1235,7 +1222,7 @@ __gg__subtractf3( cbl_arith_format_t , } // At this point, we assign the sum to *C. - *compute_error |= conditional_stash(C[i], C_o[i], C_s[i], + *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, value_b.i128[0], rdigits_b, @@ -1253,8 +1240,11 @@ extern "C" void __gg__multiplyf1_phase1(cbl_arith_format_t , size_t , + const cblc_referlet_t *A, size_t , + cblc_referlet_t *, size_t , + cblc_referlet_t *, const cbl_round_t *, int , int *) @@ -1262,25 +1252,21 @@ __gg__multiplyf1_phase1(cbl_arith_format_t , // We are getting just the one value, which we are converting to the necessary // intermediate form - cblc_field_t **A = __gg__treeplet_1f; - const size_t *A_o = __gg__treeplet_1o; - const size_t *A_s = __gg__treeplet_1s; - - if( A[0]->type == FldFloat ) + if( A[0].field->type == FldFloat ) { multiply_intermediate_is_float = true; - multiply_intermediate_float = __gg__float128_from_qualified_field(A[0], - A_o[0], - A_s[0]); + multiply_intermediate_float = __gg__float128_from_qualified_field(A[0].field, + A[0].offset, + A[0].size); } else { multiply_intermediate_is_float = false; multiply_intermediate_int128 = __gg__binary_value_from_qualified_field(&multiply_intermediate_rdigits, - A[0], - A_o[0], - A_s[0]); + A[0].field, + A[0].offset, + A[0].size); } } @@ -1348,17 +1334,16 @@ extern "C" void __gg__multiplyf1_phase2(cbl_arith_format_t , size_t , + cblc_referlet_t *, size_t , + cblc_referlet_t *, size_t , + const cblc_referlet_t *C, const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; @@ -1368,21 +1353,21 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , if( multiply_intermediate_is_float ) { a_value = multiply_intermediate_float; - if( C[0]->type == FldFloat ) + if( C[0].field->type == FldFloat ) { - b_value = __gg__float128_from_qualified_field(C[0], C_o[0], C_s[0]); + b_value = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); goto float_float; } else { // float times fixed - b_value = __gg__float128_from_qualified_field(C[0], C_o[0], C_s[0]); + b_value = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); goto float_float; } } else { - if( C[0]->type == FldFloat ) + if( C[0].field->type == FldFloat ) { // fixed * float a_value = (GCOB_FP128) multiply_intermediate_int128; @@ -1390,7 +1375,7 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , { a_value /= (GCOB_FP128)__gg__power_of_ten(multiply_intermediate_rdigits); } - b_value = __gg__float128_from_qualified_field(C[0], C_o[0], C_s[0]); + b_value = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); goto float_float; } else @@ -1402,7 +1387,7 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , int cd_rdigits; __int128 ab_value = multiply_intermediate_int128; - __int128 cd_value = __gg__binary_value_from_qualified_field(&cd_rdigits, C[0], C_o[0], C_s[0]); + __int128 cd_value = __gg__binary_value_from_qualified_field(&cd_rdigits, C[0].field, C[0].offset, C[0].size); int256 ABCD; int rdigits = multiply_intermediate_rdigits + cd_rdigits; @@ -1415,7 +1400,7 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , *compute_error |= compute_error_overflow; } // At this point, we assign running_sum to *C. - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, ABCD.i128[0], rdigits, @@ -1434,7 +1419,7 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , } else { - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, a_value, *rounded); @@ -1447,23 +1432,16 @@ extern "C" void __gg__multiplyf2( cbl_arith_format_t , size_t , + const cblc_referlet_t *A, size_t , + const cblc_referlet_t *B, size_t nC, + const cblc_referlet_t *C, const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; - const size_t *A_o = __gg__treeplet_1o; - const size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; - const size_t *B_o = __gg__treeplet_2o; - const size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); bool got_float = false; @@ -1471,10 +1449,10 @@ __gg__multiplyf2( cbl_arith_format_t , int256 product_fix; int product_fix_digits; - if( A[0]->type == FldFloat || B[0]->type == FldFloat ) + if( A[0].field->type == FldFloat || B[0].field->type == FldFloat ) { - GCOB_FP128 a_value = __gg__float128_from_qualified_field(A[0], A_o[0], A_s[0]); - GCOB_FP128 b_value = __gg__float128_from_qualified_field(B[0], B_o[0], B_s[0]); + GCOB_FP128 a_value = __gg__float128_from_qualified_field(A[0].field, A[0].offset, A[0].size); + GCOB_FP128 b_value = __gg__float128_from_qualified_field(B[0].field, B[0].offset, B[0].size); product_float = multiply_helper_float(a_value, b_value, compute_error); got_float = true; } @@ -1482,8 +1460,8 @@ __gg__multiplyf2( cbl_arith_format_t , { int a_rdigits; int b_rdigits; - __int128 a_value = __gg__binary_value_from_qualified_field(&a_rdigits, A[0], A_o[0], A_s[0]); - __int128 b_value = __gg__binary_value_from_qualified_field(&b_rdigits, B[0], B_o[0], B_s[0]); + __int128 a_value = __gg__binary_value_from_qualified_field(&a_rdigits, A[0].field, A[0].offset, A[0].size); + __int128 b_value = __gg__binary_value_from_qualified_field(&b_rdigits, B[0].field, B[0].offset, B[0].size); product_fix_digits = a_rdigits + b_rdigits; multiply_int128_by_int128(product_fix, a_value, b_value); int overflow = squeeze_int256(product_fix, product_fix_digits); @@ -1497,14 +1475,14 @@ __gg__multiplyf2( cbl_arith_format_t , { if( got_float ) { - *compute_error |= conditional_stash(C[i], C_o[i], C_s[i], + *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, product_float, *rounded++); } else { - *compute_error |= conditional_stash(C[i], C_o[i], C_s[i], + *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, product_fix.i128[0], product_fix_digits, @@ -1829,17 +1807,16 @@ extern "C" void __gg__dividef1_phase2(cbl_arith_format_t , size_t , + cblc_referlet_t *, size_t , + cblc_referlet_t *, size_t , + const cblc_referlet_t *C, const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; @@ -1849,21 +1826,25 @@ __gg__dividef1_phase2(cbl_arith_format_t , if( multiply_intermediate_is_float ) { a_value = multiply_intermediate_float; - if( C[0]->type == FldFloat ) + if( C[0].field->type == FldFloat ) { - b_value = __gg__float128_from_qualified_field(C[0], C_o[0], C_s[0]); + b_value = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); goto float_float; } else { // float times fixed - b_value = __gg__float128_from_qualified_field(C[0], C_o[0], C_s[0]); + b_value = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); goto float_float; } } else { - if( C[0]->type == FldFloat ) + if( C[0].field->type == FldFloat ) { // gixed * float a_value = (GCOB_FP128) multiply_intermediate_int128; @@ -1871,7 +1852,9 @@ __gg__dividef1_phase2(cbl_arith_format_t , { a_value /= (GCOB_FP128)__gg__power_of_ten(multiply_intermediate_rdigits); } - b_value = __gg__float128_from_qualified_field(C[0], C_o[0], C_s[0]); + b_value = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); goto float_float; } else @@ -1882,7 +1865,11 @@ __gg__dividef1_phase2(cbl_arith_format_t , // 64-bit "digits". We need to multiply them to create a 256-bit result int dividend_rdigits; - __int128 dividend = __gg__binary_value_from_qualified_field(÷nd_rdigits, C[0], C_o[0], C_s[0]); + __int128 dividend = __gg__binary_value_from_qualified_field( + ÷nd_rdigits, + C[0].field, + C[0].offset, + C[0].size); int quotient_rdigits; int256 quotient; @@ -1901,7 +1888,7 @@ __gg__dividef1_phase2(cbl_arith_format_t , *compute_error |= compute_error_overflow; } // At this point, we assign the quotient to *C. - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, quotient.i128[0], quotient_rdigits, @@ -1921,7 +1908,7 @@ __gg__dividef1_phase2(cbl_arith_format_t , } else { - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, b_value, *rounded); @@ -1934,33 +1921,30 @@ extern "C" void __gg__dividef23(cbl_arith_format_t , size_t , + const cblc_referlet_t *A, size_t , + const cblc_referlet_t *B, size_t nC, + const cblc_referlet_t *C, const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; - const size_t *A_o = __gg__treeplet_1o; - const size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; - const size_t *B_o = __gg__treeplet_2o; - const size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; - const size_t *C_o = __gg__treeplet_3o; - const size_t *C_s = __gg__treeplet_3s; - bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; - if( A[0]->type == FldFloat || B[0]->type == FldFloat ) + if( A[0].field->type == FldFloat || B[0].field->type == FldFloat ) { GCOB_FP128 a_value; GCOB_FP128 b_value; GCOB_FP128 c_value; - a_value = __gg__float128_from_qualified_field(A[0], A_o[0], A_s[0]); - b_value = __gg__float128_from_qualified_field(B[0], B_o[0], B_s[0]); + a_value = __gg__float128_from_qualified_field(A[0].field, + A[0].offset, + A[0].size); + b_value = __gg__float128_from_qualified_field(B[0].field, + B[0].offset, + B[0].size); c_value = divide_helper_float(a_value, b_value, &error_this_time); *compute_error |= error_this_time; @@ -1968,7 +1952,7 @@ __gg__dividef23(cbl_arith_format_t , { for(size_t i=0; itype == FldFloat || B[0]->type == FldFloat ) + if( A[0].field->type == FldFloat || B[0].field->type == FldFloat ) { GCOB_FP128 a_value; GCOB_FP128 b_value; GCOB_FP128 c_value; - a_value = __gg__float128_from_qualified_field(A[0], A_o[0], A_s[0]); - b_value = __gg__float128_from_qualified_field(B[0], B_o[0], B_s[0]); + a_value = __gg__float128_from_qualified_field(A[0].field, + A[0].offset, + A[0].size); + b_value = __gg__float128_from_qualified_field(B[0].field, + B[0].offset, + B[0].size); c_value = divide_helper_float(a_value, b_value, &error_this_time); *compute_error |= error_this_time; if( !error_this_time ) { - *compute_error |= conditional_stash(C[1], C_o[1], C_s[1], + *compute_error |= conditional_stash(C[1].field, C[1].offset, C[1].size, on_size_error, c_value, *rounded_p++); @@ -2057,7 +2045,7 @@ __gg__dividef45(cbl_arith_format_t , if( !*compute_error ) { c_value = 0; - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, c_value, *rounded_p++); @@ -2068,10 +2056,18 @@ __gg__dividef45(cbl_arith_format_t , { // fixed divided by fixed int dividend_rdigits; - __int128 dividend = __gg__binary_value_from_qualified_field(÷nd_rdigits, A[0], A_o[0], A_s[0]); + __int128 dividend = __gg__binary_value_from_qualified_field( + ÷nd_rdigits, + A[0].field, + A[0].offset, + A[0].size); int divisor_rdigits; - __int128 divisor = __gg__binary_value_from_qualified_field(&divisor_rdigits, B[0], B_o[0], B_s[0]); + __int128 divisor = __gg__binary_value_from_qualified_field( + &divisor_rdigits, + B[0].field, + B[0].offset, + B[0].size); int quotient_rdigits; int256 quotient; @@ -2096,28 +2092,36 @@ __gg__dividef45(cbl_arith_format_t , { case truncation_e: { - *compute_error |= conditional_stash(C[1], C_o[1], C_s[1], + *compute_error |= conditional_stash(C[1].field, + C[1].offset, + C[1].size, on_size_error, quotient.i128[0], quotient_rdigits, *rounded_p++); unrounded_quotient = __gg__binary_value_from_qualified_field( - &unrounded_quotient_digits, - C[1], C_o[1], C_s[1]); + &unrounded_quotient_digits, + C[1].field, + C[1].offset, + C[1].size); break; } default: { - conditional_stash(C[1], C_o[1], C_s[1], + conditional_stash(C[1].field, C[1].offset, C[1].size, false, quotient.i128[0], quotient_rdigits, truncation_e); unrounded_quotient = __gg__binary_value_from_qualified_field( - &unrounded_quotient_digits, - C[1], C_o[1], C_s[1]); + &unrounded_quotient_digits, + C[1].field, + C[1].offset, + C[1].size); // At this point, we assign the rounded quotient to *C. - *compute_error |= conditional_stash(C[1], C_o[1], C_s[1], + *compute_error |= conditional_stash(C[1].field, + C[1].offset, + C[1].size, on_size_error, quotient.i128[0], quotient_rdigits, @@ -2171,7 +2175,9 @@ __gg__dividef45(cbl_arith_format_t , if( !*compute_error ) { - *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], + *compute_error |= conditional_stash(C[0].field, + C[0].offset, + C[0].size, on_size_error, odividend.i128[0], temp_rdigits, diff --git a/libgcobol/inspect.cc b/libgcobol/inspect.cc index 7e6d1648e72..e333e4b1345 100644 --- a/libgcobol/inspect.cc +++ b/libgcobol/inspect.cc @@ -820,7 +820,8 @@ the_alpha_and_omega_backward( const normalized_operand &id_before, static void -inspect_backward_format_1(const size_t integers[]) +inspect_backward_format_1(const size_t integers[], + const cblc_referlet_t *params) { size_t int_index = 0; size_t cblc_index = 0; @@ -833,9 +834,9 @@ inspect_backward_format_1(const size_t integers[]) std::vector id_2_results(n_identifier_2); // Pick up identifier_1, which is the string being inspected - const cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; - size_t id1_o = __gg__treeplet_1o[cblc_index]; - size_t id1_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id1 = params[cblc_index].field ; + size_t id1_o = params[cblc_index].offset; + size_t id1_s = params[cblc_index].size ; cblc_index += 1; // normalize it, according to the language specification. normalized_operand normalized_id_1 = normalize_id(id1, id1_o, id1_s, id1->encoding); @@ -846,9 +847,9 @@ inspect_backward_format_1(const size_t integers[]) { // For each identifier_2, we pick up its value: - id_2_results[i].id2 = __gg__treeplet_1f [cblc_index]; - id_2_results[i].id2_o = __gg__treeplet_1o[cblc_index]; - id_2_results[i].id2_s = __gg__treeplet_1s[cblc_index]; + id_2_results[i].id2 = params[cblc_index].field ; + id_2_results[i].id2_o = params[cblc_index].offset; + id_2_results[i].id2_s = params[cblc_index].size ; cblc_index += 1; id_2_results[i].result = 0; @@ -873,14 +874,14 @@ inspect_backward_format_1(const size_t integers[]) next_comparand.operation = operation; next_comparand.identifier_3.length = 1; - const cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field ; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field ; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size ; cblc_index += 1; normalized_operand normalized_id_4_before @@ -923,19 +924,19 @@ inspect_backward_format_1(const size_t integers[]) next_comparand.id_2_index = i; next_comparand.operation = operation; - const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = params[cblc_index].field ; + size_t id3_o = params[cblc_index].offset; + size_t id3_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field ; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field ; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size ; cblc_index += 1; next_comparand.identifier_3 @@ -1173,11 +1174,13 @@ inspect_backward_format_1(const size_t integers[]) extern "C" void -__gg__inspect_format_1(int backward, size_t integers[]) +__gg__inspect_format_1( int backward, + size_t integers[], + const cblc_referlet_t *params) { if( backward ) { - return inspect_backward_format_1(integers); + return inspect_backward_format_1(integers, params); } size_t int_index = 0; @@ -1191,9 +1194,9 @@ __gg__inspect_format_1(int backward, size_t integers[]) std::vector id_2_results(n_identifier_2); // Pick up identifier_1, which is the string being inspected - const cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; - size_t id1_o = __gg__treeplet_1o[cblc_index]; - size_t id1_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id1 = params[cblc_index].field ; + size_t id1_o = params[cblc_index].offset; + size_t id1_s = params[cblc_index].size ; cblc_index += 1; // normalize it, according to the language specification. normalized_operand normalized_id_1 @@ -1205,9 +1208,9 @@ __gg__inspect_format_1(int backward, size_t integers[]) { // For each identifier_2, we pick up its value: - id_2_results[i].id2 = __gg__treeplet_1f [cblc_index]; - id_2_results[i].id2_o = __gg__treeplet_1o[cblc_index]; - id_2_results[i].id2_s = __gg__treeplet_1s[cblc_index]; + id_2_results[i].id2 = params[cblc_index].field ; + id_2_results[i].id2_o = params[cblc_index].offset; + id_2_results[i].id2_s = params[cblc_index].size ; cblc_index += 1; id_2_results[i].result = 0; @@ -1232,14 +1235,14 @@ __gg__inspect_format_1(int backward, size_t integers[]) next_comparand.operation = operation; next_comparand.identifier_3.length = 1; - const cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field ; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field ; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size ; cblc_index += 1; normalized_operand normalized_id_4_before @@ -1282,19 +1285,19 @@ __gg__inspect_format_1(int backward, size_t integers[]) next_comparand.id_2_index = i; next_comparand.operation = operation; - const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = params[cblc_index].field ; + size_t id3_o = params[cblc_index].offset; + size_t id3_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field ; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field ; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size ; cblc_index += 1; next_comparand.identifier_3 @@ -1531,7 +1534,8 @@ __gg__inspect_format_1(int backward, size_t integers[]) static void -inspect_backward_format_2(const size_t integers[]) +inspect_backward_format_2(const size_t integers[], + const cblc_referlet_t *params) { size_t int_index = 0; size_t cblc_index = 0; @@ -1539,9 +1543,9 @@ inspect_backward_format_2(const size_t integers[]) // Reference the language specification for the meanings of identifier_X // Pick up identifier_1, which is the string being inspected - cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; - size_t id1_o = __gg__treeplet_1o[cblc_index]; - size_t id1_s = __gg__treeplet_1s[cblc_index]; + cblc_field_t *id1 = params[cblc_index].field ; + size_t id1_o = params[cblc_index].offset; + size_t id1_s = params[cblc_index].size ; cblc_index += 1; // normalize it, according to the language specification. @@ -1564,19 +1568,19 @@ inspect_backward_format_2(const size_t integers[]) comparand next_comparand = {}; next_comparand.operation = operation; - const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = params[cblc_index].field ; + size_t id5_o = params[cblc_index].offset; + size_t id5_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field ; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field ; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size ; cblc_index += 1; next_comparand.identifier_5 @@ -1623,24 +1627,24 @@ inspect_backward_format_2(const size_t integers[]) comparand next_comparand = {}; next_comparand.operation = operation; - const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = params[cblc_index].field ; + size_t id3_o = params[cblc_index].offset; + size_t id3_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = params[cblc_index].field ; + size_t id5_o = params[cblc_index].offset; + size_t id5_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field ; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field ; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size ; cblc_index += 1; next_comparand.identifier_3 = normalize_id(id3, id3_o, id3_s, id1->encoding); @@ -1889,21 +1893,23 @@ inspect_backward_format_2(const size_t integers[]) extern "C" void -__gg__inspect_format_2(int backward, size_t integers[]) +__gg__inspect_format_2( int backward, + size_t integers[], + const cblc_referlet_t *params) { if( backward ) { - return inspect_backward_format_2(integers); + return inspect_backward_format_2(integers, params); } size_t int_index = 0; size_t cblc_index = 0; // Reference the language specification for the meanings of identifier_X - // Pick up identifier_1, which is the string being inspected - cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; - size_t id1_o = __gg__treeplet_1o[cblc_index]; - size_t id1_s = __gg__treeplet_1s[cblc_index]; + // id1 is the string being inspected + cblc_field_t *id1 = params[cblc_index].field; + size_t id1_o = params[cblc_index].offset; + size_t id1_s = params[cblc_index].size; cblc_index += 1; // normalize it, according to the language specification. @@ -1927,19 +1933,19 @@ __gg__inspect_format_2(int backward, size_t integers[]) comparand next_comparand = {} ; next_comparand.operation = operation; - const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = params[cblc_index].field; + size_t id5_o = params[cblc_index].offset; + size_t id5_s = params[cblc_index].size; cblc_index += 1; - const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size; cblc_index += 1; next_comparand.identifier_5 @@ -1984,24 +1990,24 @@ __gg__inspect_format_2(int backward, size_t integers[]) comparand next_comparand = {}; next_comparand.operation = operation; - const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = params[cblc_index].field; + size_t id3_o = params[cblc_index].offset; + size_t id3_s = params[cblc_index].size; cblc_index += 1; - const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = params[cblc_index].field; + size_t id5_o = params[cblc_index].offset; + size_t id5_s = params[cblc_index].size; cblc_index += 1; - const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size; cblc_index += 1; next_comparand.identifier_3 = normalize_id(id3, @@ -2608,13 +2614,15 @@ __gg__inspect_format_4( int backward, extern "C" void -__gg__inspect_format_1_sbc(int backward, size_t integers[]) +__gg__inspect_format_1_sbc( int backward, + size_t integers[], + const cblc_referlet_t *params) { // When this routine is called, we know we are working in a single-byte-coded // codeset like ASCII or EBCDIC. if( backward ) { - return inspect_backward_format_1(integers); + return inspect_backward_format_1(integers, params); } size_t int_index = 0; @@ -2628,9 +2636,9 @@ __gg__inspect_format_1_sbc(int backward, size_t integers[]) std::vector id_2_results(n_identifier_2); // Pick up identifier_1, which is the string being inspected - const cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; - size_t id1_o = __gg__treeplet_1o[cblc_index]; - size_t id1_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id1 = params[cblc_index].field ; + size_t id1_o = params[cblc_index].offset; + size_t id1_s = params[cblc_index].size ; cblc_index += 1; // normalize it, according to the language specification. std::string normalized_id_1 @@ -2642,9 +2650,9 @@ __gg__inspect_format_1_sbc(int backward, size_t integers[]) { // For each identifier_2, we pick up its value: - id_2_results[i].id2 = __gg__treeplet_1f [cblc_index]; - id_2_results[i].id2_o = __gg__treeplet_1o[cblc_index]; - id_2_results[i].id2_s = __gg__treeplet_1s[cblc_index]; + id_2_results[i].id2 = params[cblc_index].field ; + id_2_results[i].id2_o = params[cblc_index].offset; + id_2_results[i].id2_s = params[cblc_index].size ; cblc_index += 1; id_2_results[i].result = 0; @@ -2668,14 +2676,14 @@ __gg__inspect_format_1_sbc(int backward, size_t integers[]) next_comparand.operation = operation; next_comparand.identifier_3 = " "; - const cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field ; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field ; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size ; cblc_index += 1; std::string normalized_id_4_before @@ -2712,19 +2720,19 @@ __gg__inspect_format_1_sbc(int backward, size_t integers[]) next_comparand.id_2_index = i; next_comparand.operation = operation; - const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = params[cblc_index].field ; + size_t id3_o = params[cblc_index].offset; + size_t id3_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = params[cblc_index].field ; + size_t id4_before_o = params[cblc_index].offset; + size_t id4_before_s = params[cblc_index].size ; cblc_index += 1; - const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = params[cblc_index].field ; + size_t id4_after_o = params[cblc_index].offset; + size_t id4_after_s = params[cblc_index].size ; cblc_index += 1; next_comparand.identifier_3 = normalize_id_sbc(id3,