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

Add optional index check #191

Open
wants to merge 1 commit into
base: gcos4gnucobol-3.x
Choose a base branch
from
Open

Add optional index check #191

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
27 changes: 27 additions & 0 deletions cobc/codegen.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7670,6 +7670,33 @@ output_perform_until (struct cb_perform *p, cb_tree l)
cb_tree next;

if (l == NULL) {
if (cb_flag_check_subscript_set
&& 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);
}
output (");");
output_newline ();
}
}

/* Perform body at the end */
output_perform_once (p);
return;
Expand Down
3 changes: 3 additions & 0 deletions cobc/flag.def
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -186,6 +186,9 @@ CB_FLAG (cb_flag_stack_check, 1, "stack-check",
_(" -fstack-check PERFORM stack checking\n"
" * turned on by --debug/-g"))

CB_FLAG (cb_flag_check_subscript_set, 1, "opt-check-subscript-set",
_(" -fopt-check-subscript-set check subscript in PERFORM/SET"))

CB_FLAG_OP (1, "memory-check", CB_FLAG_GETOPT_MEMORY_CHECK,
_(" -fmemory-check=<scope> checks for invalid writes to internal storage,\n"
" <scope> may be one of: all, pointer, using, none\n"
Expand Down
77 changes: 77 additions & 0 deletions cobc/typeck.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2710,6 +2710,13 @@ cb_build_identifier (cb_tree x, const int subchk)

/* Run-time check for all non-literals */
if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
if (cb_flag_check_subscript_set
&& CB_REF_OR_FIELD_P (sub)) {
/* Skip check_subscript; Now done on SET/PERFORM */
if (CB_FIELD_PTR (sub)->flag_indexed_by) {
continue;
}
}
if (cb_subscript_check != CB_SUB_CHECK_MAX
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

That's where I'm wondering if the added lines above interact badly with this.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

No need to wonder (my guess is this breaks cb_subscript_check: max) - but a reason to add this into the "enable / disable subscript check with ODO" test (run_subscripts.at) tests, which should get a prog2.cob in any case that uses an index in any case (which should behave identical for the current tests but likely break with the new option [which only makes sense in the prog2.cob test as it only applies to indexes).
... while you at this: please replace the leading tabs in that test's prog.cob.

&& p->depending && p->depending != cb_error_node) {
cb_tree e1;
Expand Down Expand Up @@ -13737,10 +13744,59 @@ cb_check_set_to (cb_tree vars, cb_tree x, const int emit_error)
return error_found;
}

void
cb_emit_check_index (cb_tree vars, int hasval, int setval)
{
cb_tree l, v;
struct cb_field *f, *p;
for (l = vars; l; l = CB_CHAIN (l)) {
v = CB_VALUE (l);
if (!CB_REF_OR_FIELD_P (v)) continue;
f = CB_FIELD_PTR (v);
if (!f->flag_indexed_by) continue;
if (!f->index_qual) continue;
p = f->index_qual;
if (p->depending) {
if (hasval) {
if (setval > p->occurs_max
|| 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 (setval >= p->occurs_min) continue;
}
#if 0 /* COBOL standard says do not check for SET */
cb_emit (CB_BUILD_FUNCALL_4 ("cob_check_subscript",
cb_build_cast_int (v), cb_build_cast_int (p->depending),
CB_BUILD_STRING0 (f->name), cb_int1));
#endif
} else
if (hasval
&& setval >= p->occurs_min
&& setval <= p->occurs_max) {
continue; /* Checks OK at compile time */
} else {
if (hasval) {
cb_warning_x (COBC_WARN_FILLER, l,
_("SET %s TO %d is out of bounds"), f->name, setval);
}
#if 0 /* COBOL standard says do not check for SET */
cb_emit (CB_BUILD_FUNCALL_4 ("cob_check_subscript",
cb_build_cast_int (v), cb_int (p->occurs_max),
CB_BUILD_STRING0 (f->name), cb_int0));
#endif
}
}
}

void
cb_emit_set_to (cb_tree vars, cb_tree src)
{
cb_tree l;
int hasval, setval;

/* Emit statements only if targets have the correct class. */
if (cb_check_set_to (vars, src, 1)) {
Expand All @@ -13757,6 +13813,23 @@ 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;
}
} else if (src == cb_zero) {
hasval = 1;
}
if (cb_flag_check_subscript_set
&& CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
cb_emit_check_index (vars, hasval, setval);
}
}

/*
Expand Down Expand Up @@ -13898,6 +13971,7 @@ cb_emit_set_to_fcdkey (cb_tree vars, cb_tree x)
void
cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x)
{
cb_tree vars = l;
if (cb_validate_one (x)
|| cb_validate_list (l)) {
return;
Expand All @@ -13910,6 +13984,9 @@ cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x)
cb_emit (cb_build_sub (target, x, cb_int0));
}
}
if (CB_EXCEPTION_ENABLE (COB_EC_RANGE_INDEX)) {
cb_emit_check_index (vars, 0, 0);
}
}

void
Expand Down
4 changes: 3 additions & 1 deletion tests/testsuite.src/run_misc.at
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -707,7 +707,9 @@ AT_DATA([prog.cob], [
STOP RUN.
])

AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([$COMPILE -fopt-check-subscript-set prog.cob], [0], [],
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Had to explicitly activate the flag here - but is it what we want ?

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Does the result differ otherwise?

As we found that this is a non-standard optimization it should only be enabled by explicit request.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Actually 4935 added the warning to this test - but to get the warning we have to add the new -fopt-check-subscript-set flag.

Maybe we can test both behaviors: without the flag and the warning (as it was before this patch), and with the flag and the warning ?

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

No, one of the point of the back-merge was that the checks and therefore the warnings should always be done, only the codegen depend on the new flag.

... but the warnings belong into a test in syn_occurs.at, not into a runtime check (please move it). And yes, the other runtime test should be done for both cases - w/wo the new option (without is missing and the compile command for the current test uses definitely more options than needed ($COMPILE -fnew-option prog.cob should be enough, if not it is reasonable to do minor necessary adjustments to the testcase).

[prog.cob:9: warning: SET I TO 0 is out of bounds
])
AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], [])

AT_CLEANUP
Expand Down
126 changes: 126 additions & 0 deletions tests/testsuite.src/run_subscripts.at
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -582,3 +582,129 @@ AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [Hi, there!])

AT_CLEANUP


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

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.
CALL "SUBN" USING BY VALUE BINB.
SET IB1 TO 2.
* MF: Passing INDEX as CALL parameter is an error
* CALL "SUBN" USING BY VALUE IB1.

* MF: Passing INDEX as DISPLAY parameter is an error
* SET MYIDX TO IB1
* DISPLAY MYIDX

SET MYIDX TO IB1.
CALL "SUBN" USING BY VALUE MYIDX.
SET IB1 TO 1.
SET MYIDX TO IB1.
CALL "SUBN" USING BY VALUE MYIDX.
SET IB1, IB2 TO 4.
SET IB2 TO MAXIDX.
SET IB1, IB2 UP BY 1.
SET IB1 TO 3.
SET MYIDX TO IB1.
CALL "SUBN" USING BY VALUE MYIDX.
MOVE -1 TO NIDX
SET IB1 TO NIDX.
SET IB1 TO -9.
SET IB1 TO 300.
MOVE 400 TO IB1.
* MOVE -1 TO NIDX
* DISPLAY NIDX ": " MYNAME (NIDX) " ... The Begin!".
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.
* SET NIDX TO IB1
* DISPLAY NIDX ": " MYNAME (IB1) " ... The End!".

PERFORM VARYING IB2 FROM 1 BY 1 UNTIL IB2 > 4
SET IB1 TO IB2
* MF: Using wrong INDEX is warning and does not work
* DISPLAY MYMRK (IB1) MYNAME (IB1)

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.

IDENTIFICATION DIVISION.
PROGRAM-ID. SUBN.
DATA DIVISION.
LINKAGE SECTION.
01 n PIC S9(9) COMP-5.
PROCEDURE DIVISION USING BY VALUE n.
DISPLAY 'Number is ' n.
END PROGRAM SUBN.
])

AT_CHECK([$COMPILE -x -std=mf -debug -Wall -Wno-unfinished -debug -fopt-check-subscript-set -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([$COBCRUN_DIRECT ./prog], [1], [Initial value: +01
Number is +0000000042
Number is +0000000002
Number is +0000000001
Number is +0000000003
+01: A: Fred .
+02: B: Barney .
+03: C: Wilma .
+01: A: Freddy .
+02: B: Barney .
+03: C: Wilma .
], [libcob: prog.cob:73: error: subscript of 'MYMRK' out of bounds: 4
note: current maximum subscript for 'MYMRK': 3
])

AT_CLEANUP

Loading