Skip to content

Commit

Permalink
Add optional index check
Browse files Browse the repository at this point in the history
  • Loading branch information
@ddeclerck
ddeclerck committed Oct 22, 2024
1 parent 0cc8207 commit 20a071f
Show file tree
Hide file tree
Showing 5 changed files with 219 additions and 1 deletion.
27 changes: 27 additions & 0 deletions cobc/codegen.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7679,6 +7679,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 (v->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
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
60 changes: 60 additions & 0 deletions cobc/typeck.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13737,10 +13737,49 @@ 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;
}
} 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);
}
}
}
}

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 +13796,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 +13954,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 +13967,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
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], [],
[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
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

0 comments on commit 20a071f

Please sign in to comment.