Skip to content

Commit

Permalink
Merge remote-tracking branch 'upstream/master' into gc4
Browse files Browse the repository at this point in the history
  • Loading branch information
ddeclerck committed Oct 23, 2024
2 parents caeacd5 + 85730f7 commit 3df789d
Show file tree
Hide file tree
Showing 9 changed files with 218 additions and 52 deletions.
2 changes: 2 additions & 0 deletions TODO
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
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
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
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
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
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
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
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

0 comments on commit 3df789d

Please sign in to comment.