|
OpenCOBOL 1.1pre-rel
|
|
OpenCOBOL 1.1pre-rel
|
#include "config.h"#include <stdio.h>#include <stdlib.h>#include <string.h>#include <ctype.h>#include <time.h>#include <sys/time.h>#include <locale.h>#include "cobc.h"#include "tree.h"#include "libcob/system.def"
Go to the source code of this file.
| #define cb_emit | ( | x | ) | current_statement->body = cb_list_add (current_statement->body, x) |
| #define cb_emit_list | ( | l | ) | current_statement->body = cb_list_append (current_statement->body, l) |
| #define COB_SYSTEM_GEN | ( | x, | |
| y, | |||
| z | |||
| ) | { x, y }, |
| #define dpush | ( | x | ) | decimal_stack = cb_cons (x, decimal_stack) |
| #define TOKEN | ( | offset | ) | (expr_stack[expr_index + offset].token) |
| #define VALUE | ( | offset | ) | (expr_stack[expr_index + offset].value) |
Definition at line 2591 of file typeck.c.
{
cb_tree opt;
struct cb_field *f;
#ifdef COB_NON_ALIGNED
if (CB_INDEX_P (v)) {
return cb_build_move (cb_build_binary_op (v, '+', n), v);
}
if (CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
current_program->gen_ptrmanip = 1;
return cb_build_funcall_3 ("cob_pointer_manip", v, n, cb_int0);
}
#else
if (CB_INDEX_P (v) || CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
return cb_build_move (cb_build_binary_op (v, '+', n), v);
}
#endif
if (CB_REF_OR_FIELD_P (v)) {
f = cb_field (v);
f->count++;
}
if (CB_REF_OR_FIELD_P (n)) {
f = cb_field (n);
f->count++;
}
if (round_opt == cb_high) {
if (cb_fits_int (n)) {
return cb_build_optim_add (v, n);
} else {
return cb_build_funcall_3 ("cob_add", v, n, cb_int0);
}
}
opt = build_store_option (v, round_opt);
if (opt == cb_int0 && cb_fits_int (n)) {
return cb_build_optim_add (v, n);
}
return cb_build_funcall_3 ("cob_add", v, n, opt);
}
Definition at line 1027 of file typeck.c.
{
if (x == cb_error_node ||
(CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node)) {
return cb_error_node;
}
return cb_build_cast_address (x);
}
Definition at line 677 of file typeck.c.
{
const char *s;
const char *p;
if (name == cb_error_node) {
return cb_error_node;
}
switch (CB_TREE_TAG (name)) {
case CB_TAG_LITERAL:
if (strcmp ((char *)(CB_LITERAL(name)->data), "$#@DUMMY@#$") == 0) {
cfile->special = 2;
}
return name;
case CB_TAG_REFERENCE:
s = CB_REFERENCE (name)->word->name;
if (strcasecmp (s, "KEYBOARD") == 0) {
s = "#DUMMY#";
cfile->special = 1;
return cb_build_alphanumeric_literal ((ucharptr)s, strlen (s));
}
switch (cb_assign_clause) {
case CB_ASSIGN_COBOL2002:
/* TODO */
return cb_error_node;
case CB_ASSIGN_MF:
if (cfile->external_assign) {
p = strrchr (s, '-');
if (p) {
s = p + 1;
}
return cb_build_alphanumeric_literal ((ucharptr)s, strlen (s));
}
current_program->reference_list =
cb_list_add (current_program->reference_list, name);
return name;
case CB_ASSIGN_IBM:
/* check organization */
if (strncmp (s, "S-", 2) == 0 ||
strncmp (s, "AS-", 3) == 0) {
goto org;
}
/* skip the device label if exists */
if ((p = strchr (s, '-')) != NULL) {
s = p + 1;
}
/* check organization again */
if (strncmp (s, "S-", 2) == 0 ||
strncmp (s, "AS-", 3) == 0) {
org:
/* skip it for now */
s = strchr (s, '-') + 1;
}
/* convert the name into literal */
return cb_build_alphanumeric_literal ((ucharptr)s, strlen (s));
}
default:
return cb_error_node;
}
}
Definition at line 2354 of file typeck.c.
{
int size1;
int size2;
struct cb_field *f;
struct cb_binary_op *p;
cb_tree d1;
cb_tree d2;
switch (CB_TREE_TAG (x)) {
case CB_TAG_CONST:
case CB_TAG_FUNCALL:
return x;
case CB_TAG_REFERENCE:
if (!CB_FIELD_P (cb_ref (x))) {
return cb_build_cond (cb_ref (x));
}
f = cb_field (x);
/* level 88 condition */
if (f->level == 88) {
/* We need to build a 88 condition at every occurrence
instead of once at the beginning because a 88 item
may be subscripted (i.e., it is not a constant tree). */
return cb_build_cond (build_cond_88 (x));
}
cb_error_x (x, _("Invalid expression"));
return cb_error_node;
case CB_TAG_BINARY_OP:
p = CB_BINARY_OP (x);
switch (p->op) {
case '!':
return cb_build_negation (cb_build_cond (p->x));
case '&':
case '|':
return cb_build_binary_op (cb_build_cond (p->x), p->op, cb_build_cond (p->y));
default:
if (CB_INDEX_P (p->x) || CB_INDEX_P (p->y)
|| CB_TREE_CLASS (p->x) == CB_CLASS_POINTER
|| CB_TREE_CLASS (p->y) == CB_CLASS_POINTER) {
x = cb_build_binary_op (p->x, '-', p->y);
} else if (CB_BINARY_OP_P (p->x) || CB_BINARY_OP_P (p->y)) {
/* decimal comparison */
d1 = decimal_alloc ();
d2 = decimal_alloc ();
decimal_expand (d1, p->x);
decimal_expand (d2, p->y);
dpush (cb_build_funcall_2 ("cob_decimal_cmp", d1, d2));
decimal_free ();
decimal_free ();
x = cb_list_reverse (decimal_stack);
decimal_stack = NULL;
} else {
if (cb_chk_num_cond (p->x, p->y)) {
size1 = cb_field_size (p->x);
x = cb_build_funcall_3 ("memcmp",
cb_build_cast_address (p->x),
cb_build_cast_address (p->y),
cb_int (size1));
break;
}
if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC
&& CB_TREE_CLASS (p->y) == CB_CLASS_NUMERIC
&& cb_fits_int (p->y)) {
x = cb_build_optim_cond (p);
break;
}
/* field comparison */
if ((CB_REF_OR_FIELD_P (p->x))
&& (CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHANUMERIC ||
CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHABETIC)
&& (cb_field_size (p->x) == 1)
&& (!current_program->alphabet_name_list)
&& (p->y == cb_space || p->y == cb_low ||
p->y == cb_high || p->y == cb_zero)) {
x = cb_build_funcall_2 ("$G", p->x, p->y);
break;
}
if (cb_chk_alpha_cond (p->x) && cb_chk_alpha_cond (p->y)) {
size1 = cb_field_size (p->x);
size2 = cb_field_size (p->y);
} else {
size1 = 0;
size2 = 0;
}
if (size1 == 1 && size2 == 1) {
x = cb_build_funcall_2 ("$G", p->x, p->y);
} else if (size1 != 0 && size1 == size2) {
x = cb_build_funcall_3 ("memcmp",
cb_build_cast_address (p->x),
cb_build_cast_address (p->y),
cb_int (size1));
} else {
if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC && p->y == cb_zero) {
x = cb_build_optim_cond (p);
} else {
x = cb_build_funcall_2 ("cob_cmp", p->x, p->y);
}
}
}
}
return cb_build_binary_op (x, p->op, p->y);
default:
cb_error_x (x, _("Invalid expression"));
return cb_error_node;
}
/* NOT REACHED */
return x;
}
Definition at line 956 of file typeck.c.
{
struct cb_field *f;
char buff[64];
if (x == cb_error_node) {
return cb_error_node;
}
if (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node) {
return cb_error_node;
}
memset (buff, 0, sizeof (buff));
f = CB_FIELD (cb_ref (x));
if (f->flag_any_length) {
cb_error (_("ANY LENGTH item not allowed here"));
return cb_error_node;
}
if (f->level == 88) {
cb_error (_("88 level item not allowed here"));
return cb_error_node;
}
if (!f->flag_is_verified) {
cb_validate_field (f);
}
sprintf (buff, "%d", f->memory_size);
return cb_build_numeric_literal (0, (ucharptr)buff, 0);
}
Definition at line 3847 of file typeck.c.
{
return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_converting", x, y));
}
Definition at line 3406 of file typeck.c.
{
if (x == cb_error_node) {
return cb_error_node;
}
switch (CB_SYSTEM_NAME (cb_ref (x))->token) {
case CB_DEVICE_CONSOLE:
case CB_DEVICE_SYSOUT:
return cb_int0;
case CB_DEVICE_SYSERR:
return cb_int1;
default:
cb_error_x (x, _("Invalid output stream"));
return cb_error_node;
}
}
Definition at line 3425 of file typeck.c.
{
const char *name;
cb_tree sys;
if (x == cb_error_node) {
return cb_error_node;
}
name = CB_NAME (x);
if (CB_REFERENCE (x)->word->count == 0) {
sys = lookup_system_name (CB_NAME (x));
if (sys != cb_error_node) {
switch (CB_SYSTEM_NAME (sys)->token) {
case CB_DEVICE_CONSOLE:
case CB_DEVICE_SYSOUT:
cb_warning_x (x, _("'%s' undefined in SPECIAL-NAMES"), name);
return cb_int0;
case CB_DEVICE_SYSERR:
cb_warning_x (x, _("'%s' undefined in SPECIAL-NAMES"), name);
return cb_int1;
default:
break;
}
}
}
cb_error_x (x, _("'%s' undefined in SPECIAL-NAMES"), name);
return cb_error_node;
}
Definition at line 1820 of file typeck.c.
{
cb_tree l;
/* RXW
cb_tree x;
*/
int op;
cb_expr_init ();
for (l = list; l; l = CB_CHAIN (l)) {
op = CB_PURPOSE_INT (l);
switch (op) {
case '9': /* NUMERIC */
cb_expr_shift_class ("cob_is_numeric");
break;
case 'A': /* ALPHABETIC */
cb_expr_shift_class ("cob_is_alpha");
break;
case 'L': /* ALPHABETIC_LOWER */
cb_expr_shift_class ("cob_is_lower");
break;
case 'U': /* ALPHABETIC_UPPER */
cb_expr_shift_class ("cob_is_upper");
break;
case 'P': /* POSITIVE */
cb_expr_shift_sign ('>');
break;
case 'N': /* NEGATIVE */
cb_expr_shift_sign ('<');
break;
case 'O': /* OMITTED */
current_statement->null_check = NULL;
cb_expr_shift_class ("cob_is_omitted");
break;
/* RXW
case 'x':
if (CB_VALUE (l) && CB_REFERENCE_P (CB_VALUE (l))) {
x = CB_CHAIN (l);
if (x && cb_field (CB_VALUE (l))->level == 88) {
switch (CB_PURPOSE_INT (x)) {
case '&':
case '|':
case '(':
case ')':
break;
default:
cb_error (_("Invalid condition"));
break;
}
}
}
cb_expr_shift (op, CB_VALUE (l));
break;
*/
default:
cb_expr_shift (op, CB_VALUE (l));
break;
}
}
return cb_expr_finish ();
}
Definition at line 763 of file typeck.c.
{
struct cb_reference *r;
struct cb_field *f;
struct cb_field *p;
const char *name;
cb_tree v;
cb_tree e1;
cb_tree e2;
cb_tree l;
cb_tree sub;
int offset;
int length;
int n;
if (x == cb_error_node) {
return cb_error_node;
}
r = CB_REFERENCE (x);
name = r->word->name;
/* resolve reference */
v = cb_ref (x);
if (v == cb_error_node) {
return cb_error_node;
}
/* check if it is a data name */
if (!CB_FIELD_P (v)) {
if (r->subs) {
cb_error_x (x, _("'%s' cannot be subscripted"), name);
return cb_error_node;
}
if (r->offset) {
cb_error_x (x, _("'%s' cannot be reference modified"), name);
return cb_error_node;
}
return x;
}
f = CB_FIELD (v);
/* BASED check */
if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_PTR)) {
for (p = f; p->parent; p = p->parent) {
;
}
if (current_statement) {
if (p->flag_item_based ||
(f->storage == CB_STORAGE_LINKAGE &&
!p->flag_is_pdiv_parm)) {
current_statement->null_check = cb_build_funcall_2 (
"cob_check_based",
cb_build_address (cb_build_field_reference (p, NULL)),
cb_build_string0 ((ucharptr)name));
}
}
}
/* check the number of subscripts */
if (!r->all && cb_list_length (r->subs) != f->indexes) {
switch (f->indexes) {
case 0:
cb_error_x (x, _("'%s' cannot be subscripted"), name);
return cb_error_node;
case 1:
cb_error_x (x, _("'%s' requires 1 subscript"), name);
return cb_error_node;
default:
cb_error_x (x, _("'%s' requires %d subscripts"), name, f->indexes);
return cb_error_node;
}
}
/* subscript check */
if (!r->all && r->subs) {
l = r->subs;
for (p = f; p; p = p->parent) {
if (p->flag_occurs) {
sub = cb_check_integer_value (CB_VALUE (l));
l = CB_CHAIN (l);
if (sub == cb_error_node) {
continue;
}
/* compile-time check */
if (CB_LITERAL_P (sub)) {
n = cb_get_int (sub);
if (n < 1 || n > p->occurs_max) {
cb_error_x (x, _("Subscript of '%s' out of bounds: %d"),
name, n);
}
}
/* run-time check */
if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
if (p->occurs_depending) {
e1 = cb_build_funcall_4 ("cob_check_odo",
cb_build_cast_integer (p->occurs_depending),
cb_int (p->occurs_min),
cb_int (p->occurs_max),
cb_build_string0
((ucharptr)(cb_field (p->occurs_depending)->name)));
e2 = cb_build_funcall_4 ("cob_check_subscript",
cb_build_cast_integer (sub),
cb_int1,
cb_build_cast_integer (p->occurs_depending),
cb_build_string0 ((ucharptr)name));
r->check = cb_list_add (r->check, e1);
r->check = cb_list_add (r->check, e2);
} else {
if (!CB_LITERAL_P (sub)) {
e1 = cb_build_funcall_4 ("cob_check_subscript",
cb_build_cast_integer (sub),
cb_int1,
cb_int (p->occurs_max),
cb_build_string0 ((ucharptr)name));
r->check = cb_list_add (r->check, e1);
}
}
}
}
}
}
/* reference modification check */
if (r->offset) {
/* compile-time check */
if (CB_LITERAL_P (r->offset)) {
offset = cb_get_int (r->offset);
if (offset < 1 || offset > f->size) {
cb_error_x (x, _("Offset of '%s' out of bounds: %d"), name, offset);
} else if (r->length && CB_LITERAL_P (r->length)) {
length = cb_get_int (r->length);
if (length < 1 || length > f->size - offset + 1) {
cb_error_x (x, _("Length of '%s' out of bounds: %d"),
name, length);
}
}
}
/* run-time check */
if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_REF_MOD)) {
if (!CB_LITERAL_P (r->offset)
|| (r->length && !CB_LITERAL_P (r->length))) {
e1 = cb_build_funcall_4 ("cob_check_ref_mod",
cb_build_cast_integer (r->offset),
r->length ? cb_build_cast_integer (r->length) :
cb_int1, cb_int (f->size),
cb_build_string0 ((ucharptr)f->name));
r->check = cb_list_add (r->check, e1);
}
}
}
if (f->storage == CB_STORAGE_CONSTANT) {
return CB_VALUE (f->values);
}
return x;
}
Definition at line 744 of file typeck.c.
{
struct cb_field *f;
f = CB_FIELD (cb_build_field (x));
f->usage = CB_USAGE_INDEX;
cb_validate_field (f);
if (values) {
f->values = cb_list_init (values);
}
if (qual) {
f->index_qual = qual;
}
f->flag_indexed_by = indexed_by;
current_program->working_storage = cb_field_add (current_program->working_storage, f);
return x;
}
Definition at line 3859 of file typeck.c.
{
if (pos == CB_BEFORE) {
return cb_list_add (l, cb_build_funcall_1 ("cob_inspect_before", x));
} else {
return cb_list_add (l, cb_build_funcall_1 ("cob_inspect_after", x));
}
}
| cb_tree cb_build_inspect_region_start | ( | void | ) |
Definition at line 3853 of file typeck.c.
{
return cb_list_init (cb_build_funcall_0 ("cob_inspect_start"));
}
Definition at line 986 of file typeck.c.
{
struct cb_field *f;
struct cb_literal *l;
cb_tree temp;
char buff[64];
if (x == cb_error_node) {
return cb_error_node;
}
if (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node) {
return cb_error_node;
}
memset (buff, 0, sizeof (buff));
if (CB_LITERAL_P (x)) {
l = CB_LITERAL (x);
sprintf (buff, "%d", (int)l->size);
return cb_build_numeric_literal (0, (ucharptr)buff, 0);
}
if (CB_REF_OR_FIELD_P (x)) {
f = CB_FIELD (cb_ref (x));
if (f->flag_any_length) {
return cb_build_any_intrinsic (cb_list_init (x));
}
if (cb_field_variable_size (f) == NULL) {
sprintf (buff, "%d", cb_field_size (x));
return cb_build_numeric_literal (0, (ucharptr)buff, 0);
}
}
if (CB_INTRINSIC_P (x)) {
return cb_build_any_intrinsic (cb_list_init (x));
}
temp = cb_build_index (cb_build_filler (), NULL, 0, NULL);
CB_FIELD (cb_ref (temp))->usage = CB_USAGE_LENGTH;
CB_FIELD (cb_ref (temp))->count++;
cb_emit (cb_build_assign (temp, cb_build_length_1 (x)));
return temp;
}
Definition at line 4964 of file typeck.c.
{
struct cb_field *f;
struct cb_field *p;
if (src == cb_error_node || dst == cb_error_node) {
return cb_error_node;
}
if (validate_move (src, dst, 0) < 0) {
return cb_error_node;
}
if (CB_REFERENCE_P (src)) {
CB_REFERENCE (src)->type = CB_SENDING_OPERAND;
}
if (CB_REFERENCE_P (dst)) {
CB_REFERENCE (dst)->type = CB_RECEIVING_OPERAND;
}
if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER) {
return cb_build_assign (dst, src);
}
if (CB_REFERENCE_P (src) && CB_ALPHABET_NAME_P(CB_REFERENCE(src)->value)) {
return cb_build_move_call (src, dst);
}
if (CB_INDEX_P (dst)) {
if (src == cb_null) {
return cb_build_assign (dst, cb_zero);
}
return cb_build_assign (dst, src);
}
if (CB_INDEX_P (src)) {
return cb_build_funcall_2 ("cob_set_int", dst, cb_build_cast_integer (src));
}
if (CB_INTRINSIC_P (src) || CB_INTRINSIC_P (dst)) {
return cb_build_move_call (src, dst);
}
f = cb_field (dst);
if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
for (p = f; p; p = p->parent) {
if (p->flag_occurs) {
return cb_build_move_call (src, dst);
}
}
if (CB_REF_OR_FIELD_P (src)) {
for (p = cb_field (src); p; p = p->parent) {
if (p->flag_occurs) {
return cb_build_move_call (src, dst);
}
}
}
}
/* output optimal code */
if (src == cb_zero) {
return cb_build_move_zero (dst);
} else if (src == cb_space) {
return cb_build_move_space (dst);
} else if (src == cb_high) {
return cb_build_move_high (dst);
} else if (src == cb_low) {
return cb_build_move_low (dst);
} else if (src == cb_quote) {
return cb_build_move_quote (dst);
} else if (CB_LITERAL_P (src)) {
return cb_build_move_literal (src, dst);
}
return cb_build_move_field (src, dst);
}
Definition at line 5156 of file typeck.c.
{
cb_tree x;
x = cb_build_perform (CB_PERFORM_EXIT);
CB_PERFORM (x)->data = CB_TREE (label);
return x;
}
Definition at line 5143 of file typeck.c.
{
cb_tree x;
if (body == cb_error_node) {
return cb_error_node;
}
x = cb_build_perform (CB_PERFORM_FOREVER);
CB_PERFORM (x)->body = body;
return x;
}
Definition at line 5105 of file typeck.c.
{
cb_tree x;
if (body == cb_error_node) {
return cb_error_node;
}
x = cb_build_perform (CB_PERFORM_ONCE);
CB_PERFORM (x)->body = body;
return x;
}
Definition at line 5118 of file typeck.c.
{
cb_tree x;
if (cb_check_integer_value (times) == cb_error_node) {
return cb_error_node;
}
x = cb_build_perform (CB_PERFORM_TIMES);
CB_PERFORM (x)->data = times;
return x;
}
Definition at line 5132 of file typeck.c.
{
cb_tree x;
x = cb_build_perform (CB_PERFORM_UNTIL);
CB_PERFORM (x)->test = condition;
CB_PERFORM (x)->varying = varying;
return x;
}
Definition at line 1038 of file typeck.c.
{
struct cb_field *f;
if (x == cb_error_node ||
(CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node)) {
return cb_error_node;
}
if (CB_REFERENCE_P (x)) {
f = cb_field (cb_ref(x));
f->count++;
}
return cb_build_cast_ppointer (x);
}
Definition at line 591 of file typeck.c.
{
const char *s;
/* This needs some more thought, should we generate an entry
point per program source name ?
if (alt_name) {
s = (char *)CB_LITERAL (alt_name)->data;
} else if (CB_LITERAL_P (name)) {
s = (char *)CB_LITERAL (name)->data;
} else {
s = (char *)CB_NAME (name);
}
if (!cb_flag_main && strcmp (s, source_name)) {
cb_warning (_("Source name '%s' differs from PROGRAM-ID '%s'"),
source_name, s);
current_program->source_name = strdup (source_name);
}
End comment out */
if (alt_name) {
current_program->orig_source_name = strdup ((char *)CB_LITERAL (alt_name)->data);
s = (char *)CB_LITERAL (alt_name)->data;
} else if (CB_LITERAL_P (name)) {
current_program->orig_source_name = strdup ((char *)CB_LITERAL (name)->data);
s = cb_encode_program_id ((char *)CB_LITERAL (name)->data);
} else {
current_program->orig_source_name = strdup (CB_NAME (name));
s = cb_encode_program_id (CB_NAME (name));
}
if (cobc_check_valid_name (current_program->orig_source_name)) {
cb_error (_("PROGRAM-ID '%s' invalid"), current_program->orig_source_name);
}
return s;
}
| void cb_build_registers | ( | void | ) |
Definition at line 494 of file typeck.c.
{
#if !defined(__linux__) && !defined(__CYGWIN__) && defined(HAVE_TIMEZONE)
long contz;
#endif
time_t t;
char buff[48];
/* RETURN-CODE */
if (!current_program->nested_level) {
current_program->cb_return_code =
cb_build_index (cb_build_reference ("RETURN-CODE"),
cb_zero, 0, NULL);
cb_field (current_program->cb_return_code)->flag_is_global = 1;
}
/* SORT-RETURN */
current_program->cb_sort_return =
cb_build_index (cb_build_reference ("SORT-RETURN"), cb_zero, 0, NULL);
cb_field (current_program->cb_sort_return)->flag_no_init = 1;
/* NUMBER-OF-CALL-PARAMETERS */
current_program->cb_call_params =
cb_build_index (cb_build_reference ("NUMBER-OF-CALL-PARAMETERS"), cb_zero, 0, NULL);
cb_field (current_program->cb_call_params)->flag_no_init = 1;
/* TALLY */
/* 01 TALLY GLOBAL PICTURE 9(9) USAGE COMP-5 VALUE ZERO. */
/* TALLY/EXAMINE not standard/supported */
t = time (NULL);
/* WHEN-COMPILED */
memset (buff, 0, sizeof (buff));
strftime (buff, 17, "%m/%d/%y%H.%M.%S", localtime (&t));
cb_build_constant (cb_build_reference ("WHEN-COMPILED"),
cb_build_alphanumeric_literal ((ucharptr)buff, 16));
/* FUNCTION WHEN-COMPILED */
memset (buff, 0, sizeof (buff));
#if defined(__linux__) || defined(__CYGWIN__)
strftime (buff, 22, "%Y%m%d%H%M%S00%z", localtime (&t));
#elif defined(HAVE_TIMEZONE)
strftime (buff, 17, "%Y%m%d%H%M%S00", localtime (&t));
if (timezone <= 0) {
contz = -timezone;
buff[16] = '+';
} else {
contz = timezone;
buff[16] = '-';
}
sprintf (&buff[17], "%2.2ld%2.2ld", contz / 3600, contz % 60);
#else
strftime (buff, 22, "%Y%m%d%H%M%S0000000", localtime (&t));
#endif
cb_intr_whencomp = cb_build_alphanumeric_literal ((ucharptr)buff, 21);
/* FUNCTION PI */
memset (buff, 0, sizeof (buff));
strcpy (buff, "31415926535897932384626433832795029");
cb_intr_pi = cb_build_numeric_literal (0, (ucharptr)buff, 34);
/* FUNCTION E */
memset (buff, 0, sizeof (buff));
strcpy (buff, "27182818284590452353602874713526625");
cb_intr_e = cb_build_numeric_literal (0, (ucharptr)buff, 34);
}
Definition at line 3823 of file typeck.c.
{
return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_all", y, x));
}
Definition at line 3817 of file typeck.c.
{
return cb_list_add (l, cb_build_funcall_1 ("cob_inspect_characters", x));
}
Definition at line 3835 of file typeck.c.
{
return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_first", y, x));
}
Definition at line 3829 of file typeck.c.
{
return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_leading", y, x));
}
Definition at line 3841 of file typeck.c.
{
return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_trailing", y, x));
}
Definition at line 653 of file typeck.c.
{
cb_tree x;
if (name == cb_error_node) {
return cb_error_node;
}
if (CB_REFERENCE (name)->word->count > 0) {
x = CB_VALUE (CB_REFERENCE (name)->word->items);
/* Used as a non-label name or used as a section name.
Duplicate paragraphs are allowed if not referenced;
Checked in typeck.c */
if (!CB_LABEL_P (x) || sect_or_para == 0
|| (sect_or_para && CB_LABEL_P (x) && CB_LABEL (x)->is_section)) {
redefinition_error (name);
return cb_error_node;
}
}
return name;
}
Definition at line 2633 of file typeck.c.
{
cb_tree opt;
struct cb_field *f;
#ifdef COB_NON_ALIGNED
if (CB_INDEX_P (v)) {
return cb_build_move (cb_build_binary_op (v, '-', n), v);
}
if (CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
current_program->gen_ptrmanip = 1;
return cb_build_funcall_3 ("cob_pointer_manip", v, n, cb_int1);
}
#else
if (CB_INDEX_P (v) || CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
return cb_build_move (cb_build_binary_op (v, '-', n), v);
}
#endif
if (CB_REF_OR_FIELD_P (v)) {
f = cb_field (v);
f->count++;
}
if (CB_REF_OR_FIELD_P (n)) {
f = cb_field (n);
f->count++;
}
opt = build_store_option (v, round_opt);
if (opt == cb_int0 && cb_fits_int (n)) {
return cb_build_optim_sub (v, n);
}
return cb_build_funcall_3 ("cob_sub", v, n, opt);
}
| cb_tree cb_build_tarrying_all | ( | void | ) |
Definition at line 3768 of file typeck.c.
{
if (inspect_data == NULL) {
cb_error (_("Data name expected before CHARACTERS"));
}
inspect_func = NULL;
return cb_list_add (l, cb_build_funcall_1 ("cob_inspect_characters", inspect_data));
}
| cb_tree cb_build_tarrying_leading | ( | void | ) |
| cb_tree cb_build_tarrying_trailing | ( | void | ) |
Definition at line 3808 of file typeck.c.
{
if (inspect_func == NULL) {
cb_error_x (x, _("ALL, LEADING or TRAILING expected before '%s'"), cb_name (x));
}
return cb_list_add (l, cb_build_funcall_2 (inspect_func, inspect_data, x));
}
Definition at line 5866 of file typeck.c.
{
if (cb_validate_one (value)) {
return cb_error_node;
}
return cb_build_funcall_2 ("cob_unstring_delimited", value, all);
}
Definition at line 5875 of file typeck.c.
{
if (cb_validate_one (name)) {
return cb_error_node;
}
if (delimiter == NULL) {
delimiter = cb_int0;
}
if (count == NULL) {
count = cb_int0;
}
return cb_build_funcall_3 ("cob_unstring_into", name, delimiter, count);
}
Definition at line 5957 of file typeck.c.
{
cb_tree e;
int opt;
opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
e = cb_build_binary_op (cb_int (opt | COB_WRITE_LINES), '+', lines);
return cb_build_cast_integer (e);
}
Definition at line 5968 of file typeck.c.
{
int opt;
int token;
token = CB_SYSTEM_NAME (cb_ref (mnemonic))->token;
switch (token) {
case CB_FEATURE_FORMFEED:
opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
return cb_int (opt | COB_WRITE_PAGE);
case CB_FEATURE_C01:
case CB_FEATURE_C02:
case CB_FEATURE_C03:
case CB_FEATURE_C04:
case CB_FEATURE_C05:
case CB_FEATURE_C06:
case CB_FEATURE_C07:
case CB_FEATURE_C08:
case CB_FEATURE_C09:
case CB_FEATURE_C10:
case CB_FEATURE_C11:
case CB_FEATURE_C12:
opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
return cb_int (opt | COB_WRITE_CHANNEL | COB_WRITE_PAGE | token);
default:
cb_error_x (mnemonic, _("Invalid mnemonic name"));
return cb_error_node;
}
}
Definition at line 5999 of file typeck.c.
{
int opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
return cb_int (opt | COB_WRITE_PAGE);
}
Definition at line 426 of file typeck.c.
{
if (x == cb_error_node) {
return cb_error_node;
}
if (CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
return x;
}
cb_error_x (x, _("'%s' is not a numeric value"), cb_name (x));
return cb_error_node;
}
Definition at line 629 of file typeck.c.
{
cb_tree switch_id;
cb_tree value;
if (name == cb_error_node) {
return;
}
if (sname == cb_error_node) {
return;
}
if (CB_SYSTEM_NAME (sname)->category != CB_SWITCH_NAME) {
cb_error_x (ref, _("Switch-name is expected '%s'"), CB_NAME (ref));
} else {
switch_id = cb_int (CB_SYSTEM_NAME (sname)->token);
value = cb_build_funcall_1 ("cob_get_switch", switch_id);
if (flag == cb_int0) {
value = cb_build_negation (value);
}
cb_build_constant (name, value);
}
}
| void cb_emit_accept | ( | cb_tree | var, |
| cb_tree | pos, | ||
| cb_tree | fgc, | ||
| cb_tree | bgc, | ||
| cb_tree | scroll, | ||
| int | dispattrs | ||
| ) |
Definition at line 2802 of file typeck.c.
{
cb_tree line;
cb_tree column;
if (cb_validate_one (var)) {
return;
}
if (cb_validate_one (pos)) {
return;
}
if (cb_validate_one (fgc)) {
return;
}
if (cb_validate_one (bgc)) {
return;
}
if (cb_validate_one (scroll)) {
return;
}
if (current_program->flag_screen) {
/* Bump ref count to force CRT STATUS field generation */
cb_field (current_program->crt_status)->count++;
if ((CB_REF_OR_FIELD_P (var)) &&
CB_FIELD (cb_ref (var))->storage == CB_STORAGE_SCREEN) {
output_screen_from (CB_FIELD (cb_ref (var)), 0);
gen_screen_ptr = 1;
if (pos) {
if (CB_PAIR_P (pos)) {
line = CB_PAIR_X (pos);
column = CB_PAIR_Y (pos);
cb_emit (cb_build_funcall_3 ("cob_screen_accept",
var, line, column));
} else {
cb_emit (cb_build_funcall_3 ("cob_screen_accept",
var, pos, NULL));
}
} else {
cb_emit (cb_build_funcall_3 ("cob_screen_accept",
var, NULL, NULL));
}
gen_screen_ptr = 0;
output_screen_to (CB_FIELD (cb_ref (var)), 0);
} else {
if (pos || fgc || bgc) {
if (!pos) {
cb_emit (cb_build_funcall_7 ("cob_field_accept",
var, NULL, NULL, fgc, bgc,
scroll, cb_int (dispattrs)));
} else if (CB_PAIR_P (pos)) {
line = CB_PAIR_X (pos);
column = CB_PAIR_Y (pos);
cb_emit (cb_build_funcall_7 ("cob_field_accept",
var, line, column, fgc, bgc,
scroll, cb_int (dispattrs)));
} else {
cb_emit (cb_build_funcall_7 ("cob_field_accept",
var, pos, NULL, fgc, bgc,
scroll, cb_int (dispattrs)));
}
} else {
cb_emit (cb_build_funcall_7 ("cob_field_accept",
var, NULL, NULL, fgc, bgc,
scroll, cb_int (dispattrs)));
}
}
} else if (pos || fgc || bgc || scroll) {
/* Bump ref count to force CRT STATUS field generation */
cb_field (current_program->crt_status)->count++;
if (!pos) {
cb_emit (cb_build_funcall_7 ("cob_field_accept",
var, NULL, NULL, fgc, bgc, scroll,
cb_int (dispattrs)));
} else if (CB_PAIR_P (pos)) {
line = CB_PAIR_X (pos);
column = CB_PAIR_Y (pos);
cb_emit (cb_build_funcall_7 ("cob_field_accept",
var, line, column, fgc, bgc, scroll,
cb_int (dispattrs)));
} else {
cb_emit (cb_build_funcall_7 ("cob_field_accept",
var, pos, NULL, fgc, bgc, scroll,
cb_int (dispattrs)));
}
} else {
cb_emit (cb_build_funcall_1 ("cob_accept", var));
}
}
| void cb_emit_accept_arg_number | ( | cb_tree | var | ) |
Definition at line 2986 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_arg_number", var));
}
| void cb_emit_accept_arg_value | ( | cb_tree | var | ) |
Definition at line 2995 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_arg_value", var));
}
| void cb_emit_accept_command_line | ( | cb_tree | var | ) |
Definition at line 2956 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_command_line", var));
}
| void cb_emit_accept_date | ( | cb_tree | var | ) |
Definition at line 2902 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_date", var));
}
| void cb_emit_accept_date_yyyymmdd | ( | cb_tree | var | ) |
Definition at line 2911 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_date_yyyymmdd", var));
}
| void cb_emit_accept_day | ( | cb_tree | var | ) |
Definition at line 2920 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_day", var));
}
| void cb_emit_accept_day_of_week | ( | cb_tree | var | ) |
Definition at line 2938 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_day_of_week", var));
}
| void cb_emit_accept_day_yyyyddd | ( | cb_tree | var | ) |
Definition at line 2929 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_day_yyyyddd", var));
}
| void cb_emit_accept_environment | ( | cb_tree | var | ) |
Definition at line 2977 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_environment", var));
}
| void cb_emit_accept_line_or_col | ( | cb_tree | var, |
| const int | l_or_c | ||
| ) |
Definition at line 2893 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_2 ("cob_screen_line_col", var, cb_int (l_or_c)));
}
Definition at line 3004 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
switch (CB_SYSTEM_NAME (cb_ref (mnemonic))->token) {
case CB_DEVICE_CONSOLE:
case CB_DEVICE_SYSIN:
cb_emit (cb_build_funcall_1 ("cob_accept", var));
break;
default:
cb_error_x (mnemonic, _("Invalid input stream '%s'"),
cb_name (mnemonic));
break;
}
}
Definition at line 3022 of file typeck.c.
{
cb_tree sys;
if (cb_validate_one (var)) {
return;
}
if (CB_REFERENCE (name)->word->count == 0) {
sys = lookup_system_name (CB_NAME (name));
if (sys != cb_error_node) {
switch (CB_SYSTEM_NAME (sys)->token) {
case CB_DEVICE_CONSOLE:
case CB_DEVICE_SYSIN:
cb_warning_x (name, _("'%s' undefined in SPECIAL-NAMES"), CB_NAME (name));
cb_emit (cb_build_funcall_1 ("cob_accept", var));
return;
default:
break;
}
}
}
cb_error_x (name, _("'%s' undefined in SPECIAL-NAMES"), CB_NAME (name));
}
| void cb_emit_accept_time | ( | cb_tree | var | ) |
Definition at line 2947 of file typeck.c.
{
if (cb_validate_one (var)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_accept_time", var));
}
Definition at line 3053 of file typeck.c.
{
cb_tree x;
char buff[32];
if (cb_validate_one (target1)) {
return;
}
if (cb_validate_one (target2)) {
return;
}
if (cb_validate_one (size)) {
return;
}
if (target1) {
if (!(CB_REFERENCE_P(target1) &&
cb_field (target1)->flag_item_based)) {
cb_error_x (CB_TREE(current_statement),
_("Target of ALLOCATE is not a BASED item"));
}
}
if (target2) {
if (!(CB_REFERENCE_P(target2) &&
CB_TREE_CLASS (target2) == CB_CLASS_POINTER)) {
cb_error_x (CB_TREE(current_statement),
_("Target of RETURNING is not a data pointer"));
}
}
if (size) {
if (CB_TREE_CLASS (size) != CB_CLASS_NUMERIC) {
cb_error_x (CB_TREE(current_statement),
_("The CHARACTERS field of ALLOCATE must be numeric"));
}
}
if (target1) {
sprintf (buff, "%d", cb_field (target1)->memory_size);
x = cb_build_numeric_literal (0, (ucharptr)buff, 0);
cb_emit (cb_build_funcall_3 ("cob_allocate",
cb_build_cast_addr_of_addr (target1), target2, x));
} else {
cb_emit (cb_build_funcall_3 ("cob_allocate",
NULL, target2, size));
}
if (initialize && target1) {
current_statement->handler2 =
cb_build_initialize (target1, cb_true, NULL, cb_true, 0);
}
}
| void cb_emit_arg_number | ( | cb_tree | value | ) |
Definition at line 3273 of file typeck.c.
{
if (cb_validate_one (value)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_display_arg_number", value));
}
Definition at line 2094 of file typeck.c.
{
cb_tree l;
struct cb_field *f;
val = cb_check_numeric_value (val);
if (op) {
cb_list_map (cb_check_numeric_name, vars);
} else {
cb_list_map (cb_check_numeric_edited_name, vars);
}
if (cb_validate_one (val)) {
return;
}
if (cb_validate_list (vars)) {
return;
}
if (!CB_BINARY_OP_P (val)) {
if (op == '+' || op == '-') {
if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE) &&
(CB_REF_OR_FIELD_P (val))) {
f = cb_field (val);
if (f->usage == CB_USAGE_DISPLAY ||
f->usage == CB_USAGE_PACKED) {
cb_emit (cb_build_funcall_2 ("cob_check_numeric",
val,
cb_build_string0 ((ucharptr)(f->name))));
}
}
for (l = vars; l; l = CB_CHAIN (l)) {
if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE) &&
(CB_REF_OR_FIELD_P (CB_VALUE(l)))) {
f = cb_field (CB_VALUE(l));
if (f->usage == CB_USAGE_DISPLAY ||
f->usage == CB_USAGE_PACKED) {
cb_emit (cb_build_funcall_2 ("cob_check_numeric",
CB_VALUE(l),
cb_build_string0 ((ucharptr)(f->name))));
}
}
if (op == '+') {
CB_VALUE (l) = cb_build_add (CB_VALUE (l), val, CB_PURPOSE (l));
} else {
CB_VALUE (l) = cb_build_sub (CB_VALUE (l), val, CB_PURPOSE (l));
}
}
cb_emit_list (vars);
return;
}
}
cb_emit (build_decimal_assign (vars, op, val));
}
| void cb_emit_call | ( | cb_tree | prog, |
| cb_tree | using, | ||
| cb_tree | returning, | ||
| cb_tree | on_exception, | ||
| cb_tree | not_on_exception | ||
| ) |
Definition at line 3108 of file typeck.c.
{
cb_tree l;
cb_tree x;
const struct system_table *psyst;
int is_sys_call = 0;
if (CB_INTRINSIC_P (prog)) {
if (CB_INTRINSIC(prog)->intr_tab->category != CB_CATEGORY_ALPHANUMERIC) {
cb_error (_("Only alphanumeric FUNCTION types are allowed here"));
return;
}
}
if (returning) {
if (CB_TREE_CLASS(returning) != CB_CLASS_NUMERIC &&
CB_TREE_CLASS(returning) != CB_CLASS_POINTER) {
cb_error (_("Invalid RETURNING field"));
return;
}
}
for (l = using; l; l = CB_CHAIN (l)) {
x = CB_VALUE (l);
if (x == cb_error_node) {
continue;
}
if (CB_CONST_P (x) && x != cb_null) {
cb_error_x (x, _("Figurative constant invalid here"));
}
if ((CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value))
|| CB_FIELD_P (x)) {
if (cb_field (x)->level == 88) {
cb_error_x (x, _("'%s' Not a data name"), CB_NAME (x));
return;
}
if (cb_warn_call_params &&
CB_PURPOSE_INT (l) == CB_CALL_BY_REFERENCE) {
if (cb_field (x)->level != 01 &&
cb_field (x)->level != 77) {
cb_warning_x (x, _("'%s' is not 01 or 77 level item"), CB_NAME (x));
}
}
}
}
if (CB_LITERAL_P(prog)) {
for (psyst = (const struct system_table *)&system_tab[0]; psyst->syst_name; psyst++) {
if (!strcmp((const char *)CB_LITERAL(prog)->data,
(const char *)psyst->syst_name)) {
if (psyst->syst_params > cb_list_length (using)) {
cb_error (_("Wrong number of CALL parameters for '%s'"),
(char *)psyst->syst_name);
return;
}
is_sys_call = 1;
break;
}
}
}
cb_emit (cb_build_call (prog, using, on_exception, not_on_exception,
returning, is_sys_call));
}
| void cb_emit_cancel | ( | cb_tree | prog | ) |
Definition at line 3177 of file typeck.c.
{
if (cb_validate_one (prog)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_field_cancel", prog));
}
Definition at line 3190 of file typeck.c.
{
if (file == cb_error_node) {
return;
}
file = cb_ref (file);
if (file == cb_error_node) {
return;
}
current_statement->file = file;
if (CB_FILE (file)->organization == COB_ORG_SORT) {
cb_error_x (CB_TREE (current_statement),
_("Operation not allowed on SORT files"));
}
cb_emit (cb_build_funcall_3 ("cob_close", file, opt,
CB_FILE(file)->file_status));
}
| void cb_emit_command_line | ( | cb_tree | value | ) |
Definition at line 3282 of file typeck.c.
{
if (cb_validate_one (value)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_display_command_line", value));
}
| void cb_emit_commit | ( | void | ) |
Definition at line 3213 of file typeck.c.
{
cb_emit (cb_build_funcall_0 ("cob_commit"));
}
| void cb_emit_continue | ( | void | ) |
Definition at line 3223 of file typeck.c.
{
cb_emit (cb_build_continue ());
}
| void cb_emit_delete | ( | cb_tree | file | ) |
Definition at line 3233 of file typeck.c.
{
if (file == cb_error_node) {
return;
}
file = cb_ref (file);
if (file == cb_error_node) {
return;
}
current_statement->file = file;
if (CB_FILE (file)->organization == COB_ORG_SORT) {
cb_error_x (CB_TREE (current_statement),
_("Operation not allowed on SORT files"));
}
cb_emit (cb_build_funcall_2 ("cob_delete", file, CB_FILE(file)->file_status));
}
| void cb_emit_display | ( | cb_tree | values, |
| cb_tree | upon, | ||
| cb_tree | no_adv, | ||
| cb_tree | pos, | ||
| cb_tree | fgc, | ||
| cb_tree | bgc, | ||
| cb_tree | scroll, | ||
| int | dispattrs | ||
| ) |
Definition at line 3291 of file typeck.c.
{
cb_tree l;
cb_tree x;
cb_tree line;
cb_tree column;
cb_tree p;
if (cb_validate_list (values)) {
return;
}
if (cb_validate_one (pos)) {
return;
}
if (cb_validate_one (fgc)) {
return;
}
if (cb_validate_one (bgc)) {
return;
}
if (cb_validate_one (scroll)) {
return;
}
for (l = values; l; l = CB_CHAIN (l)) {
x = CB_VALUE (l);
if (x == cb_error_node) {
return;
}
switch (CB_TREE_TAG (x)) {
case CB_TAG_LITERAL:
case CB_TAG_INTRINSIC:
case CB_TAG_CONST:
case CB_TAG_STRING:
case CB_TAG_INTEGER:
break;
case CB_TAG_REFERENCE:
if (!CB_FIELD_P(CB_REFERENCE(x)->value)) {
cb_error_x (x, _("'%s' is an invalid type for DISPLAY operand"), cb_name (x));
return;
}
break;
default:
cb_error_x (x, _("Invalid type for DISPLAY operand"));
return;
}
}
if (upon == cb_error_node) {
return;
}
x = CB_VALUE (values);
if ((CB_REF_OR_FIELD_P (x)) &&
CB_FIELD (cb_ref (x))->storage == CB_STORAGE_SCREEN) {
output_screen_from (CB_FIELD (cb_ref (x)), 0);
gen_screen_ptr = 1;
if (pos) {
if (CB_PAIR_P (pos)) {
line = CB_PAIR_X (pos);
column = CB_PAIR_Y (pos);
if (line == NULL) {
line = cb_one;
}
if (column == NULL) {
column = cb_one;
}
cb_emit (cb_build_funcall_3 ("cob_screen_display", x,
line, column));
} else {
cb_emit (cb_build_funcall_3 ("cob_screen_display", x,
pos, NULL));
}
} else {
cb_emit (cb_build_funcall_3 ("cob_screen_display", x,
NULL, NULL));
}
gen_screen_ptr = 0;
} else if (pos || fgc || bgc || scroll || dispattrs) {
if (!pos) {
cb_emit (cb_build_funcall_7 ("cob_field_display",
CB_VALUE (values), NULL, NULL, fgc, bgc,
scroll, cb_int (dispattrs)));
} else if (CB_PAIR_P (pos)) {
line = CB_PAIR_X (pos);
column = CB_PAIR_Y (pos);
if (line == NULL) {
line = cb_one;
}
if (column == NULL) {
column = cb_one;
}
cb_emit (cb_build_funcall_7 ("cob_field_display",
CB_VALUE (values), line, column, fgc, bgc,
scroll, cb_int (dispattrs)));
} else {
cb_emit (cb_build_funcall_7 ("cob_field_display",
CB_VALUE (values), pos, NULL, fgc, bgc,
scroll, cb_int (dispattrs)));
}
} else {
/* DISPLAY x ... [UPON device-name] */
p = cb_build_funcall_3 ("cob_display", upon, no_adv, values);
CB_FUNCALL(p)->varcnt = cb_list_length (values);
cb_emit (p);
for (l = values; l; l = CB_CHAIN (l)) {
x = CB_VALUE (l);
if (CB_FIELD_P (x)) {
CB_FIELD (cb_ref (x))->count++;
}
}
}
}
Definition at line 3460 of file typeck.c.
{
if (cb_validate_one (dividend)) {
return;
}
if (cb_validate_one (divisor)) {
return;
}
CB_VALUE (quotient) = cb_check_numeric_edited_name (CB_VALUE (quotient));
CB_VALUE (remainder) = cb_check_numeric_edited_name (CB_VALUE (remainder));
if (cb_validate_one (CB_VALUE (quotient))) {
return;
}
if (cb_validate_one (CB_VALUE (remainder))) {
return;
}
cb_emit (cb_build_funcall_4 ("cob_div_quotient", dividend, divisor,
CB_VALUE (quotient),
build_store_option (CB_VALUE (quotient), CB_PURPOSE (quotient))));
cb_emit (cb_build_funcall_2 ("cob_div_remainder", CB_VALUE (remainder),
build_store_option (CB_VALUE (remainder), cb_int0)));
}
| void cb_emit_env_name | ( | cb_tree | value | ) |
Definition at line 3255 of file typeck.c.
{
if (cb_validate_one (value)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_display_environment", value));
}
| void cb_emit_env_value | ( | cb_tree | value | ) |
Definition at line 3264 of file typeck.c.
{
if (cb_validate_one (value)) {
return;
}
cb_emit (cb_build_funcall_1 ("cob_display_env_value", value));
}
| void cb_emit_exit | ( | size_t | goback | ) |
Definition at line 3675 of file typeck.c.
{
if (goback) {
cb_emit (cb_build_goto (cb_int1, NULL));
} else {
cb_emit (cb_build_goto (NULL, NULL));
}
}
| void cb_emit_free | ( | cb_tree | vars | ) |
Definition at line 3611 of file typeck.c.
{
cb_tree l;
struct cb_field *f;
int i;
if (cb_validate_list (vars)) {
return;
}
for (l = vars, i = 1; l; l = CB_CHAIN (l), i++) {
if (CB_TREE_CLASS (CB_VALUE (l)) == CB_CLASS_POINTER) {
if (CB_CAST_P (CB_VALUE (l))) {
f = cb_field (CB_CAST (CB_VALUE(l))->val);
if (!f->flag_item_based) {
cb_error_x (CB_TREE (current_statement),
_("Target %d of FREE, a data address identifier, must address a BASED data item"), i);
}
cb_emit (cb_build_funcall_2 ("cob_free_alloc",
cb_build_cast_address (CB_VALUE (l)), NULL));
} else {
cb_emit (cb_build_funcall_2 ("cob_free_alloc",
NULL, cb_build_cast_address (CB_VALUE (l))));
}
} else if (CB_REF_OR_FIELD_P (CB_VALUE (l))) {
f = cb_field (CB_VALUE (l));
if (!f->flag_item_based) {
cb_error_x (CB_TREE (current_statement),
_("Target %d of FREE, a data address identifier, must address a BASED data item"), i);
}
cb_emit (cb_build_funcall_2 ("cob_free_alloc",
cb_build_cast_addr_of_addr (CB_VALUE (l)), NULL));
} else {
cb_error_x (CB_TREE (current_statement),
_("Target %d of FREE must be a data pointer"), i);
}
}
}
Definition at line 2965 of file typeck.c.
{
if (cb_validate_one (envvar)) {
return;
}
if (cb_validate_one (envval)) {
return;
}
cb_emit (cb_build_funcall_2 ("cob_get_environment", envvar, envval));
}
Definition at line 3654 of file typeck.c.
{
if (target == cb_error_node) {
return;
}
if (depending) {
/* GO TO procedure-name ... DEPENDING ON identifier */
cb_emit (cb_build_goto (target, depending));
} else {
/* GO TO procedure-name */
if (target == NULL) {
cb_verify (cb_goto_statement_without_name, "GO TO without procedure-name");
} else if (CB_CHAIN (target)) {
cb_error (_("GO TO with multiple procedure-names"));
} else {
cb_emit (cb_build_goto (CB_VALUE (target), NULL));
}
}
}
Definition at line 3689 of file typeck.c.
{
cb_emit (cb_build_if (cond, stmt1, stmt2));
}
| void cb_emit_initialize | ( | cb_tree | vars, |
| cb_tree | fillinit, | ||
| cb_tree | value, | ||
| cb_tree | replacing, | ||
| cb_tree | def | ||
| ) |
Definition at line 3699 of file typeck.c.
{
cb_tree l;
int fill_init = 1;
if (cb_validate_list (vars)) {
return;
}
if (value == NULL && replacing == NULL) {
def = cb_true;
}
if (fillinit == cb_true) {
fill_init = 0;
}
for (l = vars; l; l = CB_CHAIN (l)) {
cb_emit (cb_build_initialize (CB_VALUE (l), value, replacing, def, fill_init));
}
}
Definition at line 3723 of file typeck.c.
{
switch (CB_TREE_TAG(var)) {
case CB_TAG_REFERENCE:
break;
case CB_TAG_INTRINSIC:
switch (CB_TREE_CATEGORY(var)) {
case CB_CATEGORY_ALPHABETIC:
case CB_CATEGORY_ALPHANUMERIC:
case CB_CATEGORY_NATIONAL:
break;
default:
cb_error (_("Invalid target for INSPECT"));
return;
}
break;
case CB_TAG_LITERAL:
break;
default:
cb_error (_("Invalid target for REPLACING/CONVERTING"));
return;
}
if (replconv && sending_id) {
cb_error (_("Invalid target for REPLACING/CONVERTING"));
}
cb_emit (cb_build_funcall_2 ("cob_inspect_init", var, replacing));
cb_emit_list (body);
cb_emit (cb_build_funcall_0 ("cob_inspect_finish"));
}
Definition at line 5062 of file typeck.c.
{
if (file == cb_error_node) {
return;
}
file = cb_ref (file);
if (file == cb_error_node) {
return;
}
current_statement->file = file;
if (CB_FILE (file)->organization == COB_ORG_SORT) {
cb_error_x (CB_TREE (current_statement),
_("Operation not allowed on SORT files"));
}
if (sharing == NULL) {
sharing = CB_FILE (file)->sharing ? CB_FILE (file)->sharing : cb_int0;
}
/* READ ONLY */
if (sharing == cb_int0 && CB_INTEGER (mode)->val != COB_OPEN_INPUT) {
sharing = cb_int1;
}
cb_emit (cb_build_funcall_4 ("cob_open", file, mode,
sharing, CB_FILE(file)->file_status));
}
Definition at line 5095 of file typeck.c.
{
if (perform == cb_error_node) {
return;
}
CB_PERFORM (perform)->body = body;
cb_emit (perform);
}
Definition at line 5170 of file typeck.c.
{
int read_opts = 0;
cb_tree file;
cb_tree rec;
if (lock_opts == cb_int1) {
read_opts = COB_READ_LOCK;
} else if (lock_opts == cb_int2) {
read_opts = COB_READ_NO_LOCK;
} else if (lock_opts == cb_int3) {
read_opts = COB_READ_IGNORE_LOCK;
} else if (lock_opts == cb_int4) {
read_opts = COB_READ_WAIT_LOCK;
}
if (ref == cb_error_node) {
return;
}
file = cb_ref (ref);
if (file == cb_error_node) {
return;
}
rec = cb_build_field_reference (CB_FILE (file)->record, ref);
if (CB_FILE (file)->organization == COB_ORG_SORT) {
cb_error_x (CB_TREE (current_statement),
_("Operation not allowed on SORT files"));
}
if (next == cb_int1 || next == cb_int2 ||
CB_FILE (file)->access_mode == COB_ACCESS_SEQUENTIAL) {
/* READ NEXT/PREVIOUS */
if (next == cb_int2) {
if (CB_FILE (file)->organization != COB_ORG_INDEXED) {
cb_error_x (CB_TREE (current_statement),
_("READ PREVIOUS only allowed for INDEXED SEQUENTIAL files"));
}
read_opts |= COB_READ_PREVIOUS;
} else {
read_opts |= COB_READ_NEXT;
}
if (key) {
cb_warning (_("KEY ignored with sequential READ"));
}
cb_emit (cb_build_funcall_4 ("cob_read", file, cb_int0,
CB_FILE(file)->file_status,
cb_int (read_opts)));
} else {
/* READ */
cb_emit (cb_build_funcall_4 ("cob_read",
file, key ? key : CB_FILE (file)->key,
CB_FILE(file)->file_status, cb_int (read_opts)));
}
if (into) {
current_statement->handler3 = cb_build_move (rec, into);
}
current_statement->file = file;
}
Definition at line 5278 of file typeck.c.
{
struct cb_field *f;
cb_tree file;
if (record == cb_error_node) {
return;
}
if (from == cb_error_node) {
return;
}
if (cb_ref (record) == cb_error_node) {
return;
}
if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
cb_error_x (CB_TREE (current_statement),
_("RELEASE requires a record name as subject"));
return;
}
if (cb_field (record)->storage != CB_STORAGE_FILE) {
cb_error_x (CB_TREE (current_statement),
_("RELEASE subject does not refer to a record name"));
return;
}
f = CB_FIELD (cb_ref (record));
file = CB_TREE (f->file);
if (CB_FILE (file)->organization != COB_ORG_SORT) {
cb_error_x (CB_TREE (current_statement),
_("RELEASE not allowed on this record item"));
return;
}
current_statement->file = file;
if (from) {
cb_emit (cb_build_move (from, record));
}
cb_emit (cb_build_funcall_1 ("cob_file_release", file));
}
Definition at line 5321 of file typeck.c.
{
cb_tree file;
cb_tree rec;
if (ref == cb_error_node) {
return;
}
if (into == cb_error_node) {
return;
}
file = cb_ref (ref);
if (file == cb_error_node) {
return;
}
rec = cb_build_field_reference (CB_FILE (file)->record, ref);
cb_emit (cb_build_funcall_1 ("cob_file_return", file));
if (into) {
current_statement->handler3 = cb_build_move (rec, into);
}
current_statement->file = file;
}
Definition at line 5232 of file typeck.c.
{
cb_tree file;
int opts = 0;
if (record == cb_error_node || cb_ref (record) == cb_error_node) {
return;
}
if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
cb_error_x (CB_TREE (current_statement),
_("REWRITE requires a record name as subject"));
return;
}
if (cb_field (record)->storage != CB_STORAGE_FILE) {
cb_error_x (CB_TREE (current_statement),
_("REWRITE subject does not refer to a record name"));
return;
}
file = CB_TREE (CB_FIELD (cb_ref (record))->file);
current_statement->file = file;
if (CB_FILE (file)->organization == COB_ORG_SORT) {
cb_error_x (CB_TREE (current_statement),
_("Operation not allowed on SORT files"));
} else if (current_statement->handler_id == COB_EC_I_O_INVALID_KEY &&
(CB_FILE(file)->organization != COB_ORG_RELATIVE &&
CB_FILE(file)->organization != COB_ORG_INDEXED)) {
cb_error_x (CB_TREE(current_statement),
_("INVALID KEY clause invalid with this file type"));
} else if ((CB_FILE (file)->lock_mode & COB_LOCK_AUTOMATIC) && lockopt) {
cb_error_x (CB_TREE (current_statement),
_("LOCK clause invalid with file LOCK AUTOMATIC"));
} else if (lockopt == cb_int1) {
opts = COB_WRITE_LOCK;
}
if (from) {
cb_emit (cb_build_move (from, record));
}
cb_emit (cb_build_funcall_4 ("cob_rewrite", file, record,
cb_int (opts), CB_FILE(file)->file_status));
}
| void cb_emit_rollback | ( | void | ) |
Definition at line 5349 of file typeck.c.
{
cb_emit (cb_build_funcall_0 ("cob_rollback"));
}
Definition at line 5427 of file typeck.c.
{
if (cb_validate_one (table)) {
return;
}
if (cb_validate_one (varying)) {
return;
}
if (table == cb_error_node) {
return;
}
cb_emit (cb_build_search (0, table, varying, at_end, whens));
}
Definition at line 5442 of file typeck.c.
{
if (cb_validate_one (table)) {
return;
}
if (table == cb_error_node) {
return;
}
cb_emit (cb_build_search (1, table, NULL, at_end,
cb_build_if (cb_build_search_all (table, when), stmts, NULL)));
}
| void cb_emit_set_false | ( | cb_tree | l | ) |
Definition at line 5604 of file typeck.c.
{
cb_tree x;
struct cb_field *f;
cb_tree ref;
cb_tree val;
for (; l; l = CB_CHAIN (l)) {
x = CB_VALUE (l);
if (x == cb_error_node) {
return;
}
if (!(CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value))
&& !CB_FIELD_P (x)) {
cb_error_x (x, _("Invalid SET statement"));
return;
}
f = cb_field (x);
if (f->level != 88) {
cb_error_x (x, _("Invalid SET statement"));
return;
}
if (!f->false_88) {
cb_error_x (x, _("Field does not have FALSE clause"));
return;
}
ref = cb_build_field_reference (f->parent, x);
val = CB_VALUE (f->false_88);
if (CB_PAIR_P (val)) {
val = CB_PAIR_X (val);
}
cb_emit (cb_build_move (val, ref));
}
}
Definition at line 5558 of file typeck.c.
{
struct cb_system_name *s;
if (cb_validate_list (l)) {
return;
}
for (; l; l = CB_CHAIN (l)) {
s = CB_SYSTEM_NAME (cb_ref (CB_VALUE (l)));
cb_emit (cb_build_funcall_2 ("cob_set_switch", cb_int (s->token), flag));
}
}
Definition at line 5465 of file typeck.c.
{
cb_tree l;
cb_tree v;
struct cb_cast *p;
#if 0
enum cb_class class = CB_CLASS_UNKNOWN;
#endif
if (cb_validate_one (x)) {
return;
}
if (cb_validate_list (vars)) {
return;
}
#if 0
/* determine the class of targets */
for (l = vars; l; l = CB_CHAIN (l)) {
if (CB_TREE_CLASS (CB_VALUE (l)) != CB_CLASS_UNKNOWN) {
if (class == CB_CLASS_UNKNOWN) {
class = CB_TREE_CLASS (CB_VALUE (l));
} else if (class != CB_TREE_CLASS (CB_VALUE (l))) {
break;
}
}
}
if (l || (class != CB_CLASS_INDEX && class != CB_CLASS_POINTER)) {
cb_error_x (CB_TREE (current_statement),
_("The targets of SET must be either indexes or pointers"));
return;
}
#endif
if (CB_CAST_P (x)) {
p = CB_CAST (x);
if (p->type == CB_CAST_PROGRAM_POINTER) {
for (l = vars; l; l = CB_CHAIN (l)) {
v = CB_VALUE (l);
if (!CB_REFERENCE_P (v)) {
cb_error_x (CB_TREE (current_statement),
_("SET targets must be PROGRAM-POINTER"));
CB_VALUE (l) = cb_error_node;
} else if (CB_FIELD(cb_ref(v))->usage != CB_USAGE_PROGRAM_POINTER) {
cb_error_x (CB_TREE (current_statement),
_("SET targets must be PROGRAM-POINTER"));
CB_VALUE (l) = cb_error_node;
}
}
}
}
/* validate the targets */
for (l = vars; l; l = CB_CHAIN (l)) {
v = CB_VALUE (l);
if (CB_CAST_P (v)) {
p = CB_CAST (v);
if (p->type == CB_CAST_ADDRESS
&& !CB_FIELD (cb_ref (p->val))->flag_item_based
&& CB_FIELD (cb_ref (p->val))->storage != CB_STORAGE_LINKAGE) {
cb_error_x (p->val, _("The address of '%s' cannot be changed"),
cb_name (p->val));
CB_VALUE (l) = cb_error_node;
}
}
}
if (cb_validate_list (vars)) {
return;
}
for (l = vars; l; l = CB_CHAIN (l)) {
cb_emit (cb_build_move (x, CB_VALUE (l)));
}
}
| void cb_emit_set_true | ( | cb_tree | l | ) |
Definition at line 5572 of file typeck.c.
{
cb_tree x;
struct cb_field *f;
cb_tree ref;
cb_tree val;
for (; l; l = CB_CHAIN (l)) {
x = CB_VALUE (l);
if (x == cb_error_node) {
return;
}
if (!(CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value))
&& !CB_FIELD_P (x)) {
cb_error_x (x, _("Invalid SET statement"));
return;
}
f = cb_field (x);
if (f->level != 88) {
cb_error_x (x, _("Invalid SET statement"));
return;
}
ref = cb_build_field_reference (f->parent, x);
val = CB_VALUE (f->values);
if (CB_PAIR_P (val)) {
val = CB_PAIR_X (val);
}
cb_emit (cb_build_move (val, ref));
}
}
Definition at line 5540 of file typeck.c.
{
if (cb_validate_one (x)) {
return;
}
if (cb_validate_list (l)) {
return;
}
for (; l; l = CB_CHAIN (l)) {
if (flag == cb_int0) {
cb_emit (cb_build_add (CB_VALUE (l), x, cb_int0));
} else {
cb_emit (cb_build_sub (CB_VALUE (l), x, cb_int0));
}
}
}
Definition at line 5459 of file typeck.c.
{
cb_emit (cb_build_funcall_2 ("cob_set_environment", x, y));
}
| void cb_emit_sort_finish | ( | cb_tree | file | ) |
Definition at line 5715 of file typeck.c.
{
cb_tree p;
int listlen;
if (cb_validate_list (l)) {
return;
}
for (p = l; p; p = CB_CHAIN (p)) {
if (CB_FILE (cb_ref(CB_VALUE(p)))->organization == COB_ORG_SORT) {
cb_error (_("Invalid SORT GIVING parameter"));
}
}
listlen = cb_list_length (l);
p = cb_build_funcall_2 ("cob_file_sort_giving", cb_ref (file), l);
CB_FUNCALL(p)->varcnt = listlen;
cb_emit (p);
}
Definition at line 5644 of file typeck.c.
{
cb_tree l;
struct cb_field *f;
if (cb_validate_list (keys)) {
return;
}
for (l = keys; l; l = CB_CHAIN (l)) {
if (CB_VALUE (l) == NULL) {
CB_VALUE (l) = name;
}
cb_ref (CB_VALUE (l));
}
if (CB_FILE_P (cb_ref (name))) {
if (CB_FILE (cb_ref (name))->organization != COB_ORG_SORT) {
cb_error_x (name, _("Invalid SORT filename"));
}
cb_field (current_program->cb_sort_return)->count++;
cb_emit (cb_build_funcall_5 ("cob_file_sort_init", cb_ref (name),
cb_int (cb_list_length (keys)), col,
cb_build_cast_address (current_program->cb_sort_return),
CB_FILE(cb_ref (name))->file_status));
for (l = keys; l; l = CB_CHAIN (l)) {
cb_emit (cb_build_funcall_4 ("cob_file_sort_init_key", cb_ref (name),
CB_PURPOSE (l),
CB_VALUE (l),
cb_int (cb_field (CB_VALUE(l))->offset)));
}
} else {
f = CB_FIELD (cb_ref (name));
if (keys == NULL) {
cb_error_x (name, _("Table sort without keys not implemented yet"));
}
cb_emit (cb_build_funcall_2 ("cob_table_sort_init", cb_int (cb_list_length (keys)), col));
for (l = keys; l; l = CB_CHAIN (l)) {
cb_emit (cb_build_funcall_3 ("cob_table_sort_init_key",
CB_PURPOSE (l),
CB_VALUE (l),
cb_int (cb_field (CB_VALUE(l))->offset)));
}
cb_emit (cb_build_funcall_2 ("cob_table_sort", name,
(f->occurs_depending
? cb_build_cast_integer (f->occurs_depending)
: cb_int (f->occurs_max))));
}
}
| void cb_emit_sort_input | ( | cb_tree | proc | ) |
Definition at line 5709 of file typeck.c.
{
cb_emit (cb_build_perform_once (proc));
}
| void cb_emit_sort_output | ( | cb_tree | proc | ) |
Definition at line 5735 of file typeck.c.
{
cb_emit (cb_build_perform_once (proc));
}
Definition at line 5694 of file typeck.c.
{
if (cb_validate_list (l)) {
return;
}
for (; l; l = CB_CHAIN (l)) {
if (CB_FILE (cb_ref(CB_VALUE(l)))->organization == COB_ORG_SORT) {
cb_error (_("Invalid SORT USING parameter"));
}
cb_emit (cb_build_funcall_2 ("cob_file_sort_using",
cb_ref (file), cb_ref (CB_VALUE (l))));
}
}
Definition at line 5753 of file typeck.c.
{
if (cb_validate_one (key)) {
return;
}
if (file != cb_error_node) {
current_statement->file = cb_ref (file);
cb_emit (cb_build_funcall_4 ("cob_start", cb_ref (file), op,
key ? key : CB_FILE (cb_ref (file))->key,
CB_FILE(cb_ref(file))->file_status));
}
}
| void cb_emit_stop_run | ( | cb_tree | x | ) |
Definition at line 5771 of file typeck.c.
{
cb_emit (cb_build_funcall_1 ("cob_stop_run", cb_build_cast_integer (x)));
}
Definition at line 5781 of file typeck.c.
{
cb_tree start;
cb_tree l;
cb_tree end;
cb_tree dlm;
if (cb_validate_one (into)) {
return;
}
if (cb_validate_one (pointer)) {
return;
}
start = items;
cb_emit (cb_build_funcall_2 ("cob_string_init", into, pointer));
while (start) {
/* find DELIMITED item */
for (end = start; end; end = CB_CHAIN (end)) {
if (CB_PAIR_P (CB_VALUE (end))) {
break;
}
}
/* cob_string_delimited */
dlm = end ? CB_PAIR_X (CB_VALUE (end)) : cb_int0;
cb_emit (cb_build_funcall_1 ("cob_string_delimited", dlm));
/* cob_string_append */
for (l = start; l != end; l = CB_CHAIN (l)) {
cb_emit (cb_build_funcall_1 ("cob_string_append", CB_VALUE (l)));
}
start = end ? CB_CHAIN (end) : NULL;
}
cb_emit (cb_build_funcall_0 ("cob_string_finish"));
}
| void cb_emit_unlock | ( | cb_tree | ref | ) |
Definition at line 5824 of file typeck.c.
{
cb_tree file;
if (ref != cb_error_node) {
file = cb_ref (ref);
cb_emit (cb_build_funcall_2 ("cob_unlock_file",
file, CB_FILE(file)->file_status));
current_statement->file = file;
}
}
| void cb_emit_unstring | ( | cb_tree | name, |
| cb_tree | delimited, | ||
| cb_tree | into, | ||
| cb_tree | pointer, | ||
| cb_tree | tallying | ||
| ) |
Definition at line 5841 of file typeck.c.
{
if (cb_validate_one (name)) {
return;
}
if (cb_validate_one (tallying)) {
return;
}
if (cb_validate_list (delimited)) {
return;
}
if (cb_validate_list (into)) {
return;
}
cb_emit (cb_build_funcall_3 ("cob_unstring_init", name, pointer,
cb_int (cb_list_length (delimited))));
cb_emit_list (delimited);
cb_emit_list (into);
if (tallying) {
cb_emit (cb_build_funcall_1 ("cob_unstring_tallying", tallying));
}
cb_emit (cb_build_funcall_0 ("cob_unstring_finish"));
}
Definition at line 5894 of file typeck.c.
{
cb_tree file;
int val;
if (record != cb_error_node && cb_ref (record) != cb_error_node) {
if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
cb_error_x (CB_TREE (current_statement),
_("WRITE requires a record name as subject"));
return;
}
if (cb_field (record)->storage != CB_STORAGE_FILE) {
cb_error_x (CB_TREE (current_statement),
_("WRITE subject does not refer to a record name"));
return;
}
file = CB_TREE (CB_FIELD (cb_ref (record))->file);
current_statement->file = file;
if (CB_FILE (file)->organization == COB_ORG_SORT) {
cb_error_x (CB_TREE (current_statement),
_("Operation not allowed on SORT files"));
} else if (current_statement->handler_id == COB_EC_I_O_INVALID_KEY &&
(CB_FILE(file)->organization != COB_ORG_RELATIVE &&
CB_FILE(file)->organization != COB_ORG_INDEXED)) {
cb_error_x (CB_TREE(current_statement),
_("INVALID KEY clause invalid with this file type"));
} else if (lockopt) {
if ((CB_FILE (file)->lock_mode & COB_LOCK_AUTOMATIC)) {
cb_error_x (CB_TREE (current_statement),
_("LOCK clause invalid with file LOCK AUTOMATIC"));
} else if (opt != cb_int0) {
cb_error_x (CB_TREE (current_statement),
_("LOCK clause invalid here"));
} else if (lockopt == cb_int1) {
opt = cb_int (COB_WRITE_LOCK);
}
}
if (from) {
cb_emit (cb_build_move (from, record));
}
if (CB_FILE (file)->organization == COB_ORG_LINE_SEQUENTIAL &&
opt == cb_int0) {
opt = cb_int (COB_WRITE_BEFORE | COB_WRITE_LINES | 1);
}
/* RXW - This is horrible */
if (current_statement->handler_id == COB_EC_I_O_EOP &&
current_statement->handler1) {
if (CB_CAST_P(opt)) {
val = CB_INTEGER(CB_BINARY_OP(CB_CAST(opt)->val)->x)->val;
val |= COB_WRITE_EOP;
CB_BINARY_OP(CB_CAST(opt)->val)->x = cb_int (val);
} else {
val = CB_INTEGER(opt)->val;
val |= COB_WRITE_EOP;
opt = cb_int (val);
}
}
cb_emit (cb_build_funcall_4 ("cob_write", file, record, opt,
CB_FILE(file)->file_status));
}
}
| char* cb_encode_program_id | ( | const char * | name | ) |
Definition at line 563 of file typeck.c.
{
unsigned char *p;
const unsigned char *s;
unsigned char buff[COB_SMALL_BUFF];
p = buff;
s = (const unsigned char *)name;
/* encode the initial digit */
if (isdigit (*s)) {
p += sprintf ((char *)p, "_%02X", *s++);
}
/* encode invalid letters */
for (; *s; s++) {
if (isalnum (*s) || *s == '_') {
*p++ = *s;
} else if (*s == '-') {
*p++ = '_';
*p++ = '_';
} else {
p += sprintf ((char *)p, "_%02X", *s);
}
}
*p = 0;
return strdup ((char *)buff);
}
| void cb_init_tarrying | ( | void | ) |
| void cb_validate_program_body | ( | struct cb_program * | prog | ) |
Definition at line 1416 of file typeck.c.
{
/* resolve all labels */
cb_tree l;
cb_tree x;
cb_tree v;
for (l = cb_list_reverse (prog->label_list); l; l = CB_CHAIN (l)) {
x = CB_VALUE (l);
v = cb_ref (x);
if (CB_LABEL_P (v)) {
CB_LABEL (v)->need_begin = 1;
if (CB_REFERENCE (x)->length) {
CB_LABEL (v)->need_return = 1;
}
} else if (v != cb_error_node) {
cb_error_x (x, _("'%s' not procedure name"), cb_name (x));
}
}
prog->file_list = cb_list_reverse (prog->file_list);
prog->exec_list = cb_list_reverse (prog->exec_list);
}
| void cb_validate_program_data | ( | struct cb_program * | prog | ) |
Definition at line 1286 of file typeck.c.
{
cb_tree l;
cb_tree x;
cb_tree assign;
struct cb_field *p;
struct cb_file *f;
unsigned char *c;
for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
f = CB_FILE (CB_VALUE (l));
if (!f->finalized) {
finalize_file (f, NULL);
}
}
/* build undeclared assignment name now */
if (cb_assign_clause == CB_ASSIGN_MF) {
for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
assign = CB_FILE (CB_VALUE (l))->assign;
if (!assign) {
continue;
}
if (CB_REFERENCE_P (assign)) {
for (x = current_program->file_list; x; x = CB_CHAIN (x)) {
if (!strcmp (CB_FILE (CB_VALUE (x))->name,
CB_REFERENCE (assign)->word->name)) {
redefinition_error (assign);
}
}
p = check_level_78 (CB_REFERENCE (assign)->word->name);
if (p) {
c = (unsigned char *)CB_LITERAL(CB_VALUE(p->values))->data;
assign = CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, c, strlen ((char *)c)));
CB_FILE (CB_VALUE (l))->assign = assign;
}
}
if (CB_REFERENCE_P (assign) && CB_REFERENCE (assign)->word->count == 0) {
if (cb_warn_implicit_define) {
cb_warning (_("'%s' will be implicitly defined"), CB_NAME (assign));
}
x = cb_build_implicit_field (assign, COB_SMALL_BUFF);
p = current_program->working_storage;
CB_FIELD (x)->count++;
if (p) {
while (p->sister) {
p = p->sister;
}
p->sister = CB_FIELD (x);
} else {
current_program->working_storage = CB_FIELD (x);
}
}
if (CB_REFERENCE_P (assign)) {
x = cb_ref (assign);
if (CB_FIELD_P (x) && CB_FIELD (x)->level == 88) {
cb_error_x (assign, _("ASSIGN data item '%s' invalid"), CB_NAME (assign));
}
}
}
}
if (prog->cursor_pos) {
x = cb_ref (prog->cursor_pos);
if (x == cb_error_node) {
prog->cursor_pos = NULL;
} else if (CB_FIELD(x)->size != 6 && CB_FIELD(x)->size != 4) {
cb_error_x (prog->cursor_pos, _("'%s' CURSOR is not 4 or 6 characters long"),
cb_name (prog->cursor_pos));
prog->cursor_pos = NULL;
}
}
if (prog->crt_status) {
x = cb_ref (prog->crt_status);
if (x == cb_error_node) {
prog->crt_status = NULL;
} else if (CB_FIELD(x)->size != 4) {
cb_error_x (prog->crt_status, _("'%s' CRT STATUS is not 4 characters long"),
cb_name (prog->crt_status));
prog->crt_status = NULL;
}
} else {
l = cb_build_reference ("COB-CRT-STATUS");
p = CB_FIELD (cb_build_field (l));
p->usage = CB_USAGE_DISPLAY;
p->pic = CB_PICTURE (cb_build_picture ("9(4)"));
cb_validate_field (p);
p->flag_no_init = 1;
/* Do not initialize/bump ref count here
p->values = cb_list_init (cb_zero);
p->count++;
*/
current_program->working_storage =
cb_field_add (current_program->working_storage, p);
prog->crt_status = l;
/* RXWRXW - Maybe better
prog->crt_status = cb_build_index (cb_build_reference ("COB-CRT-STATUS"), cb_zero, 0, NULL);
*/
}
/* resolve all references so far */
for (l = cb_list_reverse (prog->reference_list); l; l = CB_CHAIN (l)) {
cb_ref (CB_VALUE (l));
}
for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
f = CB_FILE (CB_VALUE (l));
if (f->record_depending && f->record_depending != cb_error_node) {
x = f->record_depending;
if (cb_ref (x) != cb_error_node) {
/* RXW - This breaks old legacy programs
if (CB_REF_OR_FIELD_P(x)) {
p = cb_field (x);
switch (p->storage) {
case CB_STORAGE_WORKING:
case CB_STORAGE_LOCAL:
case CB_STORAGE_LINKAGE:
break;
default:
cb_error (_("RECORD DEPENDING item must be in WORKING/LOCAL/LINKAGE section"));
}
} else {
*/
if (!CB_REFERENCE_P(x) && !CB_FIELD_P(x)) {
cb_error (_("Invalid RECORD DEPENDING item"));
}
}
}
}
}
| void cb_validate_program_environment | ( | struct cb_program * | prog | ) |
Definition at line 1079 of file typeck.c.
{
cb_tree x;
cb_tree y;
cb_tree l;
cb_tree ls;
struct cb_alphabet_name *ap;
unsigned char *data;
size_t dupls;
size_t unvals;
size_t count;
int lower;
int upper;
int size;
int n;
int i;
int lastval;
int values[256];
/* Check ALPHABET clauses */
for (l = current_program->alphabet_name_list; l; l = CB_CHAIN (l)) {
ap = CB_ALPHABET_NAME (CB_VALUE (l));
if (ap->type != CB_ALPHABET_CUSTOM) {
continue;
}
ap->low_val_char = 0;
ap->high_val_char = 255;
dupls = 0;
unvals = 0;
count = 0;
lastval = 0;
for (n = 0; n < 256; n++) {
values[n] = -1;
}
for (y = ap->custom_list; y; y = CB_CHAIN (y)) {
if (count > 255) {
unvals = 1;
break;
}
x = CB_VALUE (y);
if (CB_PAIR_P (x)) {
/* X THRU Y */
lower = get_value (CB_PAIR_X (x));
upper = get_value (CB_PAIR_Y (x));
lastval = upper;
if (!count) {
ap->low_val_char = lower;
}
if (lower < 0 || lower > 255) {
unvals = 1;
continue;
}
if (upper < 0 || upper > 255) {
unvals = 1;
continue;
}
if (lower <= upper) {
for (i = lower; i <= upper; i++) {
if (values[i] != -1) {
dupls = 1;
}
values[i] = i;
count++;
}
} else {
for (i = lower; i >= upper; i--) {
if (values[i] != -1) {
dupls = 1;
}
values[i] = i;
count++;
}
}
} else if (CB_LIST_P (x)) {
/* X ALSO Y ... */
if (!count) {
ap->low_val_char = get_value (CB_VALUE (x));
}
for (ls = x; ls; ls = CB_CHAIN (ls)) {
n = get_value (CB_VALUE (ls));
if (!CB_CHAIN (ls)) {
lastval = n;
}
if (n < 0 || n > 255) {
unvals = 1;
continue;
}
if (values[n] != -1) {
dupls = 1;
}
values[n] = n;
count++;
}
} else {
/* literal */
if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
n = get_value (x);
lastval = n;
if (!count) {
ap->low_val_char = n;
}
if (n < 0 || n > 255) {
unvals = 1;
continue;
}
if (values[n] != -1) {
dupls = 1;
}
values[n] = n;
count++;
} else if (CB_LITERAL_P (x)) {
size = (int)CB_LITERAL (x)->size;
data = CB_LITERAL (x)->data;
if (!count) {
ap->low_val_char = data[0];
}
lastval = data[size - 1];
for (i = 0; i < size; i++) {
n = data[i];
if (values[n] != -1) {
dupls = 1;
}
values[n] = n;
count++;
}
} else {
n = get_value (x);
lastval = n;
if (!count) {
ap->low_val_char = n;
}
if (n < 0 || n > 255) {
unvals = 1;
continue;
}
if (values[n] != -1) {
dupls = 1;
}
values[n] = n;
count++;
}
}
}
if (dupls || unvals) {
if (dupls) {
cb_error_x (l, _("Duplicate character values in alphabet '%s'"),
cb_name (CB_VALUE(l)));
}
if (unvals) {
cb_error_x (l, _("Invalid character values in alphabet '%s'"),
cb_name (CB_VALUE(l)));
}
ap->low_val_char = 0;
ap->high_val_char = 255;
continue;
}
/* Calculate HIGH-VALUE */
/* If all 256 values have been specified, HIGH-VALUE is the last one */
/* Otherwise if HIGH-VALUE has been specified, find the highest */
/* value that has not been used */
if (count == 256) {
ap->high_val_char = lastval;
} else if (values[255] != -1) {
for (n = 254; n >= 0; n--) {
if (values[n] == -1) {
ap->high_val_char = n;
break;
}
}
}
}
/* Rest HIGH/LOW-VALUES */
cb_low = cb_norm_low;
cb_high = cb_norm_high;
/* resolve the program collating sequence */
if (!prog->collating_sequence) {
return;
}
x = cb_ref (prog->collating_sequence);
/* RXWRXW
if (x == cb_error_node) {
prog->collating_sequence = NULL;
return;
}
*/
if (!CB_ALPHABET_NAME_P (x)) {
cb_error_x (prog->collating_sequence, _("'%s' not alphabet name"),
cb_name (prog->collating_sequence));
prog->collating_sequence = NULL;
return;
}
if (CB_ALPHABET_NAME (x)->type != CB_ALPHABET_CUSTOM) {
return;
}
if (CB_ALPHABET_NAME (x)->low_val_char) {
cb_low = cb_build_alphanumeric_literal ((ucharptr)"\0", 1);
CB_LITERAL(cb_low)->data[0] = CB_ALPHABET_NAME (x)->low_val_char;
CB_LITERAL(cb_low)->all = 1;
}
if (CB_ALPHABET_NAME (x)->high_val_char != 255){
cb_high = cb_build_alphanumeric_literal ((ucharptr)"\0", 1);
CB_LITERAL(cb_high)->data[0] = CB_ALPHABET_NAME (x)->high_val_char;
CB_LITERAL(cb_high)->all = 1;
}
}
Definition at line 3944 of file typeck.c.
{
struct cb_field *f;
struct cb_literal *l;
unsigned char *p;
cb_tree loc;
long long val;
size_t i;
size_t is_numeric_edited = 0;
int src_scale_mod;
int dst_scale_mod;
int dst_size_mod;
int size;
int most_significant;
int least_significant;
loc = src->source_line ? src : dst;
if (CB_REFERENCE_P(dst) && CB_ALPHABET_NAME_P(CB_REFERENCE(dst)->value)) {
goto invalid;
}
if (CB_REFERENCE_P(dst) && CB_FILE_P(CB_REFERENCE(dst)->value)) {
goto invalid;
}
if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_BOOLEAN) {
cb_error_x (loc, _("Invalid destination for MOVE"));
return -1;
}
if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER) {
if (CB_TREE_CLASS (src) == CB_CLASS_POINTER) {
return 0;
} else {
goto invalid;
}
}
f = cb_field (dst);
switch (CB_TREE_TAG (src)) {
case CB_TAG_CONST:
if (src == cb_space) {
if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC
|| (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED && !is_value)) {
goto invalid;
}
} else if (src == cb_zero) {
if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHABETIC) {
goto invalid;
}
}
break;
case CB_TAG_LITERAL:
/* TODO: ALL literal */
l = CB_LITERAL (src);
if (CB_TREE_CLASS (src) == CB_CLASS_NUMERIC) {
/* Numeric literal */
if (l->all) {
goto invalid;
}
most_significant = -999;
least_significant = 999;
/* compute the most significant figure place */
for (i = 0; i < l->size; i++) {
if (l->data[i] != '0') {
break;
}
}
if (i != l->size) {
most_significant = (int) (l->size - l->scale - i - 1);
}
/* compute the least significant figure place */
for (i = 0; i < l->size; i++) {
if (l->data[l->size - i - 1] != '0') {
break;
}
}
if (i != l->size) {
least_significant = (int) (-l->scale + i);
}
/* value check */
switch (CB_TREE_CATEGORY (dst)) {
case CB_CATEGORY_ALPHANUMERIC:
case CB_CATEGORY_ALPHANUMERIC_EDITED:
if (is_value) {
goto expect_alphanumeric;
}
if (l->scale == 0) {
goto expect_alphanumeric;
} else {
goto invalid;
}
case CB_CATEGORY_NUMERIC:
if (f->pic->scale < 0) {
/* check for PIC 9(n)P(m) */
if (least_significant < -f->pic->scale) {
goto value_mismatch;
}
} else if (f->pic->scale > f->pic->size) {
/* check for PIC P(n)9(m) */
if (most_significant >= f->pic->size - f->pic->scale) {
goto value_mismatch;
}
}
break;
case CB_CATEGORY_NUMERIC_EDITED:
if (is_value) {
goto expect_alphanumeric;
}
/* TODO */
break;
default:
if (is_value) {
goto expect_alphanumeric;
}
goto invalid;
}
/* sign check */
if (l->sign != 0 && !f->pic->have_sign) {
if (is_value) {
cb_error_x (loc, _("Data item not signed"));
return -1;
}
if (cb_warn_constant) {
cb_warning_x (loc, _("Ignoring negative sign"));
}
}
/* size check */
if (f->flag_real_binary ||
((f->usage == CB_USAGE_COMP_5 ||
f->usage == CB_USAGE_COMP_X ||
f->usage == CB_USAGE_BINARY) &&
f->pic->scale == 0)) {
p = l->data;
for (i = 0; i < l->size; i++) {
if (l->data[i] != '0') {
p = &l->data[i];
break;
}
}
i = l->size - i;
switch (f->size) {
case 1:
if (i > 18) {
goto numlit_overflow;
}
val = cb_get_long_long (src);
if (f->pic->have_sign) {
if (val < -128LL ||
val > 127LL) {
goto numlit_overflow;
}
} else {
if (val > 255LL) {
goto numlit_overflow;
}
}
break;
case 2:
if (i > 18) {
goto numlit_overflow;
}
val = cb_get_long_long (src);
if (f->pic->have_sign) {
if (val < -32768LL ||
val > 32767LL) {
goto numlit_overflow;
}
} else {
if (val > 65535LL) {
goto numlit_overflow;
}
}
break;
case 3:
if (i > 18) {
goto numlit_overflow;
}
val = cb_get_long_long (src);
if (f->pic->have_sign) {
if (val < -8388608LL ||
val > 8388607LL) {
goto numlit_overflow;
}
} else {
if (val > 16777215LL) {
goto numlit_overflow;
}
}
break;
case 4:
if (i > 18) {
goto numlit_overflow;
}
val = cb_get_long_long (src);
if (f->pic->have_sign) {
if (val < -2147483648LL ||
val > 2147483647LL) {
goto numlit_overflow;
}
} else {
if (val > 4294967295LL) {
goto numlit_overflow;
}
}
break;
case 5:
if (i > 18) {
goto numlit_overflow;
}
val = cb_get_long_long (src);
if (f->pic->have_sign) {
if (val < -549755813888LL ||
val > 549755813887LL) {
goto numlit_overflow;
}
} else {
if (val > 1099511627775LL) {
goto numlit_overflow;
}
}
break;
case 6:
if (i > 18) {
goto numlit_overflow;
}
val = cb_get_long_long (src);
if (f->pic->have_sign) {
if (val < -140737488355328LL ||
val > 140737488355327LL) {
goto numlit_overflow;
}
} else {
if (val > 281474976710655LL) {
goto numlit_overflow;
}
}
break;
case 7:
if (i > 18) {
goto numlit_overflow;
}
val = cb_get_long_long (src);
if (f->pic->have_sign) {
if (val < -36028797018963968LL ||
val > 36028797018963967LL) {
goto numlit_overflow;
}
} else {
if (val > 72057594037927935LL) {
goto numlit_overflow;
}
}
break;
default:
if (f->pic->have_sign) {
if (i < 19) {
break;
}
if (i > 19) {
goto numlit_overflow;
}
if (memcmp (p, "9223372036854775807", 19) > 0) {
goto numlit_overflow;
}
} else {
if (i < 20) {
break;
}
if (i > 20) {
goto numlit_overflow;
}
if (memcmp (p, "18446744073709551615", 20) > 0) {
goto numlit_overflow;
}
}
break;
}
return 0;
}
if (least_significant < -f->pic->scale) {
goto size_overflow;
}
if (f->pic->scale > 0) {
size = f->pic->digits - f->pic->scale;
} else {
size = f->pic->digits;
}
if (most_significant >= size) {
goto size_overflow;
}
} else {
/* Alphanumeric literal */
/* value check */
switch (CB_TREE_CATEGORY (dst)) {
case CB_CATEGORY_ALPHABETIC:
for (i = 0; i < l->size; i++) {
if (!isalpha (l->data[i]) && !isspace (l->data[i])) {
goto value_mismatch;
}
}
break;
case CB_CATEGORY_NUMERIC:
goto expect_numeric;
case CB_CATEGORY_NUMERIC_EDITED:
if (!is_value) {
goto expect_numeric;
}
/* TODO: validate the value */
break;
default:
break;
}
/* size check */
size = cb_field_size (dst);
if (size >= 0 && (int)l->size > size) {
goto size_overflow;
}
}
break;
case CB_TAG_FIELD:
case CB_TAG_REFERENCE:
if (CB_REFERENCE_P(src) &&
CB_ALPHABET_NAME_P(CB_REFERENCE(src)->value)) {
break;
}
if (CB_REFERENCE_P(src) &&
CB_FILE_P(CB_REFERENCE(src)->value)) {
goto invalid;
}
size = cb_field_size (src);
if (size < 0) {
size = cb_field (src)->size;
}
/* non-elementary move */
if (cb_field (src)->children || cb_field (dst)->children) {
if (size > cb_field (dst)->size) {
goto size_overflow_1;
}
break;
}
/* elementary move */
switch (CB_TREE_CATEGORY (src)) {
case CB_CATEGORY_ALPHANUMERIC:
switch (CB_TREE_CATEGORY (dst)) {
case CB_CATEGORY_NUMERIC:
case CB_CATEGORY_NUMERIC_EDITED:
if (size > cb_field (dst)->pic->digits) {
goto size_overflow_2;
}
break;
case CB_CATEGORY_ALPHANUMERIC_EDITED:
if (size >
count_pic_alphanumeric_edited (cb_field (dst))) {
goto size_overflow_1;
}
break;
default:
if (size > cb_field (dst)->size) {
goto size_overflow_1;
}
break;
}
break;
case CB_CATEGORY_ALPHABETIC:
case CB_CATEGORY_ALPHANUMERIC_EDITED:
switch (CB_TREE_CATEGORY (dst)) {
case CB_CATEGORY_NUMERIC:
case CB_CATEGORY_NUMERIC_EDITED:
goto invalid;
case CB_CATEGORY_ALPHANUMERIC_EDITED:
if (size >
count_pic_alphanumeric_edited(cb_field (dst))) {
goto size_overflow_1;
}
break;
default:
if (size > cb_field (dst)->size) {
goto size_overflow_1;
}
break;
}
break;
case CB_CATEGORY_NUMERIC:
case CB_CATEGORY_NUMERIC_EDITED:
switch (CB_TREE_CATEGORY (dst)) {
case CB_CATEGORY_ALPHABETIC:
goto invalid;
case CB_CATEGORY_ALPHANUMERIC_EDITED:
is_numeric_edited = 1;
/* Drop through */
case CB_CATEGORY_ALPHANUMERIC:
if (is_numeric_edited) {
dst_size_mod = count_pic_alphanumeric_edited (cb_field (dst));
} else {
dst_size_mod = cb_field (dst)->size;
}
if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC
&& cb_field (src)->pic->scale > 0) {
if (cb_move_noninteger_to_alphanumeric == CB_ERROR) {
goto invalid;
}
cb_warning_x (loc, _("Move non-integer to alphanumeric"));
break;
}
if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC
&& cb_field (src)->pic->digits > dst_size_mod) {
goto size_overflow_2;
}
if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC_EDITED
&& cb_field (src)->size > dst_size_mod) {
goto size_overflow_1;
}
break;
default:
src_scale_mod = cb_field (src)->pic->scale < 0 ?
0 : cb_field (src)->pic->scale;
dst_scale_mod = cb_field (dst)->pic->scale < 0 ?
0 : cb_field (dst)->pic->scale;
if (cb_field (src)->pic->digits - src_scale_mod >
cb_field (dst)->pic->digits - dst_scale_mod ||
src_scale_mod > dst_scale_mod) {
goto size_overflow_2;
}
break;
}
break;
default:
cb_error_x (loc, _("Invalid source for MOVE"));
return -1;
}
break;
case CB_TAG_INTEGER:
case CB_TAG_BINARY_OP:
case CB_TAG_INTRINSIC:
/* TODO: check this */
break;
default:
fprintf (stderr, "Invalid tree tag %d\n", CB_TREE_TAG (src));
ABORT ();
}
return 0;
invalid:
if (is_value) {
cb_error_x (loc, _("Invalid VALUE clause"));
} else {
cb_error_x (loc, _("Invalid MOVE statement"));
}
return -1;
numlit_overflow:
if (is_value) {
cb_error_x (loc, _("Invalid VALUE clause - literal exceeds data size"));
return -1;
}
if (cb_warn_constant) {
cb_warning_x (loc, _("Numeric literal exceeds data size"));
}
return 0;
expect_numeric:
return move_error (src, dst, is_value, cb_warn_strict_typing, 0,
_("Numeric value is expected"));
expect_alphanumeric:
return move_error (src, dst, is_value, cb_warn_strict_typing, 0,
_("Alphanumeric value is expected"));
value_mismatch:
return move_error (src, dst, is_value, cb_warn_constant, 0,
_("Value does not fit the picture string"));
size_overflow:
return move_error (src, dst, is_value, cb_warn_constant, 0,
_("Value size exceeds data size"));
size_overflow_1:
return move_error (src, dst, is_value, cb_warn_truncate, 1,
_("Sending field larger than receiving field"));
size_overflow_2:
return move_error (src, dst, is_value, cb_warn_truncate, 1,
_("Some digits may be truncated"));
}
| size_t sending_id = 0 |
| size_t suppress_warn = 0 |
1.7.4