Skip to content

Commit

Permalink
Update SVN to 5358
Browse files Browse the repository at this point in the history
  • Loading branch information
@ddeclerck
ddeclerck committed Oct 23, 2024
1 parent 79f8cea commit fc8e7a3
Show file tree
Hide file tree
Showing 9 changed files with 208 additions and 50 deletions.
2 changes: 2 additions & 0 deletions TODO
View file
Original file line number Diff line number Diff line change
Expand Up @@ -232,6 +232,8 @@ https://sourceforge.net/p/gnucobol/code/HEAD/tree/external-doc/guide/

- Make field type an enum instead of a short in common.h:cob_field_attr as per TODO

- Add back the #if-0'ed code in codegen.c:output_perform_until and typeck.c: cb_emit_check_index; as this is not ISO-compliant it should have a dedicated option; also ensure it works well with the new dialect config introduced in 5087

- Check the #if-0'ed code in field.c:validate_field_value

- Check the #if-0'ed code for setting last_exception_source in common.c:cob_set_exception
Expand Down
13 changes: 8 additions & 5 deletions cobc/ChangeLog
View file
Original file line number Diff line number Diff line change
@@ -1,9 +1,12 @@

2024-10-07 David Declerck <[email protected]>

Adjustments to merge 2023-01-16:
* codegen.c (output_perform_until): fix index bound checking
to make it work with code merged from 3.x
2024-10-23 David Declerck <[email protected]>

* codegen.c (output_perform_until): improve PERFORM bounds
checking (disabled for now)
* typeck.c (cb_emit_set_to): remove check for integer
literal (now done in parser)
* parser.y (set_to, x_numeric_or_pointer): check that the
argument to SET TO is an index, a pointer, or an integer

2024-08-28 David Declerck <[email protected]>

Expand Down
42 changes: 22 additions & 20 deletions cobc/codegen.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8248,36 +8248,38 @@ static void
output_perform_until (struct cb_perform *p, cb_tree l)
{
struct cb_perform_varying *v;
struct cb_field *f;
cb_tree next;

if (l == NULL) {
#if 0 /* FIXME: add back as option, because not conforming to ISO */
if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
cb_tree xn;
/* Check all INDEXED BY variables used in VARYING */
for (xn = p->varying; xn; xn = CB_CHAIN (xn)) {
struct cb_field *q;
v = CB_PERFORM_VARYING (CB_VALUE (xn));
if (!v->name) continue;
f = CB_FIELD_PTR (v->name);
if (!f->flag_indexed_by) continue;
if (!f->index_qual) continue;
q = f->index_qual;
output_prefix ();
output ("cob_check_subscript (");
output_integer (CB_PERFORM_VARYING(CB_VALUE (xn))->name);
output (", ");
if (q->depending) {
output_integer (q->depending);
output (", \"%s\", 1", q->name);
} else {
output ("%d, \"%s\", 0", q->occurs_max, q->name);
if (v->name
&& CB_REF_OR_FIELD_P (v->name)) {
struct cb_field *f = CB_FIELD_PTR (v->name);
if (f->flag_indexed_by
&& f->index_qual) {
f = f->index_qual;
output_prefix ();
output ("cob_check_subscript (");
output_integer (v->name);
output (", ");
if (f->depending) {
output_integer (f->depending);
output (", \"%s\", 1", f->name);
} else {
output ("%d, \"%s\", 0", f->occurs_max, f->name);
}
output (");");
output_newline ();
}
}
output (");");
output_newline ();
}
}

#endif
/* Perform body at the end */
output_perform_once (p);
return;
Expand All @@ -8295,7 +8297,7 @@ output_perform_until (struct cb_perform *p, cb_tree l)
CB_PERFORM_VARYING (CB_VALUE (next))->name);
/* DEBUG */
if (current_prog->flag_gen_debug) {
f = CB_FIELD (cb_ref (CB_PERFORM_VARYING (CB_VALUE (next))->name));
struct cb_field *f = CB_FIELD (cb_ref (CB_PERFORM_VARYING (CB_VALUE (next))->name));
if (f->flag_field_debug) {
output_stmt (cb_build_debug (cb_debug_name,
(const char *)f->name, NULL));
Expand Down
49 changes: 48 additions & 1 deletion cobc/parser.y
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16266,7 +16266,7 @@ set_to:
{
cb_emit_set_to_fcdkey ($1, $7);
}
| target_x_list TO x
| target_x_list TO x_numeric_or_pointer
{
cb_emit_set_to ($1, $3);
}
Expand All @@ -16276,6 +16276,53 @@ set_to:
}
;

x_numeric_or_pointer:
identifier
{
switch (cb_tree_class ($1)) {
case CB_CLASS_INDEX:
case CB_CLASS_POINTER:
case CB_CLASS_NUMERIC:
$$ = $1;
break;
default:
if ($1 != cb_error_node) {
cb_error_x ($1, _("an integer, INDEX, or a POINTER is expected here"));
}
$$ = cb_error_node;
}
}
| literal
{
switch (cb_tree_class ($1)) {
case CB_CLASS_INDEX:
case CB_CLASS_POINTER:
case CB_CLASS_NUMERIC:
if (!(CB_NUMERIC_LITERAL_P ($1)
&& (CB_LITERAL ($1))->scale != 0)) {
$$ = $1;
break;
}
/* fall through */
default:
if ($1 != cb_error_node) {
cb_error_x ($1, _("an integer, INDEX, or a POINTER is expected here"));
}
$$ = cb_error_node;
}
}
| ADDRESS _of prog_or_entry alnum_or_id
{
$$ = cb_build_ppointer ($4);
}
| ADDRESS _of identifier_1
{
$$ = cb_build_address (check_not_88_level ($3));
}
;



/* SET name ... UP/DOWN BY expr */

set_up_down:
Expand Down
8 changes: 4 additions & 4 deletions cobc/typeck.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13915,7 +13915,9 @@ cb_emit_check_index (cb_tree vars, int hasval, int setval)
|| setval < p->occurs_min) {
cb_warning_x (COBC_WARN_FILLER, l,
_("SET %s TO %d is out of bounds"), f->name, setval);
cb_emit (CB_BUILD_FUNCALL_1("cob_set_exception", cb_int(COB_EC_RANGE_INDEX)));
#if 0 /* FIXME: add back as option, because not conforming to ISO */
cb_emit (CB_BUILD_FUNCALL_1 ("cob_set_exception", cb_int (COB_EC_RANGE_INDEX)));
#endif
}
if (setval >= p->occurs_min) continue;
}
Expand Down Expand Up @@ -14041,12 +14043,10 @@ cb_emit_set_to (cb_tree vars, cb_tree src)
for (l = vars; l; l = CB_CHAIN (l)) {
cb_emit (cb_build_move (src, CB_VALUE (l)));
}

hasval = setval = 0;
if (CB_LITERAL_P (src)) {
if (CB_NUMERIC_LITERAL_P (src)) {
if (CB_LITERAL(src)->scale != 0) {
cb_warning_x (COBC_WARN_FILLER, src, _("SET TO should be an integer"));
}
setval = cb_get_int (src);
hasval = 1;
}
Expand Down
15 changes: 4 additions & 11 deletions tests/testsuite.src/run_subscripts.at
View file
Original file line number Diff line number Diff line change
Expand Up @@ -542,6 +542,7 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [Hi, there!])

AT_CLEANUP


AT_SETUP([Check Subscripts])
AT_KEYWORDS([SUBSCRIPT])

Expand All @@ -562,15 +563,13 @@ AT_DATA([prog.cob], [
01 FILLER REDEFINES TBL.
05 MYNAME PIC X(8) OCCURS 4 INDEXED BY IB1.
01 TBL2.
05 MYMRK PIC X(3)
05 MYMRK PIC X(3)
OCCURS 2 TO 5 DEPENDING ON MAXIDX
INDEXED BY IB2.
PROCEDURE DIVISION.
MOVE 5 TO MAXIDX
SET NIDX TO IB1.
DISPLAY "Initial value: " NIDX.
SET IB2 TO 0.2.
SET IB2 TO "fred".
SET IB2 TO 10.
MOVE "A:" TO MYMRK (1)
MOVE "B:" TO MYMRK (2)
Expand Down Expand Up @@ -642,13 +641,7 @@ AT_DATA([prog.cob], [
END PROGRAM SUBN.
])

AT_CHECK([$COMPILE -x -std=mf -debug -Wall -debug -fdefaultbyte=init -O prog.cob ], [0], [], [prog.cob:25: warning: SET TO should be an integer
prog.cob:26: warning: source is non-numeric - substituting zero
prog.cob:27: warning: SET IB2 TO 10 is out of bounds
prog.cob:56: warning: SET IB1 TO -9 is out of bounds
prog.cob:57: warning: SET IB1 TO 300 is out of bounds
])

AT_CHECK([$COMPILE -Wno-others prog.cob], [0], [], [])
AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [Initial value: +01
Number is +0000000042
Number is +0000000002
Expand All @@ -660,7 +653,7 @@ Number is +0000000003
+01: A: Freddy .
+02: B: Barney .
+03: C: Wilma .
], [libcob: prog.cob:73: error: subscript of 'MYMRK' out of bounds: 4
], [libcob: prog.cob:78: error: subscript of 'MYMRK' out of bounds: 4
note: current maximum subscript for 'MYMRK': 3
])

Expand Down
2 changes: 1 addition & 1 deletion tests/testsuite.src/syn_misc.at
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6059,7 +6059,7 @@ prog.cob:27: error: condition-name not allowed here: 'val-i1'
prog.cob:29: error: condition-name not allowed here: 'vnum-1'
prog.cob:30: error: condition-name not allowed here: 'vnum-1'
prog.cob:31: error: condition-name not allowed here: 'vnum-2'
prog.cob:33: error: condition-name not allowed here: 'val-i1'
prog.cob:33: error: an integer, INDEX, or a POINTER is expected here
prog.cob:34: error: condition-name not allowed here: 'val-i2'
prog.cob:32: error: 'val-i1 (MAIN SECTION:)' is not a procedure name
])
Expand Down
16 changes: 8 additions & 8 deletions tests/testsuite.src/syn_move.at
View file
Original file line number Diff line number Diff line change
Expand Up @@ -692,8 +692,8 @@ prog.cob:15: warning: numeric value is expected
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
prog.cob:17: warning: numeric value is expected
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
prog.cob:19: error: invalid SET statement
prog.cob:20: error: invalid SET statement
prog.cob:19: error: an integer, INDEX, or a POINTER is expected here
prog.cob:20: error: an integer, INDEX, or a POINTER is expected here
prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in COBOL 2002
prog.cob:24: warning: MOVE of figurative constant QUOTE to numeric item is archaic in COBOL 2002
prog.cob:25: warning: numeric value is expected
Expand All @@ -710,8 +710,8 @@ prog.cob:15: warning: numeric value is expected
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
prog.cob:17: warning: numeric value is expected
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
prog.cob:19: error: invalid SET statement
prog.cob:20: error: invalid SET statement
prog.cob:19: error: an integer, INDEX, or a POINTER is expected here
prog.cob:20: error: an integer, INDEX, or a POINTER is expected here
prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in IBM COBOL (lax)
prog.cob:24: warning: MOVE of figurative constant QUOTE to numeric item is archaic in IBM COBOL (lax)
prog.cob:25: warning: numeric value is expected
Expand All @@ -726,8 +726,8 @@ prog.cob:13: warning: source is non-numeric - substituting zero
prog.cob:14: warning: source is non-numeric - substituting zero
prog.cob:15: warning: source is non-numeric - substituting zero
prog.cob:17: warning: source is non-numeric - substituting zero
prog.cob:19: error: invalid SET statement
prog.cob:20: error: invalid SET statement
prog.cob:19: error: an integer, INDEX, or a POINTER is expected here
prog.cob:20: error: an integer, INDEX, or a POINTER is expected here
prog.cob:23: warning: source is non-numeric - substituting zero
prog.cob:24: warning: source is non-numeric - substituting zero
prog.cob:25: warning: source is non-numeric - substituting zero
Expand All @@ -744,8 +744,8 @@ prog.cob:15: warning: numeric value is expected
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
prog.cob:17: warning: numeric value is expected
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
prog.cob:19: error: invalid SET statement
prog.cob:20: error: invalid SET statement
prog.cob:19: error: an integer, INDEX, or a POINTER is expected here
prog.cob:20: error: an integer, INDEX, or a POINTER is expected here
prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in GnuCOBOL
prog.cob:24: warning: MOVE of figurative constant QUOTE to numeric item is obsolete in GnuCOBOL
prog.cob:24: warning: MOVE of figurative constant to numeric item is archaic in GnuCOBOL
Expand Down
111 changes: 111 additions & 0 deletions tests/testsuite.src/syn_occurs.at
View file
Original file line number Diff line number Diff line change
Expand Up @@ -501,3 +501,114 @@ AT_CHECK([$COMPILE_ONLY -std=mf -fodoslide prog.cob ], [0], [], [])

AT_CLEANUP


AT_SETUP([SET to out-of-range literal])
#AT_KEYWORDS([SET])

AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 G.
02 X PIC X OCCURS 10 INDEXED I.
01 LVL-01-CST CONSTANT 12.
78 LVL-78-CST VALUE 13.
PROCEDURE DIVISION.
SET I TO ZERO.
SET I TO 11.
SET I TO LVL-01-CST.
SET I TO LVL-78-CST.
STOP RUN.
])

AT_CHECK([$COMPILE_ONLY prog.cob], [0], [],
[prog.cob:11: warning: SET I TO 0 is out of bounds
prog.cob:12: warning: SET I TO 11 is out of bounds
prog.cob:13: warning: SET I TO 12 is out of bounds
prog.cob:14: warning: SET I TO 13 is out of bounds
])

AT_CLEANUP


AT_SETUP([SET index])
#AT_KEYWORDS([SET])

AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 BINB PIC 9(9) COMP-5 VALUE 42.
01 NIDX PIC S99.
01 MYIDX USAGE IS INDEX.
01 MAXIDX PIC 9999 VALUE 3 COMP-5.
01 TBL.
05 FILLER PIC X(8) VALUE "Fred".
05 FILLER PIC X(8) VALUE "Barney".
05 FILLER PIC X(8) VALUE "Wilma".
05 FILLER PIC X(8) VALUE "Betty".
01 FILLER REDEFINES TBL.
05 MYNAME PIC X(8) OCCURS 4 INDEXED BY IB1.
01 TBL2.
05 MYMRK PIC X(3)
OCCURS 2 TO 5 DEPENDING ON MAXIDX
INDEXED BY IB2.
PROCEDURE DIVISION.
MOVE 5 TO MAXIDX
SET NIDX TO IB1.
DISPLAY "Initial value: " NIDX.
SET IB2 TO 0.2.
SET IB2 TO "fred".
SET IB2 TO 10.
MOVE "A:" TO MYMRK (1)
MOVE "B:" TO MYMRK (2)
MOVE "C:" TO MYMRK (3)
MOVE "D:" TO MYMRK (4)
MOVE "E:" TO MYMRK (5)
MOVE 3 TO MAXIDX.
SET IB1 TO 2.
SET MYIDX TO IB1.
SET IB1 TO 1.
SET MYIDX TO IB1.
SET IB1, IB2 TO 4.
SET IB2 TO MAXIDX.
SET IB1, IB2 UP BY 1.
SET IB1 TO 3.
SET MYIDX TO IB1.
MOVE -1 TO NIDX
SET IB1 TO NIDX.
SET IB1 TO -9.
SET IB1 TO 300.
MOVE 400 TO IB1.
PERFORM VARYING IB1 FROM 1 BY 1 UNTIL IB1 > MAXIDX
SET IB2 TO IB1
SET NIDX TO IB1
SET MYIDX TO IB1
DISPLAY NIDX ": " MYMRK (IB2) MYNAME (IB1) "."
IF MYNAME (NIDX) = "Fred"
MOVE "Freddy" TO MYNAME (NIDX)
END-IF
END-PERFORM.
PERFORM VARYING IB2 FROM 1 BY 1 UNTIL IB2 > 4
SET IB1 TO IB2
SET NIDX TO IB1
SET MYIDX TO IB1
DISPLAY NIDX ": " MYMRK (IB2) MYNAME (IB1) "."
IF MYNAME (IB1) = "Fred"
MOVE "Freddy" TO MYNAME (IB1)
END-IF
END-PERFORM.
STOP RUN.
END PROGRAM prog.
])

AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:25: error: an integer, INDEX, or a POINTER is expected here
prog.cob:26: error: an integer, INDEX, or a POINTER is expected here
prog.cob:27: warning: SET IB2 TO 10 is out of bounds
prog.cob:45: warning: SET IB1 TO -9 is out of bounds
prog.cob:46: warning: SET IB1 TO 300 is out of bounds
])

AT_CLEANUP

0 comments on commit fc8e7a3

Please sign in to comment.