void
ambiguous_error (cb_tree x)
{
struct cb_word *w;
struct cb_field *p;
struct cb_label *l2;
cb_tree l;
cb_tree y;
w = CB_REFERENCE (x)->word;
if (w->error == 0) {
if (!errnamebuff) {
errnamebuff = cobc_malloc (COB_NORMAL_BUFF);
}
/* display error on the first time */
snprintf (errnamebuff, COB_NORMAL_MAX, "'%s'", CB_NAME (x));
for (l = CB_REFERENCE (x)->chain; l; l = CB_REFERENCE (l)->chain) {
strcat (errnamebuff, " in '");
strcat (errnamebuff, CB_NAME (l));
strcat (errnamebuff, "'");
}
cb_error_x (x, _("%s ambiguous; need qualification"), errnamebuff);
w->error = 1;
/* display all fields with the same name */
for (l = w->items; l; l = CB_CHAIN (l)) {
y = CB_VALUE (l);
snprintf (errnamebuff, COB_NORMAL_MAX, "'%s' ", w->name);
switch (CB_TREE_TAG (y)) {
case CB_TAG_FIELD:
for (p = CB_FIELD (y)->parent; p; p = p->parent) {
strcat (errnamebuff, "in '");
strcat (errnamebuff, p->name);
strcat (errnamebuff, "' ");
}
break;
case CB_TAG_LABEL:
l2 = CB_LABEL (y);
if (l2->section) {
strcat (errnamebuff, "in '");
strcat (errnamebuff, (const char *)(l2->section->name));
strcat (errnamebuff, "' ");
}
break;
default:
break;
}
strcat (errnamebuff, _("defined here"));
cb_error_x (y, errnamebuff);
}
}
}
void
undefined_error (cb_tree x)
{
struct cb_reference *r;
cb_tree c;
if (!errnamebuff) {
errnamebuff = cobc_malloc (COB_NORMAL_BUFF);
}
r = CB_REFERENCE (x);
snprintf (errnamebuff, COB_NORMAL_MAX, "'%s'", CB_NAME (x));
for (c = r->chain; c; c = CB_REFERENCE (c)->chain) {
strcat (errnamebuff, " in '");
strcat (errnamebuff, CB_NAME (c));
strcat (errnamebuff, "'");
}
cb_error_x (x, _("%s undefined"), errnamebuff);
}
static int
validate_field_1 (struct cb_field *f)
{
cb_tree x;
cb_tree l;
char *name;
struct cb_field *p;
char *pp;
unsigned char *pstr;
int vorint;
int need_picture;
char pic[16];
x = CB_TREE (f);
name = cb_name (x);
if (f->flag_any_length) {
if (f->storage != CB_STORAGE_LINKAGE) {
cb_error_x (x, _("'%s' ANY LENGTH only allowed in LINKAGE"), name);
return -1;
}
if (f->level != 01) {
cb_error_x (x, _("'%s' ANY LENGTH must be 01 level"), name);
return -1;
}
if (f->flag_item_based || f->flag_external) {
cb_error_x (x, _("'%s' ANY LENGTH can not be BASED/EXTERNAL"), name);
return -1;
}
if (f->flag_occurs || f->occurs_depending ||
f->children || f->values || f->flag_blank_zero) {
cb_error_x (x, _("'%s' ANY LENGTH has invalid definition"), name);
return -1;
}
if (!f->pic) {
cb_error_x (x, _("'%s' ANY LENGTH must have a PICTURE"), name);
return -1;
}
if (f->pic->size != 1 || f->usage != CB_USAGE_DISPLAY) {
cb_error_x (x, _("'%s' ANY LENGTH has invalid definition"), name);
return -1;
}
f->count++;
return 0;
}
if (f->level == 77) {
if (f->storage != CB_STORAGE_WORKING &&
f->storage != CB_STORAGE_LOCAL &&
f->storage != CB_STORAGE_LINKAGE) {
cb_error_x (x, _("'%s' 77 level not allowed here"), name);
}
}
if (f->flag_external) {
if (f->level != 01 && f->level != 77) {
cb_error_x (x, _("'%s' EXTERNAL must be specified at 01/77 level"), name);
}
if (f->storage != CB_STORAGE_WORKING &&
f->storage != CB_STORAGE_FILE) {
cb_error_x (x, _("'%s' EXTERNAL can only be specified in WORKING-STORAGE section"),
name);
}
if (f->flag_item_based) {
cb_error_x (x, _("'%s' EXTERNAL and BASED are mutually exclusive"), name);
}
if (f->redefines) {
cb_error_x (x, _("'%s' EXTERNAL not allowed with REDEFINES"), name);
}
}
if (f->flag_item_based) {
if (f->storage != CB_STORAGE_WORKING &&
f->storage != CB_STORAGE_LOCAL &&
f->storage != CB_STORAGE_LINKAGE) {
cb_error_x (x, _("'%s' BASED not allowed here"), name);
}
if (f->redefines) {
cb_error_x (x, _("'%s' BASED not allowed with REDEFINES"), name);
}
if (f->level != 01 && f->level != 77) {
cb_error_x (x, _("'%s' BASED only allowed at the 01 and 77 levels"), name);
}
}
if (f->level == 66) {
if (!f->redefines) {
level_require_error (x, "RENAMES");
return -1;
}
if (f->flag_occurs) {
level_except_error (x, "RENAMES");
}
return 0;
}
/* validate OCCURS */
if (f->flag_occurs) {
if ((!cb_verify (cb_top_level_occurs_clause, "01/77 OCCURS")
&& (f->level == 01 || f->level == 77))
|| (f->level == 66 || f->level == 88)) {
level_redundant_error (x, "OCCURS");
}
for (l = f->index_list; l; l = CB_CHAIN (l)) {
cb_field (CB_VALUE (l))->flag_is_global = f->flag_is_global;
}
}
/* validate OCCURS DEPENDING */
if (f->occurs_depending) {
/* the data item that contains a OCCURS DEPENDING clause shall not
be subordinate to a data item that has the OCCURS clause */
for (p = f->parent; p; p = p->parent) {
if (p->flag_occurs) {
cb_error_x (CB_TREE (p),
_("'%s' cannot have the OCCURS clause due to '%s'"),
check_filler_name ((char *)p->name),
check_filler_name (name));
break;
}
}
/* the data item that contains a OCCURS DEPENDING clause must be
the last data item in the group */
for (p = f; p->parent; p = p->parent) {
for (; p->sister; p = p->sister) {
if (p->sister == cb_field (f->occurs_depending)) {
cb_error_x (x,
_("'%s' ODO field item invalid here"),
p->sister->name);
}
if (!p->sister->redefines) {
if (!cb_complex_odo) {
cb_error_x (x,
_("'%s' cannot have OCCURS DEPENDING"),
check_filler_name (name));
break;
}
}
}
}
/* If the field is GLOBAL, then the ODO must also be GLOBAL */
if (f->flag_is_global) {
if (!cb_field (f->occurs_depending)->flag_is_global) {
cb_error_x (x, _("'%s' ODO item must have GLOBAL attribute"),
cb_field (f->occurs_depending)->name);
}
if (f->storage != cb_field (f->occurs_depending)->storage) {
cb_error_x (x, _("GLOBAL '%s' ODO item is not in the same section as OCCURS"),
cb_field (f->occurs_depending)->name);
}
}
}
/* validate REDEFINES */
if (f->redefines) {
/* check OCCURS */
if (f->redefines->flag_occurs) {
cb_warning_x (x, _("The original definition '%s' should not have OCCURS"),
f->redefines->name);
}
/* check definition */
for (p = f->redefines->sister; p && p != f; p = p->sister) {
if (!p->redefines) {
cb_error_x (x, _("REDEFINES must follow the original definition"));
break;
}
}
/* check variable occurrence */
if (f->occurs_depending || cb_field_variable_size (f)) {
cb_error_x (x, _("'%s' cannot be variable length"), f->name);
}
if (cb_field_variable_size (f->redefines)) {
cb_error_x (x,
_("The original definition '%s' cannot be variable length"),
f->redefines->name);
}
}
if (f->children) {
/* group item */
if (f->pic) {
group_error (x, "PICTURE");
}
if (f->flag_justified) {
group_error (x, "JUSTIFIED RIGHT");
}
if (f->flag_blank_zero) {
group_error (x, "BLANK WHEN ZERO");
}
for (f = f->children; f; f = f->sister) {
if (validate_field_1 (f) != 0) {
return -1;
}
}
} else {
/* elementary item */
/* validate PICTURE */
need_picture = 1;
if (f->usage == CB_USAGE_INDEX
|| f->usage == CB_USAGE_LENGTH
|| f->usage == CB_USAGE_OBJECT
|| f->usage == CB_USAGE_POINTER
|| f->usage == CB_USAGE_PROGRAM_POINTER
|| f->usage == CB_USAGE_FLOAT
|| f->usage == CB_USAGE_DOUBLE
|| f->usage == CB_USAGE_SIGNED_CHAR
|| f->usage == CB_USAGE_SIGNED_SHORT
|| f->usage == CB_USAGE_SIGNED_INT
|| f->usage == CB_USAGE_SIGNED_LONG
|| f->usage == CB_USAGE_UNSIGNED_CHAR
|| f->usage == CB_USAGE_UNSIGNED_SHORT
|| f->usage == CB_USAGE_UNSIGNED_INT
|| f->usage == CB_USAGE_UNSIGNED_LONG
|| f->usage == CB_USAGE_PROGRAM) {
need_picture = 0;
}
if (f->pic == NULL && need_picture != 0) {
if (f->storage == CB_STORAGE_SCREEN) {
/* RXW
if (f->values &&
CB_LITERAL(CB_VALUE(f->values))->size) {
*/
if (f->values) {
sprintf (pic, "X(%d)", (int)CB_LITERAL(CB_VALUE(f->values))->size);
} else {
sprintf (pic, "X(1)");
}
f->pic = CB_PICTURE (cb_build_picture (pic));
} else if (f->flag_item_78 && f->values &&
CB_VALUE(f->values) != cb_error_node) {
f->count++;
if (CB_NUMERIC_LITERAL_P(CB_VALUE(f->values))) {
memset (pic, 0, sizeof (pic));
pp = pic;
if (CB_LITERAL(CB_VALUE(f->values))->sign) {
*pp++ = 'S';
}
vorint = CB_LITERAL(CB_VALUE(f->values))->size -
CB_LITERAL(CB_VALUE(f->values))->scale;
if (vorint) {
pp += sprintf (pp, "9(%d)", vorint);
}
if (CB_LITERAL(CB_VALUE(f->values))->scale) {
sprintf (pp, "V9(%d)",
CB_LITERAL(CB_VALUE(f->values))->scale);
}
if (CB_LITERAL(CB_VALUE(f->values))->size < 10) {
f->usage = CB_USAGE_COMP_5;
} else {
f->usage = CB_USAGE_DISPLAY;
}
f->pic = CB_PICTURE (cb_build_picture (pic));
f->pic->category = CB_CATEGORY_NUMERIC;
} else {
sprintf (pic, "X(%d)", (int)CB_LITERAL(CB_VALUE(f->values))->size);
f->pic = CB_PICTURE (cb_build_picture (pic));
f->pic->category = CB_CATEGORY_ALPHANUMERIC;
f->usage = CB_USAGE_DISPLAY;
}
} else {
if (f->flag_item_78) {
cb_error_x (x, _("Value required for constant item '%s'"), name);
} else {
cb_error_x (x, _("PICTURE clause required for '%s'"), check_filler_name (name));
}
return -1;
}
}
if (f->pic != NULL && need_picture == 0) {
cb_error_x (x, _("'%s' cannot have PICTURE clause"), check_filler_name (name));
}
/* validate USAGE */
switch (f->usage) {
case CB_USAGE_SIGNED_CHAR:
f->usage = CB_USAGE_COMP_5;
f->pic = CB_PICTURE (cb_build_picture ("S99"));
f->flag_real_binary = 1;
break;
case CB_USAGE_SIGNED_SHORT:
f->usage = CB_USAGE_COMP_5;
f->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
f->flag_real_binary = 1;
break;
case CB_USAGE_SIGNED_INT:
f->usage = CB_USAGE_COMP_5;
f->pic = CB_PICTURE (cb_build_picture ("S9(9)"));
f->flag_real_binary = 1;
break;
case CB_USAGE_SIGNED_LONG:
f->usage = CB_USAGE_COMP_5;
f->pic = CB_PICTURE (cb_build_picture ("S9(18)"));
f->flag_real_binary = 1;
break;
case CB_USAGE_UNSIGNED_CHAR:
f->usage = CB_USAGE_COMP_5;
f->pic = CB_PICTURE (cb_build_picture ("99"));
f->flag_real_binary = 1;
break;
case CB_USAGE_UNSIGNED_SHORT:
f->usage = CB_USAGE_COMP_5;
f->pic = CB_PICTURE (cb_build_picture ("9(4)"));
f->flag_real_binary = 1;
break;
case CB_USAGE_UNSIGNED_INT:
f->usage = CB_USAGE_COMP_5;
f->pic = CB_PICTURE (cb_build_picture ("9(9)"));
f->flag_real_binary = 1;
break;
case CB_USAGE_UNSIGNED_LONG:
f->usage = CB_USAGE_COMP_5;
f->pic = CB_PICTURE (cb_build_picture ("9(18)"));
f->flag_real_binary = 1;
break;
case CB_USAGE_BINARY:
case CB_USAGE_PACKED:
if (f->pic->category != CB_CATEGORY_NUMERIC) {
cb_error_x (x, _("'%s' PICTURE clause not compatible with USAGE"), name);
}
break;
case CB_USAGE_COMP_5:
case CB_USAGE_COMP_X:
if (f->pic) {
if (f->pic->category != CB_CATEGORY_NUMERIC &&
f->pic->category != CB_CATEGORY_ALPHANUMERIC) {
cb_error_x (x, _("'%s' PICTURE clause not compatible with USAGE"), name);
}
}
break;
default:
break;
}
/* validate SIGN */
/* validate JUSTIFIED RIGHT */
if (f->flag_justified) {
switch (f->pic->category) {
case CB_CATEGORY_ALPHABETIC:
case CB_CATEGORY_ALPHANUMERIC:
break;
default:
cb_error_x (x, _("'%s' cannot have JUSTIFIED RIGHT"), name);
break;
}
}
/* validate SYNCHRONIZED */
/* validate BLANK ZERO */
if (f->flag_blank_zero) {
switch (f->pic->category) {
case CB_CATEGORY_NUMERIC:
/* reconstruct the picture string */
if (f->pic->scale > 0) {
f->pic->str = cobc_malloc (20);
pstr = (unsigned char *)(f->pic->str);
*pstr++ = '9';
vorint = f->pic->digits - f->pic->scale;
memcpy (pstr, (unsigned char *)&vorint, sizeof(int));
pstr += sizeof(int);
*pstr++ = 'V';
vorint = 1;
memcpy (pstr, (unsigned char *)&vorint, sizeof(int));
pstr += sizeof(int);
*pstr++ = '9';
vorint = f->pic->scale;
memcpy (pstr, (unsigned char *)&vorint, sizeof(int));
f->pic->size++;
} else {
f->pic->str = cobc_malloc (8);
pstr = (unsigned char *)(f->pic->str);
*pstr++ = '9';
vorint = f->pic->digits;
memcpy (pstr, (unsigned char *)&vorint, sizeof(int));
}
f->pic->category = CB_CATEGORY_NUMERIC_EDITED;
break;
case CB_CATEGORY_NUMERIC_EDITED:
break;
default:
cb_error_x (x, _("'%s' cannot have BLANK WHEN ZERO"), name);
break;
}
}
/* validate VALUE */
if (f->values) {
if (CB_PAIR_P (CB_VALUE (f->values)) || CB_CHAIN (f->values)) {
cb_error_x (x, _("Only level 88 item may have multiple values"));
}
/* ISO+IEC+1989-2002: 13.16.42.2-10 */
for (p = f; p; p = p->parent) {
if (p->redefines) {
cb_error_x (x, _("Entries under REDEFINES cannot have VALUE clause"));
}
if (p->flag_external) {
cb_warning_x (x, _("VALUE clause ignored for EXTERNAL items"));
}
}
}
}
return 0;
}
int
cb_load_conf (const char *fname, const int check_nodef, const int prefix_dir)
{
char *s;
char *e;
const char *name;
const char *val;
void *var;
FILE *fp;
char *nores;
struct noreserve *noresptr;
int i;
int j;
int ret;
int saveret;
int line;
char buff[COB_SMALL_BUFF];
/* initialize the config table */
if (check_nodef) {
for (i = 0; config_table[i].name; i++) {
config_table[i].val = NULL;
}
}
if (prefix_dir) {
snprintf (buff, COB_SMALL_MAX, "%s/%s", cob_config_dir, fname);
name = buff;
} else {
name = fname;
}
/* open the config file */
fp = fopen (name, "r");
if (fp == NULL) {
perror (name);
return -1;
}
/* read the config file */
ret = 0;
line = 0;
while (fgets (buff, COB_SMALL_BUFF, fp)) {
line++;
/* skip comments */
if (buff[0] == '#') {
continue;
}
/* skip blank lines */
for (s = buff; *s; s++) {
if (isgraph (*s)) {
break;
}
}
if (!*s) {
continue;
}
/* get the tag */
s = strpbrk (buff, " \t:=");
if (!s) {
fprintf (stderr, "%s:%d: invalid line\n", fname, line);
ret = -1;
continue;
}
*s = 0;
/* find the entry */
for (i = 0; config_table[i].name; i++) {
if (strcmp (buff, config_table[i].name) == 0) {
break;
}
}
if (!config_table[i].name) {
fprintf (stderr, "%s:%d: unknown tag '%s'\n", fname, line, buff);
ret = -1;
continue;
}
/* get the value */
for (s++; *s && strchr (" \t:=", *s); s++) {
;
}
e = s + strlen (s) - 1;
for (; e >= s && strchr (" \t\r\n", *e); e--) {
;
}
e[1] = 0;
config_table[i].val = s;
/* set the value */
name = config_table[i].name;
var = config_table[i].var;
val = config_table[i].val;
switch (config_table[i].type) {
case ANY:
if (strcmp (name, "assign-clause") == 0) {
if (strcmp (val, "cobol2002") == 0) {
unsupported_value (fname, line, val);
ret = -1;
} else if (strcmp (val, "mf") == 0) {
cb_assign_clause = CB_ASSIGN_MF;
} else if (strcmp (val, "ibm") == 0) {
cb_assign_clause = CB_ASSIGN_IBM;
} else if (strcmp (val, "jph1") == 0) {
cb_assign_clause = CB_ASSIGN_JPH1;
} else {
invalid_value (fname, line, name);
ret = -1;
}
} else if (strcmp (name, "binary-size") == 0) {
if (strcmp (val, "2-4-8") == 0) {
cb_binary_size = CB_BINARY_SIZE_2_4_8;
} else if (strcmp (val, "1-2-4-8") == 0) {
cb_binary_size = CB_BINARY_SIZE_1_2_4_8;
} else if (strcmp (val, "1--8") == 0) {
cb_binary_size = CB_BINARY_SIZE_1__8;
} else {
invalid_value (fname, line, name);
ret = -1;
}
} else if (strcmp (name, "binary-byteorder") == 0) {
if (strcmp (val, "native") == 0) {
cb_binary_byteorder = CB_BYTEORDER_NATIVE;
} else if (strcmp (val, "big-endian") == 0) {
cb_binary_byteorder = CB_BYTEORDER_BIG_ENDIAN;
} else {
invalid_value (fname, line, name);
ret = -1;
}
} else if (strcmp (name, "abort-on-io-exception") == 0) {
if (strcmp (val, "any") == 0) {
cb_abort_on_io_exception = CB_ABORT_ON_IO_ANY;
} else if (strcmp (val, "fatal") == 0) {
cb_abort_on_io_exception = CB_ABORT_ON_IO_FATAL;
} else if (strcmp (val, "never") == 0) {
cb_abort_on_io_exception = CB_ABORT_ON_IO_NEVER;
} else {
invalid_value (fname, line, name);
ret = -1;
}
} else if (strcmp (name, "default-organization") == 0) {
if (strcmp (val, "record-sequential") == 0) {
cb_default_organization = CB_ORG_RECORD_SEQUENTIAL;
} else if (strcmp (val, "line-sequential") == 0) {
cb_default_organization = CB_ORG_LINE_SEQUENTIAL;
} else {
invalid_value (fname, line, name);
ret = -1;
}
}
break;
case INT:
for (j = 0; val[j]; j++) {
if (!isdigit (val[j])) {
invalid_value (fname, line, name);
ret = -1;
break;
}
}
*((int *)var) = atoi (val);
break;
case STRING:
val = read_string (val);
if (strcmp (name, "include") == 0) {
/* include another conf file */
saveret = ret;
if (cb_load_conf (val, 0, 1) != 0) {
return -1;
}
ret = saveret;
} else if (strcmp (name, "not-reserved") == 0) {
nores = read_string (val);
noresptr = cobc_malloc (sizeof (struct noreserve));
noresptr->noresword = cobc_malloc (strlen (nores) + 1);
strcpy (noresptr->noresword, nores);
noresptr->next = norestab;
norestab = noresptr;
} else {
*((const char **)var) = val;
}
break;
case CHAR:
if (1 != strnlen (val, 2)) {
invalid_value (fname, line, name);
ret = -1;
} else {
*((char *)var) = *val;
}
break;
case BOOLEAN:
if (strcmp (val, "yes") == 0) {
*((int *)var) = 1;
} else if (strcmp (val, "no") == 0) {
*((int *)var) = 0;
} else {
invalid_value (fname, line, name);
ret = -1;
}
break;
case SUPPORT:
if (strcmp (val, "ok") == 0) {
*((enum cb_support *)var) = CB_OK;
} else if (strcmp (val, "warning") == 0) {
*((enum cb_support *)var) = CB_WARNING;
} else if (strcmp (val, "archaic") == 0) {
*((enum cb_support *)var) = CB_ARCHAIC;
} else if (strcmp (val, "obsolete") == 0) {
*((enum cb_support *)var) = CB_OBSOLETE;
} else if (strcmp (val, "skip") == 0) {
*((enum cb_support *)var) = CB_SKIP;
} else if (strcmp (val, "ignore") == 0) {
*((enum cb_support *)var) = CB_IGNORE;
} else if (strcmp (val, "error") == 0) {
*((enum cb_support *)var) = CB_ERROR;
} else if (strcmp (val, "unconformable") == 0) {
*((enum cb_support *)var) = CB_UNCONFORMABLE;
} else {
invalid_value (fname, line, name);
ret = -1;
}
break;
default:
fprintf (stderr, _("%s:%d: invalid type for '%s'\n"),
fname, line, name);
ret = -1;
break;
}
}
fclose (fp);
/* if assign_external is not setted in config file */
for (i = 0; config_table[i].name; i++) {
if (config_table[i].val == NULL && strcmp (config_table[i].name, "assign_external") == 0) {
config_table[i].val = (char *)"no";
*((int *)config_table[i].var) = 0;
}
}
/* checks for no definition */
if (check_nodef) {
for (i = 2; config_table[i].name; i++) {
if (config_table[i].val == NULL) {
fprintf (stderr, "%s: no definition of '%s'\n",
fname, config_table[i].name);
ret = -1;
}
}
}
return ret;
}
