Skip to content

Commit

Permalink
Merge SVN 4681
Browse files Browse the repository at this point in the history
  • Loading branch information
@ddeclerck
ddeclerck committed Jun 21, 2024
1 parent f7be8bc commit 3dedda0
Show file tree
Hide file tree
Showing 27 changed files with 766 additions and 129 deletions.
22 changes: 22 additions & 0 deletions cobc/ChangeLog
View file
Original file line number Diff line number Diff line change
Expand Up @@ -276,6 +276,28 @@
literal errors (intead of cb_error_node) to prevent spurious
follow-up errors on their use

2022-07-12 Nicolas Berthier <[email protected]>

* parser.y: add DEPENDING ON for picture strings with an `L`
character
* config.def: new option picture-l
* tree.h (struct cb_picture, struct cb_field), tree.c
(cb_field_variable_size, cb_field_variable_address), typeck.c
(cb_build_identifier, cb_validate_program_data, cb_emit_initialize)
(cb_emit_move_corresponding, emit_move_corresponding), codegen.c
(chk_field_variable_size, chk_field_variable_address)
(out_odoslide_fld_offset): add support for `L` characters in picture
strings, variable-length alphanumeric fields (GCOS extension)
* field.c (validate_field_value): PIC L fields may not have VALUE clause
* field.c (validate_occurs): allow PIC L fields in OCCURS groups
* field.c (validate_redefines): allow more liberal REDEFINES of
fields with PIC L
* field.c (validate_group): A PIC L data-item cannot be JUSTIFIED
or BLANK WHEN ZERO
* typeck.c (emit_move_corresponding): simplified code
* codegen.c (output_base, output_initialize_uniform): small code
refactorings

2022-07-08 Simon Sobisch <[email protected]>

* parser.y (cancel_body): preparation for CANCEL ALL
Expand Down
15 changes: 10 additions & 5 deletions cobc/cobc.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2862,6 +2862,15 @@ process_command_line (const int argc, char **argv)
long_options, &idx, 1)) >= 0) {
switch (c) {

case 7:
/* -fmax-errors=<xx> : Maximum errors until abort */
n = cobc_deciph_optarg (cob_optarg, 0);
if (n < 0) {
cobc_err_exit (COBC_INV_PAR, "-fmax-errors");
}
cb_max_errors = n;
break;

case '?':
/* Unknown option or ambiguous */
if (verbose_output >= 1) {
Expand Down Expand Up @@ -3602,11 +3611,7 @@ process_command_line (const int argc, char **argv)

case 7:
/* -fmax-errors=<xx> : Maximum errors until abort */
n = cobc_deciph_optarg (cob_optarg, 0);
if (n < 0) {
cobc_err_exit (COBC_INV_PAR, "-fmax-errors");
}
cb_max_errors = n;
/* This option was processed in the first getopt-run */
break;

case 16:
Expand Down
32 changes: 16 additions & 16 deletions cobc/codegen.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,7 +51,7 @@
/* Type of initialization to be done */
enum cobc_init_type {
INITIALIZE_NONE = 0, /* no init (beause of FILLER, REDEFINES, ...) */
INITIALIZE_ONE, /* initialize a single varialbe */
INITIALIZE_ONE, /* initialize a single variable */
INITIALIZE_COMPOUND, /* init structure */
INITIALIZE_DEFAULT /* init to default-byte value / PIC (USAGE) */
};
Expand Down Expand Up @@ -783,7 +783,7 @@ chk_field_variable_size (struct cb_field *f)
f->vsize = NULL;
for (fc = f->children; fc && !fc->redefines; fc = fc->sister) {
if (fc->depending) {
if (cb_odoslide) {
if (cb_odoslide || f->flag_picture_l) {
f->vsize = fc;
break;
}
Expand All @@ -794,11 +794,13 @@ chk_field_variable_size (struct cb_field *f)
&& f->level != 77
&& !f->sister->redefines)
break;
if (fc->sister != NULL)
if (fc->sister != NULL)
continue; /* Group has sister so NOT vary size */
f->vsize = fc;
break;
}
} else if (fc->flag_picture_l) {
continue;
} else if ((p = chk_field_variable_size (fc)) != NULL) {
f->vsize = p;
break;
Expand Down Expand Up @@ -865,7 +867,10 @@ chk_field_variable_address (struct cb_field *fld)
struct cb_field *p;
for (p = f->parent; p; f = f->parent, p = f->parent) {
for (p = p->children; p != f; p = p->sister) {
if (p->depending || chk_field_variable_size (p)) {
/* Skip PIC L fields as their representation
have constant length */
if (p->depending ||
(!p->flag_picture_l && chk_field_variable_size (p))) {
fld->flag_vaddr_done = 1;
fld->vaddr = 1;
return 1;
Expand All @@ -888,7 +893,7 @@ out_odoslide_fld_offset (struct cb_field *p, struct cb_field *fld)
if (p == fld) /* Single field */
return 1;

if (p->children) {
if (p->children && !p->flag_picture_l) {
if (out_odoslide_grp_offset (p, fld))
return 1;
} else {
Expand Down Expand Up @@ -1146,7 +1151,6 @@ static void
output_base (struct cb_field *f, const cob_u32_t no_output)
{
struct cb_field *f01;
struct cb_field *p;

/* LCOV_EXCL_START */
if (f->flag_item_78) {
Expand Down Expand Up @@ -1196,7 +1200,7 @@ output_base (struct cb_field *f, const cob_u32_t no_output)
if (cb_odoslide) {
out_odoslide_offset (f01, f);
} else {
struct cb_field *v;
struct cb_field *v, *p;
for (p = f->parent; p; f = f->parent, p = f->parent) {
for (p = p->children; p != f; p = p->sister) {
v = chk_field_variable_size (p);
Expand Down Expand Up @@ -1761,10 +1765,9 @@ output_attr (const cb_tree x)
case COB_TYPE_GROUP:
case COB_TYPE_ALPHANUMERIC:
if (f->flag_justified) {
id = lookup_attr (type, 0, 0, COB_FLAG_JUSTIFIED, NULL, 0);
} else {
id = lookup_attr (type, 0, 0, 0, NULL, 0);
flags |= COB_FLAG_JUSTIFIED;
}
id = lookup_attr (type, 0, 0, flags, NULL, 0);
break;
default:
if (f->pic->have_sign) {
Expand Down Expand Up @@ -5557,15 +5560,12 @@ output_initialize_uniform (cb_tree x, const int c, const int size)
} else {
output ("memset (");
output_data (x);
if (size <= 0) {
output (", %d, ", c);
output_size (x);
output (");");
} else if (CB_REFERENCE_P(x) && CB_REFERENCE(x)->length) {
if (size <= 0 ||
(CB_REFERENCE_P(x) && CB_REFERENCE(x)->length)) {
output (", %d, ", c);
output_size (x);
output (");");
} else if (!gen_init_working
} else if (!gen_init_working
&& (f->flag_unbounded || !(cb_complex_odo || cb_odoslide))
&& chk_field_variable_size (f) != NULL) {
output (", %d, ", c);
Expand Down
3 changes: 3 additions & 0 deletions cobc/config.def
View file
Original file line number Diff line number Diff line change
Expand Up @@ -445,3 +445,6 @@ CB_CONFIG_SUPPORT (cb_self_call_recursive, "self-call-recursive",

CB_CONFIG_SUPPORT (cb_record_contains_depending_clause, "record-contains-depending-clause",
_("DEPENDING clause in RECORD CONTAINS"))

CB_CONFIG_SUPPORT (cb_picture_l, "picture-l",
_("PICTURE string with 'L' character"))
34 changes: 26 additions & 8 deletions cobc/field.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -940,7 +940,7 @@ copy_into_field (struct cb_field *source, struct cb_field *target)
"LIKE", cb_get_usage_string (target->usage));
target->flag_invalid = 1;
}

#if 0 /* TODO, also syntax-check for usage here */
if (target->cat is_numeric) {
sprintf (pic, "9(%d)", size_implied);
Expand Down Expand Up @@ -1179,7 +1179,7 @@ create_implicit_picture (struct cb_field *f)
ret = 1;
}
}

/* Checkme: should we raise an error for !cb_relaxed_syntax_checks? */
if (!ret) {
cb_warning_x (cb_warn_additional, x, _("defining implicit picture size %d for '%s'"),
Expand Down Expand Up @@ -1312,6 +1312,7 @@ validate_occurs (const struct cb_field * const f)
/* The data item that contains a OCCURS DEPENDING clause shall not
be subordinate to a data item that has an OCCURS clause */
for (p = f->parent; p; p = p->parent) {
if (p->flag_picture_l) continue;
if (p->flag_occurs) {
cb_error_x (CB_TREE (p),
_("'%s' cannot have an OCCURS clause due to '%s'"),
Expand Down Expand Up @@ -1346,10 +1347,11 @@ validate_redefines (const struct cb_field * const f)
}

/* Check variable occurrence */
if (f->depending || cb_field_variable_size (f)) {
if (f->depending ||
(!f->flag_picture_l && cb_field_variable_size (f))) {
cb_error_x (x, _("'%s' cannot be variable length"), f->name);
}
if (cb_field_variable_size (f->redefines)) {
if (!f->redefines->flag_picture_l && cb_field_variable_size (f->redefines)) {
cb_error_x (x, _("the original definition '%s' cannot be variable length"),
f->redefines->name);
}
Expand All @@ -1366,10 +1368,18 @@ validate_group (struct cb_field *f)
group_error (x, "PICTURE");
}
if (f->flag_justified) {
group_error (x, "JUSTIFIED RIGHT");
if (!f->flag_picture_l)
group_error (x, "JUSTIFIED RIGHT");
else
cb_error_x (x, _("'%s' cannot have JUSTIFIED RIGHT clause"),
cb_name (x));
}
if (f->flag_blank_zero) {
group_error (x, "BLANK WHEN ZERO");
if (!f->flag_picture_l)
group_error (x, "BLANK WHEN ZERO");
else
cb_error_x (x, _("'%s' cannot have BLANK WHEN ZERO clause"),
cb_name (x));
}

if (f->storage == CB_STORAGE_SCREEN &&
Expand Down Expand Up @@ -2336,6 +2346,7 @@ validate_field_1 (struct cb_field *f)
validate_occurs (f);
}


if (f->level == 66) {
/* no check for redefines here */
return 0;
Expand Down Expand Up @@ -2861,7 +2872,7 @@ compute_size (struct cb_field *f)
}

/* Ensure items within OCCURS are aligned correctly. */
if (f->occurs_max > 1
if (f->occurs_max > 1
&& occur_align_size > 1
&& (size_check % occur_align_size) != 0) {
pad = occur_align_size - (size_check % occur_align_size);
Expand Down Expand Up @@ -3094,7 +3105,14 @@ validate_field_value (struct cb_field *f)
{
if (f->values) {
if (f->usage != CB_USAGE_CONTROL) {
validate_move (CB_VALUE (f->values), CB_TREE (f), 1, NULL);
if (f->flag_picture_l) {
cb_error_x (CB_TREE (f),
_("%s and %s are mutually exclusive"),
_("variable-length PICTURE"), "VALUE");
f->values = NULL;
} else {
validate_move (CB_VALUE (f->values), CB_TREE (f), 1, NULL);
}
} else {
/* CHECK: possibly add validation according to control type */
}
Expand Down
Loading

0 comments on commit 3dedda0

Please sign in to comment.