|
OpenCOBOL 1.1pre-rel
|
|
OpenCOBOL 1.1pre-rel
|
Go to the source code of this file.
| #define CB_ALPHABET_NAME | ( | x | ) | (CB_TREE_CAST (CB_TAG_ALPHABET_NAME, struct cb_alphabet_name, x)) |
| #define CB_ALPHABET_NAME_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_ALPHABET_NAME) |
| #define CB_ASSIGN | ( | x | ) | (CB_TREE_CAST (CB_TAG_ASSIGN, struct cb_assign, x)) |
| #define CB_BINARY_OP | ( | x | ) | (CB_TREE_CAST (CB_TAG_BINARY_OP, struct cb_binary_op, x)) |
| #define CB_BINARY_OP_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_BINARY_OP) |
| #define cb_build_cast_addr_of_addr | ( | x | ) | cb_build_cast (CB_CAST_ADDR_OF_ADDR, x) |
| #define cb_build_cast_address | ( | x | ) | cb_build_cast (CB_CAST_ADDRESS, x) |
| #define cb_build_cast_integer | ( | x | ) | cb_build_cast (CB_CAST_INTEGER, x) |
| #define cb_build_cast_length | ( | x | ) | cb_build_cast (CB_CAST_LENGTH, x) |
| #define cb_build_cast_ppointer | ( | x | ) | cb_build_cast (CB_CAST_PROGRAM_POINTER, x) |
| #define cb_build_funcall_0 | ( | f | ) | cb_build_funcall(f, 0, NULL, NULL, NULL, NULL, NULL, NULL, NULL) |
| #define cb_build_funcall_1 | ( | f, | |
| a1 | |||
| ) | cb_build_funcall(f, 1, a1, NULL, NULL, NULL, NULL, NULL, NULL) |
| #define cb_build_funcall_2 | ( | f, | |
| a1, | |||
| a2 | |||
| ) | cb_build_funcall(f, 2, a1, a2, NULL, NULL, NULL, NULL, NULL) |
| #define cb_build_funcall_3 | ( | f, | |
| a1, | |||
| a2, | |||
| a3 | |||
| ) | cb_build_funcall(f, 3, a1, a2, a3, NULL, NULL, NULL, NULL) |
| #define cb_build_funcall_4 | ( | f, | |
| a1, | |||
| a2, | |||
| a3, | |||
| a4 | |||
| ) | cb_build_funcall(f, 4, a1, a2, a3, a4, NULL, NULL, NULL) |
| #define cb_build_funcall_5 | ( | f, | |
| a1, | |||
| a2, | |||
| a3, | |||
| a4, | |||
| a5 | |||
| ) | cb_build_funcall(f, 5, a1, a2, a3, a4, a5, NULL, NULL) |
| #define cb_build_funcall_6 | ( | f, | |
| a1, | |||
| a2, | |||
| a3, | |||
| a4, | |||
| a5, | |||
| a6 | |||
| ) | cb_build_funcall(f, 6, a1, a2, a3, a4, a5, a6, NULL) |
| #define cb_build_funcall_7 | ( | f, | |
| a1, | |||
| a2, | |||
| a3, | |||
| a4, | |||
| a5, | |||
| a6, | |||
| a7 | |||
| ) | cb_build_funcall(f, 7, a1, a2, a3, a4, a5, a6, a7) |
| #define cb_build_negation | ( | x | ) | cb_build_binary_op (x, '!', NULL) |
| #define cb_build_parenthesis | ( | x | ) | cb_build_binary_op (x, '@', NULL) |
| #define cb_build_string0 | ( | str | ) | cb_build_string (str, strlen ((char *)str)) |
| #define CB_CALL | ( | x | ) | (CB_TREE_CAST (CB_TAG_CALL, struct cb_call, x)) |
| #define CB_CAST | ( | x | ) | (CB_TREE_CAST (CB_TAG_CAST, struct cb_cast, x)) |
| #define CB_CLASS_NAME | ( | x | ) | (CB_TREE_CAST (CB_TAG_CLASS_NAME, struct cb_class_name, x)) |
| #define CB_CLASS_NAME_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_CLASS_NAME) |
| #define CB_CONST | ( | x | ) | (CB_TREE_CAST (CB_TAG_CONST, struct cb_const, x)) |
| #define CB_CONTINUE | ( | x | ) | (CB_TREE_CAST (CB_TAG_CONTINUE, struct cb_continue, x)) |
| #define CB_CONTINUE_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_CONTINUE) |
| #define CB_DECIMAL | ( | x | ) | (CB_TREE_CAST (CB_TAG_DECIMAL, struct cb_decimal, x)) |
| #define CB_DECIMAL_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_DECIMAL) |
| #define CB_FIELD | ( | x | ) | (CB_TREE_CAST (CB_TAG_FIELD, struct cb_field, x)) |
| #define CB_FILE | ( | x | ) | (CB_TREE_CAST (CB_TAG_FILE, struct cb_file, x)) |
| #define CB_FUNCALL | ( | x | ) | (CB_TREE_CAST (CB_TAG_FUNCALL, struct cb_funcall, x)) |
| #define CB_FUNCALL_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_FUNCALL) |
| #define CB_GOTO | ( | x | ) | (CB_TREE_CAST (CB_TAG_GOTO, struct cb_goto, x)) |
| #define CB_IF | ( | x | ) | (CB_TREE_CAST (CB_TAG_IF, struct cb_if, x)) |
| #define CB_INDEX_P | ( | x | ) |
((CB_FIELD_P (x) || CB_REFERENCE_P (x)) \ && cb_field (x)->usage == CB_USAGE_INDEX)
| #define CB_INITIALIZE | ( | x | ) | (CB_TREE_CAST (CB_TAG_INITIALIZE, struct cb_initialize, x)) |
| #define CB_INITIALIZE_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_INITIALIZE) |
| #define CB_INTEGER | ( | x | ) | (CB_TREE_CAST (CB_TAG_INTEGER, struct cb_integer, x)) |
| #define CB_INTEGER_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_INTEGER) |
| #define CB_INTRINSIC | ( | x | ) | (CB_TREE_CAST (CB_TAG_INTRINSIC, struct cb_intrinsic, x)) |
| #define CB_INTRINSIC_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_INTRINSIC) |
| #define CB_LABEL | ( | x | ) | (CB_TREE_CAST (CB_TAG_LABEL, struct cb_label, x)) |
| #define CB_LIST | ( | x | ) | (CB_TREE_CAST (CB_TAG_LIST, struct cb_list, x)) |
| #define CB_LITERAL | ( | x | ) | (CB_TREE_CAST (CB_TAG_LITERAL, struct cb_literal, x)) |
| #define CB_LITERAL_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_LITERAL) |
| #define CB_LOCALE_NAME | ( | x | ) | (CB_TREE_CAST (CB_TAG_LOCALE_NAME, struct cb_locale_name, x)) |
| #define CB_LOCALE_NAME_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_LOCALE_NAME) |
| #define CB_NUMERIC_LITERAL_P | ( | x | ) | (CB_LITERAL_P (x) && CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) |
| #define CB_PERFORM | ( | x | ) | (CB_TREE_CAST (CB_TAG_PERFORM, struct cb_perform, x)) |
| #define CB_PERFORM_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_PERFORM) |
| #define CB_PERFORM_VARYING | ( | x | ) | (CB_TREE_CAST (CB_TAG_PERFORM_VARYING, struct cb_perform_varying, x)) |
| #define CB_PICTURE | ( | x | ) | (CB_TREE_CAST (CB_TAG_PICTURE, struct cb_picture, x)) |
| #define CB_PICTURE_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_PICTURE) |
| #define CB_PURPOSE_INT | ( | x | ) | (CB_INTEGER (CB_PURPOSE (x))->val) |
| #define CB_REF_OR_FIELD_P | ( | x | ) | ((CB_FIELD_P (x) || CB_REFERENCE_P (x))) |
| #define CB_REFERENCE | ( | x | ) | (CB_TREE_CAST (CB_TAG_REFERENCE, struct cb_reference, x)) |
| #define CB_REFERENCE_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_REFERENCE) |
| #define CB_SEARCH | ( | x | ) | (CB_TREE_CAST (CB_TAG_SEARCH, struct cb_search, x)) |
| #define CB_SIZES_INT_UNSIGNED | ( | x | ) | ((CB_LIST (x)->sizes) & CB_SIZE_UNSIGNED) |
| #define CB_STATEMENT | ( | x | ) | (CB_TREE_CAST (CB_TAG_STATEMENT, struct cb_statement, x)) |
| #define CB_STATEMENT_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_STATEMENT) |
| #define CB_STRING | ( | x | ) | (CB_TREE_CAST (CB_TAG_STRING, struct cb_string, x)) |
| #define CB_SYSTEM_NAME | ( | x | ) | (CB_TREE_CAST (CB_TAG_SYSTEM_NAME, struct cb_system_name, x)) |
| #define CB_SYSTEM_NAME_P | ( | x | ) | (CB_TREE_TAG (x) == CB_TAG_SYSTEM_NAME) |
| #define CB_TREE | ( | x | ) | ((struct cb_tree_common *) (x)) |
| typedef struct cb_tree_common* cb_tree |
| enum cb_cast_type |
| enum cb_category |
Definition at line 147 of file tree.h.
{
CB_CATEGORY_UNKNOWN, /* 0 */
CB_CATEGORY_ALPHABETIC, /* 1 */
CB_CATEGORY_ALPHANUMERIC, /* 2 */
CB_CATEGORY_ALPHANUMERIC_EDITED, /* 3 */
CB_CATEGORY_BOOLEAN, /* 4 */
CB_CATEGORY_INDEX, /* 5 */
CB_CATEGORY_NATIONAL, /* 6 */
CB_CATEGORY_NATIONAL_EDITED, /* 7 */
CB_CATEGORY_NUMERIC, /* 8 */
CB_CATEGORY_NUMERIC_EDITED, /* 9 */
CB_CATEGORY_OBJECT_REFERENCE, /* 10 */
CB_CATEGORY_DATA_POINTER, /* 11 */
CB_CATEGORY_PROGRAM_POINTER /* 12 */
};
| enum cb_class |
| CB_CLASS_UNKNOWN | |
| CB_CLASS_ALPHABETIC | |
| CB_CLASS_ALPHANUMERIC | |
| CB_CLASS_BOOLEAN | |
| CB_CLASS_INDEX | |
| CB_CLASS_NATIONAL | |
| CB_CLASS_NUMERIC | |
| CB_CLASS_OBJECT | |
| CB_CLASS_POINTER |
Definition at line 135 of file tree.h.
{
CB_CLASS_UNKNOWN, /* 0 */
CB_CLASS_ALPHABETIC, /* 1 */
CB_CLASS_ALPHANUMERIC, /* 2 */
CB_CLASS_BOOLEAN, /* 3 */
CB_CLASS_INDEX, /* 4 */
CB_CLASS_NATIONAL, /* 5 */
CB_CLASS_NUMERIC, /* 6 */
CB_CLASS_OBJECT, /* 7 */
CB_CLASS_POINTER /* 8 */
};
| enum cb_device_name |
| enum cb_feature_name |
| enum cb_intr_enum |
Definition at line 809 of file tree.h.
{
CB_INTR_ABS = 1,
CB_INTR_ACOS,
CB_INTR_ANNUITY,
CB_INTR_ASIN,
CB_INTR_ATAN,
CB_INTR_BOOLEAN_OF_INTEGER,
CB_INTR_BYTE_LENGTH,
CB_INTR_CHAR,
CB_INTR_CHAR_NATIONAL,
CB_INTR_COMBINED_DATETIME,
CB_INTR_CONCATENATE,
CB_INTR_COS,
CB_INTR_CURRENT_DATE,
CB_INTR_DATE_OF_INTEGER,
CB_INTR_DATE_TO_YYYYMMDD,
CB_INTR_DAY_OF_INTEGER,
CB_INTR_DAY_TO_YYYYDDD,
CB_INTR_DISPLAY_OF,
CB_INTR_E,
CB_INTR_EXCEPTION_FILE,
CB_INTR_EXCEPTION_FILE_N,
CB_INTR_EXCEPTION_LOCATION,
CB_INTR_EXCEPTION_LOCATION_N,
CB_INTR_EXCEPTION_STATEMENT,
CB_INTR_EXCEPTION_STATUS,
CB_INTR_EXP,
CB_INTR_EXP10,
CB_INTR_FACTORIAL,
CB_INTR_FRACTION_PART,
CB_INTR_HIGHEST_ALGEBRAIC,
CB_INTR_INTEGER,
CB_INTR_INTEGER_OF_BOOLEAN,
CB_INTR_INTEGER_OF_DATE,
CB_INTR_INTEGER_OF_DAY,
CB_INTR_INTEGER_PART,
CB_INTR_LENGTH,
CB_INTR_LOCALE_COMPARE,
CB_INTR_LOCALE_DATE,
CB_INTR_LOCALE_TIME,
CB_INTR_LOCALE_TIME_FROM_SECS,
CB_INTR_LOG,
CB_INTR_LOG10,
CB_INTR_LOWER_CASE,
CB_INTR_LOWEST_ALGEBRAIC,
CB_INTR_MAX,
CB_INTR_MEAN,
CB_INTR_MEDIAN,
CB_INTR_MIDRANGE,
CB_INTR_MIN,
CB_INTR_MOD,
CB_INTR_NATIONAL_OF,
CB_INTR_NUMVAL,
CB_INTR_NUMVAL_C,
CB_INTR_NUMVAL_F,
CB_INTR_ORD,
CB_INTR_ORD_MAX,
CB_INTR_ORD_MIN,
CB_INTR_PI,
CB_INTR_PRESENT_VALUE,
CB_INTR_RANDOM,
CB_INTR_RANGE,
CB_INTR_REM,
CB_INTR_REVERSE,
CB_INTR_SECONDS_FROM_FORMATTED_TIME,
CB_INTR_SECONDS_PAST_MIDNIGHT,
CB_INTR_SIGN,
CB_INTR_SIN,
CB_INTR_SQRT,
CB_INTR_STANDARD_COMPARE,
CB_INTR_STANDARD_DEVIATION,
CB_INTR_STORED_CHAR_LENGTH,
CB_INTR_SUBSTITUTE,
CB_INTR_SUBSTITUTE_CASE,
CB_INTR_SUM,
CB_INTR_TAN,
CB_INTR_TEST_DATE_YYYYMMDD,
CB_INTR_TEST_DAY_YYYYDDD,
CB_INTR_TEST_NUMVAL,
CB_INTR_TEST_NUMVAL_C,
CB_INTR_TEST_NUMVAL_F,
CB_INTR_TRIM,
CB_INTR_UPPER_CASE,
CB_INTR_VARIANCE,
CB_INTR_WHEN_COMPILED,
CB_INTR_YEAR_TO_YYYY
};
| enum cb_operand_type |
| enum cb_perform_type |
| enum cb_storage |
| CB_STORAGE_CONSTANT | |
| CB_STORAGE_FILE | |
| CB_STORAGE_WORKING | |
| CB_STORAGE_LOCAL | |
| CB_STORAGE_LINKAGE | |
| CB_STORAGE_SCREEN | |
| CB_STORAGE_REPORT | |
| CB_STORAGE_COMMUNICATION |
Definition at line 163 of file tree.h.
{
CB_STORAGE_CONSTANT, /* Constants */
CB_STORAGE_FILE, /* FILE SECTION */
CB_STORAGE_WORKING, /* WORKING-STORAGE SECTION */
CB_STORAGE_LOCAL, /* LOCAL-STORAGE SECTION */
CB_STORAGE_LINKAGE, /* LINKAGE SECTION */
CB_STORAGE_SCREEN, /* SCREEN SECTION */
CB_STORAGE_REPORT, /* REPORT SECTION */
CB_STORAGE_COMMUNICATION /* COMMUNICATION SECTION */
};
| enum cb_switch_name |
| enum cb_tag |
Definition at line 44 of file tree.h.
{
/* primitives */
CB_TAG_CONST, /* 0 constant value */
CB_TAG_INTEGER, /* 1 integer constant */
CB_TAG_STRING, /* 2 string constant */
CB_TAG_ALPHABET_NAME, /* 3 alphabet-name */
CB_TAG_CLASS_NAME, /* 4 class-name */
CB_TAG_LOCALE_NAME, /* 5 locale-name */
CB_TAG_SYSTEM_NAME, /* 6 system-name */
CB_TAG_LITERAL, /* 7 numeric/alphanumeric literal */
CB_TAG_DECIMAL, /* 8 decimal number */
CB_TAG_FIELD, /* 9 user-defined variable */
CB_TAG_FILE, /* 10 file description */
/* expressions */
CB_TAG_REFERENCE, /* 11 reference to a field, file, or label */
CB_TAG_BINARY_OP, /* 12 binary operation */
CB_TAG_FUNCALL, /* 13 run-time function call */
CB_TAG_CAST, /* 14 type cast */
CB_TAG_INTRINSIC, /* 15 intrinsic function */
/* statements */
CB_TAG_LABEL, /* 16 label statement */
CB_TAG_ASSIGN, /* 17 assignment statement */
CB_TAG_INITIALIZE, /* 18 INITIALIZE statement */
CB_TAG_SEARCH, /* 19 SEARCH statement */
CB_TAG_CALL, /* 20 CALL statement */
CB_TAG_GOTO, /* 21 GO TO statement */
CB_TAG_IF, /* 22 IF statement */
CB_TAG_PERFORM, /* 23 PERFORM statement */
CB_TAG_STATEMENT, /* 24 general statement */
CB_TAG_CONTINUE, /* 25 CONTINUE statement */
/* miscellaneous */
CB_TAG_PERFORM_VARYING, /* 26 PERFORM VARYING parameter */
CB_TAG_PICTURE, /* 27 PICTURE clause */
CB_TAG_LIST /* 28 list */
};
| enum cb_usage |
Definition at line 174 of file tree.h.
{
CB_USAGE_BINARY, /* 0 */
CB_USAGE_BIT, /* 1 */
CB_USAGE_COMP_5, /* 2 */
CB_USAGE_COMP_X, /* 3 */
CB_USAGE_DISPLAY, /* 4 */
CB_USAGE_FLOAT, /* 5 */
CB_USAGE_DOUBLE, /* 6 */
CB_USAGE_INDEX, /* 7 */
CB_USAGE_NATIONAL, /* 8 */
CB_USAGE_OBJECT, /* 9 */
CB_USAGE_PACKED, /* 10 */
CB_USAGE_POINTER, /* 11 */
CB_USAGE_PROGRAM, /* 12 */
CB_USAGE_LENGTH, /* 13 */
CB_USAGE_PROGRAM_POINTER, /* 14 */
CB_USAGE_UNSIGNED_CHAR, /* 15 */
CB_USAGE_SIGNED_CHAR, /* 16 */
CB_USAGE_UNSIGNED_SHORT, /* 17 */
CB_USAGE_SIGNED_SHORT, /* 18 */
CB_USAGE_UNSIGNED_INT, /* 19 */
CB_USAGE_SIGNED_INT, /* 20 */
CB_USAGE_UNSIGNED_LONG, /* 21 */
CB_USAGE_SIGNED_LONG /* 22 */
};
| void ambiguous_error | ( | cb_tree | x | ) |
Definition at line 197 of file error.c.
{
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);
}
}
}
Definition at line 1577 of file tree.c.
{
struct cb_file *p;
p = make_tree (CB_TAG_FILE, CB_CATEGORY_UNKNOWN, sizeof (struct cb_file));
p->name = cb_define (name, CB_TREE (p));
p->cname = to_cname (p->name);
p->organization = COB_ORG_SEQUENTIAL;
p->access_mode = COB_ACCESS_SEQUENTIAL;
p->handler = CB_LABEL (cb_standard_error_handler);
p->handler_prog = current_program;
return p;
}
| struct cb_literal* build_literal | ( | enum cb_category | category, |
| const unsigned char * | data, | ||
| size_t | size | ||
| ) | [read] |
Definition at line 426 of file tree.c.
{
struct cb_literal *p;
p = make_tree (CB_TAG_LITERAL, category, sizeof (struct cb_literal));
p->data = cobc_malloc ((size_t) (size + 1));
p->size = size;
memcpy (p->data, data, (size_t) size);
/* RXW - malloc zeroes
p->data[size] = 0;
*/
return p;
}
| void cb_add_78 | ( | struct cb_field * | f | ) |
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);
}
| cb_tree cb_build_alphabet_name | ( | cb_tree | name, |
| enum cb_alphabet_name_type | type | ||
| ) |
Definition at line 923 of file tree.c.
{
struct cb_alphabet_name *p;
p = make_tree (CB_TAG_ALPHABET_NAME, CB_CATEGORY_UNKNOWN, sizeof (struct cb_alphabet_name));
p->name = cb_define (name, CB_TREE (p));
p->cname = to_cname (p->name);
p->type = type;
return CB_TREE (p);
}
| cb_tree cb_build_alphanumeric_literal | ( | const unsigned char * | data, |
| size_t | size | ||
| ) |
Definition at line 999 of file tree.c.
{
return CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, data, size));
}
Definition at line 2253 of file tree.c.
{
struct cb_intrinsic_table *cbp;
cbp = lookup_intrinsic ("LENGTH", 0);
return make_intrinsic (NULL, cbp, args, NULL, NULL);
}
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 1954 of file tree.c.
{
struct cb_binary_op *p;
enum cb_category category = CB_CATEGORY_UNKNOWN;
switch (op) {
case '+':
case '-':
case '*':
case '/':
case '^':
/* arithmetic operators */
if (CB_TREE_CLASS (x) == CB_CLASS_POINTER ||
CB_TREE_CLASS (y) == CB_CLASS_POINTER) {
category = CB_CATEGORY_DATA_POINTER;
break;
}
x = cb_check_numeric_value (x);
y = cb_check_numeric_value (y);
if (x == cb_error_node || y == cb_error_node) {
return cb_error_node;
}
category = CB_CATEGORY_NUMERIC;
break;
case '=':
case '~':
case '<':
case '>':
case '[':
case ']':
/* relational operators */
category = CB_CATEGORY_BOOLEAN;
break;
case '!':
case '&':
case '|':
/* logical operators */
if (CB_TREE_CLASS (x) != CB_CLASS_BOOLEAN ||
(y && CB_TREE_CLASS (y) != CB_CLASS_BOOLEAN)) {
cb_error (_("Invalid expression"));
return cb_error_node;
}
category = CB_CATEGORY_BOOLEAN;
break;
case '@':
/* parentheses */
category = CB_TREE_CATEGORY (x);
break;
default:
fprintf (stderr, "Unexpected operator -> %d\n", op);
ABORT ();
}
p = make_tree (CB_TAG_BINARY_OP, category, sizeof (struct cb_binary_op));
p->op = op;
p->x = x;
p->y = y;
return CB_TREE (p);
}
| cb_tree cb_build_call | ( | cb_tree | name, |
| cb_tree | args, | ||
| cb_tree | stmt1, | ||
| cb_tree | stmt2, | ||
| cb_tree | returning, | ||
| int | is_system_call | ||
| ) |
Definition at line 2149 of file tree.c.
{
struct cb_call *p;
p = make_tree (CB_TAG_CALL, CB_CATEGORY_UNKNOWN, sizeof (struct cb_call));
p->name = name;
p->args = args;
p->stmt1 = stmt1;
p->stmt2 = stmt2;
p->returning = returning;
p->is_system = is_system_call;
return CB_TREE (p);
}
| cb_tree cb_build_cast | ( | enum cb_cast_type | type, |
| cb_tree | val | ||
| ) |
Definition at line 2060 of file tree.c.
{
struct cb_cast *p;
enum cb_category category;
if (type == CB_CAST_INTEGER) {
category = CB_CATEGORY_NUMERIC;
} else {
category = CB_CATEGORY_UNKNOWN;
}
p = make_tree (CB_TAG_CAST, category, sizeof (struct cb_cast));
p->type = type;
p->val = val;
return CB_TREE (p);
}
Definition at line 939 of file tree.c.
{
struct cb_class_name *p;
char buff[COB_MINI_BUFF];
p = make_tree (CB_TAG_CLASS_NAME, CB_CATEGORY_BOOLEAN, sizeof (struct cb_class_name));
p->name = cb_define (name, CB_TREE (p));
snprintf (buff, COB_MINI_MAX, "is_%s", to_cname (p->name));
p->cname = strdup (buff);
p->list = list;
return CB_TREE (p);
}
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 1446 of file tree.c.
{
cb_tree x;
x = cb_build_field (name);
x->category = cb_tree_category (value);
CB_FIELD (x)->storage = CB_STORAGE_CONSTANT;
CB_FIELD (x)->values = cb_list_init (value);
return x;
}
| cb_tree cb_build_continue | ( | void | ) |
Definition at line 2240 of file tree.c.
{
struct cb_continue *p;
p = make_tree (CB_TAG_CONTINUE, CB_CATEGORY_UNKNOWN, sizeof (struct cb_continue));
return CB_TREE (p);
}
Definition at line 3847 of file typeck.c.
{
return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_converting", x, y));
}
| cb_tree cb_build_decimal | ( | int | id | ) |
Definition at line 1076 of file tree.c.
{
struct cb_decimal *p;
p = make_tree (CB_TAG_DECIMAL, CB_CATEGORY_NUMERIC, sizeof (struct cb_decimal));
p->id = id;
return CB_TREE (p);
}
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 1417 of file tree.c.
{
struct cb_field *p;
p = make_tree (CB_TAG_FIELD, CB_CATEGORY_UNKNOWN, sizeof (struct cb_field));
p->id = cb_field_id++;
p->name = cb_define (name, CB_TREE (p));
p->ename = NULL;
p->usage = CB_USAGE_DISPLAY;
p->storage = CB_STORAGE_WORKING;
p->occurs_max = 1;
return CB_TREE (p);
}
Definition at line 1752 of file tree.c.
{
cb_tree x;
struct cb_word *word;
x = cb_build_reference (f->name);
word = CB_REFERENCE (x)->word;
if (ref) {
memcpy (x, ref, sizeof (struct cb_reference));
}
x->category = CB_CATEGORY_UNKNOWN;
CB_REFERENCE (x)->word = word;
CB_REFERENCE (x)->value = CB_TREE (f);
return x;
}
| cb_tree cb_build_field_tree | ( | cb_tree | level, |
| cb_tree | name, | ||
| struct cb_field * | last_field, | ||
| enum cb_storage | storage, | ||
| struct cb_file * | fn | ||
| ) |
Definition at line 78 of file field.c.
{
struct cb_reference *r;
struct cb_field *f;
struct cb_field *p;
struct cb_field *field_fill;
cb_tree dummy_fill;
cb_tree l;
cb_tree x;
int lv;
if (level == cb_error_node || name == cb_error_node) {
return cb_error_node;
}
/* check the level number */
lv = cb_get_level (level);
if (!lv) {
return cb_error_node;
}
/* build the field */
r = CB_REFERENCE (name);
f = CB_FIELD (cb_build_field (name));
f->storage = storage;
last_real_field = last_field;
if (lv == 78) {
f->level = 01;
f->flag_item_78 = 1;
return CB_TREE (f);
} else {
f->level = lv;
}
if (f->level == 01 && storage == CB_STORAGE_FILE) {
if (fn->external) {
f->flag_external = 1;
has_external = 1;
} else if (fn->global) {
f->flag_is_global = 1;
}
}
if (last_field) {
if (last_field->level == 77 && f->level != 01 &&
f->level != 77 && f->level != 66 && f->level != 88) {
cb_error_x (name, _("Level number must begin with 01 or 77"));
return cb_error_node;
}
}
/* checks for redefinition */
if (cb_warn_redefinition) {
if (r->word->count > 1) {
if (f->level == 01 || f->level == 77) {
redefinition_warning (name, NULL);
} else {
for (l = r->word->items; l; l = CB_CHAIN (l)) {
x = CB_VALUE (l);
if (!CB_FIELD_P (x)
|| CB_FIELD (x)->level == 01
|| CB_FIELD (x)->level == 77
|| (f->level == last_field->level
&& CB_FIELD (x)->parent == last_field->parent)) {
redefinition_warning (name, x);
break;
}
}
}
}
}
if (last_field && last_field->level == 88) {
last_field = last_field->parent;
}
/* link the field into the tree */
if (f->level == 01 || f->level == 77) {
/* top level */
cb_needs_01 = 0;
if (last_field) {
/*
cb_field_add (cb_field_founder (last_field), f);
*/
cb_field_founder (last_field)->sister = f;
}
} else if (!last_field || cb_needs_01) {
/* invalid top level */
cb_error_x (name, _("Level number must begin with 01 or 77"));
return cb_error_node;
} else if (f->level == 66) {
/* level 66 */
f->parent = cb_field_founder (last_field);
for (p = f->parent->children; p && p->sister; p = p->sister) ;
if (p) {
p->sister = f;
}
} else if (f->level == 88) {
/* level 88 */
f->parent = last_field;
} else if (f->level > last_field->level) {
/* lower level */
last_field->children = f;
f->parent = last_field;
} else if (f->level == last_field->level) {
/* same level */
same_level:
last_field->sister = f;
f->parent = last_field->parent;
} else {
/* upper level */
for (p = last_field->parent; p; p = p->parent) {
if (p->level == f->level) {
last_field = p;
goto same_level;
}
if (cb_relax_level_hierarchy && p->level < f->level) {
break;
}
}
if (cb_relax_level_hierarchy) {
dummy_fill = cb_build_filler ();
field_fill = CB_FIELD (cb_build_field (dummy_fill));
cb_warning_x (name, _("No previous data item of level %02d"), f->level);
field_fill->level = f->level;
field_fill->storage = storage;
field_fill->children = p->children;
field_fill->parent = p;
for (p = p->children; p != NULL; p = p->sister) {
p->parent = field_fill;
}
field_fill->parent->children = field_fill;
field_fill->sister = f;
f->parent = field_fill->parent;
last_field = field_fill;
} else {
cb_error_x (name, _("No previous data item of level %02d"), f->level);
return cb_error_node;
}
}
/* inherit parent's properties */
if (f->parent) {
f->usage = f->parent->usage;
f->indexes = f->parent->indexes;
f->flag_sign_leading = f->parent->flag_sign_leading;
f->flag_sign_separate = f->parent->flag_sign_separate;
f->flag_is_global = f->parent->flag_is_global;
}
return CB_TREE (f);
}
| cb_tree cb_build_filler | ( | void | ) |
Definition at line 1740 of file tree.c.
{
cb_tree x;
char name[16];
sprintf (name, "WORK$%d", filler_id++);
x = cb_build_reference (name);
x->source_line = cb_source_line;
return x;
}
| cb_tree cb_build_funcall | ( | const char * | name, |
| int | argc, | ||
| cb_tree | a1, | ||
| cb_tree | a2, | ||
| cb_tree | a3, | ||
| cb_tree | a4, | ||
| cb_tree | a5, | ||
| cb_tree | a6, | ||
| cb_tree | a7 | ||
| ) |
Definition at line 2035 of file tree.c.
{
struct cb_funcall *p;
p = make_tree (CB_TAG_FUNCALL, CB_CATEGORY_BOOLEAN, sizeof (struct cb_funcall));
p->name = name;
p->argc = argc;
p->varcnt = 0;
p->screenptr = gen_screen_ptr;
p->argv[0] = a1;
p->argv[1] = a2;
p->argv[2] = a3;
p->argv[3] = a4;
p->argv[4] = a5;
p->argv[5] = a6;
p->argv[6] = a7;
return CB_TREE (p);
}
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 1432 of file tree.c.
{
cb_tree x;
char pic[32];
x = cb_build_field (name);
memset (pic, 0, sizeof(pic));
sprintf (pic, "X(%d)", len);
CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture (pic));
cb_validate_field (CB_FIELD (x));
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 2113 of file tree.c.
{
struct cb_initialize *p;
p = make_tree (CB_TAG_INITIALIZE, CB_CATEGORY_UNKNOWN, sizeof (struct cb_initialize));
p->var = var;
p->val = val;
p->rep = rep;
p->def = def;
p->flag_statement = flag;
return CB_TREE (p);
}
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 2262 of file tree.c.
{
struct cb_intrinsic_table *cbp;
cb_tree x;
int numargs;
numargs = cb_list_length (args);
cbp = lookup_intrinsic (CB_NAME (name), 0);
if (cbp) {
if ((cbp->args != -1 && numargs != cbp->args) ||
(cbp->args == -1 && cbp->intr_enum != CB_INTR_RANDOM && numargs < 1)) {
cb_error_x (name, _("FUNCTION %s has wrong number of arguments"), cbp->name);
return cb_error_node;
}
if (refmod) {
if (!cbp->refmod) {
cb_error_x (name, _("FUNCTION %s can not have reference modification"), cbp->name);
return cb_error_node;
}
if (CB_LITERAL_P(CB_PAIR_X(refmod)) &&
cb_get_int (CB_PAIR_X(refmod))< 1) {
cb_error_x (name, _("FUNCTION %s has invalid reference modification"), cbp->name);
return cb_error_node;
}
if (CB_PAIR_Y(refmod) && CB_LITERAL_P(CB_PAIR_Y(refmod)) &&
cb_get_int (CB_PAIR_Y(refmod))< 1) {
cb_error_x (name, _("FUNCTION %s has invalid reference modification"), cbp->name);
return cb_error_node;
}
}
/* cb_tree x; */
switch (cbp->intr_enum) {
case CB_INTR_LENGTH:
case CB_INTR_BYTE_LENGTH:
x = CB_VALUE (args);
if (CB_INTRINSIC_P (x)) {
return make_intrinsic (name, cbp, args, NULL, NULL);
} else if ((CB_FIELD_P (x) || CB_REFERENCE_P (x)) &&
cb_field(x)->flag_any_length) {
return make_intrinsic (name, cbp, args, NULL, NULL);
} else {
return cb_build_length (CB_VALUE (args));
}
case CB_INTR_WHEN_COMPILED:
if (refmod) {
return make_intrinsic (name, cbp,
cb_list_init (cb_intr_whencomp), NULL, refmod);
} else {
return cb_intr_whencomp;
}
case CB_INTR_PI:
return cb_intr_pi;
case CB_INTR_E:
return cb_intr_e;
case CB_INTR_LOWER_CASE:
case CB_INTR_UPPER_CASE:
case CB_INTR_REVERSE:
/* RXW Why did I do this ? - still do not know
if (CB_INTRINSIC_P (CB_VALUE (args))) {
return make_intrinsic (name, cbp, args, cb_int0);
} else {
return make_intrinsic (name, cbp, args,
cb_build_length (CB_VALUE (args)));
}
RXW */
case CB_INTR_ABS:
case CB_INTR_ACOS:
case CB_INTR_ANNUITY:
case CB_INTR_ASIN:
case CB_INTR_ATAN:
case CB_INTR_CHAR:
case CB_INTR_COMBINED_DATETIME:
case CB_INTR_COS:
case CB_INTR_CURRENT_DATE:
case CB_INTR_DATE_OF_INTEGER:
case CB_INTR_DAY_OF_INTEGER:
case CB_INTR_EXCEPTION_FILE:
case CB_INTR_EXCEPTION_LOCATION:
case CB_INTR_EXCEPTION_STATUS:
case CB_INTR_EXCEPTION_STATEMENT:
case CB_INTR_EXP:
case CB_INTR_EXP10:
case CB_INTR_FACTORIAL:
case CB_INTR_FRACTION_PART:
case CB_INTR_INTEGER:
case CB_INTR_INTEGER_OF_DATE:
case CB_INTR_INTEGER_OF_DAY:
case CB_INTR_INTEGER_PART:
case CB_INTR_LOCALE_DATE:
case CB_INTR_LOCALE_TIME:
case CB_INTR_LOCALE_TIME_FROM_SECS:
case CB_INTR_LOG:
case CB_INTR_LOG10:
case CB_INTR_MOD:
case CB_INTR_NUMVAL:
case CB_INTR_NUMVAL_C:
case CB_INTR_ORD:
case CB_INTR_REM:
case CB_INTR_SECONDS_FROM_FORMATTED_TIME:
case CB_INTR_SECONDS_PAST_MIDNIGHT:
case CB_INTR_SIGN:
case CB_INTR_SIN:
case CB_INTR_SQRT:
case CB_INTR_STORED_CHAR_LENGTH:
case CB_INTR_TAN:
case CB_INTR_TEST_DATE_YYYYMMDD:
case CB_INTR_TEST_DAY_YYYYDDD:
case CB_INTR_TRIM:
return make_intrinsic (name, cbp, args, NULL, refmod);
case CB_INTR_CONCATENATE:
return make_intrinsic (name, cbp, args, cb_int1, refmod);
case CB_INTR_DATE_TO_YYYYMMDD:
case CB_INTR_DAY_TO_YYYYDDD:
case CB_INTR_MAX:
case CB_INTR_MEAN:
case CB_INTR_MEDIAN:
case CB_INTR_MIDRANGE:
case CB_INTR_MIN:
case CB_INTR_ORD_MAX:
case CB_INTR_ORD_MIN:
case CB_INTR_PRESENT_VALUE:
case CB_INTR_RANDOM:
case CB_INTR_RANGE:
case CB_INTR_STANDARD_DEVIATION:
case CB_INTR_SUM:
case CB_INTR_VARIANCE:
case CB_INTR_YEAR_TO_YYYY:
return make_intrinsic (name, cbp, args, cb_int1, NULL);
case CB_INTR_SUBSTITUTE:
case CB_INTR_SUBSTITUTE_CASE:
if (numargs < 3 || (numargs % 2) == 0) {
cb_error_x (name, _("FUNCTION %s has wrong number of arguments"), cbp->name);
return cb_error_node;
}
return make_intrinsic (name, cbp, args, cb_int1, refmod);
default:
break;
}
}
cb_error_x (name, _("FUNCTION %s not implemented"), CB_NAME (name));
return cb_error_node;
}
Definition at line 2081 of file tree.c.
{
struct cb_label *p;
p = make_tree (CB_TAG_LABEL, CB_CATEGORY_UNKNOWN, sizeof (struct cb_label));
p->id = cb_id++;
p->name = (const unsigned char *)cb_define (name, CB_TREE (p));
p->orig_name = p->name;
p->section = section;
return CB_TREE (p);
}
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 957 of file tree.c.
{
struct cb_class_name *p;
p = make_tree (CB_TAG_LOCALE_NAME, CB_CATEGORY_UNKNOWN, sizeof (struct cb_locale_name));
p->name = cb_define (name, CB_TREE (p));
p->cname = to_cname (p->name);
p->list = list;
return CB_TREE (p);
}
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);
}
| cb_tree cb_build_numeric_literal | ( | int | sign, |
| const unsigned char * | data, | ||
| int | scale | ||
| ) |
Definition at line 988 of file tree.c.
{
struct cb_literal *p;
p = build_literal (CB_CATEGORY_NUMERIC, data, strlen ((char *)data));
p->sign = (char)sign;
p->scale = (char)scale;
return CB_TREE (p);
}
| cb_tree cb_build_perform | ( | int | type | ) |
Definition at line 2199 of file tree.c.
{
struct cb_perform *p;
p = make_tree (CB_TAG_PERFORM, CB_CATEGORY_UNKNOWN, sizeof (struct cb_perform));
p->type = type;
return CB_TREE (p);
}
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 2209 of file tree.c.
{
struct cb_perform_varying *p;
p = make_tree (CB_TAG_PERFORM_VARYING, CB_CATEGORY_UNKNOWN, sizeof (struct cb_perform_varying));
p->name = name;
p->from = from;
p->step = name ? cb_build_add (name, by, cb_high) : NULL;
p->until = until;
return CB_TREE (p);
}
| cb_tree cb_build_picture | ( | const char * | str | ) |
Definition at line 1090 of file tree.c.
{
struct cb_picture *pic;
const char *p;
size_t idx = 0;
size_t buffcnt = 0;
size_t at_beginning;
size_t at_end;
size_t p_char_seen;
size_t s_char_seen;
int category = 0;
int size = 0;
int allocated = 0;
int digits = 0;
int scale = 0;
int s_count = 0;
int v_count = 0;
int i;
int n;
unsigned char c;
unsigned char lastonechar = 0;
unsigned char lasttwochar = 0;
unsigned char buff[COB_SMALL_BUFF];
pic = make_tree (CB_TAG_PICTURE, CB_CATEGORY_UNKNOWN, sizeof (struct cb_picture));
if (strlen (str) > 50) {
goto error;
}
memset (buff, 0, sizeof (buff));
p_char_seen = 0;
s_char_seen = 0;
for (p = str; *p; p++) {
n = 1;
c = *p;
repeat:
/* count the number of repeated chars */
while (p[1] == c) {
p++, n++;
}
/* add parenthesized numbers */
if (p[1] == '(') {
i = 0;
p += 2;
for (; *p == '0'; p++) {
;
}
for (; *p != ')'; p++) {
if (!isdigit (*p)) {
goto error;
} else {
allocated++;
if (allocated > 9) {
goto error;
}
i = i * 10 + (*p - '0');
}
}
if (i == 0) {
goto error;
}
n += i - 1;
goto repeat;
}
/* check grammar and category */
/* FIXME: need more error check */
switch (c) {
case 'A':
if (s_char_seen || p_char_seen) {
goto error;
}
category |= PIC_ALPHABETIC;
break;
case 'X':
if (s_char_seen || p_char_seen) {
goto error;
}
category |= PIC_ALPHANUMERIC;
break;
case '9':
category |= PIC_NUMERIC;
digits += n;
if (v_count) {
scale += n;
}
break;
case 'N':
if (s_char_seen || p_char_seen) {
goto error;
}
category |= PIC_NATIONAL;
break;
case 'S':
category |= PIC_NUMERIC;
if (category & PIC_ALPHABETIC) {
goto error;
}
s_count += n;
if (s_count > 1 || idx != 0) {
goto error;
}
s_char_seen = 1;
continue;
case ',':
case '.':
category |= PIC_NUMERIC_EDITED;
if (s_char_seen || p_char_seen) {
goto error;
}
if (c != current_program->decimal_point) {
break;
}
/* fall through */
case 'V':
category |= PIC_NUMERIC;
if (category & PIC_ALPHABETIC) {
goto error;
}
v_count += n;
if (v_count > 1) {
goto error;
}
break;
case 'P':
category |= PIC_NUMERIC;
if (category & PIC_ALPHABETIC) {
goto error;
}
if (p_char_seen) {
goto error;
}
at_beginning = 0;
at_end = 0;
switch (buffcnt) {
case 0:
/* P..... */
at_beginning = 1;
break;
case 1:
/* VP.... */
/* SP.... */
if (lastonechar == 'V' || lastonechar == 'S') {
at_beginning = 1;
}
break;
case 2:
/* SVP... */
if (lasttwochar == 'S' && lastonechar == 'V') {
at_beginning = 1;
}
break;
}
if (p[1] == 0 || (p[1] == 'V' && p[2] == 0)) {
/* .....P */
/* ....PV */
at_end = 1;
}
if (!at_beginning && !at_end) {
goto error;
}
p_char_seen = 1;
if (at_beginning) {
v_count++; /* implicit V */
}
digits += n;
if (v_count) {
scale += n;
} else {
scale -= n;
}
break;
case '0':
case 'B':
case '/':
category |= PIC_EDITED;
if (s_char_seen || p_char_seen) {
goto error;
}
break;
case '*':
case 'Z':
category |= PIC_NUMERIC_EDITED;
if (category & PIC_ALPHABETIC) {
goto error;
}
if (s_char_seen || p_char_seen) {
goto error;
}
digits += n;
if (v_count) {
scale += n;
}
break;
case '+':
case '-':
category |= PIC_NUMERIC_EDITED;
if (category & PIC_ALPHABETIC) {
goto error;
}
if (s_char_seen || p_char_seen) {
goto error;
}
digits += n - 1;
s_count++;
/* FIXME: need more check */
break;
case 'C':
category |= PIC_NUMERIC_EDITED;
if (!(p[1] == 'R' && p[2] == 0)) {
goto error;
}
if (s_char_seen || p_char_seen) {
goto error;
}
p++;
s_count++;
break;
case 'D':
category |= PIC_NUMERIC_EDITED;
if (!(p[1] == 'B' && p[2] == 0)) {
goto error;
}
if (s_char_seen || p_char_seen) {
goto error;
}
p++;
s_count++;
break;
default:
if (c == current_program->currency_symbol) {
category |= PIC_NUMERIC_EDITED;
digits += n - 1;
/* FIXME: need more check */
break;
}
goto error;
}
/* calculate size */
if (c != 'V' && c != 'P') {
size += n;
}
if (c == 'C' || c == 'D' || c == 'N') {
size += n;
}
/* store in the buffer */
buff[idx++] = c;
lasttwochar = lastonechar;
lastonechar = c;
memcpy (&buff[idx], (unsigned char *)&n, sizeof(int));
idx += sizeof(int);
++buffcnt;
}
buff[idx] = 0;
if (size == 0 && v_count) {
goto error;
}
/* set picture */
pic->orig = strdup (str);
pic->size = size;
pic->digits = (unsigned char)digits;
pic->scale = (signed char)scale;
pic->have_sign = (unsigned char)s_count;
/* set picture category */
switch (category) {
case PIC_ALPHABETIC:
pic->category = CB_CATEGORY_ALPHABETIC;
break;
case PIC_NUMERIC:
pic->category = CB_CATEGORY_NUMERIC;
if (digits > 36) {
cb_error (_("Numeric field cannot be larger than 36 digits"));
}
break;
case PIC_ALPHANUMERIC:
case PIC_NATIONAL:
pic->category = CB_CATEGORY_ALPHANUMERIC;
break;
case PIC_NUMERIC_EDITED:
pic->str = cobc_malloc (idx + 1);
memcpy (pic->str, buff, idx);
pic->category = CB_CATEGORY_NUMERIC_EDITED;
pic->lenstr = idx;
break;
case PIC_EDITED:
case PIC_ALPHABETIC_EDITED:
case PIC_ALPHANUMERIC_EDITED:
case PIC_NATIONAL_EDITED:
pic->str = cobc_malloc (idx + 1);
memcpy (pic->str, buff, idx);
pic->category = CB_CATEGORY_ALPHANUMERIC_EDITED;
pic->lenstr = idx;
break;
default:
goto error;
}
goto end;
error:
cb_error (_("Invalid picture string - '%s'"), str);
end:
return CB_TREE (pic);
}
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);
}
| struct cb_program* cb_build_program | ( | struct cb_program * | last_program, |
| int | nest_level | ||
| ) | [read] |
Definition at line 841 of file tree.c.
{
struct cb_program *p;
cb_reset_78 ();
cb_reset_in_procedure ();
cb_clear_real_field ();
p = cobc_malloc (sizeof (struct cb_program));
p->next_program = last_program;
p->nested_level = nest_level;
p->decimal_point = '.';
p->currency_symbol = '$';
p->numeric_separator = ',';
if (nest_level) {
p->global_file_list = last_program->global_file_list;
p->collating_sequence = last_program->collating_sequence;
p->function_spec_list = last_program->function_spec_list;
p->class_spec_list = last_program->class_spec_list;
p->interface_spec_list = last_program->interface_spec_list;
p->program_spec_list = last_program->program_spec_list;
p->property_spec_list = last_program->property_spec_list;
p->alphabet_name_list = last_program->alphabet_name_list;
p->class_name_list = last_program->class_name_list;
p->locale_list = last_program->locale_list;
p->symbolic_list = last_program->symbolic_list;
p->decimal_point = last_program->decimal_point;
p->numeric_separator = last_program->numeric_separator;
p->currency_symbol = last_program->currency_symbol;
p->cb_return_code = last_program->cb_return_code;
} else {
functions_are_all = cb_flag_functions_all;
}
return p;
}
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;
}
| cb_tree cb_build_reference | ( | const char * | name | ) |
Definition at line 1730 of file tree.c.
{
struct cb_reference *p;
p = make_tree (CB_TAG_REFERENCE, CB_CATEGORY_UNKNOWN, sizeof (struct cb_reference));
p->word = lookup_word (name);
return CB_TREE (p);
}
| 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));
}
| cb_tree cb_build_search | ( | int | flag_all, |
| cb_tree | table, | ||
| cb_tree | var, | ||
| cb_tree | end_stmt, | ||
| cb_tree | whens | ||
| ) |
Definition at line 2131 of file tree.c.
{
struct cb_search *p;
p = make_tree (CB_TAG_SEARCH, CB_CATEGORY_UNKNOWN, sizeof (struct cb_search));
p->flag_all = flag_all;
p->table = table;
p->var = var;
p->end_stmt = end_stmt;
p->whens = whens;
return CB_TREE (p);
}
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;
}
| struct cb_statement* cb_build_statement | ( | const char * | name | ) | [read] |
Definition at line 2226 of file tree.c.
{
struct cb_statement *p;
p = make_tree (CB_TAG_STATEMENT, CB_CATEGORY_UNKNOWN, sizeof (struct cb_statement));
p->name = name;
return p;
}
| cb_tree cb_build_string | ( | const unsigned char * | data, |
| size_t | size | ||
| ) |
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_system_name | ( | enum cb_system_name_category | category, |
| int | token | ||
| ) |
Definition at line 973 of file tree.c.
{
struct cb_system_name *p;
p = make_tree (CB_TAG_SYSTEM_NAME, CB_CATEGORY_UNKNOWN, sizeof (struct cb_system_name));
p->category = category;
p->token = token;
return CB_TREE (p);
}
| cb_tree cb_build_tarrying_all | ( | void | ) |
Definition at line 3778 of file typeck.c.
{
if (inspect_data == NULL) {
cb_error (_("Data name expected before ALL"));
}
inspect_func = "cob_inspect_all";
return NULL;
}
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));
}
Definition at line 3761 of file typeck.c.
{
inspect_data = x;
return NULL;
}
| cb_tree cb_build_tarrying_leading | ( | void | ) |
Definition at line 3788 of file typeck.c.
{
if (inspect_data == NULL) {
cb_error (_("Data name expected before LEADING"));
}
inspect_func = "cob_inspect_leading";
return NULL;
}
| cb_tree cb_build_tarrying_trailing | ( | void | ) |
Definition at line 3798 of file typeck.c.
{
if (inspect_data == NULL) {
cb_error (_("Data name expected before TRAILING"));
}
inspect_func = "cob_inspect_trailing";
return NULL;
}
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;
}
| void cb_clear_real_field | ( | void | ) |
Definition at line 1050 of file field.c.
{
last_real_field = NULL;
}
Definition at line 1005 of file tree.c.
{
unsigned char *buff;
cb_tree x;
unsigned char *data1;
unsigned char *data2;
size_t size1;
size_t size2;
if (x1 == cb_error_node || x2 == cb_error_node) {
return cb_error_node;
}
if (CB_LITERAL_P (x1)) {
data1 = CB_LITERAL (x1)->data;
size1 = CB_LITERAL (x1)->size;
} else if (CB_CONST_P (x1)) {
size1 = 1;
if (x1 == cb_space) {
data1 = (unsigned char *)" ";
} else if (x1 == cb_zero) {
data1 = (unsigned char *)"0";
} else if (x1 == cb_quote) {
data1 = (unsigned char *)"\"";
} else if (x1 == cb_norm_low) {
data1 = (unsigned char *)"\0";
} else if (x1 == cb_norm_high) {
data1 = (unsigned char *)"\255";
} else if (x1 == cb_null) {
data1 = (unsigned char *)"\0";
} else {
return cb_error_node;
}
} else {
return cb_error_node;
}
if (CB_LITERAL_P (x2)) {
data2 = CB_LITERAL (x2)->data;
size2 = CB_LITERAL (x2)->size;
} else if (CB_CONST_P (x2)) {
size2 = 1;
if (x2 == cb_space) {
data2 = (unsigned char *)" ";
} else if (x2 == cb_zero) {
data2 = (unsigned char *)"0";
} else if (x2 == cb_quote) {
data2 = (unsigned char *)"\"";
} else if (x2 == cb_norm_low) {
data2 = (unsigned char *)"\0";
} else if (x2 == cb_norm_high) {
data2 = (unsigned char *)"\255";
} else if (x2 == cb_null) {
data2 = (unsigned char *)"\0";
} else {
return cb_error_node;
}
} else {
return cb_error_node;
}
buff = cobc_malloc (size1 + size2 + 3);
memcpy (buff, data1, size1);
memcpy (buff + size1, data2, size2);
x = cb_build_alphanumeric_literal (buff, size1 + size2);
free (buff);
return x;
}
Definition at line 1769 of file tree.c.
{
struct cb_word *w;
w = CB_REFERENCE (name)->word;
w->items = cb_list_add (w->items, val);
w->count++;
val->source_file = name->source_file;
val->source_line = name->source_line;
CB_REFERENCE (name)->value = val;
return w->name;
}
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_define_system_name | ( | const char * | name | ) |
Definition at line 1783 of file tree.c.
{
cb_tree x;
x = cb_build_reference (name);
if (CB_REFERENCE (x)->word->count == 0) {
cb_define (x, lookup_system_name (name));
}
}
| 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_corresponding | ( | cb_tree(*)(cb_tree f1, cb_tree f2, cb_tree f3) | func, |
| cb_tree | x1, | ||
| cb_tree | x2, | ||
| cb_tree | opt | ||
| ) |
Definition at line 2695 of file typeck.c.
{
x1 = cb_check_group_name (x1);
x2 = cb_check_group_name (x2);
if (cb_validate_one (x1)) {
return;
}
if (cb_validate_one (x2)) {
return;
}
emit_corresponding (func, x1, x2, opt);
}
| 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));
}
Definition at line 3601 of file typeck.c.
{
cb_emit (build_evaluate (subject_list, case_list));
}
| 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 5041 of file typeck.c.
{
cb_tree l;
if (cb_validate_one (src)) {
return;
}
if (cb_validate_list (dsts)) {
return;
}
for (l = dsts; l; l = CB_CHAIN (l)) {
cb_emit (cb_build_move (src, CB_VALUE (l)));
}
}
Definition at line 2738 of file typeck.c.
{
cb_tree l;
cb_tree v;
x1 = cb_check_group_name (x1);
if (cb_validate_one (x1)) {
return;
}
for (l = x2; l; l = CB_CHAIN(l)) {
v = CB_VALUE(l);
v = cb_check_group_name (v);
if (cb_validate_one (v)) {
return;
}
emit_move_corresponding (x1, v);
}
}
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_error_x | ( | cb_tree | x, |
| const char * | fmt, | ||
| ... | |||
| ) |
Definition at line 110 of file error.c.
{
va_list ap;
va_start (ap, fmt);
print_error ((char *)(x->source_file), x->source_line, "Error: ", fmt, ap);
va_end (ap);
errorcount++;
}
| int cb_field_size | ( | cb_tree | x | ) |
Definition at line 1483 of file tree.c.
{
struct cb_reference *r;
struct cb_field *f;
switch (CB_TREE_TAG (x)) {
case CB_TAG_LITERAL:
return CB_LITERAL (x)->size;
case CB_TAG_FIELD:
return CB_FIELD (x)->size;
case CB_TAG_REFERENCE:
r = CB_REFERENCE (x);
f = CB_FIELD (r->value);
if (r->length) {
if (CB_LITERAL_P (r->length)) {
return cb_get_int (r->length);
} else {
return -1;
}
} else if (r->offset) {
if (CB_LITERAL_P (r->offset)) {
return f->size - cb_get_int (r->offset) + 1;
} else {
return -1;
}
} else {
return f->size;
}
default:
fprintf (stderr, "Unexpected tree tag %d\n", CB_TREE_TAG (x));
ABORT ();
}
/* NOT REACHED */
return 0;
}
Definition at line 1545 of file tree.c.
{
struct cb_field *p;
for (p = f->parent; p; f = f->parent, p = f->parent) {
for (p = p->children; p != f; p = p->sister) {
if (p->occurs_depending || cb_field_variable_size (p)) {
return p;
}
}
}
return NULL;
}
Definition at line 1530 of file tree.c.
{
struct cb_field *p;
for (f = f->children; f; f = f->sister) {
if (f->occurs_depending) {
return f;
} else if ((p = cb_field_variable_size (f)) != NULL) {
return p;
}
}
return NULL;
}
| int cb_fits_int | ( | cb_tree | x | ) |
Definition at line 587 of file tree.c.
{
struct cb_literal *l;
struct cb_field *f;
switch (CB_TREE_TAG (x)) {
case CB_TAG_LITERAL:
l = CB_LITERAL (x);
if (l->scale <= 0 && l->size < 10) {
return 1;
}
return 0;
case CB_TAG_FIELD:
f = CB_FIELD (x);
switch (f->usage) {
case CB_USAGE_INDEX:
case CB_USAGE_LENGTH:
return 1;
case CB_USAGE_BINARY:
case CB_USAGE_COMP_5:
case CB_USAGE_COMP_X:
if (f->pic->scale <= 0 && f->size <= (int)sizeof (int)) {
return 1;
}
return 0;
case CB_USAGE_DISPLAY:
if (f->size < 10) {
if (!f->pic || f->pic->scale <= 0) {
return 1;
}
}
return 0;
case CB_USAGE_PACKED:
if (f->pic->scale <= 0 && f->pic->digits < 10) {
return 1;
}
return 0;
default:
return 0;
}
case CB_TAG_REFERENCE:
return cb_fits_int (CB_REFERENCE (x)->value);
default:
return 0;
}
}
| int cb_fits_long_long | ( | cb_tree | x | ) |
Definition at line 635 of file tree.c.
{
struct cb_literal *l;
struct cb_field *f;
switch (CB_TREE_TAG (x)) {
case CB_TAG_LITERAL:
l = CB_LITERAL (x);
if (l->scale <= 0 && l->size < 19) {
return 1;
}
return 0;
case CB_TAG_FIELD:
f = CB_FIELD (x);
switch (f->usage) {
case CB_USAGE_INDEX:
case CB_USAGE_LENGTH:
return 1;
case CB_USAGE_BINARY:
case CB_USAGE_COMP_5:
case CB_USAGE_COMP_X:
if (f->pic->scale <= 0 && f->size <= (int)sizeof (long long)) {
return 1;
}
return 0;
case CB_USAGE_DISPLAY:
if (f->pic->scale <= 0 && f->size < 19) {
return 1;
}
return 0;
default:
return 0;
}
case CB_TAG_REFERENCE:
return cb_fits_long_long (CB_REFERENCE (x)->value);
default:
return 0;
}
}
| int cb_get_int | ( | cb_tree | x | ) |
Definition at line 676 of file tree.c.
{
struct cb_literal *l;
size_t i;
int val = 0;
l = CB_LITERAL (x);
for (i = 0; i < l->size; i++) {
if (l->data[i] != '0') {
break;
}
}
/* RXWRXW
if (l->size - i >= 10) {
ABORT ();
}
*/
for (; i < l->size; i++) {
val = val * 10 + l->data[i] - '0';
}
if (l->sign < 0) {
val = -val;
}
return val;
}
| int cb_get_level | ( | cb_tree | x | ) |
Definition at line 41 of file field.c.
{
const char *p;
const char *name;
int level = 0;
name = CB_NAME (x);
/* get level */
for (p = name; *p; p++) {
if (!isdigit (*p)) {
goto level_error;
}
level = level * 10 + (*p - '0');
}
/* check level */
switch (level) {
case 66:
case 77:
case 78:
case 88:
break;
default:
if (level < 1 || level > 49) {
goto level_error;
}
break;
}
return level;
level_error:
cb_error_x (x, _("Invalid level number '%s'"), name);
return 0;
}
| long long cb_get_long_long | ( | cb_tree | x | ) |
Definition at line 705 of file tree.c.
{
struct cb_literal *l;
size_t i;
long long val = 0;
l = CB_LITERAL (x);
for (i = 0; i < l->size; i++) {
if (l->data[i] != '0') {
break;
}
}
if (l->size - i >= 19) {
ABORT ();
}
for (; i < l->size; i++) {
val = val * 10 + l->data[i] - '0';
}
if (l->sign < 0) {
val = -val;
}
return val;
}
| void cb_init_constants | ( | void | ) |
Definition at line 732 of file tree.c.
{
char *s;
int i;
cb_error_node = make_constant (CB_CATEGORY_UNKNOWN, NULL);
cb_any = make_constant (CB_CATEGORY_UNKNOWN, NULL);
cb_true = make_constant (CB_CATEGORY_BOOLEAN, "1");
cb_false = make_constant (CB_CATEGORY_BOOLEAN, "0");
cb_null = make_constant (CB_CATEGORY_DATA_POINTER, "0");
cb_zero = make_constant (CB_CATEGORY_NUMERIC, "&cob_zero");
cb_one = make_constant (CB_CATEGORY_NUMERIC, "&cob_one");
cb_space = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_space");
cb_low = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_low");
cb_norm_low = cb_low;
cb_high = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_high");
cb_norm_high = cb_high;
cb_quote = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_quote");
cb_int0 = cb_int (0);
cb_int1 = cb_int (1);
cb_int2 = cb_int (2);
cb_int3 = cb_int (3);
cb_int4 = cb_int (4);
cb_int5 = cb_int (5);
for (i = 1; i < 8; i++) {
s = cobc_malloc (4);
sprintf (s, "i%d", i);
cb_i[i] = make_constant (CB_CATEGORY_NUMERIC, s);
}
cb_standard_error_handler = make_constant_label ("Default Error Handler");
}
| void cb_init_reserved | ( | void | ) |
Definition at line 1019 of file reserved.c.
{
int i;
/* build system-name table */
for (i = 0; system_table[i].name != NULL; ++i) {
system_table[i].node =
cb_build_system_name (system_table[i].category, system_table[i].token);
}
}
| void cb_init_tarrying | ( | void | ) |
Definition at line 3754 of file typeck.c.
{
inspect_func = NULL;
inspect_data = NULL;
}
| cb_tree cb_int | ( | int | n | ) |
Definition at line 881 of file tree.c.
{
struct cb_integer *x;
struct int_node *p;
for (p = int_node_table; p; p = p->next) {
if (p->n == n) {
return p->node;
}
}
x = make_tree (CB_TAG_INTEGER, CB_CATEGORY_NUMERIC, sizeof (struct cb_integer));
x->val = n;
p = cobc_malloc (sizeof (struct int_node));
p->n = n;
p->node = CB_TREE (x);
p->next = int_node_table;
int_node_table = p;
return p->node;
}
Definition at line 798 of file tree.c.
{
return cb_list_append (l, cb_list_init (x));
}
| void cb_list_intrinsics | ( | void | ) |
Definition at line 979 of file reserved.c.
{
const char *s;
size_t i;
size_t n;
printf ("Intrinsic Function (Implemented Y/N)\n\n");
for (i = 0; i < NUM_INTRINSICS; ++i) {
n = strlen (function_list[i].name);
switch (n / 8) {
case 0:
s = "\t\t\t\t";
break;
case 1:
s = "\t\t\t";
break;
case 2:
s = "\t\t";
break;
default:
s = "\t";
break;
}
printf ("%s%s(%s)\n", function_list[i].name, s,
function_list[i].implemented ? "Y" : "N");
}
}
| int cb_list_length | ( | cb_tree | l | ) |
| void cb_list_mnemonics | ( | void | ) |
Definition at line 1008 of file reserved.c.
{
size_t i;
printf ("Mnemonic names\n\n");
for (i = 0; system_table[i].name != NULL; ++i) {
printf ("%s\n", system_table[i].name);
}
}
| void cb_list_reserved | ( | void | ) |
Definition at line 950 of file reserved.c.
{
const char *s;
size_t i;
size_t n;
printf ("Reserved Words (Parsed Y/N)\n\n");
for (i = 0; i < NUM_RESERVED_WORDS; ++i) {
n = strlen (reserved_words[i].name);
switch (n / 8) {
case 0:
s = "\t\t\t\t";
break;
case 1:
s = "\t\t\t";
break;
case 2:
s = "\t\t";
break;
default:
s = "\t";
break;
}
printf ("%s%s(%s)\n", reserved_words[i].name, s,
reserved_words[i].token != -1 ? "Y" : "N");
}
}
| char* cb_name | ( | cb_tree | x | ) |
Definition at line 441 of file tree.c.
{
if (!treenamebuff) {
treenamebuff = cobc_malloc (COB_NORMAL_BUFF);
}
cb_name_1 (treenamebuff, x);
return treenamebuff;
}
Definition at line 1794 of file tree.c.
{
struct cb_reference *r;
struct cb_field *p;
struct cb_label *s;
cb_tree candidate = NULL;
cb_tree items;
cb_tree cb1;
cb_tree cb2;
cb_tree v;
cb_tree c;
struct cb_program *prog;
struct cb_word *w;
size_t val;
size_t ambiguous = 0;
r = CB_REFERENCE (x);
/* if this reference has already been resolved (and the value
has been cached), then just return the value */
if (r->value) {
return r->value;
}
/* resolve the value */
items = r->word->items;
for (; items; items = CB_CHAIN (items)) {
/* find a candidate value by resolving qualification */
v = CB_VALUE (items);
c = r->chain;
switch (CB_TREE_TAG (v)) {
case CB_TAG_FIELD:
/* in case the value is a field, it might be qualified
by its parent names and a file name */
if (CB_FIELD (v)->flag_indexed_by) {
p = CB_FIELD (v)->index_qual;
} else {
p = CB_FIELD (v)->parent;
}
/* resolve by parents */
for (; p; p = p->parent) {
if (c && strcasecmp (CB_NAME (c), p->name) == 0) {
c = CB_REFERENCE (c)->chain;
}
}
/* resolve by file */
if (c && CB_REFERENCE (c)->chain == NULL) {
if (CB_REFERENCE (c)->word->count == 1 && CB_FILE_P (cb_ref (c))
&& (CB_FILE (cb_ref (c)) == cb_field_founder (CB_FIELD (v))->file)) {
c = CB_REFERENCE (c)->chain;
}
}
break;
case CB_TAG_LABEL:
/* in case the value is a label, it might be qualified
by its section name */
s = CB_LABEL (v)->section;
/* unqualified paragraph name referenced within the section
is resolved without ambiguity check if not duplicated */
if (c == NULL && r->offset && s == CB_LABEL (r->offset)) {
for (cb1 = CB_CHAIN (items); cb1; cb1 = CB_CHAIN (cb1)) {
cb2 = CB_VALUE (cb1);
if (s == CB_LABEL (cb2)->section) {
ambiguous_error (x);
goto error;
}
}
candidate = v;
goto end;
}
/* resolve by section name */
if (c && s && strcasecmp (CB_NAME (c), (char *)s->name) == 0) {
c = CB_REFERENCE (c)->chain;
}
break;
default:
/* other values cannot be qualified */
break;
}
/* a well qualified value is a good candidate */
if (c == NULL) {
if (candidate == NULL) {
/* keep the first candidate */
candidate = v;
} else {
/* multiple candidates and possibly ambiguous */
ambiguous = 1;
/* continue search because the reference might not
be ambiguous and exit loop by "goto end" later */
}
}
}
/* there is no candidate */
if (candidate == NULL) {
if (current_program->nested_level > 0) {
/* Nested program - check parents for GLOBAL candidate */
ambiguous = 0;
val = hash ((const unsigned char *)r->word->name);
prog = current_program->next_program;
for (; prog; prog = prog->next_program) {
if (prog->nested_level >= current_program->nested_level) {
continue;
}
for (w = prog->word_table[val]; w; w = w->next) {
if (strcasecmp (r->word->name, w->name) == 0) {
candidate = global_check (r, w->items, &ambiguous);
if (candidate) {
if (ambiguous) {
ambiguous_error (x);
goto error;
}
if (CB_FILE_P(candidate)) {
current_program->gen_file_error = 1;
}
goto end;
}
}
}
if (prog->nested_level == 0) {
break;
}
}
}
undefined_error (x);
goto error;
}
/* the reference is ambiguous */
if (ambiguous) {
ambiguous_error (x);
goto error;
}
end:
if (CB_FIELD_P (candidate)) {
CB_FIELD (candidate)->count++;
if (CB_FIELD (candidate)->flag_invalid) {
goto error;
}
}
r->value = candidate;
return r->value;
error:
r->value = cb_error_node;
return cb_error_node;
}
| void cb_reset_78 | ( | void | ) |
| void cb_reset_in_procedure | ( | void | ) |
Definition at line 231 of file field.c.
{
struct cb_field *f;
struct cb_reference *r;
const char *name;
cb_tree x;
r = CB_REFERENCE (redefines);
name = CB_NAME (redefines);
x = CB_TREE (field);
/* check qualification */
if (r->chain) {
cb_error_x (x, _("'%s' cannot be qualified here"), name);
return NULL;
}
/* check subscripts */
if (r->subs) {
cb_error_x (x, _("'%s' cannot be subscripted here"), name);
return NULL;
}
/* resolve the name in the current group (if any) */
if (field->parent && field->parent->children) {
for (f = field->parent->children; f; f = f->sister) {
if (strcasecmp (f->name, name) == 0) {
break;
}
}
if (f == NULL) {
cb_error_x (x, _("'%s' undefined in '%s'"), name, field->parent->name);
return NULL;
}
} else {
if (cb_ref (redefines) == cb_error_node) {
return NULL;
}
f = cb_field (redefines);
}
/* check level number */
if (f->level != field->level) {
cb_error_x (x, _("Level number of REDEFINES entries must be identical"));
return NULL;
}
if (f->level == 66 || f->level == 88) {
cb_error_x (x, _("Level number of REDEFINES entry cannot be 66 or 88"));
return NULL;
}
if (!cb_indirect_redefines && f->redefines) {
cb_error_x (x, _("'%s' not the original definition"), f->name);
return NULL;
}
/* return the original definition */
while (f->redefines) {
f = f->redefines;
}
return f;
}
| void cb_set_in_procedure | ( | void | ) |
| enum cb_category cb_tree_category | ( | cb_tree | x | ) |
Definition at line 458 of file tree.c.
{
struct cb_cast *p;
struct cb_reference *r;
struct cb_field *f;
if (x == cb_error_node) {
return 0;
}
if (x->category != CB_CATEGORY_UNKNOWN) {
return x->category;
}
switch (CB_TREE_TAG (x)) {
case CB_TAG_CAST:
p = CB_CAST (x);
switch (p->type) {
case CB_CAST_ADDRESS:
case CB_CAST_ADDR_OF_ADDR:
x->category = CB_CATEGORY_DATA_POINTER;
break;
case CB_CAST_PROGRAM_POINTER:
x->category = CB_CATEGORY_PROGRAM_POINTER;
break;
default:
fprintf (stderr, "Unexpected cast type -> %d\n", p->type);
ABORT ();
}
break;
case CB_TAG_REFERENCE:
r = CB_REFERENCE (x);
if (r->offset) {
x->category = CB_CATEGORY_ALPHANUMERIC;
} else {
x->category = cb_tree_category (r->value);
}
break;
case CB_TAG_FIELD:
f = CB_FIELD (x);
if (f->children) {
x->category = CB_CATEGORY_ALPHANUMERIC;
} else if (f->usage == CB_USAGE_POINTER && f->level != 88) {
x->category = CB_CATEGORY_DATA_POINTER;
} else if (f->usage == CB_USAGE_PROGRAM_POINTER && f->level != 88) {
x->category = CB_CATEGORY_PROGRAM_POINTER;
} else {
switch (f->level) {
case 66:
if (f->rename_thru) {
x->category = CB_CATEGORY_ALPHANUMERIC;
} else {
x->category = cb_tree_category (CB_TREE (f->redefines));
}
break;
case 88:
x->category = CB_CATEGORY_BOOLEAN;
break;
default:
x->category = f->pic->category;
break;
}
}
break;
case CB_TAG_ALPHABET_NAME:
case CB_TAG_LOCALE_NAME:
x->category = CB_CATEGORY_ALPHANUMERIC;
break;
case CB_TAG_BINARY_OP:
x->category = CB_CATEGORY_BOOLEAN;
break;
default:
fprintf (stderr, "Unknown tree tag %d Category %d\n", CB_TREE_TAG (x), x->category);
ABORT ();
}
return x->category;
}
Definition at line 451 of file tree.c.
{
return category_to_class_table[CB_TREE_CATEGORY (x)];
}
| int cb_tree_type | ( | cb_tree | x | ) |
Definition at line 537 of file tree.c.
{
struct cb_field *f;
f = cb_field (x);
if (f->children) {
return COB_TYPE_GROUP;
}
switch (CB_TREE_CATEGORY (x)) {
case CB_CATEGORY_ALPHABETIC:
case CB_CATEGORY_ALPHANUMERIC:
return COB_TYPE_ALPHANUMERIC;
case CB_CATEGORY_ALPHANUMERIC_EDITED:
return COB_TYPE_ALPHANUMERIC_EDITED;
case CB_CATEGORY_NUMERIC:
switch (f->usage) {
case CB_USAGE_DISPLAY:
return COB_TYPE_NUMERIC_DISPLAY;
case CB_USAGE_BINARY:
case CB_USAGE_COMP_5:
case CB_USAGE_COMP_X:
case CB_USAGE_INDEX:
case CB_USAGE_LENGTH:
return COB_TYPE_NUMERIC_BINARY;
case CB_USAGE_FLOAT:
return COB_TYPE_NUMERIC_FLOAT;
case CB_USAGE_DOUBLE:
return COB_TYPE_NUMERIC_DOUBLE;
case CB_USAGE_PACKED:
return COB_TYPE_NUMERIC_PACKED;
default:
fprintf (stderr, "Unexpected numeric usage -> %d\n", f->usage);
ABORT ();
}
case CB_CATEGORY_NUMERIC_EDITED:
return COB_TYPE_NUMERIC_EDITED;
case CB_CATEGORY_OBJECT_REFERENCE:
case CB_CATEGORY_DATA_POINTER:
case CB_CATEGORY_PROGRAM_POINTER:
return COB_TYPE_NUMERIC_BINARY;
default:
fprintf (stderr, "Unexpected category -> %d\n", CB_TREE_CATEGORY (x));
ABORT ();
}
/* NOT REACHED */
return 0;
}
Definition at line 1033 of file field.c.
{
cb_tree x;
x = CB_TREE (f);
if (!f->values) {
level_require_error (x, "VALUE");
}
if (f->pic || f->flag_occurs) {
level_except_error (x, "VALUE");
}
cb_add_78 (f);
return last_real_field;
}
| void cb_validate_88_item | ( | struct cb_field * | p | ) |
Definition at line 1018 of file field.c.
{
cb_tree x;
x = CB_TREE (f);
if (!f->values) {
level_require_error (x, "VALUE");
}
if (f->pic || f->flag_occurs) {
level_except_error (x, "VALUE");
}
}
| void cb_validate_field | ( | struct cb_field * | p | ) |
Definition at line 973 of file field.c.
{
struct cb_field *c;
if (validate_field_1 (f) != 0) {
f->flag_invalid = 1;
return;
}
/* RXW - Remove */
if (f->flag_item_78) {
f->flag_is_verified = 1;
return;
}
/* setup parameters */
if (f->storage == CB_STORAGE_LOCAL ||
f->storage == CB_STORAGE_LINKAGE ||
f->flag_item_based) {
f->flag_local = 1;
}
if (f->storage == CB_STORAGE_LINKAGE || f->flag_item_based) {
f->flag_base = 1;
}
setup_parameters (f);
/* compute size */
compute_size (f);
if (!f->redefines) {
f->memory_size = f->size * f->occurs_max;
} else if (f->redefines->memory_size < f->size * f->occurs_max) {
f->redefines->memory_size = f->size * f->occurs_max;
}
validate_field_value (f);
if (f->flag_is_global) {
f->count++;
for (c = f->children; c; c = c->sister) {
c->flag_is_global = 1;
c->count++;
}
}
f->flag_is_verified = 1;
}
| 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;
}
}
| void cb_warning_x | ( | cb_tree | x, |
| const char * | fmt, | ||
| ... | |||
| ) |
Definition at line 98 of file error.c.
{
va_list ap;
va_start (ap, fmt);
print_error ((char *)(x->source_file), x->source_line, "Warning: ", fmt, ap);
va_end (ap);
warningcount++;
}
| char* check_filler_name | ( | char * | name | ) |
| struct cb_field* check_level_78 | ( | const char * | name | ) | [read] |
| void cobc_tree_cast_error | ( | cb_tree | x, |
| const char * | filen, | ||
| const int | linenum, | ||
| const int | tagnum | ||
| ) |
Definition at line 317 of file cobc.c.
{
fprintf (stderr, "%s:%d: Invalid type cast from '%s'\n",
filen, linenum, x ? cb_name (x) : "null");
fprintf (stderr, "Tag 1 %d Tag 2 %d\n", x ? CB_TREE_TAG(x) : 0,
tagnum);
(void)longjmp (cob_jmpbuf, 1);
}
| void codegen | ( | struct cb_program * | prog, |
| int | nested | ||
| ) |
Definition at line 4683 of file codegen.c.
{
int i;
cb_tree l;
struct attr_list *j;
struct literal_list *m;
struct field_list *k;
struct call_list *clp;
struct base_list *blp;
unsigned char *s;
struct cb_program *cp;
cb_tree l1;
cb_tree l2;
const char *prevprog;
time_t loctime;
char locbuff[48];
current_prog = prog;
param_id = 0;
stack_id = 0;
num_cob_fields = 0;
progid = 0;
loop_counter = 0;
output_indent_level = 0;
last_line = 0;
needs_exit_prog = 0;
gen_custom = 0;
call_cache = NULL;
label_cache = NULL;
local_cache = NULL;
excp_current_program_id = prog->orig_source_name;
excp_current_section = NULL;
excp_current_paragraph = NULL;
memset ((char *)i_counters, 0, sizeof (i_counters));
output_target = yyout;
if (!nested) {
gen_ebcdic = 0;
gen_ebcdic_ascii = 0;
gen_full_ebcdic = 0;
gen_native = 0;
attr_cache = NULL;
base_cache = NULL;
literal_cache = NULL;
field_cache = NULL;
loctime = time (NULL);
strftime (locbuff, sizeof(locbuff) - 1, "%b %d %Y %H:%M:%S %Z",
localtime (&loctime));
output_header (output_target, locbuff);
output_header (cb_storage_file, locbuff);
for (cp = prog; cp; cp = cp->next_program) {
output_header (cp->local_storage_file, locbuff);
}
output_storage ("/* Frame stack declaration */\n");
output_storage ("struct cob_frame {\n");
output_storage ("\tint\tperform_through;\n");
#ifndef __GNUC__
output_storage ("\tint\treturn_address;\n");
#elif COB_USE_SETJMP
output_storage ("\tjmp_buf\treturn_address;\n");
#else
output_storage ("\tvoid\t*return_address;\n");
#endif
output_storage ("};\n\n");
output_storage ("/* Union for CALL statement */\n");
output_storage ("union cob_call_union {\n");
output_storage ("\tvoid *(*funcptr)();\n");
output_storage ("\tint (*funcint)();\n");
output_storage ("\tvoid *func_void;\n");
output_storage ("};\n");
output_storage ("union cob_call_union\tcob_unifunc;\n\n");
output ("#define __USE_STRING_INLINES 1\n");
#ifdef _XOPEN_SOURCE_EXTENDED
output ("#ifndef _XOPEN_SOURCE_EXTENDED\n");
output ("#define _XOPEN_SOURCE_EXTENDED 1\n");
output ("#endif\n");
#endif
output ("#include <stdio.h>\n");
output ("#include <stdlib.h>\n");
output ("#include <string.h>\n");
output ("#include <math.h>\n");
#if COB_USE_SETJMP
output ("#include <setjmp.h>\n");
#endif
#ifdef WORDS_BIGENDIAN
output ("#define WORDS_BIGENDIAN 1\n");
#endif
#ifdef HAVE_BUILTIN_EXPECT
output ("#define HAVE_BUILTIN_EXPECT\n");
#endif
if (optimize_flag) {
output ("#define COB_LOCAL_INLINE\n");
}
output ("#include <libcob.h>\n\n");
output ("#define COB_SOURCE_FILE \"%s\"\n", cb_source_file);
output ("#define COB_PACKAGE_VERSION \"%s\"\n", PACKAGE_VERSION);
output ("#define COB_PATCH_LEVEL %d\n\n", PATCH_LEVEL);
output ("/* Global variables */\n");
output ("#include \"%s\"\n\n", cb_storage_file_name);
for (cp = prog; cp; cp = cp->next_program) {
if (cp->gen_decset) {
output("static void\n");
output("cob_decimal_set_int (cob_decimal *d, const int n)\n");
output("{\n");
output(" mpz_set_si (d->value, n);\n");
output(" d->scale = 0;\n");
output("}\n\n");
break;
}
}
for (cp = prog; cp; cp = cp->next_program) {
if (cp->gen_udecset) {
output("static void\n");
output("cob_decimal_set_uint (cob_decimal *d, const unsigned int n)\n");
output("{\n");
output(" mpz_set_ui (d->value, n);\n");
output(" d->scale = 0;\n");
output("}\n\n");
break;
}
}
for (cp = prog; cp; cp = cp->next_program) {
if (cp->gen_ptrmanip) {
output("static void\n");
output("cob_pointer_manip (cob_field *f1, cob_field *f2, size_t addsub)\n");
output("{\n");
output(" unsigned char *tmptr;\n");
output(" memcpy (&tmptr, f1->data, sizeof(void *));\n");
output(" if (addsub) {\n");
output(" tmptr -= cob_get_int (f2);\n");
output(" } else {\n");
output(" tmptr += cob_get_int (f2);\n");
output(" }\n");
output(" memcpy (f1->data, &tmptr, sizeof(void *));\n");
output("}\n\n");
break;
}
}
output ("/* Function prototypes */\n\n");
for (cp = prog; cp; cp = cp->next_program) {
/* Build parameter list */
for (l = cp->entry_list; l; l = CB_CHAIN (l)) {
for (l1 = CB_VALUE (l); l1; l1 = CB_CHAIN (l1)) {
for (l2 = cp->parameter_list; l2; l2 = CB_CHAIN (l2)) {
if (strcasecmp (cb_field (CB_VALUE (l1))->name,
cb_field (CB_VALUE (l2))->name) == 0) {
break;
}
}
if (l2 == NULL) {
cp->parameter_list = cb_list_add (cp->parameter_list, CB_VALUE (l1));
}
}
}
if (cp->flag_main) {
output ("int %s ();\n", cp->program_id);
} else {
for (l = cp->entry_list; l; l = CB_CHAIN (l)) {
output_entry_function (cp, l, cp->parameter_list, 0);
}
}
output ("static int %s_ (const int", cp->program_id);
if (!cp->flag_chained) {
for (l = cp->parameter_list; l; l = CB_CHAIN (l)) {
output (", unsigned char *");
}
}
output (");\n");
}
output ("\n");
}
/* Class-names */
if (!prog->nested_level && prog->class_name_list) {
output ("/* Class names */\n");
for (l = prog->class_name_list; l; l = CB_CHAIN (l)) {
output_class_name_definition (CB_CLASS_NAME (CB_VALUE (l)));
}
}
/* Main function */
if (prog->flag_main) {
output_main_function (prog);
}
/* Functions */
if (!nested) {
output ("/* Functions */\n\n");
}
for (l = prog->entry_list; l; l = CB_CHAIN (l)) {
output_entry_function (prog, l, prog->parameter_list, 1);
}
output_internal_function (prog, prog->parameter_list);
if (!prog->next_program) {
output ("/* End functions */\n\n");
}
if (gen_native || gen_full_ebcdic || gen_ebcdic_ascii || prog->alphabet_name_list) {
(void)lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
}
output_target = cb_storage_file;
/* Program local stuff */
if (call_cache) {
output_local ("\n/* Call pointers */\n");
for (clp = call_cache; clp; clp = clp->next) {
output_local ("static union cob_call_union\tcall_%s = { NULL };\n", clp->callname);
}
output_local ("\n");
}
for (i = 0; i < COB_MAX_SUBSCRIPTS; i++) {
if (i_counters[i]) {
output_local ("int\t\ti%d;\n", i);
}
}
if (num_cob_fields) {
output_local ("\n/* Local cob_field items */\n");
for (i = 0; i < num_cob_fields; i++) {
output_local ("cob_field\tf%d;\n", i);
}
output_local ("\n");
}
/* Skip to next nested program */
if (prog->next_program) {
codegen (prog->next_program, 1);
return;
}
/* Finalize the storage file */
if (base_cache) {
output_storage ("\n/* Storage */\n");
base_cache = list_cache_sort (base_cache, &base_cache_cmp);
prevprog = NULL;
for (blp = base_cache; blp; blp = blp->next) {
if (blp->curr_prog != prevprog) {
prevprog = blp->curr_prog;
output_storage ("\n/* PROGRAM-ID : %s */\n", prevprog);
}
#ifdef HAVE_ATTRIBUTE_ALIGNED
output_storage ("static unsigned char %s%d[%d] __attribute__((aligned));",
#else
output_storage ("static unsigned char %s%d[%d];",
#endif
CB_PREFIX_BASE, blp->f->id,
blp->f->memory_size);
output_storage ("\t/* %s */\n", blp->f->name);
}
output_storage ("\n/* End of storage */\n\n");
}
if (attr_cache) {
output_storage ("\n/* Attributes */\n\n");
attr_cache = attr_list_reverse (attr_cache);
for (j = attr_cache; j; j = j->next) {
output_storage ("static const cob_field_attr %s%d = ",
CB_PREFIX_ATTR, j->id);
output_storage ("{%d, %d, %d, %d, ", j->type, j->digits,
j->scale, j->flags);
if (j->pic) {
output_storage ("\"");
for (s = j->pic; *s; s += 5) {
output_storage ("%c\\%03o\\%03o\\%03o\\%03o",
s[0], s[1], s[2], s[3], s[4]);
}
output_storage ("\"");
} else {
output_storage ("NULL");
}
output_storage ("};\n");
}
}
if (field_cache) {
output_storage ("\n/* Fields */\n");
field_cache = list_cache_sort (field_cache, &field_cache_cmp);
prevprog = NULL;
for (k = field_cache; k; k = k->next) {
if (k->curr_prog != prevprog) {
prevprog = k->curr_prog;
output_storage ("\n/* PROGRAM-ID : %s */\n", prevprog);
}
output ("static cob_field %s%d\t= ", CB_PREFIX_FIELD, k->f->id);
if (!k->f->flag_local && !k->f->flag_item_external) {
output_field (k->x);
} else {
output ("{");
output_size (k->x);
output (", NULL, ");
output_attr (k->x);
output ("}");
}
output (";\t/* %s */\n", k->f->name);
}
output_storage ("\n/* End of fields */\n\n");
}
if (literal_cache) {
output_storage ("/* Constants */\n");
literal_cache = literal_list_reverse (literal_cache);
for (m = literal_cache; m; m = m->next) {
output ("static cob_field %s%d\t= ", CB_PREFIX_CONST, m->id);
output_field (m->x);
output (";\n");
}
output ("\n");
}
if (gen_ebcdic) {
output_storage ("/* EBCDIC translate table */\n");
output ("static const unsigned char\tcob_a2e[256] = {\n");
if (alt_ebcdic) {
output ("\t0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F,\n");
output ("\t0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
output ("\t0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26,\n");
output ("\t0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,\n");
output ("\t0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D,\n");
output ("\t0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,\n");
output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
output ("\t0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,\n");
output ("\t0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
output ("\t0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,\n");
output ("\t0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6,\n");
output ("\t0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,\n");
output ("\t0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
output ("\t0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,\n");
output ("\t0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6,\n");
output ("\t0xA7, 0xA8, 0xA9, 0xC0, 0x6A, 0xD0, 0xA1, 0x07,\n");
output ("\t0x68, 0xDC, 0x51, 0x42, 0x43, 0x44, 0x47, 0x48,\n");
output ("\t0x52, 0x53, 0x54, 0x57, 0x56, 0x58, 0x63, 0x67,\n");
output ("\t0x71, 0x9C, 0x9E, 0xCB, 0xCC, 0xCD, 0xDB, 0xDD,\n");
output ("\t0xDF, 0xEC, 0xFC, 0xB0, 0xB1, 0xB2, 0x3E, 0xB4,\n");
output ("\t0x45, 0x55, 0xCE, 0xDE, 0x49, 0x69, 0x9A, 0x9B,\n");
output ("\t0xAB, 0x9F, 0xBA, 0xB8, 0xB7, 0xAA, 0x8A, 0x8B,\n");
output ("\t0xB6, 0xB5, 0x62, 0x4F, 0x64, 0x65, 0x66, 0x20,\n");
output ("\t0x21, 0x22, 0x70, 0x23, 0x72, 0x73, 0x74, 0xBE,\n");
output ("\t0x76, 0x77, 0x78, 0x80, 0x24, 0x15, 0x8C, 0x8D,\n");
output ("\t0x8E, 0x41, 0x06, 0x17, 0x28, 0x29, 0x9D, 0x2A,\n");
output ("\t0x2B, 0x2C, 0x09, 0x0A, 0xAC, 0x4A, 0xAE, 0xAF,\n");
output ("\t0x1B, 0x30, 0x31, 0xFA, 0x1A, 0x33, 0x34, 0x35,\n");
output ("\t0x36, 0x59, 0x08, 0x38, 0xBC, 0x39, 0xA0, 0xBF,\n");
output ("\t0xCA, 0x3A, 0xFE, 0x3B, 0x04, 0xCF, 0xDA, 0x14,\n");
output ("\t0xE1, 0x8F, 0x46, 0x75, 0xFD, 0xEB, 0xEE, 0xED,\n");
output ("\t0x90, 0xEF, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF\n");
} else {
/* MF */
output ("\t0x00, 0x01, 0x02, 0x03, 0x1D, 0x19, 0x1A, 0x1B,\n");
output ("\t0x0F, 0x04, 0x16, 0x06, 0x07, 0x08, 0x09, 0x0A,\n");
output ("\t0x0B, 0x0C, 0x0D, 0x0E, 0x1E, 0x1F, 0x1C, 0x17,\n");
output ("\t0x10, 0x11, 0x20, 0x18, 0x12, 0x13, 0x14, 0x15,\n");
output ("\t0x21, 0x27, 0x3A, 0x36, 0x28, 0x30, 0x26, 0x38,\n");
output ("\t0x24, 0x2A, 0x29, 0x25, 0x2F, 0x2C, 0x22, 0x2D,\n");
output ("\t0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A,\n");
output ("\t0x7B, 0x7C, 0x35, 0x2B, 0x23, 0x39, 0x32, 0x33,\n");
output ("\t0x37, 0x57, 0x58, 0x59, 0x5A, 0x5B, 0x5C, 0x5D,\n");
output ("\t0x5E, 0x5F, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66,\n");
output ("\t0x67, 0x68, 0x69, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F,\n");
output ("\t0x70, 0x71, 0x72, 0x7D, 0x6A, 0x7E, 0x7F, 0x31,\n");
output ("\t0x34, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F, 0x40, 0x41,\n");
output ("\t0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,\n");
output ("\t0x4A, 0x4B, 0x4C, 0x4E, 0x4F, 0x50, 0x51, 0x52,\n");
output ("\t0x53, 0x54, 0x55, 0x56, 0x2E, 0x60, 0x4D, 0x05,\n");
output ("\t0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
output ("\t0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x8D, 0x8E, 0x8F,\n");
output ("\t0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97,\n");
output ("\t0x98, 0x99, 0x9A, 0x9B, 0x9C, 0x9D, 0x9E, 0x9F,\n");
output ("\t0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7,\n");
output ("\t0xA8, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF,\n");
output ("\t0xB0, 0xB1, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7,\n");
output ("\t0xB8, 0xB9, 0xBA, 0xBB, 0xBC, 0xBD, 0xBE, 0xBF,\n");
output ("\t0xC0, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
output ("\t0xC8, 0xC9, 0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF,\n");
output ("\t0xD0, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7,\n");
output ("\t0xD8, 0xD9, 0xDA, 0xDB, 0xDC, 0xDD, 0xDE, 0xDF,\n");
output ("\t0xE0, 0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7,\n");
output ("\t0xE8, 0xE9, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF,\n");
output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
output ("\t0xF8, 0xF9, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE, 0xFF\n");
}
output ("};\n");
output_storage ("\n");
}
if (gen_full_ebcdic) {
output ("static const unsigned char\tcob_ebcdic[256] = {\n");
output ("\t0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F,\n");
output ("\t0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
output ("\t0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26,\n");
output ("\t0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,\n");
output ("\t0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D,\n");
output ("\t0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,\n");
output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
output ("\t0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,\n");
output ("\t0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
output ("\t0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,\n");
output ("\t0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6,\n");
output ("\t0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,\n");
output ("\t0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
output ("\t0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,\n");
output ("\t0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6,\n");
output ("\t0xA7, 0xA8, 0xA9, 0xC0, 0x6A, 0xD0, 0xA1, 0x07,\n");
output ("\t0x68, 0xDC, 0x51, 0x42, 0x43, 0x44, 0x47, 0x48,\n");
output ("\t0x52, 0x53, 0x54, 0x57, 0x56, 0x58, 0x63, 0x67,\n");
output ("\t0x71, 0x9C, 0x9E, 0xCB, 0xCC, 0xCD, 0xDB, 0xDD,\n");
output ("\t0xDF, 0xEC, 0xFC, 0xB0, 0xB1, 0xB2, 0x3E, 0xB4,\n");
output ("\t0x45, 0x55, 0xCE, 0xDE, 0x49, 0x69, 0x9A, 0x9B,\n");
output ("\t0xAB, 0x9F, 0xBA, 0xB8, 0xB7, 0xAA, 0x8A, 0x8B,\n");
output ("\t0xB6, 0xB5, 0x62, 0x4F, 0x64, 0x65, 0x66, 0x20,\n");
output ("\t0x21, 0x22, 0x70, 0x23, 0x72, 0x73, 0x74, 0xBE,\n");
output ("\t0x76, 0x77, 0x78, 0x80, 0x24, 0x15, 0x8C, 0x8D,\n");
output ("\t0x8E, 0x41, 0x06, 0x17, 0x28, 0x29, 0x9D, 0x2A,\n");
output ("\t0x2B, 0x2C, 0x09, 0x0A, 0xAC, 0x4A, 0xAE, 0xAF,\n");
output ("\t0x1B, 0x30, 0x31, 0xFA, 0x1A, 0x33, 0x34, 0x35,\n");
output ("\t0x36, 0x59, 0x08, 0x38, 0xBC, 0x39, 0xA0, 0xBF,\n");
output ("\t0xCA, 0x3A, 0xFE, 0x3B, 0x04, 0xCF, 0xDA, 0x14,\n");
output ("\t0xE1, 0x8F, 0x46, 0x75, 0xFD, 0xEB, 0xEE, 0xED,\n");
output ("\t0x90, 0xEF, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF\n");
output ("};\n");
i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
output
("static cob_field f_ebcdic = { 256, (unsigned char *)cob_ebcdic, &%s%d };\n",
CB_PREFIX_ATTR, i);
output_storage ("\n");
}
if (gen_ebcdic_ascii) {
output ("static const unsigned char\tcob_ebcdic_ascii[256] = {\n");
output ("\t0x00, 0x01, 0x02, 0x03, 0xEC, 0x09, 0xCA, 0x7F,\n");
output ("\t0xE2, 0xD2, 0xD3, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
output ("\t0x10, 0x11, 0x12, 0x13, 0xEF, 0xC5, 0x08, 0xCB,\n");
output ("\t0x18, 0x19, 0xDC, 0xD8, 0x1C, 0x1D, 0x1E, 0x1F,\n");
output ("\t0xB7, 0xB8, 0xB9, 0xBB, 0xC4, 0x0A, 0x17, 0x1B,\n");
output ("\t0xCC, 0xCD, 0xCF, 0xD0, 0xD1, 0x05, 0x06, 0x07,\n");
output ("\t0xD9, 0xDA, 0x16, 0xDD, 0xDE, 0xDF, 0xE0, 0x04,\n");
output ("\t0xE3, 0xE5, 0xE9, 0xEB, 0x14, 0x15, 0x9E, 0x1A,\n");
output ("\t0x20, 0xC9, 0x83, 0x84, 0x85, 0xA0, 0xF2, 0x86,\n");
output ("\t0x87, 0xA4, 0xD5, 0x2E, 0x3C, 0x28, 0x2B, 0xB3,\n");
output ("\t0x26, 0x82, 0x88, 0x89, 0x8A, 0xA1, 0x8C, 0x8B,\n");
output ("\t0x8D, 0xE1, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x5E,\n");
output ("\t0x2D, 0x2F, 0xB2, 0x8E, 0xB4, 0xB5, 0xB6, 0x8F,\n");
output ("\t0x80, 0xA5, 0x7C, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,\n");
output ("\t0xBA, 0x90, 0xBC, 0xBD, 0xBE, 0xF3, 0xC0, 0xC1,\n");
output ("\t0xC2, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,\n");
output ("\t0xC3, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,\n");
output ("\t0x68, 0x69, 0xAE, 0xAF, 0xC6, 0xC7, 0xC8, 0xF1,\n");
output ("\t0xF8, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70,\n");
output ("\t0x71, 0x72, 0xA6, 0xA7, 0x91, 0xCE, 0x92, 0xA9,\n");
output ("\t0xE6, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78,\n");
output ("\t0x79, 0x7A, 0xAD, 0xA8, 0xD4, 0x5B, 0xD6, 0xD7,\n");
output ("\t0x9B, 0x9C, 0x9D, 0xFA, 0x9F, 0xB1, 0xB0, 0xAC,\n");
output ("\t0xAB, 0xFC, 0xAA, 0xFE, 0xE4, 0x5D, 0xBF, 0xE7,\n");
output ("\t0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47,\n");
output ("\t0x48, 0x49, 0xE8, 0x93, 0x94, 0x95, 0xA2, 0xED,\n");
output ("\t0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50,\n");
output ("\t0x51, 0x52, 0xEE, 0x96, 0x81, 0x97, 0xA3, 0x98,\n");
output ("\t0x5C, 0xF0, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,\n");
output ("\t0x59, 0x5A, 0xFD, 0xF5, 0x99, 0xF7, 0xF6, 0xF9,\n");
output ("\t0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,\n");
output ("\t0x38, 0x39, 0xDB, 0xFB, 0x9A, 0xF4, 0xEA, 0xFF\n");
output ("};\n");
i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
output
("static cob_field f_ebcdic_ascii = { 256, (unsigned char *)cob_ebcdic_ascii, &%s%d };\n",
CB_PREFIX_ATTR, i);
output_storage ("\n");
}
if (gen_native) {
output ("static const unsigned char\tcob_native[256] = {\n");
output ("\t0, 1, 2, 3, 4, 5, 6, 7,\n");
output ("\t8, 9, 10, 11, 12, 13, 14, 15,\n");
output ("\t16, 17, 18, 19, 20, 21, 22, 23,\n");
output ("\t24, 25, 26, 27, 28, 29, 30, 31,\n");
output ("\t32, 33, 34, 35, 36, 37, 38, 39,\n");
output ("\t40, 41, 42, 43, 44, 45, 46, 47,\n");
output ("\t48, 49, 50, 51, 52, 53, 54, 55,\n");
output ("\t56, 57, 58, 59, 60, 61, 62, 63,\n");
output ("\t64, 65, 66, 67, 68, 69, 70, 71,\n");
output ("\t72, 73, 74, 75, 76, 77, 78, 79,\n");
output ("\t80, 81, 82, 83, 84, 85, 86, 87,\n");
output ("\t88, 89, 90, 91, 92, 93, 94, 95,\n");
output ("\t96, 97, 98, 99, 100, 101, 102, 103,\n");
output ("\t104, 105, 106, 107, 108, 109, 110, 111,\n");
output ("\t112, 113, 114, 115, 116, 117, 118, 119,\n");
output ("\t120, 121, 122, 123, 124, 125, 126, 127,\n");
output ("\t128, 129, 130, 131, 132, 133, 134, 135,\n");
output ("\t136, 137, 138, 139, 140, 141, 142, 143,\n");
output ("\t144, 145, 146, 147, 148, 149, 150, 151,\n");
output ("\t152, 153, 154, 155, 156, 157, 158, 159,\n");
output ("\t160, 161, 162, 163, 164, 165, 166, 167,\n");
output ("\t168, 169, 170, 171, 172, 173, 174, 175,\n");
output ("\t176, 177, 178, 179, 180, 181, 182, 183,\n");
output ("\t184, 185, 186, 187, 188, 189, 190, 191,\n");
output ("\t192, 193, 194, 195, 196, 197, 198, 199,\n");
output ("\t200, 201, 202, 203, 204, 205, 206, 207,\n");
output ("\t208, 209, 210, 211, 212, 213, 214, 215,\n");
output ("\t216, 217, 218, 219, 220, 221, 222, 223,\n");
output ("\t224, 225, 226, 227, 228, 229, 230, 231,\n");
output ("\t232, 233, 234, 235, 236, 237, 238, 239,\n");
output ("\t240, 241, 242, 243, 244, 245, 246, 247,\n");
output ("\t248, 249, 250, 251, 252, 253, 254, 255\n");
output ("};\n");
i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
output
("static cob_field f_native = { 256, (unsigned char *)cob_native, &%s%d };\n",
CB_PREFIX_ATTR, i);
output_storage ("\n");
}
}
Definition at line 1611 of file tree.c.
{
struct cb_field *p;
struct cb_field *v;
cb_tree l;
cb_tree x;
char buff[COB_MINI_BUFF];
if (f->special) {
f->organization = COB_ORG_LINE_SEQUENTIAL;
}
if (f->fileid_assign && !f->assign) {
f->assign = cb_build_alphanumeric_literal ((unsigned char *)f->name,
strlen (f->name));
}
/* check the record size if it is limited */
for (p = records; p; p = p->sister) {
if (f->record_min > 0) {
if (p->size < f->record_min) {
cb_error (_("Record size too small '%s'"), p->name);
}
}
if (f->record_max > 0) {
if (p->size > f->record_max) {
cb_error (_("Record size too large '%s' (%d)"),
p->name, p->size);
}
}
}
/* compute the record size */
if (f->record_min == 0) {
if (records) {
f->record_min = records->size;
} else {
f->record_min = 0;
}
}
for (p = records; p; p = p->sister) {
v = cb_field_variable_size (p);
if (v && v->offset + v->size * v->occurs_min < f->record_min) {
f->record_min = v->offset + v->size * v->occurs_min;
}
if (p->size < f->record_min) {
f->record_min = p->size;
}
if (p->size > f->record_max) {
f->record_max = p->size;
}
}
if (f->same_clause) {
for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
if (CB_FILE (CB_VALUE (l))->same_clause == f->same_clause) {
if (CB_FILE (CB_VALUE (l))->finalized) {
if (f->record_max > CB_FILE (CB_VALUE (l))->record->memory_size) {
CB_FILE (CB_VALUE (l))->record->memory_size =
f->record_max;
}
f->record = CB_FILE (CB_VALUE (l))->record;
for (p = records; p; p = p->sister) {
p->file = f;
p->redefines = f->record;
}
for (p = f->record->sister; p; p = p->sister) {
if (!p->sister) {
p->sister = records;
break;
}
}
f->finalized = 1;
return;
}
}
}
}
/* create record */
snprintf (buff, COB_MINI_MAX, "%s_record", f->name);
if (f->record_max == 0) {
f->record_max = 32;
f->record_min = 32;
}
if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
f->record_min = 0;
}
f->record = CB_FIELD (cb_build_implicit_field (cb_build_reference (buff),
f->record_max));
f->record->sister = records;
f->record->count++;
if (f->external) {
has_external = 1;
f->record->flag_external = 1;
}
for (p = records; p; p = p->sister) {
p->file = f;
p->redefines = f->record;
}
f->finalized = 1;
if (f->linage) {
snprintf (buff, COB_MINI_MAX, "LC_%s", f->name);
x = cb_build_field (cb_build_reference (buff));
CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("9(9)"));
CB_FIELD (x)->usage = CB_USAGE_COMP_5;
CB_FIELD (x)->values = cb_list_init (cb_zero);
CB_FIELD (x)->count++;
cb_validate_field (CB_FIELD (x));
f->linage_ctr = cb_build_field_reference (CB_FIELD (x), NULL);
current_program->working_storage =
cb_field_add (current_program->working_storage, CB_FIELD (x));
}
}
| void group_error | ( | cb_tree | x, |
| const char * | clause | ||
| ) |
Definition at line 250 of file error.c.
{
cb_error_x (x, _("Group item '%s' cannot have %s clause"), check_filler_name (cb_name (x)), clause);
}
| void level_except_error | ( | cb_tree | x, |
| const char * | clause | ||
| ) |
Definition at line 270 of file error.c.
{
cb_error_x (x, _("Level %02d item '%s' cannot have other than %s clause"),
cb_field (x)->level, check_filler_name (cb_name (x)), clause);
}
| void level_redundant_error | ( | cb_tree | x, |
| const char * | clause | ||
| ) |
Definition at line 256 of file error.c.
{
cb_error_x (x, _("Level %02d item '%s' cannot have %s clause"),
cb_field (x)->level, check_filler_name (cb_name (x)), clause);
}
| void level_require_error | ( | cb_tree | x, |
| const char * | clause | ||
| ) |
Definition at line 263 of file error.c.
{
cb_error_x (x, _("Level %02d item '%s' requires %s clause"),
cb_field (x)->level, check_filler_name (cb_name (x)), clause);
}
| struct cb_intrinsic_table* lookup_intrinsic | ( | const char * | name, |
| const int | checkres | ||
| ) | [read] |
Definition at line 929 of file reserved.c.
{
struct cb_intrinsic_table *cbp;
struct noreserve *noresptr;
if (checkres) {
for (noresptr = norestab; noresptr; noresptr = noresptr->next) {
if (strcasecmp (name, noresptr->noresword) == 0) {
return NULL;
}
}
}
cbp = bsearch (name, function_list, NUM_INTRINSICS,
sizeof (struct cb_intrinsic_table), intrinsic_comp);
if (cbp && cbp->implemented) {
return cbp;
}
return NULL;
}
| int lookup_reserved_word | ( | const char * | name | ) |
Definition at line 906 of file reserved.c.
{
struct reserved *p;
struct noreserve *noresptr;
p = bsearch (name, reserved_words, NUM_RESERVED_WORDS,
sizeof (struct reserved), reserve_comp);
if (!p) {
return 0;
}
for (noresptr = norestab; noresptr; noresptr = noresptr->next) {
if (strcasecmp (name, noresptr->noresword) == 0) {
return 0;
}
}
if (p->token != -1) {
return p->token;
}
cb_error (_("'%s' reserved word, but not supported yet"), name);
return 0;
}
| cb_tree lookup_system_name | ( | const char * | name | ) |
Definition at line 893 of file reserved.c.
{
int i;
for (i = 0; system_table[i].name != NULL; ++i) {
if (strcasecmp (name, system_table[i].name) == 0) {
return system_table[i].node;
}
}
return cb_error_node;
}
| void redefinition_error | ( | cb_tree | x | ) |
Definition at line 154 of file error.c.
{
struct cb_word *w;
w = CB_REFERENCE (x)->word;
cb_error_x (x, _("Redefinition of '%s'"), w->name);
cb_error_x (CB_VALUE (w->items), _("'%s' previously defined here"), w->name);
}
Definition at line 164 of file error.c.
{
struct cb_word *w;
w = CB_REFERENCE (x)->word;
cb_warning_x (x, _("Redefinition of '%s'"), w->name);
if (y) {
cb_warning_x (y, _("'%s' previously defined here"), w->name);
} else {
cb_warning_x (CB_VALUE (w->items), _("'%s' previously defined here"), w->name);
}
}
| void undefined_error | ( | cb_tree | x | ) |
Definition at line 178 of file error.c.
{
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);
}
Definition at line 1593 of file tree.c.
{
/* check RECORD/RELATIVE KEY clause */
switch (f->organization) {
case COB_ORG_INDEXED:
if (f->key == NULL) {
file_error (name, "RECORD KEY");
}
break;
case COB_ORG_RELATIVE:
if (f->key == NULL && f->access_mode != COB_ACCESS_SEQUENTIAL) {
file_error (name, "RELATIVE KEY");
}
break;
}
}
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 cb_needs_01 |
| size_t gen_screen_ptr |
| int non_const_word |
1.7.4