Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

"Fix" PERFORM bounds check in 4.x - but disable it for now as it is not ISO-compliant #194

Open
wants to merge 1 commit into
base: gc4
Choose a base branch
from
Open

"Fix" PERFORM bounds check in 4.x - but disable it for now as it is not ISO-compliant #194

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions TODO
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -230,6 +230,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
9 changes: 9 additions & 0 deletions cobc/ChangeLog
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,13 @@

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]>

* tree.c (char_to_precedence_idx, get_char_type_description, valid_char_order):
Expand Down
56 changes: 30 additions & 26 deletions cobc/codegen.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8104,10 +8104,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)) {
v = CB_PERFORM_VARYING (CB_VALUE (xn));
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 ();
}
}
}
}
#endif
/* Perform body at the end */
output_perform_once (p);
return;
Expand All @@ -8125,7 +8153,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 Expand Up @@ -8164,30 +8192,6 @@ output_perform_until (struct cb_perform *p, cb_tree l)
output (")");
output_newline ();
output_line (" break;");
if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)
&& next) {
cb_tree xn;
/* Check all INDEXED BY variables used in VARYING */
for (xn = l; xn; xn = CB_CHAIN (xn)) {
struct cb_field *q;
f = CB_FIELD_PTR (CB_PERFORM_VARYING(CB_VALUE (xn))->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",f->name);
} else {
output ("%d, \"%s\", 0",q->occurs_max,f->name);
}
output (");");
output_newline ();
}
}

if (p->test == CB_BEFORE) {
output_perform_until (p, next);
Expand Down
49 changes: 48 additions & 1 deletion cobc/parser.y
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16221,7 +16221,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 @@ -16231,6 +16231,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
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13461,7 +13461,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 @@ -13584,12 +13586,10 @@ cb_emit_set_to (cb_tree vars, cb_tree x)
cb_emit_incompat_data_checks (x);
cb_emit (cb_build_move (x, CB_VALUE (l)));
}

hasval = setval = 0;
if (CB_LITERAL_P (x)) {
if (CB_NUMERIC_LITERAL_P (x)) {
if (CB_LITERAL(x)->scale != 0) {
cb_warning_x (COBC_WARN_FILLER, x, _("SET TO should be an integer"));
}
setval = cb_get_int (x);
hasval = 1;
}
Expand Down
17 changes: 5 additions & 12 deletions tests/testsuite.src/run_subscripts.at
View file
Open in desktop
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 @@ -631,7 +630,7 @@ AT_DATA([prog.cob], [
END-PERFORM.
STOP RUN.
END PROGRAM prog.

IDENTIFICATION DIVISION.
PROGRAM-ID. SUBN.
DATA DIVISION.
Expand All @@ -642,13 +641,7 @@ AT_DATA([prog.cob], [
END PROGRAM SUBN.
])

AT_CHECK([$COMPILE -x -std=mf -debug -Wall -debug -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:80: 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
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6057,7 +6057,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
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -594,8 +594,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 @@ -612,8 +612,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 @@ -628,8 +628,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 @@ -646,8 +646,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
Loading
Loading