Skip to content

Commit

Permalink
Merge SVN 5132
Browse files Browse the repository at this point in the history
  • Loading branch information
@ddeclerck
ddeclerck committed Jan 18, 2025
1 parent 8c7f1cd commit 6507f30
Show file tree
Hide file tree
Showing 6 changed files with 195 additions and 32 deletions.
4 changes: 4 additions & 0 deletions cobc/ChangeLog
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,6 +52,10 @@
2023-07-21 Simon Sobisch <[email protected]>

* typeck.c (refmod_checks): fixed ec-bound-refmod checks for UNBOUNDED
* field.c (compute_size): take fields before the UNBOUNDED field into
account when calculating its maximum elements
* parser.y (validated_field_reference): extracted from (identifier_field)
and used in all places with the exact same code

2023-07-20 Simon Sobisch <[email protected]>

Expand Down
44 changes: 35 additions & 9 deletions cobc/field.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2992,15 +2992,41 @@ compute_size (struct cb_field *f)
if (c->storage != CB_STORAGE_REPORT)
c->offset = f->offset + (int) size_check;
compute_size (c);
if (c->flag_unbounded) {
const int max_odo_value = get_max_int_val (CB_FIELD_PTR (c->depending));
unbounded_items++;
/* computed MAX */
c->occurs_max = (COB_MAX_UNBOUNDED_SIZE / c->size / unbounded_parts) - 1;
/* maximum from ODO field */
if (max_odo_value != 0
&& max_odo_value < c->occurs_max) {
c->occurs_max = max_odo_value;
if (c->flag_unbounded && CB_VALID_TREE (c->depending)) {
cb_tree dep = cb_ref (c->depending);
if (CB_FIELD_P (dep)) {
const int max_odo_value = get_max_int_val (CB_FIELD (dep));
unbounded_items++;
/* computed MAX */
{
/* size above the field [there is no sister for UNBOUNDED]*/
cob_s64_t size_above = 0;
struct cb_field *curr_fld = c;
struct cb_field *p_fld = f;
while (p_fld) {
struct cb_field *p_fld_c;
for (p_fld_c = p_fld->children; p_fld_c != curr_fld; p_fld_c = p_fld_c->sister) {
if (p_fld_c->size == 0) {
compute_size (p_fld_c);
}
size_above += p_fld_c->size;
}
curr_fld = p_fld;
p_fld = p_fld->parent;
}
/* calculated size */
c->occurs_max = ( (COB_MAX_UNBOUNDED_SIZE - size_above)
/ (c->size * unbounded_parts)
) - 1;
/* maximum possible in ODO field */
if (max_odo_value != 0
&& max_odo_value < c->occurs_max) {
c->occurs_max = max_odo_value;
}
}

} else {
c->depending = cb_error_node;
}
}
size_check += (cob_s64_t)c->size * c->occurs_max;
Expand Down
41 changes: 20 additions & 21 deletions cobc/parser.y
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2308,6 +2308,23 @@ error_if_not_usage_display_or_nonnumeric_lit (cb_tree x)
}
}

/* guarantees a reference to a validated field-reference (or cb_error_node) */
static cb_tree
validated_field_reference (cb_tree fld_ref)
{
cb_tree ref = NULL;
if (CB_REFERENCE_P (fld_ref)) {
ref = cb_ref (fld_ref);
if (CB_FIELD_P (ref)) {
return fld_ref;
}
}
if (ref != cb_error_node) {
cb_error_x (fld_ref, _ ("'%s' is not a field"), cb_name (fld_ref));
}
return cb_error_node;
}

static void
check_validate_item (cb_tree x)
{
Expand Down Expand Up @@ -19518,35 +19535,17 @@ identifier_or_file_name:
identifier_field:
identifier_1
{
cb_tree x = NULL;
if (CB_REFERENCE_P ($1)) {
x = cb_ref ($1);
}

if (x && CB_FIELD_P (x)) {
$$ = $1;
} else {
if (x != cb_error_node) {
cb_error_x ($1, _("'%s' is not a field"), cb_name ($1));
}
$$ = cb_error_node;
}
$$ = validated_field_reference ($1);
}
;

identifier:
identifier_1
{
cb_tree x = NULL;
if (CB_REFERENCE_P ($1)) {
x = cb_ref ($1);
}
if (x && CB_FIELD_P (x)) {
cb_tree x = validated_field_reference ($1);
if (x != cb_error_node) {
$$ = cb_build_identifier ($1, 0);
} else {
if (x != cb_error_node) {
cb_error_x ($1, _("'%s' is not a field"), cb_name ($1));
}
$$ = cb_error_node;
}
}
Expand Down
2 changes: 2 additions & 0 deletions cobc/typeck.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5113,6 +5113,8 @@ cb_validate_program_data (struct cb_program *prog)
/* Resolve all references so far */
for (l = cb_list_reverse (prog->reference_list); l; l = CB_CHAIN (l)) {
cb_ref (CB_VALUE (l));
/* TODO: move allocation of prog->reference_list outside of parse_mem
and free it here directly */
}

/* Check ODO items */
Expand Down
4 changes: 2 additions & 2 deletions tests/testsuite.src/run_extensions.at
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1118,7 +1118,7 @@ VARTAB(17) = "0000HI MOM 0000"
AT_CLEANUP

AT_SETUP([INITIALIZE OCCURS UNBOUNDED])
AT_KEYWORDS([extensions runsubscripts subscripts refmod exceptions])
AT_KEYWORDS([extensions runsubscripts subscripts refmod exceptions ibm])

AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
Expand Down Expand Up @@ -1221,7 +1221,7 @@ AT_CLEANUP


AT_SETUP([INITIALIZE OCCURS ODOSLIDE])
AT_KEYWORDS([extensions runsubscripts subscripts])
AT_KEYWORDS([extensions runsubscripts subscripts ibm])

AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
Expand Down
132 changes: 132 additions & 0 deletions tests/testsuite.src/syn_occurs.at
View file
Original file line number Diff line number Diff line change
Expand Up @@ -195,6 +195,24 @@ AT_DATA([prog4.cob], [
77 I PIC X.
])

AT_DATA([prog5.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 G-1.
05 G-1-F1 PIC X(002).
05 G-2.
07 G-3
OCCURS 1 TO 99999
DEPENDING ON G-3-ELEMENTS
ASCENDING KEY IS G-4-KEY
INDEXED BY IND.
10 G-4.
15 N PIC 9(001).
*
])

AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
[prog.cob:7: error: 'G-2' cannot have an OCCURS clause due to 'X'
])
Expand All @@ -220,6 +238,120 @@ AT_CHECK([$COMPILE_ONLY -fcomplex-odo prog4.cob], [1], [],
[prog4.cob:8: error: 'I' is not numeric
])

AT_CHECK([$COMPILE_ONLY prog5.cob], [1], [],
[prog5.cob:11: error: 'G-3-ELEMENTS' is not defined
prog5.cob:12: error: 'G-4-KEY IN G-2 IN G-1' is not defined
])

AT_CLEANUP


AT_SETUP([OCCURS UNBOUNDED])
#AT_KEYWORDS([ibm])

AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
LINKAGE SECTION.
01 G-1.
07 G-2-ELEMENTS PIC 9(08).
07 G-2
OCCURS UNBOUNDED
DEPENDING ON G-2-ELEMENTS.
10 X PIC X.
PROCEDURE DIVISION USING G-1.
DISPLAY G-1.
GOBACK.
])

AT_DATA([prog2.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
LINKAGE SECTION.
01 G-1.
05 G-1-F1 PIC X(22).
05 G-1-F2 PIC X(12).
05 G-2.
07 G-3-ELEMENTS PIC 9(08).
07 G-3
OCCURS UNBOUNDED
DEPENDING ON G-3-ELEMENTS.
10 G-4.
15 X PIC 9(22).
PROCEDURE DIVISION USING G-1.
DISPLAY G-1.
GOBACK.
])

AT_DATA([bad.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 G-1.
07 G-2-ELEMENTS PIC 9(08).
07 G-2
OCCURS UNBOUNDED
DEPENDING ON G-2-ELEMENTS.
10 X PIC X.
])

AT_DATA([bad2.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 G-1.
05 G-1-F1 PIC X(22).
05 G-2.
07 G-3-ELEMENTS PIC 9(08).
07 G-3
OCCURS UNBOUNDED.
10 G-4.
15 X PIC 9(22).
])

AT_DATA([bad3.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 G-1.
05 G-1-F1 PIC X(22).
05 G-1-F2 PIC X(12).
05 G-2.
07 G-3
OCCURS UNBOUNDED
DEPENDING ON G-3-ELEMENTS.
10 G-4.
15 X PIC 9(22).
])

AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
AT_CHECK([$COMPILE_ONLY -std=ibm-strict prog.cob], [0], [], [])

# TODO: opt to a different path, if UNBOUNDED is not reserved
AT_CHECK([$COMPILE_ONLY -std=cobol2014 prog.cob], [1], [],
[prog.cob:9: error: syntax error, unexpected Identifier, expecting UNBOUNDED
])

AT_CHECK([$COMPILE_ONLY prog2.cob], [0], [], [])

AT_CHECK([$COMPILE_ONLY bad.cob], [1], [],
[bad.cob:8: error: 'G-2' is not in LINKAGE SECTION
])

AT_CHECK([$COMPILE_ONLY bad2.cob], [1], [],
[bad2.cob:11: error: syntax error, unexpected ., expecting DEPENDING
])

AT_CHECK([$COMPILE_ONLY bad3.cob], [1], [],
[bad3.cob:10: error: 'G-3' is not in LINKAGE SECTION
bad3.cob:12: error: 'G-3-ELEMENTS' is not defined
])

AT_CLEANUP


Expand Down

0 comments on commit 6507f30

Please sign in to comment.