OpenCOBOL 1.1pre-rel
Data Structures | Defines | Functions | Variables
typeck.c File Reference
#include "config.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <time.h>
#include <sys/time.h>
#include <locale.h>
#include "cobc.h"
#include "tree.h"
#include "libcob/system.def"
Include dependency graph for typeck.c:

Go to the source code of this file.

Data Structures

struct  system_table
struct  expr_node

Defines

#define START_STACK_SIZE   32
#define TOKEN(offset)   (expr_stack[expr_index + offset].token)
#define VALUE(offset)   (expr_stack[expr_index + offset].value)
#define dpush(x)   decimal_stack = cb_cons (x, decimal_stack)
#define cb_emit(x)   current_statement->body = cb_list_add (current_statement->body, x)
#define cb_emit_list(l)   current_statement->body = cb_list_append (current_statement->body, l)
#define COB_SYSTEM_GEN(x, y, z)   { x, y },

Functions

static size_t cb_validate_one (cb_tree x)
static size_t cb_validate_list (cb_tree l)
static cb_tree cb_check_group_name (cb_tree x)
static cb_tree cb_check_numeric_name (cb_tree x)
static cb_tree cb_check_numeric_edited_name (cb_tree x)
cb_tree cb_check_numeric_value (cb_tree x)
static cb_tree cb_check_integer_value (cb_tree x)
void cb_build_registers (void)
char * cb_encode_program_id (const char *name)
const char * cb_build_program_id (cb_tree name, cb_tree alt_name)
void cb_define_switch_name (cb_tree name, cb_tree sname, cb_tree flag, cb_tree ref)
cb_tree cb_build_section_name (cb_tree name, int sect_or_para)
cb_tree cb_build_assignment_name (struct cb_file *cfile, cb_tree name)
cb_tree cb_build_index (cb_tree x, cb_tree values, int indexed_by, struct cb_field *qual)
cb_tree cb_build_identifier (cb_tree x)
static cb_tree cb_build_length_1 (cb_tree x)
cb_tree cb_build_const_length (cb_tree x)
cb_tree cb_build_length (cb_tree x)
cb_tree cb_build_address (cb_tree x)
cb_tree cb_build_ppointer (cb_tree x)
static int get_value (cb_tree x)
void cb_validate_program_environment (struct cb_program *prog)
void cb_validate_program_data (struct cb_program *prog)
void cb_validate_program_body (struct cb_program *prog)
static void cb_expr_init (void)
static int expr_reduce (int token)
static void cb_expr_shift_sign (const int op)
static void cb_expr_shift_class (const char *name)
static void cb_expr_shift (int token, cb_tree value)
static void expr_expand (cb_tree *x)
static cb_tree cb_expr_finish (void)
cb_tree cb_build_expr (cb_tree list)
static cb_tree build_store_option (cb_tree x, cb_tree round_opt)
static cb_tree decimal_alloc (void)
static void decimal_free (void)
static void decimal_compute (const int op, cb_tree x, cb_tree y)
static void decimal_expand (cb_tree d, cb_tree x)
static void decimal_assign (cb_tree x, cb_tree d, cb_tree round_opt)
static cb_tree build_decimal_assign (cb_tree vars, int op, cb_tree val)
void cb_emit_arithmetic (cb_tree vars, int op, cb_tree val)
static cb_tree build_cond_88 (cb_tree x)
static cb_tree cb_build_optim_cond (struct cb_binary_op *p)
static int cb_chk_num_cond (cb_tree x, cb_tree y)
static int cb_chk_alpha_cond (cb_tree x)
cb_tree cb_build_cond (cb_tree x)
static cb_tree cb_build_optim_add (cb_tree v, cb_tree n)
static cb_tree cb_build_optim_sub (cb_tree v, cb_tree n)
cb_tree cb_build_add (cb_tree v, cb_tree n, cb_tree round_opt)
cb_tree cb_build_sub (cb_tree v, cb_tree n, cb_tree round_opt)
static void emit_corresponding (cb_tree(*func)(cb_tree f1, cb_tree f2, cb_tree f3), cb_tree x1, cb_tree x2, cb_tree opt)
void cb_emit_corresponding (cb_tree(*func)(cb_tree f1, cb_tree f2, cb_tree f3), cb_tree x1, cb_tree x2, cb_tree opt)
static void emit_move_corresponding (cb_tree x1, cb_tree x2)
void cb_emit_move_corresponding (cb_tree x1, cb_tree x2)
static void output_screen_from (struct cb_field *p, const size_t sisters)
static void output_screen_to (struct cb_field *p, const size_t sisters)
void cb_emit_accept (cb_tree var, cb_tree pos, cb_tree fgc, cb_tree bgc, cb_tree scroll, int dispattrs)
void cb_emit_accept_line_or_col (cb_tree var, const int l_or_c)
void cb_emit_accept_date (cb_tree var)
void cb_emit_accept_date_yyyymmdd (cb_tree var)
void cb_emit_accept_day (cb_tree var)
void cb_emit_accept_day_yyyyddd (cb_tree var)
void cb_emit_accept_day_of_week (cb_tree var)
void cb_emit_accept_time (cb_tree var)
void cb_emit_accept_command_line (cb_tree var)
void cb_emit_get_environment (cb_tree envvar, cb_tree envval)
void cb_emit_accept_environment (cb_tree var)
void cb_emit_accept_arg_number (cb_tree var)
void cb_emit_accept_arg_value (cb_tree var)
void cb_emit_accept_mnemonic (cb_tree var, cb_tree mnemonic)
void cb_emit_accept_name (cb_tree var, cb_tree name)
void cb_emit_allocate (cb_tree target1, cb_tree target2, cb_tree size, cb_tree initialize)
void cb_emit_call (cb_tree prog, cb_tree using, cb_tree returning, cb_tree on_exception, cb_tree not_on_exception)
void cb_emit_cancel (cb_tree prog)
void cb_emit_close (cb_tree file, cb_tree opt)
void cb_emit_commit (void)
void cb_emit_continue (void)
void cb_emit_delete (cb_tree file)
void cb_emit_env_name (cb_tree value)
void cb_emit_env_value (cb_tree value)
void cb_emit_arg_number (cb_tree value)
void cb_emit_command_line (cb_tree value)
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)
cb_tree cb_build_display_upon (cb_tree x)
cb_tree cb_build_display_upon_direct (cb_tree x)
void cb_emit_divide (cb_tree dividend, cb_tree divisor, cb_tree quotient, cb_tree remainder)
static cb_tree evaluate_test (cb_tree s, cb_tree o)
static cb_tree build_evaluate (cb_tree subject_list, cb_tree case_list)
void cb_emit_evaluate (cb_tree subject_list, cb_tree case_list)
void cb_emit_free (cb_tree vars)
void cb_emit_goto (cb_tree target, cb_tree depending)
void cb_emit_exit (size_t goback)
void cb_emit_if (cb_tree cond, cb_tree stmt1, cb_tree stmt2)
void cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value, cb_tree replacing, cb_tree def)
void cb_emit_inspect (cb_tree var, cb_tree body, cb_tree replacing, int replconv)
void cb_init_tarrying (void)
cb_tree cb_build_tarrying_data (cb_tree x)
cb_tree cb_build_tarrying_characters (cb_tree l)
cb_tree cb_build_tarrying_all (void)
cb_tree cb_build_tarrying_leading (void)
cb_tree cb_build_tarrying_trailing (void)
cb_tree cb_build_tarrying_value (cb_tree x, cb_tree l)
cb_tree cb_build_replacing_characters (cb_tree x, cb_tree l)
cb_tree cb_build_replacing_all (cb_tree x, cb_tree y, cb_tree l)
cb_tree cb_build_replacing_leading (cb_tree x, cb_tree y, cb_tree l)
cb_tree cb_build_replacing_first (cb_tree x, cb_tree y, cb_tree l)
cb_tree cb_build_replacing_trailing (cb_tree x, cb_tree y, cb_tree l)
cb_tree cb_build_converting (cb_tree x, cb_tree y, cb_tree l)
cb_tree cb_build_inspect_region_start (void)
cb_tree cb_build_inspect_region (cb_tree l, cb_tree pos, cb_tree x)
static void warning_destination (cb_tree x)
static int move_error (cb_tree src, cb_tree dst, const size_t value_flag, const int flag, const int src_flag, const char *msg)
static int count_pic_alphanumeric_edited (struct cb_field *field)
int validate_move (cb_tree src, cb_tree dst, size_t is_value)
static cb_tree cb_build_memset (cb_tree x, int c)
static cb_tree cb_build_move_copy (cb_tree src, cb_tree dst)
static cb_tree cb_build_move_call (cb_tree src, cb_tree dst)
static cb_tree cb_build_move_num_zero (cb_tree x)
static cb_tree cb_build_move_space (cb_tree x)
static cb_tree cb_build_move_zero (cb_tree x)
static cb_tree cb_build_move_high (cb_tree x)
static cb_tree cb_build_move_low (cb_tree x)
static cb_tree cb_build_move_quote (cb_tree x)
static void cob_put_sign_ebcdic (unsigned char *p, const int sign)
static cb_tree cb_build_move_literal (cb_tree src, cb_tree dst)
static cb_tree cb_build_move_field (cb_tree src, cb_tree dst)
cb_tree cb_build_move (cb_tree src, cb_tree dst)
void cb_emit_move (cb_tree src, cb_tree dsts)
void cb_emit_open (cb_tree file, cb_tree mode, cb_tree sharing)
void cb_emit_perform (cb_tree perform, cb_tree body)
cb_tree cb_build_perform_once (cb_tree body)
cb_tree cb_build_perform_times (cb_tree times)
cb_tree cb_build_perform_until (cb_tree condition, cb_tree varying)
cb_tree cb_build_perform_forever (cb_tree body)
cb_tree cb_build_perform_exit (struct cb_label *label)
void cb_emit_read (cb_tree ref, cb_tree next, cb_tree into, cb_tree key, cb_tree lock_opts)
void cb_emit_rewrite (cb_tree record, cb_tree from, cb_tree lockopt)
void cb_emit_release (cb_tree record, cb_tree from)
void cb_emit_return (cb_tree ref, cb_tree into)
void cb_emit_rollback (void)
static void search_set_keys (struct cb_field *f, cb_tree x)
static cb_tree cb_build_search_all (cb_tree table, cb_tree cond)
void cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens)
void cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts)
void cb_emit_setenv (cb_tree x, cb_tree y)
void cb_emit_set_to (cb_tree vars, cb_tree x)
void cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x)
void cb_emit_set_on_off (cb_tree l, cb_tree flag)
void cb_emit_set_true (cb_tree l)
void cb_emit_set_false (cb_tree l)
void cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col)
void cb_emit_sort_using (cb_tree file, cb_tree l)
void cb_emit_sort_input (cb_tree proc)
void cb_emit_sort_giving (cb_tree file, cb_tree l)
void cb_emit_sort_output (cb_tree proc)
void cb_emit_sort_finish (cb_tree file)
void cb_emit_start (cb_tree file, cb_tree op, cb_tree key)
void cb_emit_stop_run (cb_tree x)
void cb_emit_string (cb_tree items, cb_tree into, cb_tree pointer)
void cb_emit_unlock (cb_tree ref)
void cb_emit_unstring (cb_tree name, cb_tree delimited, cb_tree into, cb_tree pointer, cb_tree tallying)
cb_tree cb_build_unstring_delimited (cb_tree all, cb_tree value)
cb_tree cb_build_unstring_into (cb_tree name, cb_tree delimiter, cb_tree count)
void cb_emit_write (cb_tree record, cb_tree from, cb_tree opt, cb_tree lockopt)
cb_tree cb_build_write_advancing_lines (cb_tree pos, cb_tree lines)
cb_tree cb_build_write_advancing_mnemonic (cb_tree pos, cb_tree mnemonic)
cb_tree cb_build_write_advancing_page (cb_tree pos)

Variables

size_t sending_id = 0
size_t suppress_warn = 0
static cb_tree decimal_stack = NULL
static const char * inspect_func
static cb_tree inspect_data
static int expr_op
static cb_tree expr_lh
static int expr_index
static int expr_stack_size
static struct expr_nodeexpr_stack
static char expr_prio [256]
static struct system_table system_tab []
static const char *const bin_set_funcs []
static const char *const bin_compare_funcs []
static const char *const bin_add_funcs []
static const char *const bin_sub_funcs []
static const char *const align_bin_compare_funcs []
static const char *const align_bin_add_funcs []
static const char *const align_bin_sub_funcs []

Define Documentation

#define cb_emit (   x)    current_statement->body = cb_list_add (current_statement->body, x)

Definition at line 67 of file typeck.c.

#define cb_emit_list (   l)    current_statement->body = cb_list_append (current_statement->body, l)

Definition at line 69 of file typeck.c.

#define COB_SYSTEM_GEN (   x,
  y,
 
)    { x, y },
#define dpush (   x)    decimal_stack = cb_cons (x, decimal_stack)

Definition at line 65 of file typeck.c.

#define START_STACK_SIZE   32

Definition at line 61 of file typeck.c.

#define TOKEN (   offset)    (expr_stack[expr_index + offset].token)

Definition at line 62 of file typeck.c.

#define VALUE (   offset)    (expr_stack[expr_index + offset].value)

Definition at line 63 of file typeck.c.


Function Documentation

static cb_tree build_cond_88 ( cb_tree  x) [static]

Definition at line 2155 of file typeck.c.

{
        struct cb_field *f;
        cb_tree         l;
        cb_tree         t;
        cb_tree         c1 = NULL;
        cb_tree         c2;

        f = cb_field (x);
        /* refer to parent's data storage */
        x = cb_build_field_reference (f->parent, x);
        f->parent->count++;

        /* build condition */
        for (l = f->values; l; l = CB_CHAIN (l)) {
                t = CB_VALUE (l);
                if (CB_PAIR_P (t)) {
                        /* VALUE THRU VALUE */
                        c2 = cb_build_binary_op (cb_build_binary_op (CB_PAIR_X (t), '[', x),
                                                 '&', cb_build_binary_op (x, '[', CB_PAIR_Y (t)));
                } else {
                        /* VALUE */
                        c2 = cb_build_binary_op (x, '=', t);
                }
                if (c1 == NULL) {
                        c1 = c2;
                } else {
                        c1 = cb_build_binary_op (c1, '|', c2);
                }
        }
        return c1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree build_decimal_assign ( cb_tree  vars,
int  op,
cb_tree  val 
) [static]

Definition at line 2054 of file typeck.c.

{
        cb_tree l;
        cb_tree t;
        cb_tree s1 = NULL;
        cb_tree d;

        d = decimal_alloc ();

        /* set d, VAL */
        decimal_expand (d, val);

        if (op == 0) {
                for (l = vars; l; l = CB_CHAIN (l)) {
                        /* set VAR, d */
                        decimal_assign (CB_VALUE (l), d, CB_PURPOSE (l));
                        s1 = cb_list_add (s1, cb_list_reverse (decimal_stack));
                        decimal_stack = NULL;
                }
        } else {
                t = decimal_alloc ();
                for (l = vars; l; l = CB_CHAIN (l)) {
                        /* set t, VAR
                         * OP t, d
                         * set VAR, t
                         */
                        decimal_expand (t, CB_VALUE (l));
                        decimal_compute (op, t, d);
                        decimal_assign (CB_VALUE (l), t, CB_PURPOSE (l));
                        s1 = cb_list_add (s1, cb_list_reverse (decimal_stack));
                        decimal_stack = NULL;
                }
                decimal_free ();
        }

        decimal_free ();
        return s1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree build_evaluate ( cb_tree  subject_list,
cb_tree  case_list 
) [static]

Definition at line 3546 of file typeck.c.

{
        cb_tree c1 = NULL;
        cb_tree c2;
        cb_tree c3;
        cb_tree subjs;
        cb_tree whens;
        cb_tree objs;
        cb_tree stmt;

        if (case_list == NULL) {
                return NULL;
        }

        whens = CB_VALUE (case_list);
        stmt = CB_VALUE (whens);
        whens = CB_CHAIN (whens);

        /* for each WHEN sequence */
        for (; whens; whens = CB_CHAIN (whens)) {
                c2 = NULL;
                /* single WHEN test */
                for (subjs = subject_list, objs = CB_VALUE (whens);
                     subjs && objs; subjs = CB_CHAIN (subjs), objs = CB_CHAIN (objs)) {
                        c3 = evaluate_test (CB_VALUE (subjs), CB_VALUE (objs));
                        if (c3 == NULL) {
                                return NULL;
                        }

                        if (c2 == NULL) {
                                c2 = c3;
                        } else {
                                c2 = cb_build_binary_op (c2, '&', c3);
                        }
                }
                if (subjs || objs) {
                        cb_error (_("Wrong number of WHEN parameters"));
                }
                /* connect multiple WHEN's */
                if (c1 == NULL) {
                        c1 = c2;
                } else {
                        c1 = cb_build_binary_op (c1, '|', c2);
                }
        }

        if (c1 == NULL) {
                return stmt;
        } else {
                return cb_build_if (cb_build_cond (c1), stmt,
                                    build_evaluate (subject_list, CB_CHAIN (case_list)));
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree build_store_option ( cb_tree  x,
cb_tree  round_opt 
) [static]

Definition at line 1889 of file typeck.c.

{
        int opt = 0;

        if (round_opt == cb_int1) {
                opt |= COB_STORE_ROUND;
        }

        switch (CB_FIELD (cb_ref (x))->usage) {
        case CB_USAGE_COMP_5:
        case CB_USAGE_COMP_X:
                if (current_statement->handler1) {
                        opt |= COB_STORE_KEEP_ON_OVERFLOW;
                }
                break;
        default:
                if (!cb_binary_truncate) {
                        if (current_statement->handler1) {
                                opt |= COB_STORE_KEEP_ON_OVERFLOW;
                        }
                        break;
                }

/* RXW Fixme - It seems as though we have NEVER implemented TRUNC,
   Code has always been wrong. Hmm. The following statement would
   activate what was intended but ...
   What should we do here?
                if (current_statement->handler1) {
*/
                if (current_statement->handler_id) {
                        opt |= COB_STORE_KEEP_ON_OVERFLOW;
                } else if (cb_binary_truncate) {
                        opt |= COB_STORE_TRUNC_ON_OVERFLOW;
                }
                break;
        }

        return cb_int (opt);
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_build_add ( cb_tree  v,
cb_tree  n,
cb_tree  round_opt 
)

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);
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_build_address ( cb_tree  x)

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);
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_build_assignment_name ( struct cb_file cfile,
cb_tree  name 
)

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;
        }
}

Here is the call graph for this function:

cb_tree cb_build_cond ( cb_tree  x)

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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_build_const_length ( cb_tree  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);
}

Here is the call graph for this function:

cb_tree cb_build_converting ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

Definition at line 3847 of file typeck.c.

{
        return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_converting", x, y));
}

Here is the call graph for this function:

cb_tree cb_build_display_upon ( cb_tree  x)

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;
        }
}

Here is the call graph for this function:

cb_tree cb_build_display_upon_direct ( cb_tree  x)

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;
}

Here is the call graph for this function:

cb_tree cb_build_expr ( cb_tree  list)

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 ();
}

Here is the call graph for this function:

cb_tree cb_build_identifier ( cb_tree  x)

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;
}

Here is the call graph for this function:

cb_tree cb_build_index ( cb_tree  x,
cb_tree  values,
int  indexed_by,
struct cb_field qual 
)

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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_build_inspect_region ( cb_tree  l,
cb_tree  pos,
cb_tree  x 
)

Definition at line 3859 of file typeck.c.

{
        if (pos == CB_BEFORE) {
                return cb_list_add (l, cb_build_funcall_1 ("cob_inspect_before", x));
        } else {
                return cb_list_add (l, cb_build_funcall_1 ("cob_inspect_after", x));
        }
}

Here is the call graph for this function:

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"));
}
cb_tree cb_build_length ( cb_tree  x)

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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_length_1 ( cb_tree  x) [static]

Definition at line 928 of file typeck.c.

{
        struct cb_field *f;
        cb_tree         e;
        cb_tree         size;

        f = CB_FIELD (cb_ref (x));

        if (cb_field_variable_size (f) == NULL) {
                /* constant size */
                return cb_int (cb_field_size (x));
        } else {
                /* variable size */
                e = NULL;
                for (f = f->children; f; f = f->sister) {
                        size = cb_build_length_1 (cb_build_field_reference (f, x));
                        if (f->occurs_depending) {
                                size = cb_build_binary_op (size, '*', f->occurs_depending);
                        } else if (f->occurs_max > 1) {
                                size = cb_build_binary_op (size, '*', cb_int (f->occurs_max));
                        }
                        e = e ? cb_build_binary_op (e, '+', size) : size;
                }
                return e;
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_memset ( cb_tree  x,
int  c 
) [static]

Definition at line 4441 of file typeck.c.

{
        int size = cb_field_size (x);

        if (size == 1) {
                return cb_build_funcall_2 ("$E", x, cb_int (c));
        } else {
                return cb_build_funcall_3 ("memset",
                                           cb_build_cast_address (x),
                                           cb_int (c), cb_build_cast_length (x));
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_build_move ( cb_tree  src,
cb_tree  dst 
)

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);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_move_call ( cb_tree  src,
cb_tree  dst 
) [static]

Definition at line 4469 of file typeck.c.

{
        return cb_build_funcall_2 ("cob_move", src, dst);
}

Here is the caller graph for this function:

static cb_tree cb_build_move_copy ( cb_tree  src,
cb_tree  dst 
) [static]

Definition at line 4455 of file typeck.c.

{
        int size = cb_field_size (dst);

        if (size == 1) {
                return cb_build_funcall_2 ("$F", dst, src);
        } else {
                return cb_build_funcall_3 ("memcpy",
                                           cb_build_cast_address (dst),
                                           cb_build_cast_address (src), cb_build_cast_length (dst));
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_move_field ( cb_tree  src,
cb_tree  dst 
) [static]

Definition at line 4906 of file typeck.c.

{
        struct cb_field *src_f;
        struct cb_field *dst_f;
        int             src_size;
        int             dst_size;

        src_f = cb_field (src);
        src_size = cb_field_size (src);
        dst_f = cb_field (dst);
        dst_size = cb_field_size (dst);

        if ((src_size > 0 && dst_size > 0 && src_size >= dst_size)
            && (!cb_field_variable_size (src_f) && !cb_field_variable_size (dst_f))) {
                switch (CB_TREE_CATEGORY (src)) {
                case CB_CATEGORY_ALPHABETIC:
                        if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHABETIC
                            || CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC) {
                                if (dst_f->flag_justified == 0) {
                                        return cb_build_move_copy (src, dst);
                                }
                        }
                        break;
                case CB_CATEGORY_ALPHANUMERIC:
                        if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC) {
                                if (dst_f->flag_justified == 0) {
                                        return cb_build_move_copy (src, dst);
                                }
                        }
                        break;
                case CB_CATEGORY_NUMERIC:
                        if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC
                            && src_f->usage == dst_f->usage
                            && src_f->pic->size == dst_f->pic->size
                            && src_f->pic->digits == dst_f->pic->digits
                            && src_f->pic->scale == dst_f->pic->scale
                            && src_f->pic->have_sign == dst_f->pic->have_sign
                            && src_f->flag_binary_swap == dst_f->flag_binary_swap
                            && src_f->flag_sign_leading == dst_f->flag_sign_leading
                            && src_f->flag_sign_separate == dst_f->flag_sign_separate) {
                                return cb_build_move_copy (src, dst);
                        } else if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC
                                 && src_f->usage == CB_USAGE_DISPLAY
                                 && src_f->pic->have_sign == 0
                                 && !src_f->flag_sign_leading
                                 && !src_f->flag_sign_separate) {
                                return cb_build_move_copy (src, dst);
                        }
                        break;
                default:
                        break;
                }
        }

        return cb_build_move_call (src, dst);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_move_high ( cb_tree  x) [static]

Definition at line 4556 of file typeck.c.

{
        switch (CB_TREE_CATEGORY (x)) {
        case CB_CATEGORY_NUMERIC:
        case CB_CATEGORY_ALPHABETIC:
        case CB_CATEGORY_ALPHANUMERIC:
                if (cb_high == cb_norm_high) {
                        return cb_build_memset (x, 255);
                } else {
                        return cb_build_move_call (cb_high, x);
                }
        default:
                return cb_build_move_call (cb_high, x);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_move_literal ( cb_tree  src,
cb_tree  dst 
) [static]

Definition at line 4722 of file typeck.c.

{
        struct cb_literal       *l;
        struct cb_field         *f;
        unsigned char           *buff;
        unsigned char           *p;
        enum cb_category        cat;
        int                     i;
        int                     diff;
        int                     val;
        int                     n;
        unsigned char           bbyte;

        l = CB_LITERAL (src);
        f = cb_field (dst);
        cat = CB_TREE_CATEGORY (dst);

        if (l->all) {
                if (cat == CB_CATEGORY_NUMERIC || cat == CB_CATEGORY_NUMERIC_EDITED) {
                        return cb_build_move_call (src, dst);
                }
                if (l->size == 1) {
                        return cb_build_funcall_3 ("memset",
                                           cb_build_cast_address (dst),
                                           cb_int (l->data[0]), cb_build_cast_length (dst));
                }
                bbyte = l->data[0];
                for (i = 0; i < (int)l->size; i++) {
                        if (bbyte != l->data[i]) {
                                break;
                        }
                        bbyte = l->data[i];
                }
                if (i == (int)l->size) {
                        return cb_build_funcall_3 ("memset",
                                           cb_build_cast_address (dst),
                                           cb_int (l->data[0]), cb_build_cast_length (dst));
                }
                if (f->size > 128) {
                        return cb_build_move_call (src, dst);
                }
                buff = cobc_malloc ((size_t)f->size);
                for (i = 0; i < f->size; i++) {
                        buff[i] = l->data[i % l->size];
                }
                return cb_build_funcall_3 ("memcpy",
                                           cb_build_cast_address (dst),
                                           cb_build_string (buff, f->size), cb_build_cast_length (dst));
        } else if ((cat == CB_CATEGORY_NUMERIC
                    && f->usage == CB_USAGE_DISPLAY
                    && f->pic->scale == l->scale && !f->flag_sign_leading && !f->flag_sign_separate)
                   || ((cat == CB_CATEGORY_ALPHABETIC || cat == CB_CATEGORY_ALPHANUMERIC)
                       && f->size < (int) (l->size + 16) && !cb_field_variable_size (f))) {
                buff = cobc_malloc ((size_t)f->size);
                diff = (int) (f->size - l->size);
                if (cat == CB_CATEGORY_NUMERIC) {
                        if (diff <= 0) {
                                memcpy (buff, l->data - diff, (size_t)f->size);
                        } else {
                                memset (buff, '0', (size_t)diff);
                                memcpy (buff + diff, l->data, (size_t)l->size);
                        }
                        if (f->pic->have_sign) {
                                p = &buff[f->size - 1];
                                if (cb_display_sign) {
                                        cob_put_sign_ebcdic (p, l->sign);
                                } else if (l->sign < 0) {
#ifdef  COB_EBCDIC_MACHINE
                                        cob_put_sign_ascii (p);
#else
                                        *p += 0x40;
#endif
                                }
                        }
                } else {
                        if (f->flag_justified) {
                                if (diff <= 0) {
                                        memcpy (buff, l->data - diff, (size_t)f->size);
                                } else {
                                        memset (buff, ' ', (size_t)diff);
                                        memcpy (buff + diff, l->data, (size_t)l->size);
                                }
                        } else {
                                if (diff <= 0) {
                                        memcpy (buff, l->data, (size_t)f->size);
                                } else {
                                        memcpy (buff, l->data, (size_t)l->size);
                                        memset (buff + l->size, ' ', (size_t)diff);
                                }
                        }
                }
                bbyte = *buff;
                if (f->size == 1) {
                        free (buff);
                        return cb_build_funcall_2 ("$E", dst, cb_int (bbyte));
                }
                for (i = 0; i < f->size; i++) {
                        if (bbyte != buff[i]) {
                                break;
                        }
                }
                if (i == f->size) {
                        free (buff);
                        return cb_build_funcall_3 ("memset",
                                           cb_build_cast_address (dst),
                                           cb_int (bbyte), cb_build_cast_length (dst));
                }
                return cb_build_funcall_3 ("memcpy",
                                           cb_build_cast_address (dst),
                                           cb_build_string (buff, f->size),
                                           cb_build_cast_length (dst));
        } else if (cb_fits_int (src) && f->size <= 8 &&
                   (f->usage == CB_USAGE_BINARY || f->usage == CB_USAGE_COMP_5 ||
                    f->usage == CB_USAGE_COMP_X)) {
                val = cb_get_int (src);
                n = f->pic->scale - l->scale;
                if ((l->size + n) > 9) {
                        return cb_build_move_call (src, dst);
                }
                for (; n > 0; n--) {
                        val *= 10;
                }
                for (; n < 0; n++) {
                        val /= 10;
                }
                if (val == 0) {
                        return cb_build_move_num_zero (dst);
                }
                if (f->size == 1) {
                        return cb_build_assign (dst, cb_int (val));
                }
                if (f->flag_binary_swap) {
                        i = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0));
                        return cb_build_funcall_2 (bin_set_funcs[i],
                                cb_build_cast_address (dst),
                                cb_int (val));
                }
                switch (f->size) {
                case 2:
#ifdef  COB_SHORT_BORK
                        if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
                           (f->offset % 4 == 0)) {
                                return cb_build_assign (dst, cb_int (val));
                        }
                        break;
#endif
                case 4:
                case 8:
#ifdef  COB_NON_ALIGNED
                        if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
                           (f->offset % f->size == 0)) {
                                return cb_build_assign (dst, cb_int (val));
                        }
                        break;
#else
                        return cb_build_assign (dst, cb_int (val));
#endif
                }
                return cb_build_move_call (src, dst);
        } else if (cb_fits_int (src) && f->usage == CB_USAGE_PACKED) {
                if (f->pic->scale < 0) {
                        return cb_build_move_call (src, dst);
                }
                val = cb_get_int (src);
                n = f->pic->scale - l->scale;
                if ((l->size + n) > 9) {
                        return cb_build_move_call (src, dst);
                }
                for (; n > 0; n--) {
                        val *= 10;
                }
                for (; n < 0; n++) {
                        val /= 10;
                }
                if (val == 0) {
                        return cb_build_move_num_zero (dst);
                }
                return cb_build_funcall_2 ("cob_set_packed_int", dst, cb_int (val));
        } else {
                return cb_build_move_call (src, dst);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_move_low ( cb_tree  x) [static]

Definition at line 4573 of file typeck.c.

{
        switch (CB_TREE_CATEGORY (x)) {
        case CB_CATEGORY_NUMERIC:
        case CB_CATEGORY_ALPHABETIC:
        case CB_CATEGORY_ALPHANUMERIC:
                if (cb_low == cb_norm_low) {
                        return cb_build_memset (x, 0);
                } else {
                        return cb_build_move_call (cb_low, x);
                }
        default:
                return cb_build_move_call (cb_low, x);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_move_num_zero ( cb_tree  x) [static]

Definition at line 4475 of file typeck.c.

{
        struct cb_field *f;

        f = cb_field (x);
        switch (f->usage) {
        case CB_USAGE_BINARY:
        case CB_USAGE_COMP_5:
        case CB_USAGE_COMP_X:
                if (f->flag_binary_swap) {
                        return cb_build_memset (x, 0);
                }
                switch (f->size) {
#ifdef  COB_NON_ALIGNED
                case 1:
                        return cb_build_assign (x, cb_int0);
                case 2:
#ifdef  COB_SHORT_BORK
                        if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
                           (f->offset % 4 == 0)) {
                                return cb_build_assign (x, cb_int0);
                        }
                        break;
#endif
                case 4:
                case 8:
                        if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
                           (f->offset % f->size == 0)) {
                                return cb_build_assign (x, cb_int0);
                        }
                        break;
#else
                case 1:
                case 2:
                case 4:
                case 8:
                        return cb_build_assign (x, cb_int0);
#endif
                }
                return cb_build_memset (x, 0);
        case CB_USAGE_DISPLAY:
                return cb_build_memset (x, '0');
        case CB_USAGE_PACKED:
                return cb_build_funcall_1 ("cob_set_packed_zero", x);
        default:
                return cb_build_move_call (cb_zero, x);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_move_quote ( cb_tree  x) [static]

Definition at line 4590 of file typeck.c.

{
        switch (CB_TREE_CATEGORY (x)) {
        case CB_CATEGORY_NUMERIC:
        case CB_CATEGORY_ALPHABETIC:
        case CB_CATEGORY_ALPHANUMERIC:
                return cb_build_memset (x, '"');
        default:
                return cb_build_move_call (cb_quote, x);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_move_space ( cb_tree  x) [static]

Definition at line 4525 of file typeck.c.

{
        switch (CB_TREE_CATEGORY (x)) {
        case CB_CATEGORY_NUMERIC:
        case CB_CATEGORY_ALPHABETIC:
        case CB_CATEGORY_ALPHANUMERIC:
                return cb_build_memset (x, ' ');
        default:
                return cb_build_move_call (cb_space, x);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_move_zero ( cb_tree  x) [static]

Definition at line 4538 of file typeck.c.

{
        switch (CB_TREE_CATEGORY (x)) {
        case CB_CATEGORY_NUMERIC:
                if (cb_field (x)->flag_blank_zero) {
                        return cb_build_move_space (x);
                } else {
                        return cb_build_move_num_zero (x);
                }
        case CB_CATEGORY_ALPHABETIC:
        case CB_CATEGORY_ALPHANUMERIC:
                return cb_build_memset (x, '0');
        default:
                return cb_build_move_call (cb_zero, x);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_optim_add ( cb_tree  v,
cb_tree  n 
) [static]

Definition at line 2473 of file typeck.c.

{
        size_t          z;
        const char      *s;
        struct cb_field *f;

        if (CB_REF_OR_FIELD_P (v)) {
                f = cb_field (v);
                if (!f->pic->scale && (f->usage == CB_USAGE_BINARY ||
                    f->usage == CB_USAGE_COMP_5 ||
                    f->usage == CB_USAGE_COMP_X)) {
                        z = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0)) +
                                (16 * (f->flag_binary_swap ? 1 : 0));
#if     defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
                        switch (f->size) {
                        case 2:
#ifdef  COB_SHORT_BORK
                                s = bin_add_funcs[z];
                                break;
#endif
                        case 4:
                        case 8:
                                if (f->storage != CB_STORAGE_LINKAGE &&
                                    f->indexes == 0 && (f->offset % f->size) == 0) {
                                        s = align_bin_add_funcs[z];
                                } else {
                                        s = bin_add_funcs[z];
                                }
                                break;
                        default:
                                s = bin_add_funcs[z];
                                break;
                        }
#else
                        if (f->usage == CB_USAGE_COMP_5) {
                                switch (f->size) {
                                case 1:
                                case 2:
                                case 4:
                                case 8:
                                        return cb_build_assign (v, cb_build_binary_op (v, '+', n));
                                }
                        }
                        s = bin_add_funcs[z];
#endif
                        if (s) {
                                return cb_build_funcall_2 (s,
                                        cb_build_cast_address (v),
                                        cb_build_cast_integer (n));
                        }
                } else if (!f->pic->scale && f->usage == CB_USAGE_PACKED &&
                       f->pic->digits < 10) {
                        return cb_build_funcall_2 ("cob_add_packed_int",
                                v, cb_build_cast_integer (n));
                }

        }
        return cb_build_funcall_2 ("cob_add_int", v, cb_build_cast_integer (n));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_optim_cond ( struct cb_binary_op p) [static]

Definition at line 2189 of file typeck.c.

{
        struct cb_field *f;
        struct cb_field *fy;
        const char      *s;
        size_t          n;

        if (CB_REF_OR_FIELD_P (p->y)) {
                fy = cb_field (p->y);
                if (!fy->pic->have_sign && (fy->usage == CB_USAGE_BINARY ||
                    fy->usage == CB_USAGE_COMP_5 ||
                    fy->usage == CB_USAGE_COMP_X)) {
                        return cb_build_funcall_2 ("cob_cmp_uint", p->x, cb_build_cast_integer (p->y));
                }
        }
        if (CB_REF_OR_FIELD_P (p->x)) {
                f = cb_field (p->x);
                if (!f->pic->scale && f->usage == CB_USAGE_PACKED) {
                        if (f->pic->digits < 10) {
                                return cb_build_funcall_2 ("cob_cmp_packed_int",
                                        p->x,
                                        cb_build_cast_integer (p->y));
                        } else {
                                return cb_build_funcall_2 ("cob_cmp_packed",
                                        p->x,
                                        cb_build_cast_integer (p->y));
                        }
                }
                if (!f->pic->scale && f->usage == CB_USAGE_DISPLAY &&
                    !f->flag_sign_leading && !f->flag_sign_separate) {
                        if (cb_fits_int (p->x)) {
                                if (!f->pic->have_sign) {
                                        return cb_build_funcall_3 ("cob_cmp_numdisp",
                                                cb_build_cast_address (p->x),
                                                cb_int (f->size),
                                                cb_build_cast_integer (p->y));
                                } else {
                                        return cb_build_funcall_3 ("cob_cmp_sign_numdisp",
                                                cb_build_cast_address (p->x),
                                                cb_int (f->size),
                                                cb_build_cast_integer (p->y));
                                }
                        } else if (cb_fits_long_long (p->x)) {
                                if (!f->pic->have_sign) {
                                        return cb_build_funcall_3 ("cob_cmp_long_numdisp",
                                                cb_build_cast_address (p->x),
                                                cb_int (f->size),
                                                cb_build_cast_integer (p->y));
                                } else {
                                        return cb_build_funcall_3 ("cob_cmp_long_sign_numdisp",
                                                cb_build_cast_address (p->x),
                                                cb_int (f->size),
                                                cb_build_cast_integer (p->y));
                                }
                        }
                }
                if (!f->pic->scale && (f->usage == CB_USAGE_BINARY ||
                    f->usage == CB_USAGE_COMP_5 ||
                    f->usage == CB_USAGE_INDEX ||
                    f->usage == CB_USAGE_COMP_X)) {
                        n = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0)) +
                                (16 * (f->flag_binary_swap ? 1 : 0));
#if     defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
                        switch (f->size) {
                        case 2:
#ifdef  COB_SHORT_BORK
                                s = bin_compare_funcs[n];
                                break;
#endif
                        case 4:
                        case 8:
                                if (f->storage != CB_STORAGE_LINKAGE &&
                                    f->indexes == 0 && (f->offset % f->size) == 0) {
                                        s = align_bin_compare_funcs[n];
                                } else {
                                        s = bin_compare_funcs[n];
                                }
                                break;
                        default:
                                s = bin_compare_funcs[n];
                                break;
                        }
#else
                        s = bin_compare_funcs[n];
#endif
                        if (s) {
                                return cb_build_funcall_2 (s,
                                        cb_build_cast_address (p->x),
                                        cb_build_cast_integer (p->y));
                        }
                }
        }
        return cb_build_funcall_2 ("cob_cmp_int", p->x, cb_build_cast_integer (p->y));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_build_optim_sub ( cb_tree  v,
cb_tree  n 
) [static]

Definition at line 2534 of file typeck.c.

{
        size_t          z;
        const char      *s;
        struct cb_field *f;

        if (CB_REF_OR_FIELD_P (v)) {
                f = cb_field (v);
                if (!f->pic->scale && (f->usage == CB_USAGE_BINARY ||
                    f->usage == CB_USAGE_COMP_5 ||
                    f->usage == CB_USAGE_COMP_X)) {
                        z = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0)) +
                                (16 * (f->flag_binary_swap ? 1 : 0));
#if     defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
                        switch (f->size) {
                        case 2:
#ifdef  COB_SHORT_BORK
                                s = bin_sub_funcs[z];
                                break;
#endif
                        case 4:
                        case 8:
                                if (f->storage != CB_STORAGE_LINKAGE &&
                                    f->indexes == 0 && (f->offset % f->size) == 0) {
                                        s = align_bin_sub_funcs[z];
                                } else {
                                        s = bin_sub_funcs[z];
                                }
                                break;
                        default:
                                s = bin_sub_funcs[z];
                                break;
                        }
#else
                        if (f->usage == CB_USAGE_COMP_5) {
                                switch (f->size) {
                                case 1:
                                case 2:
                                case 4:
                                case 8:
                                        return cb_build_assign (v, cb_build_binary_op (v, '-', n));
                                }
                        }
                        s = bin_sub_funcs[z];
#endif
                        if (s) {
                                return cb_build_funcall_2 (s,
                                        cb_build_cast_address (v),
                                        cb_build_cast_integer (n));
                        }
                }

        }
        return cb_build_funcall_2 ("cob_sub_int", v, cb_build_cast_integer (n));
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_build_perform_exit ( struct cb_label label)

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;
}

Here is the call graph for this function:

cb_tree cb_build_perform_forever ( cb_tree  body)

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;
}

Here is the call graph for this function:

cb_tree cb_build_perform_once ( cb_tree  body)

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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_build_perform_times ( cb_tree  times)

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;
}

Here is the call graph for this function:

cb_tree cb_build_perform_until ( cb_tree  condition,
cb_tree  varying 
)

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;
}

Here is the call graph for this function:

cb_tree cb_build_ppointer ( cb_tree  x)

Definition at line 1038 of file typeck.c.

{
        struct cb_field *f;

        if (x == cb_error_node ||
            (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node)) {
                return cb_error_node;
        }

        if (CB_REFERENCE_P (x)) {
                f = cb_field (cb_ref(x));
                f->count++;
        }
        return cb_build_cast_ppointer (x);
}

Here is the call graph for this function:

const char* cb_build_program_id ( cb_tree  name,
cb_tree  alt_name 
)

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;
}

Here is the call graph for this function:

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);
}

Here is the call graph for this function:

cb_tree cb_build_replacing_all ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

Definition at line 3823 of file typeck.c.

{
        return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_all", y, x));
}

Here is the call graph for this function:

cb_tree cb_build_replacing_characters ( cb_tree  x,
cb_tree  l 
)

Definition at line 3817 of file typeck.c.

{
        return cb_list_add (l, cb_build_funcall_1 ("cob_inspect_characters", x));
}

Here is the call graph for this function:

cb_tree cb_build_replacing_first ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

Definition at line 3835 of file typeck.c.

{
        return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_first", y, x));
}

Here is the call graph for this function:

cb_tree cb_build_replacing_leading ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

Definition at line 3829 of file typeck.c.

{
        return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_leading", y, x));
}

Here is the call graph for this function:

cb_tree cb_build_replacing_trailing ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

Definition at line 3841 of file typeck.c.

{
        return cb_list_add (l, cb_build_funcall_2 ("cob_inspect_trailing", y, x));
}

Here is the call graph for this function:

static cb_tree cb_build_search_all ( cb_tree  table,
cb_tree  cond 
) [static]

Definition at line 5393 of file typeck.c.

{
        cb_tree         c1 = NULL;
        cb_tree         c2;
        struct cb_field *f;
        int             i;

        f = cb_field (table);
        /* set keys */
        for (i = 0; i < f->nkeys; i++) {
                f->keys[i].ref = NULL;
        }
        search_set_keys (f, cond);

        /* build condition */
        for (i = 0; i < f->nkeys; i++) {
                if (f->keys[i].ref) {
                        if (f->keys[i].dir == COB_ASCENDING) {
                                c2 = cb_build_binary_op (f->keys[i].ref, '=', f->keys[i].val);
                        } else {
                                c2 = cb_build_binary_op (f->keys[i].val, '=', f->keys[i].ref);
                        }
                        if (c1 == NULL) {
                                c1 = c2;
                        } else {
                                c1 = cb_build_binary_op (c1, '&', c2);
                        }
                }
        }

        return cb_build_cond (c1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_build_section_name ( cb_tree  name,
int  sect_or_para 
)

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;
}

Here is the call graph for this function:

cb_tree cb_build_sub ( cb_tree  v,
cb_tree  n,
cb_tree  round_opt 
)

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);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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;
}

Here is the call graph for this function:

cb_tree cb_build_tarrying_characters ( cb_tree  l)

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));
}

Here is the call graph for this function:

cb_tree cb_build_tarrying_data ( cb_tree  x)

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;
}

Here is the call graph for this function:

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;
}

Here is the call graph for this function:

cb_tree cb_build_tarrying_value ( cb_tree  x,
cb_tree  l 
)

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));
}

Here is the call graph for this function:

cb_tree cb_build_unstring_delimited ( cb_tree  all,
cb_tree  value 
)

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);
}

Here is the call graph for this function:

cb_tree cb_build_unstring_into ( cb_tree  name,
cb_tree  delimiter,
cb_tree  count 
)

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);
}

Here is the call graph for this function:

cb_tree cb_build_write_advancing_lines ( cb_tree  pos,
cb_tree  lines 
)

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);
}

Here is the call graph for this function:

cb_tree cb_build_write_advancing_mnemonic ( cb_tree  pos,
cb_tree  mnemonic 
)

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;
        }
}

Here is the call graph for this function:

cb_tree cb_build_write_advancing_page ( cb_tree  pos)

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);
}

Here is the call graph for this function:

static cb_tree cb_check_group_name ( cb_tree  x) [static]

Definition at line 367 of file typeck.c.

{
        cb_tree         y;

        if (x == cb_error_node) {
                return cb_error_node;
        }

        if (CB_REFERENCE_P (x)) {
                y = cb_ref (x);
                if (y == cb_error_node) {
                        return cb_error_node;
                }
                if (CB_FIELD_P (y) && CB_FIELD (y)->children != NULL &&
                    CB_REFERENCE (x)->offset == NULL) {
                        return x;
                }
        }

        cb_error_x (x, _("'%s' is not group name"), cb_name (x));
        return cb_error_node;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_check_integer_value ( cb_tree  x) [static]

Definition at line 441 of file typeck.c.

{
        struct cb_literal       *l;
        struct cb_field         *f;
        cb_tree                 y;

        if (x == cb_error_node) {
                return cb_error_node;
        }

        if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
                goto invalid;
        }

        switch (CB_TREE_TAG (x)) {
        case CB_TAG_CONST:
                if (x != cb_zero) {
                        goto invalid;
                }
                return x;
        case CB_TAG_LITERAL:
                l = CB_LITERAL (x);
                if (l->sign < 0 || l->scale > 0) {
                        goto invliteral;
                }
                return x;
        case CB_TAG_REFERENCE:
                y = cb_ref (x);
                if (y == cb_error_node) {
                        return cb_error_node;
                }
                f = CB_FIELD (y);
                if (f->pic->scale > 0) {
                        goto invalid;
                }
                return x;
        case CB_TAG_BINARY_OP:
                /* TODO: need to check */
                return x;
        case CB_TAG_INTRINSIC:
                /* TODO: need to check */
                return x;
        default:
invalid:
                cb_error_x (x, _("'%s' is not an integer value"), cb_name (x));
                return cb_error_node;
        }
invliteral:
        cb_error_x (x, _("A positive numeric integer is required here"));
        return cb_error_node;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_check_numeric_edited_name ( cb_tree  x) [static]

Definition at line 408 of file typeck.c.

{
        if (x == cb_error_node) {
                return cb_error_node;
        }

        if (CB_REFERENCE_P (x)
            && CB_FIELD_P (cb_ref (x))
            && (CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC
                || CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC_EDITED)) {
                return x;
        }

        cb_error_x (x, _("'%s' is not numeric or numeric-edited name"), cb_name (x));
        return cb_error_node;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree cb_check_numeric_name ( cb_tree  x) [static]

Definition at line 391 of file typeck.c.

{
        if (x == cb_error_node) {
                return cb_error_node;
        }

        if (CB_REFERENCE_P (x)
            && CB_FIELD_P (cb_ref (x))
            && CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
                return x;
        }

        cb_error_x (x, _("'%s' is not a numeric name"), cb_name (x));
        return cb_error_node;
}

Here is the call graph for this function:

Here is the caller graph for this function:

cb_tree cb_check_numeric_value ( cb_tree  x)

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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int cb_chk_alpha_cond ( cb_tree  x) [static]

Definition at line 2329 of file typeck.c.

{
        if (current_program->alphabet_name_list) {
                return 0;
        }
        if (CB_LITERAL_P (x)) {
                return 1;
        }
        if (!CB_REFERENCE_P (x) && !CB_FIELD_P (x)) {
                return 0;
        }
        if (CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHANUMERIC &&
            CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHABETIC) {
                return 0;
        }
        if (cb_field_variable_size (cb_field (x))) {
                return 0;
        }
        if (cb_field_size (x) < 0) {
                return 0;
        }
        return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int cb_chk_num_cond ( cb_tree  x,
cb_tree  y 
) [static]

Definition at line 2285 of file typeck.c.

{
        struct cb_field         *fx;
        struct cb_field         *fy;

        if (!CB_REFERENCE_P (x) && !CB_FIELD_P (x)) {
                return 0;
        }
        if (!CB_REFERENCE_P (y) && !CB_FIELD_P (y)) {
                return 0;
        }
        if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
                return 0;
        }
        if (CB_TREE_CATEGORY (y) != CB_CATEGORY_NUMERIC) {
                return 0;
        }
        if (CB_TREE_CLASS (x) != CB_CLASS_NUMERIC) {
                return 0;
        }
        if (CB_TREE_CLASS (y) != CB_CLASS_NUMERIC) {
                return 0;
        }
        fx = cb_field (x);
        fy = cb_field (y);
        if (fx->usage != CB_USAGE_DISPLAY) {
                return 0;
        }
        if (fy->usage != CB_USAGE_DISPLAY) {
                return 0;
        }
        if (fx->pic->have_sign || fy->pic->have_sign) {
                return 0;
        }
        if (fx->size != fy->size) {
                return 0;
        }
        if (fx->pic->scale != fy->pic->scale) {
                return 0;
        }
        return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cb_define_switch_name ( cb_tree  name,
cb_tree  sname,
cb_tree  flag,
cb_tree  ref 
)

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);
        }
}

Here is the call graph for this function:

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));
        }
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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)));
}

Here is the call graph for this function:

void cb_emit_accept_mnemonic ( cb_tree  var,
cb_tree  mnemonic 
)

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;
        }
}

Here is the call graph for this function:

void cb_emit_accept_name ( cb_tree  var,
cb_tree  name 
)

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

void cb_emit_allocate ( cb_tree  target1,
cb_tree  target2,
cb_tree  size,
cb_tree  initialize 
)

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);
        }
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

void cb_emit_arithmetic ( cb_tree  vars,
int  op,
cb_tree  val 
)

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

void cb_emit_close ( cb_tree  file,
cb_tree  opt 
)

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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.

Here is the call graph for this function:

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);
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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++;
                        }
                }
        }
}

Here is the call graph for this function:

void cb_emit_divide ( cb_tree  dividend,
cb_tree  divisor,
cb_tree  quotient,
cb_tree  remainder 
)

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)));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

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));
}

Here is the call graph for this function:

void cb_emit_evaluate ( cb_tree  subject_list,
cb_tree  case_list 
)

Definition at line 3601 of file typeck.c.

{
        cb_emit (build_evaluate (subject_list, case_list));
}

Here is the call graph for this function:

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));
        }
}

Here is the call graph for this function:

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);
                }
        }
}

Here is the call graph for this function:

void cb_emit_get_environment ( cb_tree  envvar,
cb_tree  envval 
)

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));
}

Here is the call graph for this function:

void cb_emit_goto ( cb_tree  target,
cb_tree  depending 
)

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));
                }
        }
}

Here is the call graph for this function:

void cb_emit_if ( cb_tree  cond,
cb_tree  stmt1,
cb_tree  stmt2 
)

Definition at line 3689 of file typeck.c.

{
        cb_emit (cb_build_if (cond, stmt1, stmt2));
}

Here is the call graph for this function:

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));
        }
}

Here is the call graph for this function:

void cb_emit_inspect ( cb_tree  var,
cb_tree  body,
cb_tree  replacing,
int  replconv 
)

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"));
}

Here is the call graph for this function:

void cb_emit_move ( cb_tree  src,
cb_tree  dsts 
)

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)));
        }
}

Here is the call graph for this function:

void cb_emit_move_corresponding ( cb_tree  x1,
cb_tree  x2 
)

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);
        }
}

Here is the call graph for this function:

void cb_emit_open ( cb_tree  file,
cb_tree  mode,
cb_tree  sharing 
)

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));
}

Here is the call graph for this function:

void cb_emit_perform ( cb_tree  perform,
cb_tree  body 
)

Definition at line 5095 of file typeck.c.

{
        if (perform == cb_error_node) {
                return;
        }
        CB_PERFORM (perform)->body = body;
        cb_emit (perform);
}
void cb_emit_read ( cb_tree  ref,
cb_tree  next,
cb_tree  into,
cb_tree  key,
cb_tree  lock_opts 
)

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;
}

Here is the call graph for this function:

void cb_emit_release ( cb_tree  record,
cb_tree  from 
)

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));
}

Here is the call graph for this function:

void cb_emit_return ( cb_tree  ref,
cb_tree  into 
)

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;
}

Here is the call graph for this function:

void cb_emit_rewrite ( cb_tree  record,
cb_tree  from,
cb_tree  lockopt 
)

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));
}

Here is the call graph for this function:

void cb_emit_rollback ( void  )

Definition at line 5349 of file typeck.c.

{
        cb_emit (cb_build_funcall_0 ("cob_rollback"));
}
void cb_emit_search ( cb_tree  table,
cb_tree  varying,
cb_tree  at_end,
cb_tree  whens 
)

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));
}

Here is the call graph for this function:

void cb_emit_search_all ( cb_tree  table,
cb_tree  at_end,
cb_tree  when,
cb_tree  stmts 
)

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)));
}

Here is the call graph for this function:

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));
        }
}

Here is the call graph for this function:

void cb_emit_set_on_off ( cb_tree  l,
cb_tree  flag 
)

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));
        }
}

Here is the call graph for this function:

void cb_emit_set_to ( cb_tree  vars,
cb_tree  x 
)

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)));
        }
}

Here is the call graph for this function:

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));
        }
}

Here is the call graph for this function:

void cb_emit_set_up_down ( cb_tree  l,
cb_tree  flag,
cb_tree  x 
)

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));
                }
        }
}

Here is the call graph for this function:

void cb_emit_setenv ( cb_tree  x,
cb_tree  y 
)

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 5741 of file typeck.c.

{
        if (CB_FILE_P (cb_ref (file))) {
                cb_emit (cb_build_funcall_1 ("cob_file_sort_close", cb_ref (file)));
        }
}

Here is the call graph for this function:

void cb_emit_sort_giving ( cb_tree  file,
cb_tree  l 
)

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);
}

Here is the call graph for this function:

void cb_emit_sort_init ( cb_tree  name,
cb_tree  keys,
cb_tree  col 
)

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))));
        }
}

Here is the call graph for this function:

void cb_emit_sort_input ( cb_tree  proc)

Definition at line 5709 of file typeck.c.

Here is the call graph for this function:

void cb_emit_sort_output ( cb_tree  proc)

Definition at line 5735 of file typeck.c.

Here is the call graph for this function:

void cb_emit_sort_using ( cb_tree  file,
cb_tree  l 
)

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))));
        }
}

Here is the call graph for this function:

void cb_emit_start ( cb_tree  file,
cb_tree  op,
cb_tree  key 
)

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));
        }
}

Here is the call graph for this function:

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)));
}
void cb_emit_string ( cb_tree  items,
cb_tree  into,
cb_tree  pointer 
)

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"));
}

Here is the call graph for this function:

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;
        }
}

Here is the call graph for this function:

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"));
}

Here is the call graph for this function:

void cb_emit_write ( cb_tree  record,
cb_tree  from,
cb_tree  opt,
cb_tree  lockopt 
)

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));
        }
}

Here is the call graph for this function:

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);
}

Here is the caller graph for this function:

static cb_tree cb_expr_finish ( void  ) [static]

Definition at line 1798 of file typeck.c.

{
        expr_reduce (0);        /* reduce all */

        if (expr_index != 4) {
                cb_error (_("Invalid expression"));
                return cb_error_node;
        }

        if (!expr_stack[3].value) {
                cb_error (_("Invalid expression"));
                return cb_error_node;
        }
        expr_expand (&expr_stack[3].value);
        if (expr_stack[3].token != 'x') {
                cb_error (_("Invalid expression"));
                return cb_error_node;
        }
        return expr_stack[3].value;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void cb_expr_init ( void  ) [static]

Definition at line 1445 of file typeck.c.

{
        static int initialized = 0;

        if (initialized == 0) {
                /* init priority talble */
                expr_prio['x'] = 0;
                expr_prio['^'] = 1;
                expr_prio['*'] = 2;
                expr_prio['/'] = 2;
                expr_prio['+'] = 3;
                expr_prio['-'] = 3;
                expr_prio['='] = 4;
                expr_prio['~'] = 4;
                expr_prio['<'] = 4;
                expr_prio['>'] = 4;
                expr_prio['['] = 4;
                expr_prio[']'] = 4;
                expr_prio['!'] = 5;
                expr_prio['&'] = 6;
                expr_prio['|'] = 7;
                expr_prio[')'] = 8;
                expr_prio['('] = 9;
                expr_prio[0] = 10;
                /* init stack */
                expr_stack_size = START_STACK_SIZE;
                expr_stack = cobc_malloc (sizeof (struct expr_node) * START_STACK_SIZE);
                expr_stack[0].token = 0;        /* dummy */
                expr_stack[1].token = 0;        /* dummy */
                expr_stack[2].token = 0;        /* dummy */
                initialized = 1;
        }

        expr_op = 0;
        expr_lh = NULL;
        expr_index = 3;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void cb_expr_shift ( int  token,
cb_tree  value 
) [static]

Definition at line 1667 of file typeck.c.

{
        switch (token) {
        case 'x':
                /* sign ZERO condition */
                if (value == cb_zero) {
                        if (TOKEN (-1) == 'x' || TOKEN (-1) == '!') {
                                cb_expr_shift_sign ('=');
                                return;
                        }
                }

                /* class condition */
                if (CB_REFERENCE_P (value)
                    && CB_CLASS_NAME_P (cb_ref (value))) {
                        cb_expr_shift_class (CB_CLASS_NAME (cb_ref (value))->cname);
                        return;
                }

                /* unary sign */
                if ((TOKEN (-1) == '+' || TOKEN (-1) == '-') && TOKEN (-2) != 'x') {
                        if (TOKEN (-1) == '-') {
                                value = cb_build_binary_op (cb_zero, '-', value);
                        }
                        expr_index -= 1;
                }
                break;

        case '(':
                /* 'x' op '(' --> '(' 'x' op */
                switch (TOKEN (-1)) {
                case '=':
                case '~':
                case '<':
                case '>':
                case '[':
                case ']':
                        expr_op = TOKEN (-1);
                        if (TOKEN (-2) == 'x') {
                                expr_lh = VALUE (-2);
                        }
                }
                break;

        case ')':
                /* enclose by parentheses */
                expr_reduce (token);
                if (TOKEN (-2) == '(') {
                        value = cb_build_parenthesis (VALUE (-1));
                        expr_index -= 2;
                        cb_expr_shift ('x', value);
                        return;
                }
                break;

        default:
                /* '<' '|' '=' --> '[' */
                /* '>' '|' '=' --> ']' */
                if (token == '=' && TOKEN (-1) == '|' && (TOKEN (-2) == '<' || TOKEN (-2) == '>')) {
                        token = (TOKEN (-2) == '<') ? '[' : ']';
                        expr_index -= 2;
                }

                /* '!' '=' --> '~', etc. */
                if (TOKEN (-1) == '!') {
                        switch (token) {
                        case '=':
                                token = '~';
                                expr_index--;
                                break;
                        case '~':
                                token = '=';
                                expr_index--;
                                break;
                        case '<':
                                token = ']';
                                expr_index--;
                                break;
                        case '>':
                                token = '[';
                                expr_index--;
                                break;
                        case '[':
                                token = '>';
                                expr_index--;
                                break;
                        case ']':
                                token = '<';
                                expr_index--;
                                break;
                        }
                }
                break;
        }

        /* reduce */
        expr_reduce (token);

        /* allocate sufficient stack memory */
        if (expr_index >= expr_stack_size) {
                expr_stack_size *= 2;
                expr_stack = cobc_realloc (expr_stack, sizeof (struct expr_node) * expr_stack_size);
        }

        /* put on the stack */
        TOKEN (0) = token;
        VALUE (0) = value;
        expr_index++;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void cb_expr_shift_class ( const char *  name) [static]

Definition at line 1649 of file typeck.c.

{
        int     have_not = 0;

        if (TOKEN (-1) == '!') {
                have_not = 1;
                expr_index--;
        }
        expr_reduce ('=');
        if (TOKEN (-1) == 'x') {
                VALUE (-1) = cb_build_funcall_1 (name, VALUE (-1));
                if (have_not) {
                        VALUE (-1) = cb_build_negation (VALUE (-1));
                }
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void cb_expr_shift_sign ( const int  op) [static]

Definition at line 1631 of file typeck.c.

{
        int     have_not = 0;

        if (TOKEN (-1) == '!') {
                have_not = 1;
                expr_index--;
        }
        expr_reduce ('=');
        if (TOKEN (-1) == 'x') {
                VALUE (-1) = cb_build_binary_op (VALUE (-1), op, cb_zero);
                if (have_not) {
                        VALUE (-1) = cb_build_negation (VALUE (-1));
                }
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cb_init_tarrying ( void  )

Definition at line 3754 of file typeck.c.

static size_t cb_validate_list ( cb_tree  l) [static]

Definition at line 356 of file typeck.c.

{
        for (; l; l = CB_CHAIN (l)) {
                if (cb_validate_one (CB_VALUE (l))) {
                        return 1;
                }
        }
        return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static size_t cb_validate_one ( cb_tree  x) [static]

Definition at line 332 of file typeck.c.

{
        cb_tree         y;

        if (x == cb_error_node) {
                return 1;
        }
        if (!x) {
                return 0;
        }
        if (CB_REFERENCE_P (x)) {
                y = cb_ref (x);
                if (y == cb_error_node) {
                        return 1;
                }
                if (CB_FIELD_P (y) && CB_FIELD (y)->level == 88) {
                        cb_error_x (x, _("Invalid use of 88 level item"));
                        return 1;
                }
        }
        return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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);
}

Here is the call graph for this function:

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"));
                                }
                        }
                }
        }
}

Here is the call graph for this function:

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;
        }
}

Here is the call graph for this function:

static void cob_put_sign_ebcdic ( unsigned char *  p,
const int  sign 
) [static]

Definition at line 4642 of file typeck.c.

{
        if (sign < 0) {
                switch (*p) {
                case '0':
                        *p = (unsigned char)'}';
                        return;
                case '1':
                        *p = (unsigned char)'J';
                        return;
                case '2':
                        *p = (unsigned char)'K';
                        return;
                case '3':
                        *p = (unsigned char)'L';
                        return;
                case '4':
                        *p = (unsigned char)'M';
                        return;
                case '5':
                        *p = (unsigned char)'N';
                        return;
                case '6':
                        *p = (unsigned char)'O';
                        return;
                case '7':
                        *p = (unsigned char)'P';
                        return;
                case '8':
                        *p = (unsigned char)'Q';
                        return;
                case '9':
                        *p = (unsigned char)'R';
                        return;
                default:
                        /* What to do here */
                        *p = (unsigned char)'}';
                        return;
                }
        }
        switch (*p) {
        case '0':
                *p = (unsigned char)'{';
                return;
        case '1':
                *p = (unsigned char)'A';
                return;
        case '2':
                *p = (unsigned char)'B';
                return;
        case '3':
                *p = (unsigned char)'C';
                return;
        case '4':
                *p = (unsigned char)'D';
                return;
        case '5':
                *p = (unsigned char)'E';
                return;
        case '6':
                *p = (unsigned char)'F';
                return;
        case '7':
                *p = (unsigned char)'G';
                return;
        case '8':
                *p = (unsigned char)'H';
                return;
        case '9':
                *p = (unsigned char)'I';
                return;
        default:
                /* What to do here */
                *p = (unsigned char)'{';
                return;
        }
/* NOT REACHED */
}

Here is the caller graph for this function:

static int count_pic_alphanumeric_edited ( struct cb_field field) [static]

Definition at line 3927 of file typeck.c.

{
        int             count;
        int             repeat;
        unsigned char   *p;

        count = 0;
        for (p = (unsigned char *)(field->pic->str); *p; p += 5) {
                if (*p == '9' || *p == 'A' || *p == 'X') {
                        memcpy ((unsigned char *)&repeat, p + 1, sizeof(int));
                        count += repeat;
                }
        }
        return count;
}

Here is the caller graph for this function:

static cb_tree decimal_alloc ( void  ) [static]

Definition at line 1930 of file typeck.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static void decimal_assign ( cb_tree  x,
cb_tree  d,
cb_tree  round_opt 
) [static]

Definition at line 2048 of file typeck.c.

{
        dpush (cb_build_funcall_3 ("cob_decimal_get_field", d, x, build_store_option (x, round_opt)));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void decimal_compute ( const int  op,
cb_tree  x,
cb_tree  y 
) [static]

Definition at line 1949 of file typeck.c.

{
        const char *func;

        switch (op) {
        case '+':
                func = "cob_decimal_add";
                break;
        case '-':
                func = "cob_decimal_sub";
                break;
        case '*':
                func = "cob_decimal_mul";
                break;
        case '/':
                func = "cob_decimal_div";
                break;
        case '^':
                func = "cob_decimal_pow";
                break;
        default:
                fprintf (stderr, "Unexpected operation %d\n", op);
                ABORT ();
        }
        dpush (cb_build_funcall_2 (func, x, y));
}

Here is the caller graph for this function:

static void decimal_expand ( cb_tree  d,
cb_tree  x 
) [static]

Definition at line 1977 of file typeck.c.

{
        struct cb_literal       *l;
        struct cb_field         *f;
        struct cb_binary_op     *p;
        cb_tree                 t;

        switch (CB_TREE_TAG (x)) {
        case CB_TAG_CONST:
                if (x == cb_zero) {
                        dpush (cb_build_funcall_2 ("cob_decimal_set_int", d, cb_int0));
                        current_program->gen_decset = 1;
                } else {
                        fprintf (stderr, "Unexpected constant expansion\n");
                        ABORT ();
                }
                break;
        case CB_TAG_LITERAL:
                /* set d, N */
                l = CB_LITERAL (x);
                if (l->size < 10 && l->scale == 0) {
                        dpush (cb_build_funcall_2 ("cob_decimal_set_int", d, cb_build_cast_integer (x)));
                        current_program->gen_decset = 1;
                } else {
                        dpush (cb_build_funcall_2 ("cob_decimal_set_field", d, x));
                }
                break;
        case CB_TAG_REFERENCE:
                /* set d, X */
                f = cb_field (x);
                /* check numeric */
                if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE)) {
                        if (f->usage == CB_USAGE_DISPLAY || f->usage == CB_USAGE_PACKED) {
                                dpush (cb_build_funcall_2 ("cob_check_numeric",
                                                           x, cb_build_string0 ((ucharptr)(f->name))));
                        }
                }

                if (cb_fits_int (x)) {
                        if (f->pic->have_sign) {
                                dpush (cb_build_funcall_2 ("cob_decimal_set_int", d, cb_build_cast_integer (x)));
                                current_program->gen_decset = 1;
                        } else {
                                dpush (cb_build_funcall_2 ("cob_decimal_set_uint", d, cb_build_cast_integer (x)));
                                current_program->gen_udecset = 1;
                        }
                } else {
                        dpush (cb_build_funcall_2 ("cob_decimal_set_field", d, x));
                }
                break;
        case CB_TAG_BINARY_OP:
                /* set d, X
                 * set t, Y
                 * OP d, t */
                p = CB_BINARY_OP (x);
                t = decimal_alloc ();
                decimal_expand (d, p->x);
                decimal_expand (t, p->y);
                decimal_compute (p->op, d, t);
                decimal_free ();
                break;
        case CB_TAG_INTRINSIC:
                dpush (cb_build_funcall_2 ("cob_decimal_set_field", d, x));
                break;
        default:
                fprintf (stderr, "Unexpected tree tag %d\n", CB_TREE_TAG (x));
                ABORT ();
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void decimal_free ( void  ) [static]

Definition at line 1943 of file typeck.c.

Here is the caller graph for this function:

static void emit_corresponding ( cb_tree(*)(cb_tree f1, cb_tree f2, cb_tree f3)  func,
cb_tree  x1,
cb_tree  x2,
cb_tree  opt 
) [static]

Definition at line 2668 of file typeck.c.

{
        struct cb_field *f1, *f2;
        cb_tree         t1;
        cb_tree         t2;

        for (f1 = cb_field (x1)->children; f1; f1 = f1->sister) {
                if (!f1->redefines && !f1->flag_occurs) {
                        for (f2 = cb_field (x2)->children; f2; f2 = f2->sister) {
                                if (!f2->redefines && !f2->flag_occurs) {
                                        if (strcmp (f1->name, f2->name) == 0) {
                                                t1 = cb_build_field_reference (f1, x1);
                                                t2 = cb_build_field_reference (f2, x2);
                                                if (f1->children && f2->children) {
                                                        emit_corresponding (func, t1, t2, opt);
                                                } else {
                                                        cb_emit (func (t1, t2, opt));
                                                }
                                        }
                                }
                        }
                }
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void emit_move_corresponding ( cb_tree  x1,
cb_tree  x2 
) [static]

Definition at line 2712 of file typeck.c.

{
        struct cb_field *f1, *f2;
        cb_tree         t1;
        cb_tree         t2;

        for (f1 = cb_field (x1)->children; f1; f1 = f1->sister) {
                if (!f1->redefines && !f1->flag_occurs) {
                        for (f2 = cb_field (x2)->children; f2; f2 = f2->sister) {
                                if (!f2->redefines && !f2->flag_occurs) {
                                        if (strcmp (f1->name, f2->name) == 0) {
                                                t1 = cb_build_field_reference (f1, x1);
                                                t2 = cb_build_field_reference (f2, x2);
                                                if (f1->children && f2->children) {
                                                        emit_move_corresponding (t1, t2);
                                                } else {
                                                        cb_emit (cb_build_move (t1, t2));
                                                }
                                        }
                                }
                        }
                }
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cb_tree evaluate_test ( cb_tree  s,
cb_tree  o 
) [static]

Definition at line 3490 of file typeck.c.

{
        int     flag;
        cb_tree x, y;
        cb_tree t;

        /* ANY is always true */
        if (o == cb_any) {
                return cb_true;
        }

        /* object TRUE or FALSE */
        if (o == cb_true) {
                return s;
        }
        if (o == cb_false) {
                return cb_build_negation (s);
        }

        flag = CB_PURPOSE_INT (o);
        x = CB_PAIR_X (CB_VALUE (o));
        y = CB_PAIR_Y (CB_VALUE (o));

        /* subject TRUE or FALSE */
        if (s == cb_true) {
                return flag ? cb_build_negation (x) : x;
        }
        if (s == cb_false) {
                return flag ? x : cb_build_negation (x);
        }

        /* x THRU y */
        if (y) {
                t = cb_build_binary_op (cb_build_binary_op (x, '[', s),
                                                '&',
                                                cb_build_binary_op (s, '[', y));

                return flag ? cb_build_negation (t) : t;
        }

        if (CB_REFERENCE_P(x) && CB_FIELD_P(CB_REFERENCE(x)->value) &&
            CB_FIELD(CB_REFERENCE(x)->value)->level == 88) {
                cb_error_x (CB_TREE (current_statement),
                        _("Invalid use of 88 level in WHEN expression"));
                return NULL;
        }

        /* regular comparison */
        if (flag) {
                return cb_build_binary_op (s, '~', x);
        } else {
                return cb_build_binary_op (s, '=', x);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void expr_expand ( cb_tree x) [static]

Definition at line 1778 of file typeck.c.

{
        struct cb_binary_op     *p;

start:
        /* remove parenthesis */
        if (CB_BINARY_OP_P (*x)) {
                p = CB_BINARY_OP (*x);
                if (p->op == '@') {
                        *x = p->x;
                        goto start;
                }
                expr_expand (&p->x);
                if (p->y) {
                        expr_expand (&p->y);
                }
        }
}

Here is the caller graph for this function:

static int expr_reduce ( int  token) [static]

Definition at line 1484 of file typeck.c.

{
        /* Example:
         * index: -3  -2  -1   0
         * token: 'x' '*' 'x' '+' ...
         */

        int     op;

        while (expr_prio[TOKEN (-2)] <= expr_prio[token]) {
                /* Reduce the expression depending on the last operator */
                op = TOKEN (-2);
                switch (op) {
                case 'x':
                        return 0;

                case '+':
                case '-':
                case '*':
                case '/':
                case '^':
                        /* Arithmetic operators: 'x' op 'x' */
                        if (TOKEN (-1) != 'x' || TOKEN (-3) != 'x') {
                                return -1;
                        }
                        TOKEN (-3) = 'x';
                        VALUE (-3) = cb_build_binary_op (VALUE (-3), op, VALUE (-1));
                        expr_index -= 2;
                        break;

                case '!':
                        /* Negation: '!' 'x' */
                        if (TOKEN (-1) != 'x') {
                                return -1;
                        }
                        /* 'x' '=' 'x' '|' '!' 'x' */
                        if (expr_lh) {
                                if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
                                        VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
                                }
                        }
                        TOKEN (-2) = 'x';
                        VALUE (-2) = cb_build_negation (VALUE (-1));
                        expr_index -= 1;
                        break;

                case '&':
                case '|':
                        /* Logical AND/OR: 'x' op 'x' */
                        if (TOKEN (-1) != 'x' || TOKEN (-3) != 'x') {
                                return -1;
                        }
                        /* 'x' '=' 'x' '|' 'x' */
                        if (expr_lh) {
                                if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
                                        VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
                                }
                                if (CB_TREE_CLASS (VALUE (-3)) != CB_CLASS_BOOLEAN) {
                                        VALUE (-3) = cb_build_binary_op (expr_lh, expr_op, VALUE (-3));
                                }
                        }
                        /* warning for complex expressions without explicit parentheses
                           (i.e., "a OR b AND c" or "a AND b OR c") */
                        if (cb_warn_parentheses && op == '|') {
                                if ((CB_BINARY_OP_P (VALUE (-3))
                                     && CB_BINARY_OP (VALUE (-3))->op == '&')
                                    || (CB_BINARY_OP_P (VALUE (-1))
                                        && CB_BINARY_OP (VALUE (-1))->op == '&')) {
                                        cb_warning (_("Suggest parentheses around AND within OR"));
                                }
                        }
                        TOKEN (-3) = 'x';
                        VALUE (-3) = cb_build_binary_op (VALUE (-3), op, VALUE (-1));
                        expr_index -= 2;
                        break;

                case '(':
                case ')':
                        return 0;

                default:
                        /* Relational operators */
                        if (TOKEN (-1) != 'x') {
                                return -1;
                        }
                        switch (TOKEN (-3)) {
                        case 'x':
                                /* Simple condition: 'x' op 'x' */
                                if (VALUE (-3) == cb_error_node || VALUE (-1) == cb_error_node) {
                                        VALUE (-3) = cb_error_node;
                                } else {
                                        expr_lh = VALUE (-3);
                                        if (CB_REF_OR_FIELD_P (expr_lh)) {
                                                if (cb_field (expr_lh)->level == 88) {
                                                        VALUE (-3) = cb_error_node;
                                                        return -1;
                                                }
                                        }
                                        if (CB_REF_OR_FIELD_P (VALUE(-1))) {
                                                if (cb_field (VALUE(-1))->level == 88) {
                                                        VALUE (-3) = cb_error_node;
                                                        return -1;
                                                }
                                        }
                                        expr_op = op;
                                        TOKEN (-3) = 'x';
                                        if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
                                                VALUE (-3) = cb_build_binary_op (expr_lh, op, VALUE (-1));
                                        } else {
                                                VALUE (-3) = VALUE (-1);
                                        }
                                }
                                expr_index -= 2;
                                break;
                        case '&':
                        case '|':
                                /* Complex condition: 'x' '=' 'x' '|' op 'x' */
                                if (VALUE (-1) == cb_error_node) {
                                        VALUE (-2) = cb_error_node;
                                } else {
                                        expr_op = op;
                                        TOKEN (-2) = 'x';
                                        if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
                                                VALUE (-2) = cb_build_binary_op (expr_lh, op, VALUE (-1));
                                        } else {
                                                VALUE (-2) = VALUE (-1);
                                        }
                                }
                                expr_index -= 1;
                                break;
                        default:
                                return -1;
                        }
                        break;
                }
        }

        /* handle special case "op OR x AND" */
        if (token == '&' && TOKEN (-2) == '|' && CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
                TOKEN (-1) = 'x';
                VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
        }

        return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int get_value ( cb_tree  x) [static]

Definition at line 1057 of file typeck.c.

{
        if (x == cb_space) {
                return ' ';
        } else if (x == cb_zero) {
                return '0';
        } else if (x == cb_quote) {
                return '"';
        } else if (x == cb_norm_low) {
                return 0;
        } else if (x == cb_norm_high) {
                return 255;
        } else if (x == cb_null) {
                return 0;
        } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
                return cb_get_int (x) - 1;
        } else {
                return CB_LITERAL (x)->data[0];
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int move_error ( cb_tree  src,
cb_tree  dst,
const size_t  value_flag,
const int  flag,
const int  src_flag,
const char *  msg 
) [static]

Definition at line 3899 of file typeck.c.

{
        cb_tree loc;

        if (suppress_warn) {
                return 0;
        }
        loc = src->source_line ? src : dst;
        if (value_flag) {
                /* VALUE clause */
                cb_warning_x (loc, msg);
        } else {
                /* MOVE statement */
                if (flag) {
                        cb_warning_x (loc, msg);
                        if (src_flag) {
                                warning_destination (src);
                        }
                        warning_destination (dst);
                }
        }

        return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void output_screen_from ( struct cb_field p,
const size_t  sisters 
) [static]

Definition at line 2758 of file typeck.c.

{
        int type;

        if (sisters && p->sister) {
                output_screen_from (p->sister, 1);
        }
        if (p->children) {
                output_screen_from (p->children, 1);
        }

        type = (p->children ? COB_SCREEN_TYPE_GROUP :
                p->values ? COB_SCREEN_TYPE_VALUE :
                (p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
        if (type == COB_SCREEN_TYPE_FIELD && p->screen_from) {
                cb_emit (cb_build_funcall_2 ("cob_move", p->screen_from, CB_TREE (p)));
        }
}

Here is the caller graph for this function:

static void output_screen_to ( struct cb_field p,
const size_t  sisters 
) [static]

Definition at line 2778 of file typeck.c.

{
        int type;

        if (sisters && p->sister) {
                output_screen_to (p->sister, 1);
        }
        if (p->children) {
                output_screen_to (p->children, 1);
        }

        type = (p->children ? COB_SCREEN_TYPE_GROUP :
                p->values ? COB_SCREEN_TYPE_VALUE :
                (p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
        if (type == COB_SCREEN_TYPE_FIELD && p->screen_to) {
                cb_emit (cb_build_funcall_2 ("cob_move", CB_TREE (p), p->screen_to));
        }
}

Here is the caller graph for this function:

static void search_set_keys ( struct cb_field f,
cb_tree  x 
) [static]

Definition at line 5359 of file typeck.c.

{
        struct cb_binary_op     *p;
        int                     i;

        if (CB_REFERENCE_P (x)) {
                x = build_cond_88 (x);
        }

        p = CB_BINARY_OP (x);
        switch (p->op) {
        case '&':
                search_set_keys (f, p->x);
                search_set_keys (f, p->y);
                break;
        case '=':
                for (i = 0; i < f->nkeys; i++) {
                        if (cb_field (p->x) == cb_field (f->keys[i].key)) {
                                f->keys[i].ref = p->x;
                                f->keys[i].val = p->y;
                                break;
                        }
                }
                if (i == f->nkeys) {
                        cb_error_x (x, _("Undeclared key '%s'"), cb_field (p->x)->name);
                }
                break;
        default:
                cb_error_x (x, _("Invalid SEARCH ALL condition"));
                break;
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

int validate_move ( cb_tree  src,
cb_tree  dst,
size_t  is_value 
)

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"));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void warning_destination ( cb_tree  x) [static]

Definition at line 3873 of file typeck.c.

{
        struct cb_reference     *r;
        struct cb_field         *f;
        cb_tree                 loc;

        r = CB_REFERENCE (x);
        f = CB_FIELD (r->value);
        loc = CB_TREE (f);

        if (r->offset) {
                return;
        }

        if (!strcmp (f->name, "RETURN-CODE") ||
            !strcmp (f->name, "SORT-RETURN") ||
            !strcmp (f->name, "NUMBER-OF-CALL-PARAMETERS")) {
                cb_warning (_("Internal register '%s' defined as BINARY-LONG"), f->name);
        } else if (f->pic) {
                cb_warning_x (loc, _("'%s' defined here as PIC %s"), f->name, f->pic->orig);
        } else {
                cb_warning_x (loc, _("'%s' defined here as a group of length %d"), f->name, f->size);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:


Variable Documentation

const char* const align_bin_add_funcs[] [static]

Definition at line 259 of file typeck.c.

const char* const align_bin_compare_funcs[] [static]

Definition at line 224 of file typeck.c.

const char* const align_bin_sub_funcs[] [static]

Definition at line 294 of file typeck.c.

const char* const bin_add_funcs[] [static]

Definition at line 154 of file typeck.c.

const char* const bin_compare_funcs[] [static]

Definition at line 119 of file typeck.c.

const char* const bin_set_funcs[] [static]
Initial value:
 {
        NULL,
        "cob_setswp_u16_binary",
        "cob_setswp_u24_binary",
        "cob_setswp_u32_binary",
        "cob_setswp_u40_binary",
        "cob_setswp_u48_binary",
        "cob_setswp_u56_binary",
        "cob_setswp_u64_binary",
        NULL,
        "cob_setswp_s16_binary",
        "cob_setswp_s24_binary",
        "cob_setswp_s32_binary",
        "cob_setswp_s40_binary",
        "cob_setswp_s48_binary",
        "cob_setswp_s56_binary",
        "cob_setswp_s64_binary"
}

Definition at line 100 of file typeck.c.

const char* const bin_sub_funcs[] [static]

Definition at line 189 of file typeck.c.

cb_tree decimal_stack = NULL [static]

Definition at line 79 of file typeck.c.

int expr_index [static]

Definition at line 87 of file typeck.c.

cb_tree expr_lh [static]

Definition at line 85 of file typeck.c.

int expr_op [static]

Definition at line 84 of file typeck.c.

char expr_prio[256] [static]

Definition at line 91 of file typeck.c.

struct expr_node* expr_stack [static]

Definition at line 89 of file typeck.c.

int expr_stack_size [static]

Definition at line 88 of file typeck.c.

Definition at line 82 of file typeck.c.

const char* inspect_func [static]

Definition at line 81 of file typeck.c.

size_t sending_id = 0

Definition at line 74 of file typeck.c.

size_t suppress_warn = 0

Definition at line 75 of file typeck.c.

struct system_table system_tab[] [static]

Definition at line 93 of file typeck.c.

 All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Defines