Skip to content

Commit 8de1114

Browse files
ddeclerckddeclerck
committed
"Fix" PERFORM bounds check - but disable it for now as it is not ISO-compliant
1 parent caeacd5 commit 8de1114

File tree

8 files changed

+209
-52
lines changed

8 files changed

+209
-52
lines changed

‎TODO

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -230,6 +230,8 @@ https://sourceforge.net/p/gnucobol/code/HEAD/tree/external-doc/guide/
230230

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

233+
- 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
234+
233235
- Check the #if-0'ed code in field.c:validate_field_value
234236

235237
- Check the #if-0'ed code for setting last_exception_source in common.c:cob_set_exception

‎cobc/codegen.c

Lines changed: 30 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -8104,10 +8104,38 @@ static void
81048104
output_perform_until (struct cb_perform *p, cb_tree l)
81058105
{
81068106
struct cb_perform_varying *v;
8107-
struct cb_field *f;
81088107
cb_tree next;
81098108

81108109
if (l == NULL) {
8110+
#if 0 /* FIXME: add back as option, because not conforming to ISO */
8111+
if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
8112+
cb_tree xn;
8113+
/* Check all INDEXED BY variables used in VARYING */
8114+
for (xn = p->varying; xn; xn = CB_CHAIN (xn)) {
8115+
v = CB_PERFORM_VARYING (CB_VALUE (xn));
8116+
if (v->name
8117+
&& CB_REF_OR_FIELD_P (v->name)) {
8118+
struct cb_field *f = CB_FIELD_PTR (v->name);
8119+
if (f->flag_indexed_by
8120+
&& f->index_qual) {
8121+
f = f->index_qual;
8122+
output_prefix ();
8123+
output ("cob_check_subscript (");
8124+
output_integer (v->name);
8125+
output (", ");
8126+
if (f->depending) {
8127+
output_integer (f->depending);
8128+
output (", \"%s\", 1", f->name);
8129+
} else {
8130+
output ("%d, \"%s\", 0", f->occurs_max, f->name);
8131+
}
8132+
output (");");
8133+
output_newline ();
8134+
}
8135+
}
8136+
}
8137+
}
8138+
#endif
81118139
/* Perform body at the end */
81128140
output_perform_once (p);
81138141
return;
@@ -8125,7 +8153,7 @@ output_perform_until (struct cb_perform *p, cb_tree l)
81258153
CB_PERFORM_VARYING (CB_VALUE (next))->name);
81268154
/* DEBUG */
81278155
if (current_prog->flag_gen_debug) {
8128-
f = CB_FIELD (cb_ref (CB_PERFORM_VARYING (CB_VALUE (next))->name));
8156+
struct cb_field *f = CB_FIELD (cb_ref (CB_PERFORM_VARYING (CB_VALUE (next))->name));
81298157
if (f->flag_field_debug) {
81308158
output_stmt (cb_build_debug (cb_debug_name,
81318159
(const char *)f->name, NULL));
@@ -8164,30 +8192,6 @@ output_perform_until (struct cb_perform *p, cb_tree l)
81648192
output (")");
81658193
output_newline ();
81668194
output_line (" break;");
8167-
if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)
8168-
&& next) {
8169-
cb_tree xn;
8170-
/* Check all INDEXED BY variables used in VARYING */
8171-
for (xn = l; xn; xn = CB_CHAIN (xn)) {
8172-
struct cb_field *q;
8173-
f = CB_FIELD_PTR (CB_PERFORM_VARYING(CB_VALUE (xn))->name);
8174-
if (!f->flag_indexed_by) continue;
8175-
if (!f->index_qual) continue;
8176-
q = f->index_qual;
8177-
output_prefix ();
8178-
output ("cob_check_subscript (");
8179-
output_integer (CB_PERFORM_VARYING(CB_VALUE (xn))->name);
8180-
output (", ");
8181-
if (q->depending) {
8182-
output_integer (q->depending);
8183-
output (", \"%s\", 1",f->name);
8184-
} else {
8185-
output ("%d, \"%s\", 0",q->occurs_max,f->name);
8186-
}
8187-
output (");");
8188-
output_newline ();
8189-
}
8190-
}
81918195

81928196
if (p->test == CB_BEFORE) {
81938197
output_perform_until (p, next);

‎cobc/parser.y

Lines changed: 48 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -16221,7 +16221,7 @@ set_to:
1622116221
{
1622216222
cb_emit_set_to_fcdkey ($1, $7);
1622316223
}
16224-
| target_x_list TO x
16224+
| target_x_list TO x_numeric_or_pointer
1622516225
{
1622616226
cb_emit_set_to ($1, $3);
1622716227
}
@@ -16231,6 +16231,53 @@ set_to:
1623116231
}
1623216232
;
1623316233

16234+
x_numeric_or_pointer:
16235+
identifier
16236+
{
16237+
switch (cb_tree_class ($1)) {
16238+
case CB_CLASS_INDEX:
16239+
case CB_CLASS_POINTER:
16240+
case CB_CLASS_NUMERIC:
16241+
$$ = $1;
16242+
break;
16243+
default:
16244+
if ($1 != cb_error_node) {
16245+
cb_error_x ($1, _("an integer, INDEX, or a POINTER is expected here"));
16246+
}
16247+
$$ = cb_error_node;
16248+
}
16249+
}
16250+
| literal
16251+
{
16252+
switch (cb_tree_class ($1)) {
16253+
case CB_CLASS_INDEX:
16254+
case CB_CLASS_POINTER:
16255+
case CB_CLASS_NUMERIC:
16256+
if (!(CB_NUMERIC_LITERAL_P ($1)
16257+
&& (CB_LITERAL ($1))->scale != 0)) {
16258+
$$ = $1;
16259+
break;
16260+
}
16261+
/* fall through */
16262+
default:
16263+
if ($1 != cb_error_node) {
16264+
cb_error_x ($1, _("an integer, INDEX, or a POINTER is expected here"));
16265+
}
16266+
$$ = cb_error_node;
16267+
}
16268+
}
16269+
| ADDRESS _of prog_or_entry alnum_or_id
16270+
{
16271+
$$ = cb_build_ppointer ($4);
16272+
}
16273+
| ADDRESS _of identifier_1
16274+
{
16275+
$$ = cb_build_address (check_not_88_level ($3));
16276+
}
16277+
;
16278+
16279+
16280+
1623416281
/* SET name ... UP/DOWN BY expr */
1623516282

1623616283
set_up_down:

‎cobc/typeck.c

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -13461,7 +13461,9 @@ cb_emit_check_index (cb_tree vars, int hasval, int setval)
1346113461
|| setval < p->occurs_min) {
1346213462
cb_warning_x (COBC_WARN_FILLER, l,
1346313463
_("SET %s TO %d is out of bounds"), f->name, setval);
13464-
cb_emit (CB_BUILD_FUNCALL_1("cob_set_exception", cb_int(COB_EC_RANGE_INDEX)));
13464+
#if 0 /* FIXME: add back as option, because not conforming to ISO */
13465+
cb_emit (CB_BUILD_FUNCALL_1 ("cob_set_exception", cb_int (COB_EC_RANGE_INDEX)));
13466+
#endif
1346513467
}
1346613468
if (setval >= p->occurs_min) continue;
1346713469
}
@@ -13584,12 +13586,10 @@ cb_emit_set_to (cb_tree vars, cb_tree x)
1358413586
cb_emit_incompat_data_checks (x);
1358513587
cb_emit (cb_build_move (x, CB_VALUE (l)));
1358613588
}
13589+
1358713590
hasval = setval = 0;
1358813591
if (CB_LITERAL_P (x)) {
1358913592
if (CB_NUMERIC_LITERAL_P (x)) {
13590-
if (CB_LITERAL(x)->scale != 0) {
13591-
cb_warning_x (COBC_WARN_FILLER, x, _("SET TO should be an integer"));
13592-
}
1359313593
setval = cb_get_int (x);
1359413594
hasval = 1;
1359513595
}

‎tests/testsuite.src/run_subscripts.at

Lines changed: 5 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -542,6 +542,7 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [Hi, there!])
542542

543543
AT_CLEANUP
544544

545+
545546
AT_SETUP([Check Subscripts])
546547
AT_KEYWORDS([SUBSCRIPT])
547548

@@ -562,15 +563,13 @@ AT_DATA([prog.cob], [
562563
01 FILLER REDEFINES TBL.
563564
05 MYNAME PIC X(8) OCCURS 4 INDEXED BY IB1.
564565
01 TBL2.
565-
05 MYMRK PIC X(3)
566+
05 MYMRK PIC X(3)
566567
OCCURS 2 TO 5 DEPENDING ON MAXIDX
567568
INDEXED BY IB2.
568569
PROCEDURE DIVISION.
569570
MOVE 5 TO MAXIDX
570571
SET NIDX TO IB1.
571572
DISPLAY "Initial value: " NIDX.
572-
SET IB2 TO 0.2.
573-
SET IB2 TO "fred".
574573
SET IB2 TO 10.
575574
MOVE "A:" TO MYMRK (1)
576575
MOVE "B:" TO MYMRK (2)
@@ -631,7 +630,7 @@ AT_DATA([prog.cob], [
631630
END-PERFORM.
632631
STOP RUN.
633632
END PROGRAM prog.
634-
633+
635634
IDENTIFICATION DIVISION.
636635
PROGRAM-ID. SUBN.
637636
DATA DIVISION.
@@ -642,13 +641,7 @@ AT_DATA([prog.cob], [
642641
END PROGRAM SUBN.
643642
])
644643

645-
AT_CHECK([$COMPILE -x -std=mf -debug -Wall -debug -O prog.cob ], [0], [], [prog.cob:25: warning: SET TO should be an integer
646-
prog.cob:26: warning: source is non-numeric - substituting zero
647-
prog.cob:27: warning: SET IB2 TO 10 is out of bounds
648-
prog.cob:56: warning: SET IB1 TO -9 is out of bounds
649-
prog.cob:57: warning: SET IB1 TO 300 is out of bounds
650-
])
651-
644+
AT_CHECK([$COMPILE -Wno-others prog.cob], [0], [], [])
652645
AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [Initial value: +01
653646
Number is +0000000042
654647
Number is +0000000002
@@ -660,7 +653,7 @@ Number is +0000000003
660653
+01: A: Freddy .
661654
+02: B: Barney .
662655
+03: C: Wilma .
663-
], [libcob: prog.cob:80: error: subscript of 'MYMRK' out of bounds: 4
656+
], [libcob: prog.cob:78: error: subscript of 'MYMRK' out of bounds: 4
664657
note: current maximum subscript for 'MYMRK': 3
665658
])
666659

‎tests/testsuite.src/syn_misc.at

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6057,7 +6057,7 @@ prog.cob:27: error: condition-name not allowed here: 'val-i1'
60576057
prog.cob:29: error: condition-name not allowed here: 'vnum-1'
60586058
prog.cob:30: error: condition-name not allowed here: 'vnum-1'
60596059
prog.cob:31: error: condition-name not allowed here: 'vnum-2'
6060-
prog.cob:33: error: condition-name not allowed here: 'val-i1'
6060+
prog.cob:33: error: an integer, INDEX, or a POINTER is expected here
60616061
prog.cob:34: error: condition-name not allowed here: 'val-i2'
60626062
prog.cob:32: error: 'val-i1 (MAIN SECTION:)' is not a procedure name
60636063
])

‎tests/testsuite.src/syn_move.at

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -594,8 +594,8 @@ prog.cob:15: warning: numeric value is expected
594594
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
595595
prog.cob:17: warning: numeric value is expected
596596
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
597-
prog.cob:19: error: invalid SET statement
598-
prog.cob:20: error: invalid SET statement
597+
prog.cob:19: error: an integer, INDEX, or a POINTER is expected here
598+
prog.cob:20: error: an integer, INDEX, or a POINTER is expected here
599599
prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in COBOL 2002
600600
prog.cob:24: warning: MOVE of figurative constant QUOTE to numeric item is archaic in COBOL 2002
601601
prog.cob:25: warning: numeric value is expected
@@ -612,8 +612,8 @@ prog.cob:15: warning: numeric value is expected
612612
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
613613
prog.cob:17: warning: numeric value is expected
614614
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
615-
prog.cob:19: error: invalid SET statement
616-
prog.cob:20: error: invalid SET statement
615+
prog.cob:19: error: an integer, INDEX, or a POINTER is expected here
616+
prog.cob:20: error: an integer, INDEX, or a POINTER is expected here
617617
prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in IBM COBOL (lax)
618618
prog.cob:24: warning: MOVE of figurative constant QUOTE to numeric item is archaic in IBM COBOL (lax)
619619
prog.cob:25: warning: numeric value is expected
@@ -628,8 +628,8 @@ prog.cob:13: warning: source is non-numeric - substituting zero
628628
prog.cob:14: warning: source is non-numeric - substituting zero
629629
prog.cob:15: warning: source is non-numeric - substituting zero
630630
prog.cob:17: warning: source is non-numeric - substituting zero
631-
prog.cob:19: error: invalid SET statement
632-
prog.cob:20: error: invalid SET statement
631+
prog.cob:19: error: an integer, INDEX, or a POINTER is expected here
632+
prog.cob:20: error: an integer, INDEX, or a POINTER is expected here
633633
prog.cob:23: warning: source is non-numeric - substituting zero
634634
prog.cob:24: warning: source is non-numeric - substituting zero
635635
prog.cob:25: warning: source is non-numeric - substituting zero
@@ -646,8 +646,8 @@ prog.cob:15: warning: numeric value is expected
646646
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
647647
prog.cob:17: warning: numeric value is expected
648648
prog.cob:6: note: 'MYFLD' defined here as PIC 9(4)
649-
prog.cob:19: error: invalid SET statement
650-
prog.cob:20: error: invalid SET statement
649+
prog.cob:19: error: an integer, INDEX, or a POINTER is expected here
650+
prog.cob:20: error: an integer, INDEX, or a POINTER is expected here
651651
prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in GnuCOBOL
652652
prog.cob:24: warning: MOVE of figurative constant QUOTE to numeric item is obsolete in GnuCOBOL
653653
prog.cob:24: warning: MOVE of figurative constant to numeric item is archaic in GnuCOBOL

0 commit comments

Comments
 (0)