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 23, 2024
1 parent 0cc8207 commit e7c9540
Show file tree
Hide file tree
Showing 9 changed files with 379 additions and 14 deletions.
32 changes: 30 additions & 2 deletions cobc/codegen.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7675,10 +7675,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 (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)) {
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 ();
}
}
}
}

/* Perform body at the end */
output_perform_once (p);
return;
Expand All @@ -7695,7 +7723,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
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
47 changes: 46 additions & 1 deletion cobc/parser.y
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16476,7 +16476,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 @@ -16486,6 +16486,51 @@ 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
57 changes: 57 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,20 @@ 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)) {
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 +13951,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 +13964,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
6 changes: 4 additions & 2 deletions 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 Expand Up @@ -3978,7 +3980,7 @@ AT_DATA([prog.cob], [
01 KK PIC X.
PROCEDURE DIVISION.
SORT TBL ASCENDING KEY K.
SET KK TO "3"
MOVE "3" TO KK
SEARCH ALL TBL
AT END
DISPLAY KK " NOT FOUND"
Expand Down
118 changes: 118 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,121 @@ 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 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 -fopt-check-subscript-set -Wno-unfinished -Wno-others prog.cob], [0], [], [])
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:71: error: subscript of 'MYMRK' out of bounds: 4
note: current maximum subscript for 'MYMRK': 3
])

AT_CLEANUP

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 @@ -6124,7 +6124,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
Loading

0 comments on commit e7c9540

Please sign in to comment.