/*
 * Copyright (C) 2001-2009 Keisuke Nishida
 * Copyright (C) 2007-2009 Roger While
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 51 Franklin Street, Fifth Floor
 * Boston, MA 02110-1301 USA
 */

#include "config.h"

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <time.h>
long int timezone;
#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif
#ifdef	_WIN32
#define WINDOWS_LEAN_AND_MEAN
#include <windows.h>
#endif 

#ifdef	HAVE_LOCALE_H
#include <locale.h>
#endif 

#include "cobc.h"
#include "tree.h"

struct system_table {
	const char		*syst_name;
	const int		syst_params;
};

struct expr_node {
	/* The token of this node.
	 *  'x'                          - values (cb_tree)
	 *  '+', '-', '*', '/', '^'      - arithmetic operators
	 *  '=', '~', '<', '>', '[', ']' - relational operators
	 *  '!', '&', '|'                - logical operators
	 *  '(', ')'                     - parentheses
	 */
	int		token;
	/* The value itself if this node is a value */
	cb_tree		value;
};

#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)

/* Global variables */

size_t			sending_id = 0;
size_t			suppress_warn = 0;

/* Local variables */

static cb_tree		decimal_stack = NULL;

static const char	*inspect_func;
static cb_tree		inspect_data;

static int		expr_op;			/* last operator */
static cb_tree		expr_lh;			/* last left hand */

static int		expr_index;			/* stack index */
static int		expr_stack_size;		/* stack max size */
static struct expr_node *expr_stack;			/* expr node stack */

static char		expr_prio[256];

static const struct system_table	system_tab[] = {
#undef	COB_SYSTEM_GEN
#define	COB_SYSTEM_GEN(x, y, z)	{ x, y },
#include "libcob/system.def"
	{ NULL, 0 }
};

static const char	*const bin_set_funcs[] = {
	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"
};

static const char	*const bin_compare_funcs[] = {
	"cob_cmp_u8_binary",
	"cob_cmp_u16_binary",
	"cob_cmp_u24_binary",
	"cob_cmp_u32_binary",
	"cob_cmp_u40_binary",
	"cob_cmp_u48_binary",
	"cob_cmp_u56_binary",
	"cob_cmp_u64_binary",
	"cob_cmp_s8_binary",
	"cob_cmp_s16_binary",
	"cob_cmp_s24_binary",
	"cob_cmp_s32_binary",
	"cob_cmp_s40_binary",
	"cob_cmp_s48_binary",
	"cob_cmp_s56_binary",
	"cob_cmp_s64_binary",
	"cob_cmp_u8_binary",
	"cob_cmpswp_u16_binary",
	"cob_cmpswp_u24_binary",
	"cob_cmpswp_u32_binary",
	"cob_cmpswp_u40_binary",
	"cob_cmpswp_u48_binary",
	"cob_cmpswp_u56_binary",
	"cob_cmpswp_u64_binary",
	"cob_cmp_s8_binary",
	"cob_cmpswp_s16_binary",
	"cob_cmpswp_s24_binary",
	"cob_cmpswp_s32_binary",
	"cob_cmpswp_s40_binary",
	"cob_cmpswp_s48_binary",
	"cob_cmpswp_s56_binary",
	"cob_cmpswp_s64_binary"
};

static const char	*const bin_add_funcs[] = {
	"cob_add_u8_binary",
	"cob_add_u16_binary",
	"cob_add_u24_binary",
	"cob_add_u32_binary",
	"cob_add_u40_binary",
	"cob_add_u48_binary",
	"cob_add_u56_binary",
	"cob_add_u64_binary",
	"cob_add_s8_binary",
	"cob_add_s16_binary",
	"cob_add_s24_binary",
	"cob_add_s32_binary",
	"cob_add_s40_binary",
	"cob_add_s48_binary",
	"cob_add_s56_binary",
	"cob_add_s64_binary",
	"cob_add_u8_binary",
	"cob_addswp_u16_binary",
	"cob_addswp_u24_binary",
	"cob_addswp_u32_binary",
	"cob_addswp_u40_binary",
	"cob_addswp_u48_binary",
	"cob_addswp_u56_binary",
	"cob_addswp_u64_binary",
	"cob_add_s8_binary",
	"cob_addswp_s16_binary",
	"cob_addswp_s24_binary",
	"cob_addswp_s32_binary",
	"cob_addswp_s40_binary",
	"cob_addswp_s48_binary",
	"cob_addswp_s56_binary",
	"cob_addswp_s64_binary"
};

static const char	*const bin_sub_funcs[] = {
	"cob_sub_u8_binary",
	"cob_sub_u16_binary",
	"cob_sub_u24_binary",
	"cob_sub_u32_binary",
	"cob_sub_u40_binary",
	"cob_sub_u48_binary",
	"cob_sub_u56_binary",
	"cob_sub_u64_binary",
	"cob_sub_s8_binary",
	"cob_sub_s16_binary",
	"cob_sub_s24_binary",
	"cob_sub_s32_binary",
	"cob_sub_s40_binary",
	"cob_sub_s48_binary",
	"cob_sub_s56_binary",
	"cob_sub_s64_binary",
	"cob_sub_u8_binary",
	"cob_subswp_u16_binary",
	"cob_subswp_u24_binary",
	"cob_subswp_u32_binary",
	"cob_subswp_u40_binary",
	"cob_subswp_u48_binary",
	"cob_subswp_u56_binary",
	"cob_subswp_u64_binary",
	"cob_sub_s8_binary",
	"cob_subswp_s16_binary",
	"cob_subswp_s24_binary",
	"cob_subswp_s32_binary",
	"cob_subswp_s40_binary",
	"cob_subswp_s48_binary",
	"cob_subswp_s56_binary",
	"cob_subswp_s64_binary"
};

static const char	*const align_bin_compare_funcs[] = {
	"cob_cmp_u8_binary",
	"cob_cmp_align_u16_binary",
	"cob_cmp_u24_binary",
	"cob_cmp_align_u32_binary",
	"cob_cmp_u40_binary",
	"cob_cmp_u48_binary",
	"cob_cmp_u56_binary",
	"cob_cmp_align_u64_binary",
	"cob_cmp_s8_binary",
	"cob_cmp_align_s16_binary",
	"cob_cmp_s24_binary",
	"cob_cmp_align_s32_binary",
	"cob_cmp_s40_binary",
	"cob_cmp_s48_binary",
	"cob_cmp_s56_binary",
	"cob_cmp_align_s64_binary",
	"cob_cmp_u8_binary",
	"cob_cmpswp_align_u16_binary",
	"cob_cmpswp_u24_binary",
	"cob_cmpswp_align_u32_binary",
	"cob_cmpswp_u40_binary",
	"cob_cmpswp_u48_binary",
	"cob_cmpswp_u56_binary",
	"cob_cmpswp_align_u64_binary",
	"cob_cmp_s8_binary",
	"cob_cmpswp_align_s16_binary",
	"cob_cmpswp_s24_binary",
	"cob_cmpswp_align_s32_binary",
	"cob_cmpswp_s40_binary",
	"cob_cmpswp_s48_binary",
	"cob_cmpswp_s56_binary",
	"cob_cmpswp_align_s64_binary"
};

static const char	*const align_bin_add_funcs[] = {
	"cob_add_u8_binary",
	"cob_add_align_u16_binary",
	"cob_add_u24_binary",
	"cob_add_align_u32_binary",
	"cob_add_u40_binary",
	"cob_add_u48_binary",
	"cob_add_u56_binary",
	"cob_add_align_u64_binary",
	"cob_add_s8_binary",
	"cob_add_align_s16_binary",
	"cob_add_s24_binary",
	"cob_add_align_s32_binary",
	"cob_add_s40_binary",
	"cob_add_s48_binary",
	"cob_add_s56_binary",
	"cob_add_align_s64_binary",
	"cob_add_u8_binary",
	"cob_addswp_u16_binary",
	"cob_addswp_u24_binary",
	"cob_addswp_u32_binary",
	"cob_addswp_u40_binary",
	"cob_addswp_u48_binary",
	"cob_addswp_u56_binary",
	"cob_addswp_u64_binary",
	"cob_add_s8_binary",
	"cob_addswp_s16_binary",
	"cob_addswp_s24_binary",
	"cob_addswp_s32_binary",
	"cob_addswp_s40_binary",
	"cob_addswp_s48_binary",
	"cob_addswp_s56_binary",
	"cob_addswp_s64_binary"
};

static const char	*const align_bin_sub_funcs[] = {
	"cob_sub_u8_binary",
	"cob_sub_align_u16_binary",
	"cob_sub_u24_binary",
	"cob_sub_align_u32_binary",
	"cob_sub_u40_binary",
	"cob_sub_u48_binary",
	"cob_sub_u56_binary",
	"cob_sub_align_u64_binary",
	"cob_sub_s8_binary",
	"cob_sub_align_s16_binary",
	"cob_sub_s24_binary",
	"cob_sub_align_s32_binary",
	"cob_sub_s40_binary",
	"cob_sub_s48_binary",
	"cob_sub_s56_binary",
	"cob_sub_align_s64_binary",
	"cob_sub_u8_binary",
	"cob_subswp_u16_binary",
	"cob_subswp_u24_binary",
	"cob_subswp_u32_binary",
	"cob_subswp_u40_binary",
	"cob_subswp_u48_binary",
	"cob_subswp_u56_binary",
	"cob_subswp_u64_binary",
	"cob_sub_s8_binary",
	"cob_subswp_s16_binary",
	"cob_subswp_s24_binary",
	"cob_subswp_s32_binary",
	"cob_subswp_s40_binary",
	"cob_subswp_s48_binary",
	"cob_subswp_s56_binary",
	"cob_subswp_s64_binary"
};

/* functions */

static size_t
cb_validate_one (cb_tree x)
{
	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;
}

static size_t
cb_validate_list (cb_tree l)
{
	for (; l; l = CB_CHAIN (l)) {
		if (cb_validate_one (CB_VALUE (l))) {
			return 1;
		}
	}
	return 0;
}

static cb_tree
cb_check_group_name (cb_tree x)
{
	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;
}

static cb_tree
cb_check_numeric_name (cb_tree x)
{
	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;
}

static cb_tree
cb_check_numeric_edited_name (cb_tree x)
{
	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;
}

cb_tree
cb_check_numeric_value (cb_tree x)
{
	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;
}

static cb_tree
cb_check_integer_value (cb_tree x)
{
	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;
}

void
cb_build_registers (void)
{
#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);
}

char *
cb_encode_program_id (const char *name)
{
	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);
}

const char *
cb_build_program_id (cb_tree name, cb_tree alt_name)
{
	const char	*s;

/* This needs some more thought, should we generate an entry
	point per program source name ?
	if (alt_name) {
		s = (char *)CB_LITERAL (alt_name)->data;
	} else if (CB_LITERAL_P (name)) {
		s = (char *)CB_LITERAL (name)->data;
	} else {
		s = (char *)CB_NAME (name);
	}

	if (!cb_flag_main && strcmp (s, source_name)) {
		cb_warning (_("Source name '%s' differs from PROGRAM-ID '%s'"),
				source_name, s);
		current_program->source_name = strdup (source_name);
	}
 End comment out */

	if (alt_name) {
		current_program->orig_source_name = strdup ((char *)CB_LITERAL (alt_name)->data);
		s = (char *)CB_LITERAL (alt_name)->data;
	} else if (CB_LITERAL_P (name)) {
		current_program->orig_source_name = strdup ((char *)CB_LITERAL (name)->data);
		s = cb_encode_program_id ((char *)CB_LITERAL (name)->data);
	} else {
		current_program->orig_source_name = strdup (CB_NAME (name));
		s = cb_encode_program_id (CB_NAME (name));
	}
	if (cobc_check_valid_name (current_program->orig_source_name)) {
		cb_error (_("PROGRAM-ID '%s' invalid"), current_program->orig_source_name);
	}
	return s;
}

void
cb_define_switch_name (cb_tree name, cb_tree sname, cb_tree flag, cb_tree ref)
{
	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);
	}
}

cb_tree
cb_build_section_name (cb_tree name, int sect_or_para)
{
	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;
}

cb_tree
cb_build_assignment_name (struct cb_file *cfile, cb_tree name)
{
	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;
	}
}

cb_tree
cb_build_index (cb_tree x, cb_tree values, int indexed_by, struct cb_field *qual)
{
	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;
}

cb_tree
cb_build_identifier (cb_tree x)
{
	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;
}

static cb_tree
cb_build_length_1 (cb_tree x)
{
	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;
	}
}

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

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

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

	return cb_build_cast_address (x);
}

cb_tree
cb_build_ppointer (cb_tree x)
{
	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);
}

/* validate program */

static int
get_value (cb_tree x)
{
	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];
	}
}

void
cb_validate_program_environment (struct cb_program *prog)
{
	cb_tree			x;
	cb_tree			y;
	cb_tree			l;
	cb_tree			ls;
	struct cb_alphabet_name	*ap;
	unsigned char		*data;
	size_t			dupls;
	size_t			unvals;
	size_t			count;
	int			lower;
	int			upper;
	int			size;
	int			n;
	int			i;
	int			lastval;
	int			values[256];

	/* Check ALPHABET clauses */
	for (l = current_program->alphabet_name_list; l; l = CB_CHAIN (l)) {
		ap = CB_ALPHABET_NAME (CB_VALUE (l));
		if (ap->type != CB_ALPHABET_CUSTOM) {
			continue;
		}
		ap->low_val_char = 0;
		ap->high_val_char = 255;
		dupls = 0;
		unvals = 0;
		count = 0;
		lastval = 0;
		for (n = 0; n < 256; n++) {
			values[n] = -1;
		}
		for (y = ap->custom_list; y; y = CB_CHAIN (y)) {
			if (count > 255) {
				unvals = 1;
				break;
			}
			x = CB_VALUE (y);
			if (CB_PAIR_P (x)) {
				/* X THRU Y */
				lower = get_value (CB_PAIR_X (x));
				upper = get_value (CB_PAIR_Y (x));
				lastval = upper;
				if (!count) {
					ap->low_val_char = lower;
				}
				if (lower < 0 || lower > 255) {
					unvals = 1;
					continue;
				}
				if (upper < 0 || upper > 255) {
					unvals = 1;
					continue;
				}
				if (lower <= upper) {
					for (i = lower; i <= upper; i++) {
						if (values[i] != -1) {
							dupls = 1;
						}
						values[i] = i;
						count++;
					}
				} else {
					for (i = lower; i >= upper; i--) {
						if (values[i] != -1) {
							dupls = 1;
						}
						values[i] = i;
						count++;
					}
				}
			} else if (CB_LIST_P (x)) {
				/* X ALSO Y ... */
				if (!count) {
					ap->low_val_char = get_value (CB_VALUE (x));
				}
				for (ls = x; ls; ls = CB_CHAIN (ls)) {
					n = get_value (CB_VALUE (ls));
					if (!CB_CHAIN (ls)) {
						lastval = n;
					}
					if (n < 0 || n > 255) {
						unvals = 1;
						continue;
					}
					if (values[n] != -1) {
						dupls = 1;
					}
					values[n] = n;
					count++;
				}
			} else {
				/* literal */
				if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
					n = get_value (x);
					lastval = n;
					if (!count) {
						ap->low_val_char = n;
					}
					if (n < 0 || n > 255) {
						unvals = 1;
						continue;
					}
					if (values[n] != -1) {
						dupls = 1;
					}
					values[n] = n;
					count++;
				} else if (CB_LITERAL_P (x)) {
					size = (int)CB_LITERAL (x)->size;
					data = CB_LITERAL (x)->data;
					if (!count) {
						ap->low_val_char = data[0];
					}
					lastval = data[size - 1];
					for (i = 0; i < size; i++) {
						n = data[i];
						if (values[n] != -1) {
							dupls = 1;
						}
						values[n] = n;
						count++;
					}
				} else {
					n = get_value (x);
					lastval = n;
					if (!count) {
						ap->low_val_char = n;
					}
					if (n < 0 || n > 255) {
						unvals = 1;
						continue;
					}
					if (values[n] != -1) {
						dupls = 1;
					}
					values[n] = n;
					count++;
				}
			}
		}
		if (dupls || unvals) {
			if (dupls) {
				cb_error_x (l, _("Duplicate character values in alphabet '%s'"),
					    cb_name (CB_VALUE(l)));
			}
			if (unvals) {
				cb_error_x (l, _("Invalid character values in alphabet '%s'"),
					    cb_name (CB_VALUE(l)));
			}
			ap->low_val_char = 0;
			ap->high_val_char = 255;
			continue;
		}
		/* Calculate HIGH-VALUE */
		/* If all 256 values have been specified, HIGH-VALUE is the last one */
		/* Otherwise if HIGH-VALUE has been specified, find the highest */
		/* value that has not been used */
		if (count == 256) {
			ap->high_val_char = lastval;
		} else if (values[255] != -1) {
			for (n = 254; n >= 0; n--) {
				if (values[n] == -1) {
					ap->high_val_char = n;
					break;
				}
			}
		}
	}
	/* Rest HIGH/LOW-VALUES */
	cb_low = cb_norm_low;
	cb_high = cb_norm_high;
	/* resolve the program collating sequence */
	if (!prog->collating_sequence) {
		return;
	}
	x = cb_ref (prog->collating_sequence);
/* RXWRXW
	if (x == cb_error_node) {
		prog->collating_sequence = NULL;
		return;
	}
*/
	if (!CB_ALPHABET_NAME_P (x)) {
		cb_error_x (prog->collating_sequence, _("'%s' not alphabet name"),
			    cb_name (prog->collating_sequence));
		prog->collating_sequence = NULL;
		return;
	}
	if (CB_ALPHABET_NAME (x)->type != CB_ALPHABET_CUSTOM) {
		return;
	}
	if (CB_ALPHABET_NAME (x)->low_val_char) {
		cb_low = cb_build_alphanumeric_literal ((ucharptr)"\0", 1);
		CB_LITERAL(cb_low)->data[0] = CB_ALPHABET_NAME (x)->low_val_char;
		CB_LITERAL(cb_low)->all = 1;
	}
	if (CB_ALPHABET_NAME (x)->high_val_char != 255){
		cb_high = cb_build_alphanumeric_literal ((ucharptr)"\0", 1);
		CB_LITERAL(cb_high)->data[0] = CB_ALPHABET_NAME (x)->high_val_char;
		CB_LITERAL(cb_high)->all = 1;
	}
}

void
cb_validate_program_data (struct cb_program *prog)
{
	cb_tree		l;
	cb_tree		x;
	cb_tree		assign;
	struct cb_field	*p;
	struct cb_file	*f;
	unsigned char	*c;

	for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
		f = CB_FILE (CB_VALUE (l));
		if (!f->finalized) {
			finalize_file (f, NULL);
		}
	}
	/* build undeclared assignment name now */
	if (cb_assign_clause == CB_ASSIGN_MF) {
		for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
			assign = CB_FILE (CB_VALUE (l))->assign;
			if (!assign) {
				continue;
			}
			if (CB_REFERENCE_P (assign)) {
				for (x = current_program->file_list; x; x = CB_CHAIN (x)) {
					if (!strcmp (CB_FILE (CB_VALUE (x))->name,
					     CB_REFERENCE (assign)->word->name)) {
						redefinition_error (assign);
					}
				}
				p = check_level_78 (CB_REFERENCE (assign)->word->name);
				if (p) {
					c = (unsigned char *)CB_LITERAL(CB_VALUE(p->values))->data;
					assign = CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, c, strlen ((char *)c)));
					CB_FILE (CB_VALUE (l))->assign = assign;
				}
			}
			if (CB_REFERENCE_P (assign) && CB_REFERENCE (assign)->word->count == 0) {
				if (cb_warn_implicit_define) {
					cb_warning (_("'%s' will be implicitly defined"), CB_NAME (assign));
				}
				x = cb_build_implicit_field (assign, COB_SMALL_BUFF);
				p = current_program->working_storage;
				CB_FIELD (x)->count++;
				if (p) {
					while (p->sister) {
						p = p->sister;
					}
					p->sister = CB_FIELD (x);
				} else {
					current_program->working_storage = CB_FIELD (x);
				}
			}
			if (CB_REFERENCE_P (assign)) {
				x = cb_ref (assign);
				if (CB_FIELD_P (x) && CB_FIELD (x)->level == 88) {
					cb_error_x (assign, _("ASSIGN data item '%s' invalid"), CB_NAME (assign));
				}
			}
		}
	}

	if (prog->cursor_pos) {
		x = cb_ref (prog->cursor_pos);
		if (x == cb_error_node) {
			prog->cursor_pos = NULL;
		} else if (CB_FIELD(x)->size != 6 && CB_FIELD(x)->size != 4) {
			cb_error_x (prog->cursor_pos, _("'%s' CURSOR is not 4 or 6 characters long"),
				    cb_name (prog->cursor_pos));
			prog->cursor_pos = NULL;
		}
	}
	if (prog->crt_status) {
		x = cb_ref (prog->crt_status);
		if (x == cb_error_node) {
			prog->crt_status = NULL;
		} else if (CB_FIELD(x)->size != 4) {
			cb_error_x (prog->crt_status, _("'%s' CRT STATUS is not 4 characters long"),
				    cb_name (prog->crt_status));
			prog->crt_status = NULL;
		}
	} else {
		l = cb_build_reference ("COB-CRT-STATUS");
		p = CB_FIELD (cb_build_field (l));
		p->usage = CB_USAGE_DISPLAY;
		p->pic = CB_PICTURE (cb_build_picture ("9(4)"));
		cb_validate_field (p);
		p->flag_no_init = 1;
		/* Do not initialize/bump ref count here
		p->values = cb_list_init (cb_zero);
		p->count++;
		*/
		current_program->working_storage =
			cb_field_add (current_program->working_storage, p);
		prog->crt_status = l;
		/* RXWRXW - Maybe better
		prog->crt_status = cb_build_index (cb_build_reference ("COB-CRT-STATUS"), cb_zero, 0, NULL);
		*/
	}

	/* resolve all references so far */
	for (l = cb_list_reverse (prog->reference_list); l; l = CB_CHAIN (l)) {
		cb_ref (CB_VALUE (l));
	}
	for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
		f = CB_FILE (CB_VALUE (l));
		if (f->record_depending && f->record_depending != cb_error_node) {
			x = f->record_depending;
			if (cb_ref (x) != cb_error_node) {
/* RXW - This breaks old legacy programs
				if (CB_REF_OR_FIELD_P(x)) {
					p = cb_field (x);
					switch (p->storage) {
					case CB_STORAGE_WORKING:
					case CB_STORAGE_LOCAL:
					case CB_STORAGE_LINKAGE:
						break;
					default:
						cb_error (_("RECORD DEPENDING item must be in WORKING/LOCAL/LINKAGE section"));
					}
				} else {
*/
				if (!CB_REFERENCE_P(x) && !CB_FIELD_P(x)) {
					cb_error (_("Invalid RECORD DEPENDING item"));
				}
			}
		}
	}
}

void
cb_validate_program_body (struct cb_program *prog)
{
	/* 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);
}

/*
 * Expressions
 */

static void
cb_expr_init (void)
{
	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;
}

static int
expr_reduce (int token)
{
	/* 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;
}

static void
cb_expr_shift_sign (const int op)
{
	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));
		}
	}
}

static void
cb_expr_shift_class (const char *name)
{
	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));
		}
	}
}

static void
cb_expr_shift (int token, cb_tree value)
{
	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++;
}

static void
expr_expand (cb_tree *x)
{
	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);
		}
	}
}

static cb_tree
cb_expr_finish (void)
{
	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;
}

cb_tree
cb_build_expr (cb_tree list)
{
	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 ();
}

/*
 * Numerical operation
 */

static cb_tree
build_store_option (cb_tree x, cb_tree round_opt)
{
	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);
}

static cb_tree
decimal_alloc (void)
{
	cb_tree x;

	x = cb_build_decimal (current_program->decimal_index);
	current_program->decimal_index++;
	if (current_program->decimal_index > current_program->decimal_index_max) {
		current_program->decimal_index_max = current_program->decimal_index;
	}
	return x;
}

static void
decimal_free (void)
{
	current_program->decimal_index--;
}

static void
decimal_compute (const int op, cb_tree x, cb_tree y)
{
	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));
}

static void
decimal_expand (cb_tree d, cb_tree x)
{
	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 ();
	}
}

static void
decimal_assign (cb_tree x, cb_tree d, cb_tree round_opt)
{
	dpush (cb_build_funcall_3 ("cob_decimal_get_field", d, x, build_store_option (x, round_opt)));
}

static cb_tree
build_decimal_assign (cb_tree vars, int op, cb_tree val)
{
	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;
}

void
cb_emit_arithmetic (cb_tree vars, int op, cb_tree val)
{
	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));
}

/*
 * Condition
 */

static cb_tree
build_cond_88 (cb_tree x)
{
	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;
}

static cb_tree
cb_build_optim_cond (struct cb_binary_op *p)
{
	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));
}

static int
cb_chk_num_cond (cb_tree x, cb_tree y)
{
	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;
}

static int
cb_chk_alpha_cond (cb_tree x)
{
	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;
}

cb_tree
cb_build_cond (cb_tree x)
{
	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;
}

/*
 * ADD/SUBTRACT CORRESPONDING
 */

static cb_tree
cb_build_optim_add (cb_tree v, cb_tree n)
{
	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));
}

static cb_tree
cb_build_optim_sub (cb_tree v, cb_tree n)
{
	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));
}

cb_tree
cb_build_add (cb_tree v, cb_tree n, cb_tree round_opt)
{
	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);
}

cb_tree
cb_build_sub (cb_tree v, cb_tree n, cb_tree round_opt)
{
	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);
}

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

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

static void
emit_move_corresponding (cb_tree x1, cb_tree x2)
{
	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));
						}
					}
				}
			}
		}
	}
}

void
cb_emit_move_corresponding (cb_tree x1, cb_tree x2)
{
	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);
	}
}

static void
output_screen_from (struct cb_field *p, const size_t sisters)
{
	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)));
	}
}

static void
output_screen_to (struct cb_field *p, const size_t sisters)
{
	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));
	}
}

/*
 * ACCEPT statement
 */

void
cb_emit_accept (cb_tree var, cb_tree pos, cb_tree fgc, cb_tree bgc,
		cb_tree scroll, int dispattrs)
{
	cb_tree	line;
	cb_tree	column;

	if (cb_validate_one (var)) {
		return;
	}
	if (cb_validate_one (pos)) {
		return;
	}
	if (cb_validate_one (fgc)) {
		return;
	}
	if (cb_validate_one (bgc)) {
		return;
	}
	if (cb_validate_one (scroll)) {
		return;
	}
	if (current_program->flag_screen) {
		/* Bump ref count to force CRT STATUS field generation */
		cb_field (current_program->crt_status)->count++;
		if ((CB_REF_OR_FIELD_P (var)) &&
		     CB_FIELD (cb_ref (var))->storage == CB_STORAGE_SCREEN) {
			output_screen_from (CB_FIELD (cb_ref (var)), 0);
			gen_screen_ptr = 1;
			if (pos) {
				if (CB_PAIR_P (pos)) {
					line = CB_PAIR_X (pos);
					column = CB_PAIR_Y (pos);
					cb_emit (cb_build_funcall_3 ("cob_screen_accept",
						var, line, column));
				} else {
					cb_emit (cb_build_funcall_3 ("cob_screen_accept",
						var, pos, NULL));
				}
			} else {
				cb_emit (cb_build_funcall_3 ("cob_screen_accept",
					var, NULL, NULL));
			}
			gen_screen_ptr = 0;
			output_screen_to (CB_FIELD (cb_ref (var)), 0);
		} else {
			if (pos || fgc || bgc) {
				if (!pos) {
					cb_emit (cb_build_funcall_7 ("cob_field_accept",
						var, NULL, NULL, fgc, bgc,
						scroll, cb_int (dispattrs)));
				} else if (CB_PAIR_P (pos)) {
					line = CB_PAIR_X (pos);
					column = CB_PAIR_Y (pos);
					cb_emit (cb_build_funcall_7 ("cob_field_accept",
						var, line, column, fgc, bgc,
						scroll, cb_int (dispattrs)));
				} else {
					cb_emit (cb_build_funcall_7 ("cob_field_accept",
						var, pos, NULL, fgc, bgc,
						scroll, cb_int (dispattrs)));
				}
			} else {
				cb_emit (cb_build_funcall_7 ("cob_field_accept",
					var, NULL, NULL, fgc, bgc,
					scroll, cb_int (dispattrs)));
			}
		}
	} else if (pos || fgc || bgc || scroll) {
		/* Bump ref count to force CRT STATUS field generation */
		cb_field (current_program->crt_status)->count++;
		if (!pos) {
			cb_emit (cb_build_funcall_7 ("cob_field_accept",
				var, NULL, NULL, fgc, bgc, scroll,
				cb_int (dispattrs)));
		} else if (CB_PAIR_P (pos)) {
			line = CB_PAIR_X (pos);
			column = CB_PAIR_Y (pos);
			cb_emit (cb_build_funcall_7 ("cob_field_accept",
				var, line, column, fgc, bgc, scroll,
				cb_int (dispattrs)));
		} else {
			cb_emit (cb_build_funcall_7 ("cob_field_accept",
				var, pos, NULL, fgc, bgc, scroll,
				cb_int (dispattrs)));
		}
	} else {
		cb_emit (cb_build_funcall_1 ("cob_accept", var));
	}
}

void
cb_emit_accept_line_or_col (cb_tree var, const int l_or_c)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_2 ("cob_screen_line_col", var, cb_int (l_or_c)));
}

void
cb_emit_accept_date (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_date", var));
}

void
cb_emit_accept_date_yyyymmdd (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_date_yyyymmdd", var));
}

void
cb_emit_accept_day (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_day", var));
}

void
cb_emit_accept_day_yyyyddd (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_day_yyyyddd", var));
}

void
cb_emit_accept_day_of_week (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_day_of_week", var));
}

void
cb_emit_accept_time (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_time", var));
}

void
cb_emit_accept_command_line (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_command_line", var));
}

void
cb_emit_get_environment (cb_tree envvar, cb_tree envval)
{
	if (cb_validate_one (envvar)) {
		return;
	}
	if (cb_validate_one (envval)) {
		return;
	}
	cb_emit (cb_build_funcall_2 ("cob_get_environment", envvar, envval));
}

void
cb_emit_accept_environment (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_environment", var));
}

void
cb_emit_accept_arg_number (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_arg_number", var));
}

void
cb_emit_accept_arg_value (cb_tree var)
{
	if (cb_validate_one (var)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_accept_arg_value", var));
}

void
cb_emit_accept_mnemonic (cb_tree var, cb_tree mnemonic)
{
	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;
	}
}

void
cb_emit_accept_name (cb_tree var, cb_tree name)
{
	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));
}

/*
 * ALLOCATE statement
 */

void
cb_emit_allocate (cb_tree target1, cb_tree target2, cb_tree size, cb_tree initialize)
{
	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);
	}
}


/*
 * CALL statement
 */

void
cb_emit_call (cb_tree prog, cb_tree using, cb_tree returning,
	      cb_tree on_exception, cb_tree not_on_exception)
{
	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));
}

/*
 * CANCEL statement
 */

void
cb_emit_cancel (cb_tree prog)
{
	if (cb_validate_one (prog)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_field_cancel", prog));
}

/*
 * CLOSE statement
 */

void
cb_emit_close (cb_tree file, cb_tree opt)
{
	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));
}

/*
 * COMMIT statement
 */

void
cb_emit_commit (void)
{
	cb_emit (cb_build_funcall_0 ("cob_commit"));
}

/*
 * CONTINUE statement
 */

void
cb_emit_continue (void)
{
	cb_emit (cb_build_continue ());
}

/*
 * DELETE statement
 */

void
cb_emit_delete (cb_tree file)
{
	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));
}

/*
 * DISPLAY statement
 */

void
cb_emit_env_name (cb_tree value)
{
	if (cb_validate_one (value)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_display_environment", value));
}

void
cb_emit_env_value (cb_tree value)
{
	if (cb_validate_one (value)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_display_env_value", value));
}

void
cb_emit_arg_number (cb_tree value)
{
	if (cb_validate_one (value)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_display_arg_number", value));
}

void
cb_emit_command_line (cb_tree value)
{
	if (cb_validate_one (value)) {
		return;
	}
	cb_emit (cb_build_funcall_1 ("cob_display_command_line", 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	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++;
			}
		}
	}
}

cb_tree
cb_build_display_upon (cb_tree x)
{
	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;
	}
}

cb_tree
cb_build_display_upon_direct (cb_tree x)
{
	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;
}

/*
 * DIVIDE statement
 */

void
cb_emit_divide (cb_tree dividend, cb_tree divisor, cb_tree quotient, cb_tree remainder)
{
	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)));
}

/*
 * EVALUATE statement
 */

static cb_tree
evaluate_test (cb_tree s, cb_tree o)
{
	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);
	}
}

static cb_tree
build_evaluate (cb_tree subject_list, cb_tree case_list)
{
	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)));
	}
}

void
cb_emit_evaluate (cb_tree subject_list, cb_tree case_list)
{
	cb_emit (build_evaluate (subject_list, case_list));
}

/*
 * FREE statement
 */

void
cb_emit_free (cb_tree vars)
{
	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);
		}
	}
}

/*
 * GO TO statement
 */

void
cb_emit_goto (cb_tree target, cb_tree depending)
{
	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));
		}
	}
}

void
cb_emit_exit (size_t goback)
{
	if (goback) {
		cb_emit (cb_build_goto (cb_int1, NULL));
	} else {
		cb_emit (cb_build_goto (NULL, NULL));
	}
}

/*
 * IF statement
 */

void
cb_emit_if (cb_tree cond, cb_tree stmt1, cb_tree stmt2)
{
	cb_emit (cb_build_if (cond, stmt1, stmt2));
}

/*
 * INITIALIZE statement
 */

void
cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value, cb_tree replacing, cb_tree def)
{
	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));
	}
}

/*
 * INSPECT statement
 */

void
cb_emit_inspect (cb_tree var, cb_tree body, cb_tree replacing, int replconv)
{
	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"));
}

void
cb_init_tarrying (void)
{
	inspect_func = NULL;
	inspect_data = NULL;
}

cb_tree
cb_build_tarrying_data (cb_tree x)
{
	inspect_data = x;
	return NULL;
}

cb_tree
cb_build_tarrying_characters (cb_tree l)
{
	if (inspect_data == NULL) {
		cb_error (_("Data name expected before CHARACTERS"));
	}
	inspect_func = NULL;
	return cb_list_add (l, cb_build_funcall_1 ("cob_inspect_characters", inspect_data));
}

cb_tree
cb_build_tarrying_all (void)
{
	if (inspect_data == NULL) {
		cb_error (_("Data name expected before ALL"));
	}
	inspect_func = "cob_inspect_all";
	return NULL;
}

cb_tree
cb_build_tarrying_leading (void)
{
	if (inspect_data == NULL) {
		cb_error (_("Data name expected before LEADING"));
	}
	inspect_func = "cob_inspect_leading";
	return NULL;
}

cb_tree
cb_build_tarrying_trailing (void)
{
	if (inspect_data == NULL) {
		cb_error (_("Data name expected before TRAILING"));
	}
	inspect_func = "cob_inspect_trailing";
	return NULL;
}

cb_tree
cb_build_tarrying_value (cb_tree x, cb_tree l)
{
	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));
}

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

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

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

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

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

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

cb_tree
cb_build_inspect_region_start (void)
{
	return cb_list_init (cb_build_funcall_0 ("cob_inspect_start"));
}

cb_tree
cb_build_inspect_region (cb_tree l, cb_tree pos, cb_tree x)
{
	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));
	}
}

/*
 * MOVE statement
 */

static void
warning_destination (cb_tree x)
{
	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);
	}
}

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

/* count the number of free places in an alphanumeric edited field */
static int
count_pic_alphanumeric_edited (struct cb_field *field)
{
	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;
}

int
validate_move (cb_tree src, cb_tree dst, size_t is_value)
{
	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"));
}

static cb_tree
cb_build_memset (cb_tree x, int 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));
	}
}

static cb_tree
cb_build_move_copy (cb_tree src, cb_tree dst)
{
	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));
	}
}

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

static cb_tree
cb_build_move_num_zero (cb_tree x)
{
	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);
	}
}

static cb_tree
cb_build_move_space (cb_tree x)
{
	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);
	}
}

static cb_tree
cb_build_move_zero (cb_tree x)
{
	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);
	}
}

static cb_tree
cb_build_move_high (cb_tree x)
{
	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);
	}
}

static cb_tree
cb_build_move_low (cb_tree x)
{
	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);
	}
}

static cb_tree
cb_build_move_quote (cb_tree x)
{
	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);
	}
}

#ifdef	COB_EBCDIC_MACHINE
static void
cob_put_sign_ascii (unsigned char *p)
{
	switch (*p) {
	case '0':
		*p = (unsigned char)'p';
		return;
	case '1':
		*p = (unsigned char)'q';
		return;
	case '2':
		*p = (unsigned char)'r';
		return;
	case '3':
		*p = (unsigned char)'s';
		return;
	case '4':
		*p = (unsigned char)'t';
		return;
	case '5':
		*p = (unsigned char)'u';
		return;
	case '6':
		*p = (unsigned char)'v';
		return;
	case '7':
		*p = (unsigned char)'w';
		return;
	case '8':
		*p = (unsigned char)'x';
		return;
	case '9':
		*p = (unsigned char)'y';
		return;
	}
}
#endif

static void
cob_put_sign_ebcdic (unsigned char *p, const int sign)
{
	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 */
}

static cb_tree
cb_build_move_literal (cb_tree src, cb_tree dst)
{
	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);
	}
}

static cb_tree
cb_build_move_field (cb_tree src, cb_tree dst)
{
	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);
}

cb_tree
cb_build_move (cb_tree src, cb_tree dst)
{
	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);
}

void
cb_emit_move (cb_tree src, cb_tree dsts)
{
	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)));
	}
}

/*
 * OPEN statement
 */

void
cb_emit_open (cb_tree file, cb_tree mode, cb_tree sharing)
{
	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));
}

/*
 * PERFORM statement
 */

void
cb_emit_perform (cb_tree perform, cb_tree body)
{
	if (perform == cb_error_node) {
		return;
	}
	CB_PERFORM (perform)->body = body;
	cb_emit (perform);
}

cb_tree
cb_build_perform_once (cb_tree body)
{
	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;
}

cb_tree
cb_build_perform_times (cb_tree times)
{
	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;
}

cb_tree
cb_build_perform_until (cb_tree condition, cb_tree varying)
{
	cb_tree x;

	x = cb_build_perform (CB_PERFORM_UNTIL);
	CB_PERFORM (x)->test = condition;
	CB_PERFORM (x)->varying = varying;
	return x;
}

cb_tree
cb_build_perform_forever (cb_tree body)
{
	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;
}

cb_tree
cb_build_perform_exit (struct cb_label *label)
{
	cb_tree x;

	x = cb_build_perform (CB_PERFORM_EXIT);
	CB_PERFORM (x)->data = CB_TREE (label);
	return x;
}

/*
 * READ statement
 */

void
cb_emit_read (cb_tree ref, cb_tree next, cb_tree into, cb_tree key, cb_tree lock_opts)
{
	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;
}

/*
 * REWRITE statement
 */

void
cb_emit_rewrite (cb_tree record, cb_tree from, cb_tree lockopt)
{
	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));
}

/*
 * RELEASE statement
 */

void
cb_emit_release (cb_tree record, cb_tree from)
{
	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));
}

/*
 * RETURN statement
 */

void
cb_emit_return (cb_tree ref, cb_tree into)
{
	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;
}

/*
 * ROLLBACK statement
 */

void
cb_emit_rollback (void)
{
	cb_emit (cb_build_funcall_0 ("cob_rollback"));
}

/*
 * SEARCH statement
 */

static void
search_set_keys (struct cb_field *f, cb_tree x)
{
	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;
	}
}

static cb_tree
cb_build_search_all (cb_tree table, cb_tree cond)
{
	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);
}

void
cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens)
{
	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));
}

void
cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts)
{
	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)));
}

/*
 * SET statement
 */

void
cb_emit_setenv (cb_tree x, cb_tree y)
{
	cb_emit (cb_build_funcall_2 ("cob_set_environment", x, y));
}

void
cb_emit_set_to (cb_tree vars, cb_tree x)
{
	cb_tree		l;
	cb_tree		v;
	struct cb_cast	*p;
#if 0
	enum cb_class class = CB_CLASS_UNKNOWN;
#endif

	if (cb_validate_one (x)) {
		return;
	}
	if (cb_validate_list (vars)) {
		return;
	}

#if 0
	/* determine the class of targets */
	for (l = vars; l; l = CB_CHAIN (l)) {
		if (CB_TREE_CLASS (CB_VALUE (l)) != CB_CLASS_UNKNOWN) {
			if (class == CB_CLASS_UNKNOWN) {
				class = CB_TREE_CLASS (CB_VALUE (l));
			} else if (class != CB_TREE_CLASS (CB_VALUE (l))) {
				break;
			}
		}
	}
	if (l || (class != CB_CLASS_INDEX && class != CB_CLASS_POINTER)) {
		cb_error_x (CB_TREE (current_statement),
			    _("The targets of SET must be either indexes or pointers"));
		return;
	}
#endif

	if (CB_CAST_P (x)) {
		p = CB_CAST (x);
		if (p->type == CB_CAST_PROGRAM_POINTER) {
			for (l = vars; l; l = CB_CHAIN (l)) {
				v = CB_VALUE (l);
				if (!CB_REFERENCE_P (v)) {
					cb_error_x (CB_TREE (current_statement),
					_("SET targets must be PROGRAM-POINTER"));
					CB_VALUE (l) = cb_error_node;
				} else if (CB_FIELD(cb_ref(v))->usage != CB_USAGE_PROGRAM_POINTER) {
					cb_error_x (CB_TREE (current_statement),
					_("SET targets must be PROGRAM-POINTER"));
					CB_VALUE (l) = cb_error_node;
				}
			}
		}
	}
	/* validate the targets */
	for (l = vars; l; l = CB_CHAIN (l)) {
		v = CB_VALUE (l);
		if (CB_CAST_P (v)) {
			p = CB_CAST (v);
			if (p->type == CB_CAST_ADDRESS
			    && !CB_FIELD (cb_ref (p->val))->flag_item_based
			    && CB_FIELD (cb_ref (p->val))->storage != CB_STORAGE_LINKAGE) {
				cb_error_x (p->val, _("The address of '%s' cannot be changed"),
					    cb_name (p->val));
				CB_VALUE (l) = cb_error_node;
			}
		}
	}
	if (cb_validate_list (vars)) {
		return;
	}

	for (l = vars; l; l = CB_CHAIN (l)) {
		cb_emit (cb_build_move (x, CB_VALUE (l)));
	}
}

void
cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x)
{
	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));
		}
	}
}

void
cb_emit_set_on_off (cb_tree l, cb_tree flag)
{
	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));
	}
}

void
cb_emit_set_true (cb_tree l)
{
	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));
	}
}

void
cb_emit_set_false (cb_tree l)
{
	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));
	}
}

/*
 * SORT statement
 */

void
cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col)
{
	cb_tree		l;
	struct cb_field	*f;

	if (cb_validate_list (keys)) {
		return;
	}
	for (l = keys; l; l = CB_CHAIN (l)) {
		if (CB_VALUE (l) == NULL) {
			CB_VALUE (l) = name;
		}
		cb_ref (CB_VALUE (l));
	}

	if (CB_FILE_P (cb_ref (name))) {
		if (CB_FILE (cb_ref (name))->organization != COB_ORG_SORT) {
			cb_error_x (name, _("Invalid SORT filename"));
		}
		cb_field (current_program->cb_sort_return)->count++;
		cb_emit (cb_build_funcall_5 ("cob_file_sort_init", cb_ref (name),
					     cb_int (cb_list_length (keys)), col,
					     cb_build_cast_address (current_program->cb_sort_return),
					     CB_FILE(cb_ref (name))->file_status));
		for (l = keys; l; l = CB_CHAIN (l)) {
			cb_emit (cb_build_funcall_4 ("cob_file_sort_init_key", cb_ref (name),
					CB_PURPOSE (l),
					CB_VALUE (l),
					cb_int (cb_field (CB_VALUE(l))->offset)));
		}
	} else {
		f = CB_FIELD (cb_ref (name));
		if (keys == NULL) {
			cb_error_x (name, _("Table sort without keys not implemented yet"));
		}
		cb_emit (cb_build_funcall_2 ("cob_table_sort_init", cb_int (cb_list_length (keys)), col));
		for (l = keys; l; l = CB_CHAIN (l)) {
			cb_emit (cb_build_funcall_3 ("cob_table_sort_init_key",
					CB_PURPOSE (l),
					CB_VALUE (l),
					cb_int (cb_field (CB_VALUE(l))->offset)));
		}
		cb_emit (cb_build_funcall_2 ("cob_table_sort", name,
					     (f->occurs_depending
					      ? cb_build_cast_integer (f->occurs_depending)
					      : cb_int (f->occurs_max))));
	}
}

void
cb_emit_sort_using (cb_tree file, cb_tree l)
{
	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))));
	}
}

void
cb_emit_sort_input (cb_tree proc)
{
	cb_emit (cb_build_perform_once (proc));
}

void
cb_emit_sort_giving (cb_tree file, cb_tree l)
{
	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);
}

void
cb_emit_sort_output (cb_tree proc)
{
	cb_emit (cb_build_perform_once (proc));
}

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

/*
 * START statement
 */

void
cb_emit_start (cb_tree file, cb_tree op, cb_tree key)
{
	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));
	}
}

/*
 * STOP statement
 */

void
cb_emit_stop_run (cb_tree x)
{
	cb_emit (cb_build_funcall_1 ("cob_stop_run", cb_build_cast_integer (x)));
}

/*
 * STRING statement
 */

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

/*
 * UNLOCK statement
 */

void
cb_emit_unlock (cb_tree ref)
{
	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;
	}
}

/*
 * UNSTRING statement
 */

void
cb_emit_unstring (cb_tree name, cb_tree delimited, cb_tree into, cb_tree pointer, cb_tree tallying)
{
	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"));
}

cb_tree
cb_build_unstring_delimited (cb_tree all, cb_tree value)
{
	if (cb_validate_one (value)) {
		return cb_error_node;
	}
	return cb_build_funcall_2 ("cob_unstring_delimited", value, all);
}

cb_tree
cb_build_unstring_into (cb_tree name, cb_tree delimiter, cb_tree count)
{
	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);
}

/*
 * WRITE statement
 */

void
cb_emit_write (cb_tree record, cb_tree from, cb_tree opt, cb_tree lockopt)
{
	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));
	}
}

cb_tree
cb_build_write_advancing_lines (cb_tree pos, cb_tree lines)
{
	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);
}

cb_tree
cb_build_write_advancing_mnemonic (cb_tree pos, cb_tree mnemonic)
{
	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;
	}
}

cb_tree
cb_build_write_advancing_page (cb_tree pos)
{
	int opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;

	return cb_int (opt | COB_WRITE_PAGE);
}
