#include "config.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <unistd.h>
#include "cobc.h"
#include "tree.h"
#include "parser.h"

Include dependency graph for scanner.l:

Data Structures
struct	cob_field_attr

struct	cob_field

struct	cob_fp_128

struct	cob_decimal

struct	cob_frame

union	cob_content

union	cob_call_union

struct	cob_call_struct

struct	__cob_screen

struct	__cob_module

struct	cob_func_loc

struct	cob_file_key

struct	cob_file

struct	cob_linage

struct	cob_report

struct	__cob_global

struct	cob_fileio_funcs

struct	cobjmp_buf

struct	longoption_def

struct	cb_text_list

struct	cb_replace_list

struct	cb_define_struct

struct	local_filename

struct	filename

struct	cb_exception

struct	noreserve

struct	cobc_mem_struct

struct	cobc_reserved

struct	cb_tree_common

struct	cb_const

struct	cb_direct

struct	cb_debug

struct	cb_debug_call

struct	cb_integer

struct	cb_string

struct	cb_alphabet_name

struct	cb_class_name

struct	cb_locale_name

struct	cb_system_name

struct	cb_literal

struct	cb_decimal

struct	cb_picture

struct	cb_key

struct	cb_field

struct	cb_para_label

struct	cb_alter_id

struct	cb_label

struct	handler_struct

struct	cb_alt_key

struct	cb_file

struct	cb_word

struct	cb_reference

struct	cb_binary_op

struct	cb_funcall

struct	cb_cast

struct	cb_assign

struct	cb_intrinsic_table

struct	cb_intrinsic

struct	cb_initialize

struct	cb_search

struct	cb_call

struct	cb_cancel

struct	cb_alter

struct	cb_goto

struct	cb_if

struct	cb_perform_varying

struct	cb_perform

struct	cb_attr_struct

struct	cb_statement

struct	cb_continue

struct	cb_set_attr

struct	cb_list

struct	cb_report

struct	nested_list

struct	cb_program

struct	cb_level_78

struct	cb_top_level_78

Macros
#define	YY_READ_BUF_SIZE 32768

#define	YY_BUF_SIZE 32768

#define	YY_SKIP_YYWRAP

#define	yywrap() 1

#define	YY_INPUT(buf, result, max_size)

#define	YY_USER_INIT

#define	COB_IN_SCANNER 1

#define	YYSTYPE cb_tree

#define	SET_LOCATION(x)

Typedefs
typedef struct __cob_screen	cob_screen

typedef struct __cob_module	cob_module

typedef struct __cob_global	cob_global

typedef struct longoption_def	longoption_def

typedef struct cb_tree_common *	cb_tree

Enumerations
enum	cb_operation_type { CB_OPERATION_READ = 0, CB_OPERATION_WRITE, CB_OPERATION_ASSIGN }

enum	cb_support { CB_OK = 0, CB_WARNING, CB_ARCHAIC, CB_OBSOLETE, CB_SKIP, CB_IGNORE, CB_ERROR, CB_UNCONFORMABLE }

enum	cb_std_def { CB_STD_OC = 0, CB_STD_MF, CB_STD_IBM, CB_STD_MVS, CB_STD_BS2000, CB_STD_85, CB_STD_2002 }

enum	cb_tag { CB_TAG_CONST = 0, CB_TAG_INTEGER, CB_TAG_STRING, CB_TAG_ALPHABET_NAME, CB_TAG_CLASS_NAME, CB_TAG_LOCALE_NAME, CB_TAG_SYSTEM_NAME, CB_TAG_LITERAL, CB_TAG_DECIMAL, CB_TAG_FIELD, CB_TAG_FILE, CB_TAG_REPORT, CB_TAG_REFERENCE, CB_TAG_BINARY_OP, CB_TAG_FUNCALL, CB_TAG_CAST, CB_TAG_INTRINSIC, CB_TAG_LABEL, CB_TAG_ASSIGN, CB_TAG_INITIALIZE, CB_TAG_SEARCH, CB_TAG_CALL, CB_TAG_GOTO, CB_TAG_IF, CB_TAG_PERFORM, CB_TAG_STATEMENT, CB_TAG_CONTINUE, CB_TAG_CANCEL, CB_TAG_ALTER, CB_TAG_SET_ATTR, CB_TAG_PERFORM_VARYING, CB_TAG_PICTURE, CB_TAG_LIST, CB_TAG_DIRECT, CB_TAG_DEBUG, CB_TAG_DEBUG_CALL, CB_TAG_CONST = 0, CB_TAG_INTEGER, CB_TAG_STRING, CB_TAG_ALPHABET_NAME, CB_TAG_CLASS_NAME, CB_TAG_LOCALE_NAME, CB_TAG_SYSTEM_NAME, CB_TAG_LITERAL, CB_TAG_DECIMAL, CB_TAG_FIELD, CB_TAG_FILE, CB_TAG_REPORT, CB_TAG_REFERENCE, CB_TAG_BINARY_OP, CB_TAG_FUNCALL, CB_TAG_CAST, CB_TAG_INTRINSIC, CB_TAG_LABEL, CB_TAG_ASSIGN, CB_TAG_INITIALIZE, CB_TAG_SEARCH, CB_TAG_CALL, CB_TAG_GOTO, CB_TAG_IF, CB_TAG_PERFORM, CB_TAG_STATEMENT, CB_TAG_CONTINUE, CB_TAG_CANCEL, CB_TAG_ALTER, CB_TAG_SET_ATTR, CB_TAG_PERFORM_VARYING, CB_TAG_PICTURE, CB_TAG_LIST, CB_TAG_DIRECT, CB_TAG_DEBUG, CB_TAG_DEBUG_CALL, CB_TAG_CONST = 0, CB_TAG_INTEGER, CB_TAG_STRING, CB_TAG_ALPHABET_NAME, CB_TAG_CLASS_NAME, CB_TAG_LOCALE_NAME, CB_TAG_SYSTEM_NAME, CB_TAG_LITERAL, CB_TAG_DECIMAL, CB_TAG_FIELD, CB_TAG_FILE, CB_TAG_REPORT, CB_TAG_REFERENCE, CB_TAG_BINARY_OP, CB_TAG_FUNCALL, CB_TAG_CAST, CB_TAG_INTRINSIC, CB_TAG_LABEL, CB_TAG_ASSIGN, CB_TAG_INITIALIZE, CB_TAG_SEARCH, CB_TAG_CALL, CB_TAG_GOTO, CB_TAG_IF, CB_TAG_PERFORM, CB_TAG_STATEMENT, CB_TAG_CONTINUE, CB_TAG_CANCEL, CB_TAG_ALTER, CB_TAG_SET_ATTR, CB_TAG_PERFORM_VARYING, CB_TAG_PICTURE, CB_TAG_LIST, CB_TAG_DIRECT, CB_TAG_DEBUG, CB_TAG_DEBUG_CALL }

enum	cb_system_name_category { CB_DEVICE_NAME = 0, CB_SWITCH_NAME, CB_FEATURE_NAME, CB_CALL_CONVENTION_NAME, CB_CODE_NAME, CB_COMPUTER_NAME, CB_ENTRY_CONVENTION_NAME, CB_EXTERNAL_LOCALE_NAME, CB_LIBRARY_NAME, CB_TEXT_NAME, CB_DEVICE_NAME = 0, CB_SWITCH_NAME, CB_FEATURE_NAME, CB_CALL_CONVENTION_NAME, CB_CODE_NAME, CB_COMPUTER_NAME, CB_ENTRY_CONVENTION_NAME, CB_EXTERNAL_LOCALE_NAME, CB_LIBRARY_NAME, CB_TEXT_NAME, CB_DEVICE_NAME = 0, CB_SWITCH_NAME, CB_FEATURE_NAME, CB_CALL_CONVENTION_NAME, CB_CODE_NAME, CB_COMPUTER_NAME, CB_ENTRY_CONVENTION_NAME, CB_EXTERNAL_LOCALE_NAME, CB_LIBRARY_NAME, CB_TEXT_NAME }

enum	cb_class { CB_CLASS_UNKNOWN = 0, CB_CLASS_ALPHABETIC, CB_CLASS_ALPHANUMERIC, CB_CLASS_BOOLEAN, CB_CLASS_INDEX, CB_CLASS_NATIONAL, CB_CLASS_NUMERIC, CB_CLASS_OBJECT, CB_CLASS_POINTER, CB_CLASS_UNKNOWN = 0, CB_CLASS_ALPHABETIC, CB_CLASS_ALPHANUMERIC, CB_CLASS_BOOLEAN, CB_CLASS_INDEX, CB_CLASS_NATIONAL, CB_CLASS_NUMERIC, CB_CLASS_OBJECT, CB_CLASS_POINTER, CB_CLASS_UNKNOWN = 0, CB_CLASS_ALPHABETIC, CB_CLASS_ALPHANUMERIC, CB_CLASS_BOOLEAN, CB_CLASS_INDEX, CB_CLASS_NATIONAL, CB_CLASS_NUMERIC, CB_CLASS_OBJECT, CB_CLASS_POINTER }

enum	cb_category { CB_CATEGORY_UNKNOWN = 0, CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_ALPHANUMERIC_EDITED, CB_CATEGORY_BOOLEAN, CB_CATEGORY_INDEX, CB_CATEGORY_NATIONAL, CB_CATEGORY_NATIONAL_EDITED, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, CB_CATEGORY_OBJECT_REFERENCE, CB_CATEGORY_DATA_POINTER, CB_CATEGORY_PROGRAM_POINTER, CB_CATEGORY_UNKNOWN = 0, CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_ALPHANUMERIC_EDITED, CB_CATEGORY_BOOLEAN, CB_CATEGORY_INDEX, CB_CATEGORY_NATIONAL, CB_CATEGORY_NATIONAL_EDITED, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, CB_CATEGORY_OBJECT_REFERENCE, CB_CATEGORY_DATA_POINTER, CB_CATEGORY_PROGRAM_POINTER, CB_CATEGORY_UNKNOWN = 0, CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_ALPHANUMERIC_EDITED, CB_CATEGORY_BOOLEAN, CB_CATEGORY_INDEX, CB_CATEGORY_NATIONAL, CB_CATEGORY_NATIONAL_EDITED, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, CB_CATEGORY_OBJECT_REFERENCE, CB_CATEGORY_DATA_POINTER, CB_CATEGORY_PROGRAM_POINTER }

enum	cb_storage { CB_STORAGE_CONSTANT = 0, CB_STORAGE_FILE, CB_STORAGE_WORKING, CB_STORAGE_LOCAL, CB_STORAGE_LINKAGE, CB_STORAGE_SCREEN, CB_STORAGE_REPORT, CB_STORAGE_COMMUNICATION, CB_STORAGE_CONSTANT = 0, CB_STORAGE_FILE, CB_STORAGE_WORKING, CB_STORAGE_LOCAL, CB_STORAGE_LINKAGE, CB_STORAGE_SCREEN, CB_STORAGE_REPORT, CB_STORAGE_COMMUNICATION, CB_STORAGE_CONSTANT = 0, CB_STORAGE_FILE, CB_STORAGE_WORKING, CB_STORAGE_LOCAL, CB_STORAGE_LINKAGE, CB_STORAGE_SCREEN, CB_STORAGE_REPORT, CB_STORAGE_COMMUNICATION }

enum	cb_usage { CB_USAGE_BINARY = 0, CB_USAGE_BIT, CB_USAGE_COMP_5, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_FLOAT, CB_USAGE_DOUBLE, CB_USAGE_INDEX, CB_USAGE_NATIONAL, CB_USAGE_OBJECT, CB_USAGE_PACKED, CB_USAGE_POINTER, CB_USAGE_PROGRAM, CB_USAGE_LENGTH, CB_USAGE_PROGRAM_POINTER, CB_USAGE_UNSIGNED_CHAR, CB_USAGE_SIGNED_CHAR, CB_USAGE_UNSIGNED_SHORT, CB_USAGE_SIGNED_SHORT, CB_USAGE_UNSIGNED_INT, CB_USAGE_SIGNED_INT, CB_USAGE_UNSIGNED_LONG, CB_USAGE_SIGNED_LONG, CB_USAGE_COMP_6, CB_USAGE_FP_DEC64, CB_USAGE_FP_DEC128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_BIN128, CB_USAGE_LONG_DOUBLE, CB_USAGE_BINARY = 0, CB_USAGE_BIT, CB_USAGE_COMP_5, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_FLOAT, CB_USAGE_DOUBLE, CB_USAGE_INDEX, CB_USAGE_NATIONAL, CB_USAGE_OBJECT, CB_USAGE_PACKED, CB_USAGE_POINTER, CB_USAGE_PROGRAM, CB_USAGE_LENGTH, CB_USAGE_PROGRAM_POINTER, CB_USAGE_UNSIGNED_CHAR, CB_USAGE_SIGNED_CHAR, CB_USAGE_UNSIGNED_SHORT, CB_USAGE_SIGNED_SHORT, CB_USAGE_UNSIGNED_INT, CB_USAGE_SIGNED_INT, CB_USAGE_UNSIGNED_LONG, CB_USAGE_SIGNED_LONG, CB_USAGE_COMP_6, CB_USAGE_FP_DEC64, CB_USAGE_FP_DEC128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_BIN128, CB_USAGE_LONG_DOUBLE, CB_USAGE_BINARY = 0, CB_USAGE_BIT, CB_USAGE_COMP_5, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_FLOAT, CB_USAGE_DOUBLE, CB_USAGE_INDEX, CB_USAGE_NATIONAL, CB_USAGE_OBJECT, CB_USAGE_PACKED, CB_USAGE_POINTER, CB_USAGE_PROGRAM, CB_USAGE_LENGTH, CB_USAGE_PROGRAM_POINTER, CB_USAGE_UNSIGNED_CHAR, CB_USAGE_SIGNED_CHAR, CB_USAGE_UNSIGNED_SHORT, CB_USAGE_SIGNED_SHORT, CB_USAGE_UNSIGNED_INT, CB_USAGE_SIGNED_INT, CB_USAGE_UNSIGNED_LONG, CB_USAGE_SIGNED_LONG, CB_USAGE_COMP_6, CB_USAGE_FP_DEC64, CB_USAGE_FP_DEC128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_BIN128, CB_USAGE_LONG_DOUBLE }

enum	cb_cast_type { CB_CAST_INTEGER = 0, CB_CAST_LONG_INT, CB_CAST_ADDRESS, CB_CAST_ADDR_OF_ADDR, CB_CAST_LENGTH, CB_CAST_PROGRAM_POINTER, CB_CAST_INTEGER = 0, CB_CAST_LONG_INT, CB_CAST_ADDRESS, CB_CAST_ADDR_OF_ADDR, CB_CAST_LENGTH, CB_CAST_PROGRAM_POINTER, CB_CAST_INTEGER = 0, CB_CAST_LONG_INT, CB_CAST_ADDRESS, CB_CAST_ADDR_OF_ADDR, CB_CAST_LENGTH, CB_CAST_PROGRAM_POINTER }

enum	cb_intr_enum { CB_INTR_ABS = 1, CB_INTR_ACOS, CB_INTR_ANNUITY, CB_INTR_ASIN, CB_INTR_ATAN, CB_INTR_BOOLEAN_OF_INTEGER, CB_INTR_BYTE_LENGTH, CB_INTR_CHAR, CB_INTR_CHAR_NATIONAL, CB_INTR_COMBINED_DATETIME, CB_INTR_CONCATENATE, CB_INTR_COS, CB_INTR_CURRENCY_SYMBOL, CB_INTR_CURRENT_DATE, CB_INTR_DATE_OF_INTEGER, CB_INTR_DATE_TO_YYYYMMDD, CB_INTR_DAY_OF_INTEGER, CB_INTR_DAY_TO_YYYYDDD, CB_INTR_DISPLAY_OF, CB_INTR_E, CB_INTR_EXCEPTION_FILE, CB_INTR_EXCEPTION_FILE_N, CB_INTR_EXCEPTION_LOCATION, CB_INTR_EXCEPTION_LOCATION_N, CB_INTR_EXCEPTION_STATEMENT, CB_INTR_EXCEPTION_STATUS, CB_INTR_EXP, CB_INTR_EXP10, CB_INTR_FACTORIAL, CB_INTR_FORMATTED_CURRENT_DATE, CB_INTR_FORMATTED_DATE, CB_INTR_FORMATTED_DATETIME, CB_INTR_FORMATTED_TIME, CB_INTR_FRACTION_PART, CB_INTR_HIGHEST_ALGEBRAIC, CB_INTR_INTEGER, CB_INTR_INTEGER_OF_BOOLEAN, CB_INTR_INTEGER_OF_DATE, CB_INTR_INTEGER_OF_DAY, CB_INTR_INTEGER_OF_FORMATTED_DATE, CB_INTR_INTEGER_PART, CB_INTR_LENGTH, CB_INTR_LOCALE_COMPARE, CB_INTR_LOCALE_DATE, CB_INTR_LOCALE_TIME, CB_INTR_LOCALE_TIME_FROM_SECS, CB_INTR_LOG, CB_INTR_LOG10, CB_INTR_LOWER_CASE, CB_INTR_LOWEST_ALGEBRAIC, CB_INTR_MAX, CB_INTR_MEAN, CB_INTR_MEDIAN, CB_INTR_MIDRANGE, CB_INTR_MIN, CB_INTR_MOD, CB_INTR_MODULE_CALLER_ID, CB_INTR_MODULE_DATE, CB_INTR_MODULE_FORMATTED_DATE, CB_INTR_MODULE_ID, CB_INTR_MODULE_PATH, CB_INTR_MODULE_SOURCE, CB_INTR_MODULE_TIME, CB_INTR_MON_DECIMAL_POINT, CB_INTR_MON_THOUSANDS_SEP, CB_INTR_NATIONAL_OF, CB_INTR_NUM_DECIMAL_POINT, CB_INTR_NUM_THOUSANDS_SEP, CB_INTR_NUMVAL, CB_INTR_NUMVAL_C, CB_INTR_NUMVAL_F, CB_INTR_ORD, CB_INTR_ORD_MAX, CB_INTR_ORD_MIN, CB_INTR_PI, CB_INTR_PRESENT_VALUE, CB_INTR_RANDOM, CB_INTR_RANGE, CB_INTR_REM, CB_INTR_REVERSE, CB_INTR_SECONDS_FROM_FORMATTED_TIME, CB_INTR_SECONDS_PAST_MIDNIGHT, CB_INTR_SIGN, CB_INTR_SIN, CB_INTR_SQRT, CB_INTR_STANDARD_COMPARE, CB_INTR_STANDARD_DEVIATION, CB_INTR_STORED_CHAR_LENGTH, CB_INTR_SUBSTITUTE, CB_INTR_SUBSTITUTE_CASE, CB_INTR_SUM, CB_INTR_TAN, CB_INTR_TEST_DATE_YYYYMMDD, CB_INTR_TEST_DAY_YYYYDDD, CB_INTR_TEST_FORMATTED_DATETIME, CB_INTR_TEST_NUMVAL, CB_INTR_TEST_NUMVAL_C, CB_INTR_TEST_NUMVAL_F, CB_INTR_TRIM, CB_INTR_UPPER_CASE, CB_INTR_USER_FUNCTION, CB_INTR_VARIANCE, CB_INTR_WHEN_COMPILED, CB_INTR_YEAR_TO_YYYY, CB_INTR_ABS = 1, CB_INTR_ACOS, CB_INTR_ANNUITY, CB_INTR_ASIN, CB_INTR_ATAN, CB_INTR_BOOLEAN_OF_INTEGER, CB_INTR_BYTE_LENGTH, CB_INTR_CHAR, CB_INTR_CHAR_NATIONAL, CB_INTR_COMBINED_DATETIME, CB_INTR_CONCATENATE, CB_INTR_COS, CB_INTR_CURRENCY_SYMBOL, CB_INTR_CURRENT_DATE, CB_INTR_DATE_OF_INTEGER, CB_INTR_DATE_TO_YYYYMMDD, CB_INTR_DAY_OF_INTEGER, CB_INTR_DAY_TO_YYYYDDD, CB_INTR_DISPLAY_OF, CB_INTR_E, CB_INTR_EXCEPTION_FILE, CB_INTR_EXCEPTION_FILE_N, CB_INTR_EXCEPTION_LOCATION, CB_INTR_EXCEPTION_LOCATION_N, CB_INTR_EXCEPTION_STATEMENT, CB_INTR_EXCEPTION_STATUS, CB_INTR_EXP, CB_INTR_EXP10, CB_INTR_FACTORIAL, CB_INTR_FORMATTED_CURRENT_DATE, CB_INTR_FORMATTED_DATE, CB_INTR_FORMATTED_DATETIME, CB_INTR_FORMATTED_TIME, CB_INTR_FRACTION_PART, CB_INTR_HIGHEST_ALGEBRAIC, CB_INTR_INTEGER, CB_INTR_INTEGER_OF_BOOLEAN, CB_INTR_INTEGER_OF_DATE, CB_INTR_INTEGER_OF_DAY, CB_INTR_INTEGER_OF_FORMATTED_DATE, CB_INTR_INTEGER_PART, CB_INTR_LENGTH, CB_INTR_LOCALE_COMPARE, CB_INTR_LOCALE_DATE, CB_INTR_LOCALE_TIME, CB_INTR_LOCALE_TIME_FROM_SECS, CB_INTR_LOG, CB_INTR_LOG10, CB_INTR_LOWER_CASE, CB_INTR_LOWEST_ALGEBRAIC, CB_INTR_MAX, CB_INTR_MEAN, CB_INTR_MEDIAN, CB_INTR_MIDRANGE, CB_INTR_MIN, CB_INTR_MOD, CB_INTR_MODULE_CALLER_ID, CB_INTR_MODULE_DATE, CB_INTR_MODULE_FORMATTED_DATE, CB_INTR_MODULE_ID, CB_INTR_MODULE_PATH, CB_INTR_MODULE_SOURCE, CB_INTR_MODULE_TIME, CB_INTR_MON_DECIMAL_POINT, CB_INTR_MON_THOUSANDS_SEP, CB_INTR_NATIONAL_OF, CB_INTR_NUM_DECIMAL_POINT, CB_INTR_NUM_THOUSANDS_SEP, CB_INTR_NUMVAL, CB_INTR_NUMVAL_C, CB_INTR_NUMVAL_F, CB_INTR_ORD, CB_INTR_ORD_MAX, CB_INTR_ORD_MIN, CB_INTR_PI, CB_INTR_PRESENT_VALUE, CB_INTR_RANDOM, CB_INTR_RANGE, CB_INTR_REM, CB_INTR_REVERSE, CB_INTR_SECONDS_FROM_FORMATTED_TIME, CB_INTR_SECONDS_PAST_MIDNIGHT, CB_INTR_SIGN, CB_INTR_SIN, CB_INTR_SQRT, CB_INTR_STANDARD_COMPARE, CB_INTR_STANDARD_DEVIATION, CB_INTR_STORED_CHAR_LENGTH, CB_INTR_SUBSTITUTE, CB_INTR_SUBSTITUTE_CASE, CB_INTR_SUM, CB_INTR_TAN, CB_INTR_TEST_DATE_YYYYMMDD, CB_INTR_TEST_DAY_YYYYDDD, CB_INTR_TEST_FORMATTED_DATETIME, CB_INTR_TEST_NUMVAL, CB_INTR_TEST_NUMVAL_C, CB_INTR_TEST_NUMVAL_F, CB_INTR_TRIM, CB_INTR_UPPER_CASE, CB_INTR_USER_FUNCTION, CB_INTR_VARIANCE, CB_INTR_WHEN_COMPILED, CB_INTR_YEAR_TO_YYYY, CB_INTR_ABS = 1, CB_INTR_ACOS, CB_INTR_ANNUITY, CB_INTR_ASIN, CB_INTR_ATAN, CB_INTR_BOOLEAN_OF_INTEGER, CB_INTR_BYTE_LENGTH, CB_INTR_CHAR, CB_INTR_CHAR_NATIONAL, CB_INTR_COMBINED_DATETIME, CB_INTR_CONCATENATE, CB_INTR_COS, CB_INTR_CURRENCY_SYMBOL, CB_INTR_CURRENT_DATE, CB_INTR_DATE_OF_INTEGER, CB_INTR_DATE_TO_YYYYMMDD, CB_INTR_DAY_OF_INTEGER, CB_INTR_DAY_TO_YYYYDDD, CB_INTR_DISPLAY_OF, CB_INTR_E, CB_INTR_EXCEPTION_FILE, CB_INTR_EXCEPTION_FILE_N, CB_INTR_EXCEPTION_LOCATION, CB_INTR_EXCEPTION_LOCATION_N, CB_INTR_EXCEPTION_STATEMENT, CB_INTR_EXCEPTION_STATUS, CB_INTR_EXP, CB_INTR_EXP10, CB_INTR_FACTORIAL, CB_INTR_FORMATTED_CURRENT_DATE, CB_INTR_FORMATTED_DATE, CB_INTR_FORMATTED_DATETIME, CB_INTR_FORMATTED_TIME, CB_INTR_FRACTION_PART, CB_INTR_HIGHEST_ALGEBRAIC, CB_INTR_INTEGER, CB_INTR_INTEGER_OF_BOOLEAN, CB_INTR_INTEGER_OF_DATE, CB_INTR_INTEGER_OF_DAY, CB_INTR_INTEGER_OF_FORMATTED_DATE, CB_INTR_INTEGER_PART, CB_INTR_LENGTH, CB_INTR_LOCALE_COMPARE, CB_INTR_LOCALE_DATE, CB_INTR_LOCALE_TIME, CB_INTR_LOCALE_TIME_FROM_SECS, CB_INTR_LOG, CB_INTR_LOG10, CB_INTR_LOWER_CASE, CB_INTR_LOWEST_ALGEBRAIC, CB_INTR_MAX, CB_INTR_MEAN, CB_INTR_MEDIAN, CB_INTR_MIDRANGE, CB_INTR_MIN, CB_INTR_MOD, CB_INTR_MODULE_CALLER_ID, CB_INTR_MODULE_DATE, CB_INTR_MODULE_FORMATTED_DATE, CB_INTR_MODULE_ID, CB_INTR_MODULE_PATH, CB_INTR_MODULE_SOURCE, CB_INTR_MODULE_TIME, CB_INTR_MON_DECIMAL_POINT, CB_INTR_MON_THOUSANDS_SEP, CB_INTR_NATIONAL_OF, CB_INTR_NUM_DECIMAL_POINT, CB_INTR_NUM_THOUSANDS_SEP, CB_INTR_NUMVAL, CB_INTR_NUMVAL_C, CB_INTR_NUMVAL_F, CB_INTR_ORD, CB_INTR_ORD_MAX, CB_INTR_ORD_MIN, CB_INTR_PI, CB_INTR_PRESENT_VALUE, CB_INTR_RANDOM, CB_INTR_RANGE, CB_INTR_REM, CB_INTR_REVERSE, CB_INTR_SECONDS_FROM_FORMATTED_TIME, CB_INTR_SECONDS_PAST_MIDNIGHT, CB_INTR_SIGN, CB_INTR_SIN, CB_INTR_SQRT, CB_INTR_STANDARD_COMPARE, CB_INTR_STANDARD_DEVIATION, CB_INTR_STORED_CHAR_LENGTH, CB_INTR_SUBSTITUTE, CB_INTR_SUBSTITUTE_CASE, CB_INTR_SUM, CB_INTR_TAN, CB_INTR_TEST_DATE_YYYYMMDD, CB_INTR_TEST_DAY_YYYYDDD, CB_INTR_TEST_FORMATTED_DATETIME, CB_INTR_TEST_NUMVAL, CB_INTR_TEST_NUMVAL_C, CB_INTR_TEST_NUMVAL_F, CB_INTR_TRIM, CB_INTR_UPPER_CASE, CB_INTR_USER_FUNCTION, CB_INTR_VARIANCE, CB_INTR_WHEN_COMPILED, CB_INTR_YEAR_TO_YYYY }

enum	cb_perform_type { CB_PERFORM_EXIT = 0, CB_PERFORM_ONCE, CB_PERFORM_TIMES, CB_PERFORM_UNTIL, CB_PERFORM_FOREVER, CB_PERFORM_EXIT = 0, CB_PERFORM_ONCE, CB_PERFORM_TIMES, CB_PERFORM_UNTIL, CB_PERFORM_FOREVER, CB_PERFORM_EXIT = 0, CB_PERFORM_ONCE, CB_PERFORM_TIMES, CB_PERFORM_UNTIL, CB_PERFORM_FOREVER }

Functions
COB_EXPIMP void	print_runtime_env (void)

COB_EXPIMP void	print_info (void)

COB_EXPIMP void	print_version (void)

char *	cob_int_to_string (int, char *)

char *	cob_int_to_formatted_bytestring (int, char *)

char *	cob_strcat (char , char )

char *	cob_strjoin (char *, int, char )

COB_EXPIMP cob_global *	cob_get_global_ptr (void)

COB_EXPIMP void	cob_init (const int, char **)

COB_EXPIMP void	cob_module_enter (cob_module , cob_global , const int)

COB_EXPIMP void	cob_module_leave (cob_module *)

DECLNORET COB_EXPIMP void	cob_stop_run (const int) COB_A_NORETURN

DECLNORET COB_EXPIMP void	cob_fatal_error (const int) COB_A_NORETURN

COB_EXPIMP void *	cob_malloc (const size_t) COB_A_MALLOC

COB_EXPIMP void	cob_free (void *)

COB_EXPIMP void *	cob_fast_malloc (const size_t) COB_A_MALLOC

COB_EXPIMP void *	cob_cache_malloc (const size_t) COB_A_MALLOC

COB_EXPIMP void *	cob_cache_realloc (void *, const size_t)

COB_EXPIMP void	cob_cache_free (void *)

COB_EXPIMP void	cob_set_locale (cob_field *, const int)

COB_EXPIMP void	cob_check_version (const char , const char , const int)

COB_EXPIMP void *	cob_save_func (cob_field **, const int, const int,...)

COB_EXPIMP void	cob_restore_func (struct cob_func_loc *)

COB_EXPIMP void	cob_accept_arg_number (cob_field *)

COB_EXPIMP void	cob_accept_arg_value (cob_field *)

COB_EXPIMP void	cob_accept_command_line (cob_field *)

COB_EXPIMP void	cob_accept_date (cob_field *)

COB_EXPIMP void	cob_accept_date_yyyymmdd (cob_field *)

COB_EXPIMP void	cob_accept_day (cob_field *)

COB_EXPIMP void	cob_accept_day_yyyyddd (cob_field *)

COB_EXPIMP void	cob_accept_day_of_week (cob_field *)

COB_EXPIMP void	cob_accept_environment (cob_field *)

COB_EXPIMP void	cob_accept_exception_status (cob_field *)

COB_EXPIMP void	cob_accept_time (cob_field *)

COB_EXPIMP void	cob_accept_user_name (cob_field *)

COB_EXPIMP void	cob_display_command_line (cob_field *)

COB_EXPIMP void	cob_display_environment (const cob_field *)

COB_EXPIMP void	cob_display_env_value (const cob_field *)

COB_EXPIMP void	cob_display_arg_number (cob_field *)

COB_EXPIMP void	cob_get_environment (const cob_field , cob_field )

COB_EXPIMP void	cob_set_environment (const cob_field , const cob_field )

COB_EXPIMP void	cob_chain_setup (void *, const size_t, const size_t)

COB_EXPIMP void	cob_allocate (unsigned char *, cob_field , cob_field , cob_field )

COB_EXPIMP void	cob_free_alloc (unsigned char *, unsigned char )

COB_EXPIMP int	cob_extern_init (void)

COB_EXPIMP int	cob_tidy (void)

COB_EXPIMP void *	cob_command_line (int, int , char , char , char *)

COB_EXPIMP char *	cob_getenv (const char *)

COB_EXPIMP int	cob_putenv (char *)

COB_EXPIMP void	cob_incr_temp_iteration (void)

COB_EXPIMP void	cob_temp_name (char , const char )

COB_EXPIMP int	cob_sys_exit_proc (const void , const void )

COB_EXPIMP int	cob_sys_error_proc (const void , const void )

COB_EXPIMP int	cob_sys_system (const void *)

COB_EXPIMP int	cob_sys_and (const void , void , const int)

COB_EXPIMP int	cob_sys_or (const void , void , const int)

COB_EXPIMP int	cob_sys_nor (const void , void , const int)

COB_EXPIMP int	cob_sys_xor (const void , void , const int)

COB_EXPIMP int	cob_sys_imp (const void , void , const int)

COB_EXPIMP int	cob_sys_nimp (const void , void , const int)

COB_EXPIMP int	cob_sys_eq (const void , void , const int)

COB_EXPIMP int	cob_sys_not (void *, const int)

COB_EXPIMP int	cob_sys_xf4 (void , const void )

COB_EXPIMP int	cob_sys_xf5 (const void , void )

COB_EXPIMP int	cob_sys_x91 (void , const void , void *)

COB_EXPIMP int	cob_sys_toupper (void *, const int)

COB_EXPIMP int	cob_sys_tolower (void *, const int)

COB_EXPIMP int	cob_sys_oc_nanosleep (const void *)

COB_EXPIMP int	cob_sys_getpid (void)

COB_EXPIMP int	cob_sys_return_args (void *)

COB_EXPIMP int	cob_sys_parameter_size (void *)

COB_EXPIMP int	cob_sys_getopt_long_long (void , void , void , const int, void , void *)

COB_EXPIMP int	cob_sys_sleep (const void *)

COB_EXPIMP int	cob_sys_calledby (void *)

COB_EXPIMP int	cob_sys_justify (void *,...)

COB_EXPIMP int	cob_sys_printable (void *,...)

COB_EXPIMP void	cob_set_location (const char , const unsigned int, const char , const char , const char )

COB_EXPIMP void	cob_trace_section (const char , const char , const int)

COB_EXPIMP void *	cob_external_addr (const char *, const int)

COB_EXPIMP unsigned char *	cob_get_pointer (const void *)

COB_EXPIMP void *	cob_get_prog_pointer (const void *)

COB_EXPIMP void	cob_ready_trace (void)

COB_EXPIMP void	cob_reset_trace (void)

COB_EXPIMP void	cob_reg_sighnd (void(*sighnd)(int))

COB_EXPIMP int	cob_get_switch (const int)

COB_EXPIMP void	cob_set_switch (const int, const int)

COB_EXPIMP int	cob_cmp (cob_field , cob_field )

COB_EXPIMP int	cob_is_omitted (const cob_field *)

COB_EXPIMP int	cob_is_numeric (const cob_field *)

COB_EXPIMP int	cob_is_alpha (const cob_field *)

COB_EXPIMP int	cob_is_upper (const cob_field *)

COB_EXPIMP int	cob_is_lower (const cob_field *)

COB_EXPIMP void	cob_table_sort_init (const size_t, const unsigned char *)

COB_EXPIMP void	cob_table_sort_init_key (cob_field *, const int, const unsigned int)

COB_EXPIMP void	cob_table_sort (cob_field *, const int)

COB_EXPIMP void	cob_check_numeric (const cob_field , const char )

COB_EXPIMP void	cob_correct_numeric (cob_field *)

COB_EXPIMP void	cob_check_based (const unsigned char , const char )

COB_EXPIMP void	cob_check_odo (const int, const int, const int, const char *)

COB_EXPIMP void	cob_check_subscript (const int, const int, const int, const char *)

COB_EXPIMP void	cob_check_ref_mod (const int, const int, const int, const char *)

COB_EXPIMP int	cob_numeric_cmp (cob_field , cob_field )

COB_EXPIMP void	cob_inspect_init (cob_field *, const cob_u32_t)

COB_EXPIMP void	cob_inspect_start (void)

COB_EXPIMP void	cob_inspect_before (const cob_field *)

COB_EXPIMP void	cob_inspect_after (const cob_field *)

COB_EXPIMP void	cob_inspect_characters (cob_field *)

COB_EXPIMP void	cob_inspect_all (cob_field , cob_field )

COB_EXPIMP void	cob_inspect_leading (cob_field , cob_field )

COB_EXPIMP void	cob_inspect_first (cob_field , cob_field )

COB_EXPIMP void	cob_inspect_trailing (cob_field , cob_field )

COB_EXPIMP void	cob_inspect_converting (const cob_field , const cob_field )

COB_EXPIMP void	cob_inspect_finish (void)

COB_EXPIMP void	cob_string_init (cob_field , cob_field )

COB_EXPIMP void	cob_string_delimited (cob_field *)

COB_EXPIMP void	cob_string_append (cob_field *)

COB_EXPIMP void	cob_string_finish (void)

COB_EXPIMP void	cob_unstring_init (cob_field , cob_field , const size_t)

COB_EXPIMP void	cob_unstring_delimited (cob_field *, const cob_u32_t)

COB_EXPIMP void	cob_unstring_into (cob_field , cob_field , cob_field *)

COB_EXPIMP void	cob_unstring_tallying (cob_field *)

COB_EXPIMP void	cob_unstring_finish (void)

COB_EXPIMP void	cob_move (cob_field , cob_field )

COB_EXPIMP void	cob_set_int (cob_field *, const int)

COB_EXPIMP int	cob_get_int (cob_field *)

COB_EXPIMP cob_s64_t	cob_get_llint (cob_field *)

COB_EXPIMP void	cob_decimal_init (cob_decimal *)

COB_EXPIMP void	cob_decimal_set_llint (cob_decimal *, const cob_s64_t)

COB_EXPIMP void	cob_decimal_set_field (cob_decimal , cob_field )

COB_EXPIMP int	cob_decimal_get_field (cob_decimal , cob_field , const int)

COB_EXPIMP void	cob_decimal_add (cob_decimal , cob_decimal )

COB_EXPIMP void	cob_decimal_sub (cob_decimal , cob_decimal )

COB_EXPIMP void	cob_decimal_mul (cob_decimal , cob_decimal )

COB_EXPIMP void	cob_decimal_div (cob_decimal , cob_decimal )

COB_EXPIMP void	cob_decimal_pow (cob_decimal , cob_decimal )

COB_EXPIMP int	cob_decimal_cmp (cob_decimal , cob_decimal )

COB_EXPIMP void	cob_add (cob_field , cob_field , const int)

COB_EXPIMP void	cob_sub (cob_field , cob_field , const int)

COB_EXPIMP void	cob_mul (cob_field , cob_field , const int)

COB_EXPIMP void	cob_div (cob_field , cob_field , const int)

COB_EXPIMP int	cob_add_int (cob_field *, const int, const int)

COB_EXPIMP int	cob_sub_int (cob_field *, const int, const int)

COB_EXPIMP void	cob_div_quotient (cob_field , cob_field , cob_field *, const int)

COB_EXPIMP void	cob_div_remainder (cob_field *, const int)

COB_EXPIMP int	cob_cmp_int (cob_field *, const int)

COB_EXPIMP int	cob_cmp_uint (cob_field *, const unsigned int)

COB_EXPIMP int	cob_cmp_llint (cob_field *, const cob_s64_t)

COB_EXPIMP int	cob_cmp_packed (cob_field *, const cob_s64_t)

COB_EXPIMP int	cob_cmp_numdisp (const unsigned char *, const size_t, const cob_s64_t, const cob_u32_t)

COB_EXPIMP int	cob_cmp_float (cob_field , cob_field )

COB_EXPIMP void	cob_set_packed_zero (cob_field *)

COB_EXPIMP void	cob_set_packed_int (cob_field *, const int)

COB_EXPIMP void	cob_decimal_alloc (const cob_u32_t,...)

COB_EXPIMP void	cob_decimal_push (const cob_u32_t,...)

COB_EXPIMP void	cob_decimal_pop (const cob_u32_t,...)

COB_EXPIMP void	cob_gmp_free (void *)

DECLNORET COB_EXPIMP void	cob_call_error (void) COB_A_NORETURN

COB_EXPIMP void	cob_set_cancel (cob_module *)

COB_EXPIMP void *	cob_resolve (const char *)

COB_EXPIMP void *	cob_resolve_cobol (const char *, const int, const int)

COB_EXPIMP void *	cob_resolve_func (const char *)

COB_EXPIMP const char *	cob_resolve_error (void)

COB_EXPIMP void *	cob_call_field (const cob_field , const struct cob_call_struct , const unsigned int, const int)

COB_EXPIMP void	cob_cancel_field (const cob_field , const struct cob_call_struct )

COB_EXPIMP void	cob_cancel (const char *)

COB_EXPIMP int	cob_call (const char , const int, void *)

COB_EXPIMP int	cob_func (const char , const int, void *)

COB_EXPIMP void *	cob_savenv (struct cobjmp_buf *)

COB_EXPIMP void *	cob_savenv2 (struct cobjmp_buf *, const int)

COB_EXPIMP void	cob_longjmp (struct cobjmp_buf *)

COB_EXPIMP void	cob_screen_line_col (cob_field *, const int)

COB_EXPIMP void	cob_screen_display (cob_screen , cob_field , cob_field *)

COB_EXPIMP void	cob_screen_accept (cob_screen , cob_field , cob_field , cob_field )

COB_EXPIMP void	cob_field_display (cob_field , cob_field , cob_field , cob_field , cob_field , cob_field , const int)

COB_EXPIMP void	cob_field_accept (cob_field , cob_field , cob_field , cob_field , cob_field , cob_field , cob_field , cob_field , const int)

COB_EXPIMP void	cob_accept_escape_key (cob_field *)

COB_EXPIMP int	cob_sys_clear_screen (void)

COB_EXPIMP int	cob_sys_sound_bell (void)

COB_EXPIMP int	cob_sys_get_csr_pos (unsigned char *)

COB_EXPIMP int	cob_sys_get_scr_size (unsigned char , unsigned char )

COB_EXPIMP void	cob_display (const int, const int, const int,...)

COB_EXPIMP void	cob_accept (cob_field *)

COB_EXPIMP void	cob_open (cob_file , const int, const int, cob_field )

COB_EXPIMP void	cob_close (cob_file , cob_field , const int, const int)

COB_EXPIMP void	cob_read (cob_file , cob_field , cob_field *, const int)

COB_EXPIMP void	cob_read_next (cob_file , cob_field , const int)

COB_EXPIMP void	cob_rewrite (cob_file , cob_field , const int, cob_field *)

COB_EXPIMP void	cob_delete (cob_file , cob_field )

COB_EXPIMP void	cob_start (cob_file , const int, cob_field , cob_field , cob_field )

COB_EXPIMP void	cob_write (cob_file , cob_field , const int, cob_field *, const unsigned int)

COB_EXPIMP void	cob_delete_file (cob_file , cob_field )

COB_EXPIMP void	cob_unlock_file (cob_file , cob_field )

COB_EXPIMP void	cob_commit (void)

COB_EXPIMP void	cob_rollback (void)

COB_EXPIMP int	cob_sys_open_file (unsigned char , unsigned char , unsigned char , unsigned char , unsigned char *)

COB_EXPIMP int	cob_sys_create_file (unsigned char , unsigned char , unsigned char , unsigned char , unsigned char *)

COB_EXPIMP int	cob_sys_read_file (unsigned char , unsigned char , unsigned char , unsigned char , unsigned char *)

COB_EXPIMP int	cob_sys_write_file (unsigned char , unsigned char , unsigned char , unsigned char , unsigned char *)

COB_EXPIMP int	cob_sys_close_file (unsigned char *)

COB_EXPIMP int	cob_sys_flush_file (unsigned char *)

COB_EXPIMP int	cob_sys_delete_file (unsigned char *)

COB_EXPIMP int	cob_sys_copy_file (unsigned char , unsigned char )

COB_EXPIMP int	cob_sys_check_file_exist (unsigned char , unsigned char )

COB_EXPIMP int	cob_sys_rename_file (unsigned char , unsigned char )

COB_EXPIMP int	cob_sys_get_current_dir (const int, const int, unsigned char *)

COB_EXPIMP int	cob_sys_change_dir (unsigned char *)

COB_EXPIMP int	cob_sys_create_dir (unsigned char *)

COB_EXPIMP int	cob_sys_delete_dir (unsigned char *)

COB_EXPIMP int	cob_sys_chdir (unsigned char , unsigned char )

COB_EXPIMP int	cob_sys_mkdir (unsigned char *)

COB_EXPIMP int	cob_sys_copyfile (unsigned char , unsigned char , unsigned char *)

COB_EXPIMP int	cob_sys_file_info (unsigned char , unsigned char )

COB_EXPIMP int	cob_sys_file_delete (unsigned char , unsigned char )

COB_EXPIMP void	cob_file_sort_init (cob_file , const unsigned int, const unsigned char , void , cob_field )

COB_EXPIMP void	cob_file_sort_init_key (cob_file , cob_field , const int, const unsigned int)

COB_EXPIMP void	cob_file_sort_close (cob_file *)

COB_EXPIMP void	cob_file_sort_using (cob_file , cob_file )

COB_EXPIMP void	cob_file_sort_giving (cob_file *, const size_t,...)

COB_EXPIMP void	cob_file_release (cob_file *)

COB_EXPIMP void	cob_file_return (cob_file *)

COB_EXPIMP void	cob_put_indirect_field (cob_field *)

COB_EXPIMP void	cob_get_indirect_field (cob_field *)

COB_EXPIMP cob_field *	cob_switch_value (const int)

COB_EXPIMP cob_field *	cob_intr_binop (cob_field , const int, cob_field )

COB_EXPIMP int	cob_valid_date_format (const char *)

COB_EXPIMP int	cob_valid_datetime_format (const char *)

COB_EXPIMP int	cob_valid_time_format (const char *)

COB_EXPIMP cob_field *	cob_intr_current_date (const int, const int)

COB_EXPIMP cob_field *	cob_intr_when_compiled (const int, const int, cob_field *)

COB_EXPIMP cob_field *	cob_intr_module_date (void)

COB_EXPIMP cob_field *	cob_intr_module_time (void)

COB_EXPIMP cob_field *	cob_intr_module_id (void)

COB_EXPIMP cob_field *	cob_intr_module_caller_id (void)

COB_EXPIMP cob_field *	cob_intr_module_source (void)

COB_EXPIMP cob_field *	cob_intr_module_formatted_date (void)

COB_EXPIMP cob_field *	cob_intr_module_path (void)

COB_EXPIMP cob_field *	cob_intr_exception_file (void)

COB_EXPIMP cob_field *	cob_intr_exception_location (void)

COB_EXPIMP cob_field *	cob_intr_exception_status (void)

COB_EXPIMP cob_field *	cob_intr_exception_statement (void)

COB_EXPIMP cob_field *	cob_intr_mon_decimal_point (void)

COB_EXPIMP cob_field *	cob_intr_num_decimal_point (void)

COB_EXPIMP cob_field *	cob_intr_mon_thousands_sep (void)

COB_EXPIMP cob_field *	cob_intr_num_thousands_sep (void)

COB_EXPIMP cob_field *	cob_intr_currency_symbol (void)

COB_EXPIMP cob_field *	cob_intr_char (cob_field *)

COB_EXPIMP cob_field *	cob_intr_ord (cob_field *)

COB_EXPIMP cob_field *	cob_intr_stored_char_length (cob_field *)

COB_EXPIMP cob_field *	cob_intr_combined_datetime (cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_date_of_integer (cob_field *)

COB_EXPIMP cob_field *	cob_intr_day_of_integer (cob_field *)

COB_EXPIMP cob_field *	cob_intr_integer_of_date (cob_field *)

COB_EXPIMP cob_field *	cob_intr_integer_of_day (cob_field *)

COB_EXPIMP cob_field *	cob_intr_test_date_yyyymmdd (cob_field *)

COB_EXPIMP cob_field *	cob_intr_test_day_yyyyddd (cob_field *)

COB_EXPIMP cob_field *	cob_intr_test_numval (cob_field *)

COB_EXPIMP cob_field *	cob_intr_test_numval_c (cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_test_numval_f (cob_field *)

COB_EXPIMP cob_field *	cob_intr_factorial (cob_field *)

COB_EXPIMP cob_field *	cob_intr_pi (void)

COB_EXPIMP cob_field *	cob_intr_e (void)

COB_EXPIMP cob_field *	cob_intr_exp (cob_field *)

COB_EXPIMP cob_field *	cob_intr_exp10 (cob_field *)

COB_EXPIMP cob_field *	cob_intr_abs (cob_field *)

COB_EXPIMP cob_field *	cob_intr_acos (cob_field *)

COB_EXPIMP cob_field *	cob_intr_asin (cob_field *)

COB_EXPIMP cob_field *	cob_intr_atan (cob_field *)

COB_EXPIMP cob_field *	cob_intr_cos (cob_field *)

COB_EXPIMP cob_field *	cob_intr_log (cob_field *)

COB_EXPIMP cob_field *	cob_intr_log10 (cob_field *)

COB_EXPIMP cob_field *	cob_intr_sin (cob_field *)

COB_EXPIMP cob_field *	cob_intr_sqrt (cob_field *)

COB_EXPIMP cob_field *	cob_intr_tan (cob_field *)

COB_EXPIMP cob_field *	cob_intr_upper_case (const int, const int, cob_field *)

COB_EXPIMP cob_field *	cob_intr_lower_case (const int, const int, cob_field *)

COB_EXPIMP cob_field *	cob_intr_reverse (const int, const int, cob_field *)

COB_EXPIMP cob_field *	cob_intr_concatenate (const int, const int, const int,...)

COB_EXPIMP cob_field *	cob_intr_substitute (const int, const int, const int,...)

COB_EXPIMP cob_field *	cob_intr_substitute_case (const int, const int, const int,...)

COB_EXPIMP cob_field *	cob_intr_trim (const int, const int, cob_field *, const int)

COB_EXPIMP cob_field *	cob_intr_length (cob_field *)

COB_EXPIMP cob_field *	cob_intr_byte_length (cob_field *)

COB_EXPIMP cob_field *	cob_intr_integer (cob_field *)

COB_EXPIMP cob_field *	cob_intr_integer_part (cob_field *)

COB_EXPIMP cob_field *	cob_intr_fraction_part (cob_field *)

COB_EXPIMP cob_field *	cob_intr_sign (cob_field *)

COB_EXPIMP cob_field *	cob_intr_lowest_algebraic (cob_field *)

COB_EXPIMP cob_field *	cob_intr_highest_algebraic (cob_field *)

COB_EXPIMP cob_field *	cob_intr_numval (cob_field *)

COB_EXPIMP cob_field *	cob_intr_numval_c (cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_numval_f (cob_field *)

COB_EXPIMP cob_field *	cob_intr_annuity (cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_mod (cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_rem (cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_sum (const int,...)

COB_EXPIMP cob_field *	cob_intr_ord_min (const int,...)

COB_EXPIMP cob_field *	cob_intr_ord_max (const int,...)

COB_EXPIMP cob_field *	cob_intr_min (const int,...)

COB_EXPIMP cob_field *	cob_intr_max (const int,...)

COB_EXPIMP cob_field *	cob_intr_midrange (const int,...)

COB_EXPIMP cob_field *	cob_intr_median (const int,...)

COB_EXPIMP cob_field *	cob_intr_mean (const int,...)

COB_EXPIMP cob_field *	cob_intr_range (const int,...)

COB_EXPIMP cob_field *	cob_intr_random (const int,...)

COB_EXPIMP cob_field *	cob_intr_variance (const int,...)

COB_EXPIMP cob_field *	cob_intr_standard_deviation (const int,...)

COB_EXPIMP cob_field *	cob_intr_present_value (const int,...)

COB_EXPIMP cob_field *	cob_intr_year_to_yyyy (const int,...)

COB_EXPIMP cob_field *	cob_intr_date_to_yyyymmdd (const int,...)

COB_EXPIMP cob_field *	cob_intr_day_to_yyyyddd (const int,...)

COB_EXPIMP cob_field *	cob_intr_locale_compare (const int,...)

COB_EXPIMP cob_field *	cob_intr_locale_date (const int, const int, cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_locale_time (const int, const int, cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_seconds_past_midnight (void)

COB_EXPIMP cob_field *	cob_intr_lcl_time_from_secs (const int, const int, cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_seconds_from_formatted_time (cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_boolean_of_integer (cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_char_national (cob_field *)

COB_EXPIMP cob_field *	cob_intr_display_of (const int, const int, const int,...)

COB_EXPIMP cob_field *	cob_intr_exception_file_n (void)

COB_EXPIMP cob_field *	cob_intr_exception_location_n (void)

COB_EXPIMP cob_field *	cob_intr_formatted_current_date (const int, const int, cob_field *)

COB_EXPIMP cob_field *	cob_intr_formatted_date (const int, const int, cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_formatted_datetime (const int, const int, const int,...)

COB_EXPIMP cob_field *	cob_intr_formatted_time (const int, const int, const int,...)

COB_EXPIMP cob_field *	cob_intr_integer_of_boolean (cob_field *)

COB_EXPIMP cob_field *	cob_intr_national_of (const int, const int, const int,...)

COB_EXPIMP cob_field *	cob_intr_standard_compare (const int,...)

COB_EXPIMP cob_field *	cob_intr_test_formatted_datetime (cob_field , cob_field )

COB_EXPIMP cob_field *	cob_intr_integer_of_formatted_date (cob_field , cob_field )

static const char *	pgettext_aux (const char domain, const char msg_ctxt_id, const char *msgid, int category)

static const char *	npgettext_aux (const char domain, const char msg_ctxt_id, const char msgid, const char msgid_plural, unsigned long int n, int category)

static const char *	dcpgettext_expr (const char domain, const char msgctxt, const char *msgid, int category)

static const char *	dcnpgettext_expr (const char domain, const char msgctxt, const char msgid, const char msgid_plural, unsigned long int n, int category)

	CB_FLAG_RQ (cb_stack_size, 0,"stack-size", 255, 1, _("Define PERFORM stack size\n\t\t\t- Default : 255")) CB_FLAG_RQ(cb_if_cutoff

if	_ ("Define cutoff depth for IF statements\n\t\t\t- Default : 3")) CB_FLAG_RQ(cb_ebcdic_sign

if	_ ("Define display sign representation\n\t\t\t- ASCII or EBCDIC (Default : machine native)")) CB_FLAG_RQ(cb_fold_copy

if fold	_ ("Fold COPY subject to value\n\t\t\t- UPPER or LOWER (Default : no transformation)")) CB_FLAG_RQ(cb_fold_call

if fold fold	_ ("Fold PROGRAM-ID, CALL, CANCEL subject to value\n\t\t\t- UPPER or LOWER (Default : no transformation)")) CB_FLAG_RQ(cb_default_byte

if fold fold	_ ("Initialize fields without VALUE to decimal value\n\t\t\t- 0 to 255 (Default : initialize to picture)")) CB_FLAG_NQ(1

if fold fold	_ ("Intrinsics to be used without FUNCTION keyword\n\t\t\t- ALL or intrinsic function name (,name,...)")) CB_FLAG(cb_flag_static_call

if fold fold static	_ ("Output static function calls for the CALL statement")) CB_FLAG(cb_flag_computed_goto

if fold fold static computed	_ ("Generate computed goto C statements")) CB_FLAG(cb_flag_alt_ebcdic

if fold fold static computed alternate	_ ("Use restricted ASCII to EBCDIC translate")) CB_FLAG(cb_flag_extra_brace

if fold fold static computed alternate extra	_ ("Generate extra braces in generated C code")) CB_FLAG(cb_flag_correct_numeric

if fold fold static computed alternate extra correct	_ ("Attempt correction of invalid numeric display items")) CB_FLAG(cb_flag_stack_on_heap

if fold fold static computed alternate extra correct stack on	_ ("PERFORM stack allocated on heap")) CB_FLAG(cb_flag_trace

if fold fold static computed alternate extra correct stack on	_ ("Generate trace code\n\t\t\t- Executed SECTION/PARAGRAPH")) CB_FLAG(cb_flag_traceall

if fold fold static computed alternate extra correct stack on	_ ("Generate trace code\n\t\t\t- Executed SECTION/PARAGRAPH/STATEMENTS\n\t\t\t- Turned on by -debug")) CB_FLAG(cb_flag_syntax_only

if fold fold static computed alternate extra correct stack on syntax	_ ("Syntax error checking only; don't emit any output")) CB_FLAG(cb_flag_debugging_line

if fold fold static computed alternate extra correct stack on syntax debugging	_ ("Enable debugging lines\n\t\t\t- 'D' in indicator column or floating >>D")) CB_FLAG(cb_flag_source_location

if fold fold static computed alternate extra correct stack on syntax debugging source	_ ("Generate source location code\n\t\t\t- Turned on by -debug/-g/-ftraceall")) CB_FLAG(cb_flag_implicit_init

if fold fold static computed alternate extra correct stack on syntax debugging source implicit	_ ("Automatic initialization of the Cobol runtime system")) CB_FLAG(cb_flag_stack_check

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack	_ ("PERFORM stack checking\n\t\t\t- Turned on by -debug or -g")) CB_FLAG(cb_flag_syntax_extension

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax	_ ("Allow syntax extensions\n\t\t\t- eg. Switch name SW1, etc.")) CB_FLAG(cb_flag_write_after

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write	_ ("Use AFTER 1 for WRITE of LINE SEQUENTIAL\n\t\t\t- Default : BEFORE 1")) CB_FLAG(cb_flag_mfcomment

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write	_ ("'*' or '/' in column 1 treated as comment\n\t\t\t- FIXED format only")) CB_FLAG(cb_flag_acucomment

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write	_ ("'$' in indicator area treated as '*',\n\t\t\t'\|' treated as floating comment")) CB_FLAG(cb_flag_notrunc

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write	_ ("Allow numeric field overflow\n\t\t\t- Non-ANSI behaviour")) CB_FLAG(cb_flag_odoslide

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write	_ ("Adjust items following OCCURS DEPENDING\n\t\t\t- Requires implicit/explicit relaxed syntax")) CB_FLAG(cb_flag_apostrophe

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single	_ ("Use a single quote (apostrophe) for QUOTE\n\t\t\t- Default : double quote")) CB_FLAG(cb_flag_recursive

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive	_ ("Check recursive program call")) CB_FLAG(cb_flag_relaxed_syntax

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax	_ ("Relax syntax checking\n\t\t\t- eg. REDEFINES position")) CB_FLAG(cb_flag_optional_file

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	_ ("Treat all files as OPTIONAL\n\t\t\t- unless NOT OPTIONAL specified")) CB_WARNDEF(cb_warn_obsolete

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	_ ("Warn if obsolete features are used")) CB_WARNDEF(cb_warn_archaic

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	_ ("Warn if archaic features are used")) CB_WARNDEF(cb_warn_redefinition

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	_ ("Warn incompatible redefinition of data items")) CB_WARNDEF(cb_warn_constant

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	_ ("Warn inconsistent constant")) CB_WARNDEF(cb_warn_overlap

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	_ ("Warn overlapping MOVE items")) CB_WARNDEF(cb_warn_parentheses

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	_ ("Warn lack of parentheses around AND within OR")) CB_WARNDEF(cb_warn_strict_typing

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict	_ ("Warn type mismatch strictly")) CB_WARNDEF(cb_warn_implicit_define

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit	_ ("Warn implicitly defined data items")) CB_WARNDEF(cb_warn_corresponding

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit	_ ("Warn CORRESPONDING with no matching items")) CB_WARNDEF(cb_warn_external_val

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external	_ ("Warn EXTERNAL item with VALUE clause")) CB_NOWARNDEF(cb_warn_call_params

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call	_ ("Warn non 01/77 items for CALL params")) CB_NOWARNDEF(cb_warn_column_overflow

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	_ ("Warn text after column 72, FIXED format")) CB_NOWARNDEF(cb_warn_terminator

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	_ ("Warn lack of scope terminator END-XXX")) CB_NOWARNDEF(cb_warn_truncate

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	_ ("Warn possible field truncation")) CB_NOWARNDEF(cb_warn_linkage

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	_ ("Warn dangling LINKAGE items")) CB_NOWARNDEF(cb_warn_unreachable

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	_ ("Warn unreachable statements")) enum cb_optim

void *	cobc_malloc (const size_t)
	memory allocation for use when compiling More...

void	cobc_free (void *)
	deallocation of compile time memory More...

void *	cobc_strdup (const char *)
	safely duplicate a character array More...

void *	cobc_realloc (void *, const size_t)

void *	cobc_main_malloc (const size_t)

void *	cobc_main_strdup (const char *)

void *	cobc_main_realloc (void *, const size_t)

void	cobc_main_free (void *)

void *	cobc_parse_malloc (const size_t)

void *	cobc_parse_strdup (const char *)

void *	cobc_parse_realloc (void *, const size_t)

void	cobc_parse_free (void *)

void *	cobc_plex_malloc (const size_t)

void *	cobc_plex_strdup (const char *)

void *	cobc_check_string (const char *)

void	cobc_abort_pr (const char *,...) COB_A_FORMAT12

DECLNORET void	cobc_abort (const char *, const int) COB_A_NORETURN

DECLNORET void	cobc_too_many_errors (void) COB_A_NORETURN

DECLNORET void	cobc_dumb_abort (const char *, const int)

size_t	cobc_check_valid_name (const char *, const unsigned int)

int	cb_load_std (const char *)

int	cb_config_entry (char , const char , const int)

int	cb_load_conf (const char *, const int, const int)

int	ppparse (void)

int	ppopen (const char , struct cb_replace_list )

int	ppcopy (const char , const char , struct cb_replace_list *)

void	pp_set_replace_list (struct cb_replace_list *, const cob_u32_t)

void	ppparse_error (const char *)

void	ppparse_clear_vars (const struct cb_define_struct *)

void	plex_clear_vars (void)

void	plex_clear_all (void)

void	plex_call_destroy (void)

void	plex_action_directive (const unsigned int, const unsigned int)

int	yyparse (void)

void	ylex_clear_all (void)

void	ylex_call_destroy (void)

void	cob_gen_optim (const enum cb_optim)

void	cb_warning (const char *,...) COB_A_FORMAT12

void	cb_error (const char *,...) COB_A_FORMAT12

void	cb_plex_warning (const size_t, const char *,...) COB_A_FORMAT23

void	cb_plex_error (const size_t, const char *,...) COB_A_FORMAT23

void	configuration_error (const char , const int, const char ,...) COB_A_FORMAT34

unsigned int	cb_verify (const enum cb_support, const char *)

char *	cb_name (cb_tree)

enum cb_class	cb_tree_class (cb_tree)

enum cb_category	cb_tree_category (cb_tree)

int	cb_tree_type (const cb_tree, const struct cb_field *)

int	cb_category_is_alpha (cb_tree)

int	cb_fits_int (const cb_tree)

int	cb_fits_long_long (const cb_tree)

int	cb_get_int (const cb_tree)

cob_s64_t	cb_get_long_long (const cb_tree)

cob_u64_t	cb_get_u_long_long (const cb_tree)

void	cb_init_constants (void)

cb_tree	cb_int (const int)

cb_tree	cb_int_hex (const int)

cb_tree	cb_build_string (const void *, const size_t)

cb_tree	cb_build_class_name (cb_tree, cb_tree)

cb_tree	cb_build_locale_name (cb_tree, cb_tree)

cb_tree	cb_build_numeric_literal (const int, const void *, const int)

cb_tree	cb_build_alphanumeric_literal (const void *, const size_t)

cb_tree	cb_build_numsize_literal (const void *, const size_t, const int)

cb_tree	cb_concat_literals (const cb_tree, const cb_tree)

cb_tree	cb_build_decimal (const int)

cb_tree	cb_build_picture (const char *)

cb_tree	cb_build_comment (const char *)

cb_tree	cb_build_direct (const char *, const unsigned int)

cb_tree	cb_build_debug (const cb_tree, const char *, const cb_tree)

cb_tree	cb_build_debug_call (struct cb_label *)

struct cb_picture *	cb_build_binary_picture (const char *, const cob_u32_t, const cob_u32_t)

cb_tree	cb_build_field (cb_tree)

cb_tree	cb_build_implicit_field (cb_tree, const int)

cb_tree	cb_build_constant (cb_tree, cb_tree)

void	cb_build_symbolic_chars (const cb_tree, const cb_tree)

struct cb_field *	cb_field_add (struct cb_field , struct cb_field )

struct cb_field *	cb_field_founder (const struct cb_field *)

struct cb_field *	cb_field_variable_size (const struct cb_field *)

unsigned int	cb_field_variable_address (const struct cb_field *)

int	cb_field_subordinate (const struct cb_field , const struct cb_field )

cb_tree	cb_build_label (cb_tree, struct cb_label *)

struct cb_file *	build_file (cb_tree)

void	validate_file (struct cb_file *, cb_tree)

void	finalize_file (struct cb_file , struct cb_field )

cb_tree	cb_build_filler (void)

cb_tree	cb_build_reference (const char *)

cb_tree	cb_build_field_reference (struct cb_field *, cb_tree)

const char *	cb_define (cb_tree, cb_tree)

char *	cb_to_cname (const char *)

void	cb_set_system_names (void)

cb_tree	cb_ref (cb_tree)

cb_tree	cb_build_binary_op (cb_tree, const int, cb_tree)

cb_tree	cb_build_binary_list (cb_tree, const int)

cb_tree	cb_build_funcall (const char *, const int, const cb_tree, const cb_tree, const cb_tree, const cb_tree, const cb_tree, const cb_tree, const cb_tree, const cb_tree, const cb_tree, const cb_tree)

cb_tree	cb_build_cast (const enum cb_cast_type, const cb_tree)

cb_tree	cb_build_cast_int (const cb_tree)

cb_tree	cb_build_cast_llint (const cb_tree)

cb_tree	cb_build_assign (const cb_tree, const cb_tree)

cb_tree	cb_build_intrinsic (cb_tree, cb_tree, cb_tree, const int)

cb_tree	cb_build_any_intrinsic (cb_tree)

cb_tree	cb_build_search (const int, const cb_tree, const cb_tree, const cb_tree, const cb_tree)

cb_tree	cb_build_call (const cb_tree, const cb_tree, const cb_tree, const cb_tree, const cb_tree, const cob_u32_t, const int)

cb_tree	cb_build_alter (const cb_tree, const cb_tree)

cb_tree	cb_build_cancel (const cb_tree)

cb_tree	cb_build_goto (const cb_tree, const cb_tree)

cb_tree	cb_build_if (const cb_tree, const cb_tree, const cb_tree, const unsigned int)

cb_tree	cb_build_perform (const enum cb_perform_type)

cb_tree	cb_build_perform_varying (cb_tree, cb_tree, cb_tree, cb_tree)

struct cb_statement *	cb_build_statement (const char *)

cb_tree	cb_build_continue (void)

cb_tree	cb_build_list (cb_tree, cb_tree, cb_tree)

cb_tree	cb_list_add (cb_tree, cb_tree)

cb_tree	cb_pair_add (cb_tree, cb_tree, cb_tree)

cb_tree	cb_list_append (cb_tree, cb_tree)

cb_tree	cb_list_reverse (cb_tree)

int	cb_list_length (cb_tree)

struct cb_report *	build_report (cb_tree)

void	cb_add_common_prog (struct cb_program *)

void	cb_insert_common_prog (struct cb_program , struct cb_program )

struct cb_intrinsic_table *	lookup_intrinsic (const char *, const int, const int)

cb_tree	cb_build_alphabet_name (cb_tree)

cb_tree	cb_build_initialize (const cb_tree, const cb_tree, const cb_tree, const unsigned int, const unsigned int, const unsigned int)

struct cb_literal *	build_literal (enum cb_category, const void *, const size_t)

cb_tree	cb_build_system_name (const enum cb_system_name_category, const int)

struct cobc_reserved *	lookup_reserved_word (const char *)

cb_tree	lookup_system_name (const char *)

void	cb_list_reserved (void)

void	cb_list_intrinsics (void)

void	cb_list_mnemonics (void)

void	cb_list_system (void)

void	cb_list_map (cb_tree(*)(cb_tree), cb_tree)

void	cb_warning_x (cb_tree, const char *,...) COB_A_FORMAT23

void	cb_error_x (cb_tree, const char *,...) COB_A_FORMAT23

void	redefinition_error (cb_tree)

void	redefinition_warning (cb_tree, cb_tree)

void	undefined_error (cb_tree)

void	ambiguous_error (cb_tree)

void	group_error (cb_tree, const char *)

void	level_redundant_error (cb_tree, const char *)

void	level_require_error (cb_tree, const char *)

void	level_except_error (cb_tree, const char *)

int	cb_get_level (cb_tree)

cb_tree	cb_build_field_tree (cb_tree, cb_tree, struct cb_field , enum cb_storage, struct cb_file , const int)

struct cb_field *	cb_resolve_redefines (struct cb_field *, cb_tree)

void	cb_validate_field (struct cb_field *)

void	cb_validate_88_item (struct cb_field *)

struct cb_field *	cb_validate_78_item (struct cb_field *, const cob_u32_t)

struct cb_field *	cb_get_real_field (void)

void	cb_clear_real_field (void)

struct cb_program *	cb_build_program (struct cb_program *, const int)

cb_tree	cb_check_numeric_value (cb_tree)

size_t	cb_check_index_p (cb_tree x)

void	cb_build_registers (void)

void	cb_build_debug_item (void)

void	cb_check_field_debug (cb_tree)

char *	cb_encode_program_id (const char *)

char *	cb_build_program_id (cb_tree, cb_tree, const cob_u32_t)

cb_tree	cb_define_switch_name (cb_tree, cb_tree, const int)

cb_tree	cb_build_section_name (cb_tree, const int)

cb_tree	cb_build_assignment_name (struct cb_file *, cb_tree)

cb_tree	cb_build_index (cb_tree, cb_tree, const unsigned int, struct cb_field *)

cb_tree	cb_build_identifier (cb_tree, const int)

cb_tree	cb_build_length (cb_tree)

cb_tree	cb_build_const_length (cb_tree)

cb_tree	cb_build_address (cb_tree)

cb_tree	cb_build_ppointer (cb_tree)

void	cb_validate_program_environment (struct cb_program *)

void	cb_validate_program_data (struct cb_program *)

void	cb_validate_program_body (struct cb_program *)

cb_tree	cb_build_expr (cb_tree)

cb_tree	cb_build_cond (cb_tree)

void	cb_emit_arithmetic (cb_tree, const int, cb_tree)

cb_tree	cb_build_add (cb_tree, cb_tree, cb_tree)

cb_tree	cb_build_sub (cb_tree, cb_tree, cb_tree)

void	cb_emit_corresponding (cb_tree(*)(cb_tree, cb_tree, cb_tree), cb_tree, cb_tree, cb_tree)

void	cb_emit_move_corresponding (cb_tree, cb_tree)

void	cb_emit_accept (cb_tree, cb_tree, struct cb_attr_struct *)

void	cb_emit_accept_line_or_col (cb_tree, const int)

void	cb_emit_accept_escape_key (cb_tree)

void	cb_emit_accept_exception_status (cb_tree)

void	cb_emit_accept_user_name (cb_tree)

void	cb_emit_accept_date (cb_tree)

void	cb_emit_accept_date_yyyymmdd (cb_tree)

void	cb_emit_accept_day (cb_tree)

void	cb_emit_accept_day_yyyyddd (cb_tree)

void	cb_emit_accept_day_of_week (cb_tree)

void	cb_emit_accept_time (cb_tree)

void	cb_emit_accept_command_line (cb_tree)

void	cb_emit_accept_environment (cb_tree)

void	cb_emit_accept_mnemonic (cb_tree, cb_tree)

void	cb_emit_accept_name (cb_tree, cb_tree)

void	cb_emit_accept_arg_number (cb_tree)

void	cb_emit_accept_arg_value (cb_tree)

void	cb_emit_get_environment (cb_tree, cb_tree)

void	cb_emit_allocate (cb_tree, cb_tree, cb_tree, cb_tree)

void	cb_emit_alter (cb_tree, cb_tree)

void	cb_emit_free (cb_tree)

void	cb_emit_call (cb_tree, cb_tree, cb_tree, cb_tree, cb_tree, cb_tree)

void	cb_emit_cancel (cb_tree)

void	cb_emit_close (cb_tree, cb_tree)

void	cb_emit_commit (void)

void	cb_emit_continue (void)

void	cb_emit_delete (cb_tree)

void	cb_emit_delete_file (cb_tree)

void	cb_emit_display (cb_tree, cb_tree, cb_tree, cb_tree, struct cb_attr_struct *)

cb_tree	cb_build_display_mnemonic (cb_tree)

cb_tree	cb_build_display_name (cb_tree)

void	cb_emit_env_name (cb_tree)

void	cb_emit_env_value (cb_tree)

void	cb_emit_arg_number (cb_tree)

void	cb_emit_command_line (cb_tree)

void	cb_emit_divide (cb_tree, cb_tree, cb_tree, cb_tree)

void	cb_emit_evaluate (cb_tree, cb_tree)

void	cb_emit_goto (cb_tree, cb_tree)

void	cb_emit_exit (const unsigned int)

void	cb_emit_if (cb_tree, cb_tree, cb_tree)

cb_tree	cb_build_if_check_break (cb_tree, cb_tree)

void	cb_emit_initialize (cb_tree, cb_tree, cb_tree, cb_tree, cb_tree)

void	cb_emit_inspect (cb_tree, cb_tree, cb_tree, const unsigned int)

void	cb_init_tallying (void)

cb_tree	cb_build_tallying_data (cb_tree)

cb_tree	cb_build_tallying_characters (cb_tree)

cb_tree	cb_build_tallying_all (void)

cb_tree	cb_build_tallying_leading (void)

cb_tree	cb_build_tallying_trailing (void)

cb_tree	cb_build_tallying_value (cb_tree, cb_tree)

cb_tree	cb_build_replacing_characters (cb_tree, cb_tree)

cb_tree	cb_build_replacing_all (cb_tree, cb_tree, cb_tree)

cb_tree	cb_build_replacing_leading (cb_tree, cb_tree, cb_tree)

cb_tree	cb_build_replacing_first (cb_tree, cb_tree, cb_tree)

cb_tree	cb_build_replacing_trailing (cb_tree, cb_tree, cb_tree)

cb_tree	cb_build_converting (cb_tree, cb_tree, cb_tree)

cb_tree	cb_build_inspect_region_start (void)

int	validate_move (cb_tree, cb_tree, const unsigned int)

cb_tree	cb_build_move (cb_tree, cb_tree)

void	cb_emit_move (cb_tree, cb_tree)

void	cb_emit_open (cb_tree, cb_tree, cb_tree)

void	cb_emit_perform (cb_tree, cb_tree)

cb_tree	cb_build_perform_once (cb_tree)

cb_tree	cb_build_perform_times (cb_tree)

cb_tree	cb_build_perform_until (cb_tree, cb_tree)

cb_tree	cb_build_perform_forever (cb_tree)

cb_tree	cb_build_perform_exit (struct cb_label *)

void	cb_emit_read (cb_tree, cb_tree, cb_tree, cb_tree, cb_tree)

void	cb_emit_ready_trace (void)

void	cb_emit_rewrite (cb_tree, cb_tree, cb_tree)

void	cb_emit_release (cb_tree, cb_tree)

void	cb_emit_reset_trace (void)

void	cb_emit_return (cb_tree, cb_tree)

void	cb_emit_rollback (void)

void	cb_emit_search (cb_tree, cb_tree, cb_tree, cb_tree)

void	cb_emit_search_all (cb_tree, cb_tree, cb_tree, cb_tree)

void	cb_emit_setenv (cb_tree, cb_tree)

void	cb_emit_set_to (cb_tree, cb_tree)

void	cb_emit_set_up_down (cb_tree, cb_tree, cb_tree)

void	cb_emit_set_on_off (cb_tree, cb_tree)

void	cb_emit_set_true (cb_tree)

void	cb_emit_set_false (cb_tree)

void	cb_emit_set_attribute (cb_tree, const int, const int)

cb_tree	cb_build_set_attribute (const struct cb_field *, const int, const int)

void	cb_emit_sort_init (cb_tree, cb_tree, cb_tree)

void	cb_emit_sort_using (cb_tree, cb_tree)

void	cb_emit_sort_input (cb_tree)

void	cb_emit_sort_giving (cb_tree, cb_tree)

void	cb_emit_sort_output (cb_tree)

void	cb_emit_sort_finish (cb_tree)

void	cb_emit_start (cb_tree, cb_tree, cb_tree, cb_tree)

void	cb_emit_stop_run (cb_tree)

void	cb_emit_string (cb_tree, cb_tree, cb_tree)

void	cb_emit_unlock (cb_tree)

void	cb_emit_unstring (cb_tree, cb_tree, cb_tree, cb_tree, cb_tree)

cb_tree	cb_build_unstring_delimited (cb_tree, cb_tree)

cb_tree	cb_build_unstring_into (cb_tree, cb_tree, cb_tree)

void	cb_emit_write (cb_tree, cb_tree, cb_tree, cb_tree)

cb_tree	cb_build_write_advancing_lines (cb_tree, cb_tree)

cb_tree	cb_build_write_advancing_mnemonic (cb_tree, cb_tree)

cb_tree	cb_build_write_advancing_page (cb_tree)

DECLNORET void	cobc_tree_cast_error (const cb_tree, const char *, const int, const enum cb_tag) COB_A_NORETURN

void	codegen (struct cb_program *, const int)

void	cb_unput_dot (void)

void	cb_add_78 (struct cb_field *)

void	cb_reset_78 (void)

void	cb_reset_global_78 (void)

struct cb_field *	check_level_78 (const char *)

int	yyparse ()

static void	read_literal (const int)

static int	scan_x (char *, const int)

static int	scan_z (char *, const int, const cob_u32_t)

static int	scan_h (char *, const int)

static int	scan_numeric (char *)

static int	scan_floating_numeric (const char *)

static void	scan_picture (char *)

static void	count_lines (const char *)

static void	scan_define_options (const char *)

static void	scan_options (const char *, const unsigned int)

	cobc_free (var)

void	ylex_clear_all (void)

void	ylex_call_destroy (void)

Variables
option option case insensitive option never interactive option noyy_scan_buffer option noyy_scan_bytes option noyy_scan_string option noyyget_extra option noyyset_extra option noyyget_leng option noyyget_text option noyyget_lineno option noyyset_lineno option noyyget_in option noyyset_in option noyyget_out option noyyset_out option noyyget_lval option noyyset_lval option noyyget_lloc option noyyset_lloc option noyyget_debug option	noyyset_debug

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	obsolete

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	archaic

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	redefinition

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	constant

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	overlap

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional	parentheses

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict	typing

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit	define

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit	corresponding

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external	value

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call	params

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	overflow

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	terminator

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	truncate

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	linkage

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column	unreachable

cb_tree	cb_any

cb_tree	cb_true

cb_tree	cb_false

cb_tree	cb_null

cb_tree	cb_zero

cb_tree	cb_one

cb_tree	cb_space

cb_tree	cb_low

cb_tree	cb_high

cb_tree	cb_norm_low

cb_tree	cb_norm_high

cb_tree	cb_quote

cb_tree	cb_int0

cb_tree	cb_int1

cb_tree	cb_int2

cb_tree	cb_int3

cb_tree	cb_int4

cb_tree	cb_int5

cb_tree	cb_i [COB_MAX_SUBSCRIPTS]

cb_tree	cb_error_node

cb_tree	cb_intr_whencomp

cb_tree	cb_standard_error_handler

cb_tree	cb_depend_check

unsigned int	gen_screen_ptr

cb_tree	cobc_printer_node

int	non_const_word

unsigned int	cobc_in_procedure

unsigned int	cobc_in_repository

unsigned int	cobc_force_literal

unsigned int	cobc_cs_check

size_t	cb_needs_01

cb_tree	cb_debug_item

cb_tree	cb_debug_line

cb_tree	cb_debug_name

cb_tree	cb_debug_sub_1

cb_tree	cb_debug_sub_2

cb_tree	cb_debug_sub_3

cb_tree	cb_debug_contents

static struct cb_level_78 *	top78ptr = NULL

static struct cb_level_78 *	const78ptr = NULL

static struct cb_level_78 *	lev78ptr = NULL

static struct cb_level_78 *	globlev78ptr = NULL

static unsigned char *	plexbuff = NULL

static char *	picbuff1 = NULL

static char *	picbuff2 = NULL

static size_t	plexsize

static size_t	pic1size

static size_t	pic2size

static unsigned int	last_token_is_dot = 0

static unsigned int	integer_is_label = 0

static unsigned int	inside_bracket = 0

static const unsigned char	valid_char [256]

s DECIMAL_IS_PERIOD DECIMAL_IS_COMMA x PICTURE_STATE	FUNCTION_STATE

freevar	__pad0__

Macro Definition Documentation

#define COB_IN_SCANNER 1

#define SET_LOCATION ( x )

Value:

do {                        \
        (x)->source_file = cb_source_file;  \
        (x)->source_line = cb_source_line;  \
    } while (0)

#define YY_BUF_SIZE 32768

#define YY_INPUT	(	buf,
		result,
		max_size
	)

Value:

{   \
        if (fgets (buf, (int)max_size, yyin) == NULL) { \
            result = YY_NULL; \
        } else { \
            result = strlen (buf); \
        } \
    }

#define YY_READ_BUF_SIZE 32768

#define YY_SKIP_YYWRAP

#define YY_USER_INIT

Value:

if (!plexbuff) {                    \
        plexbuff = cobc_malloc ((size_t)COB_MINI_BUFF); \
        plexsize = COB_MINI_BUFF;           \
    }                           \
    if (!picbuff1) {                    \
        picbuff1 = cobc_malloc ((size_t)COB_MINI_BUFF); \
        pic1size = COB_MINI_BUFF;           \
    }                           \
    if (!picbuff2) {                    \
        picbuff2 = cobc_malloc ((size_t)COB_MINI_BUFF); \
        pic2size = COB_MINI_BUFF;           \
    }

#define YYSTYPE cb_tree

#define yywrap ( ) 1

Typedef Documentation

typedef struct cb_tree_common* cb_tree

typedef struct __cob_global cob_global

typedef struct __cob_module cob_module

typedef struct __cob_screen cob_screen

typedef struct longoption_def longoption_def

Enumeration Type Documentation

enum cb_cast_type

Enumerator
CB_CAST_INTEGER
CB_CAST_LONG_INT
CB_CAST_ADDRESS
CB_CAST_ADDR_OF_ADDR
CB_CAST_LENGTH
CB_CAST_PROGRAM_POINTER
CB_CAST_INTEGER
CB_CAST_LONG_INT
CB_CAST_ADDRESS
CB_CAST_ADDR_OF_ADDR
CB_CAST_LENGTH
CB_CAST_PROGRAM_POINTER
CB_CAST_INTEGER
CB_CAST_LONG_INT
CB_CAST_ADDRESS
CB_CAST_ADDR_OF_ADDR
CB_CAST_LENGTH
CB_CAST_PROGRAM_POINTER

                         {
     /* Line directive */
     char        *p1;
     char        *p2;
 

enum cb_category

Enumerator
CB_CATEGORY_UNKNOWN
CB_CATEGORY_ALPHABETIC
CB_CATEGORY_ALPHANUMERIC
CB_CATEGORY_ALPHANUMERIC_EDITED
CB_CATEGORY_BOOLEAN
CB_CATEGORY_INDEX
CB_CATEGORY_NATIONAL
CB_CATEGORY_NATIONAL_EDITED
CB_CATEGORY_NUMERIC
CB_CATEGORY_NUMERIC_EDITED
CB_CATEGORY_OBJECT_REFERENCE
CB_CATEGORY_DATA_POINTER
CB_CATEGORY_PROGRAM_POINTER
CB_CATEGORY_UNKNOWN
CB_CATEGORY_ALPHABETIC
CB_CATEGORY_ALPHANUMERIC
CB_CATEGORY_ALPHANUMERIC_EDITED
CB_CATEGORY_BOOLEAN
CB_CATEGORY_INDEX
CB_CATEGORY_NATIONAL
CB_CATEGORY_NATIONAL_EDITED
CB_CATEGORY_NUMERIC
CB_CATEGORY_NUMERIC_EDITED
CB_CATEGORY_OBJECT_REFERENCE
CB_CATEGORY_DATA_POINTER
CB_CATEGORY_PROGRAM_POINTER
CB_CATEGORY_UNKNOWN
CB_CATEGORY_ALPHABETIC
CB_CATEGORY_ALPHANUMERIC
CB_CATEGORY_ALPHANUMERIC_EDITED
CB_CATEGORY_BOOLEAN
CB_CATEGORY_INDEX
CB_CATEGORY_NATIONAL
CB_CATEGORY_NATIONAL_EDITED
CB_CATEGORY_NUMERIC
CB_CATEGORY_NUMERIC_EDITED
CB_CATEGORY_OBJECT_REFERENCE
CB_CATEGORY_DATA_POINTER
CB_CATEGORY_PROGRAM_POINTER

231 {

enum cb_class

Enumerator
CB_CLASS_UNKNOWN
CB_CLASS_ALPHABETIC
CB_CLASS_ALPHANUMERIC
CB_CLASS_BOOLEAN
CB_CLASS_INDEX
CB_CLASS_NATIONAL
CB_CLASS_NUMERIC
CB_CLASS_OBJECT
CB_CLASS_POINTER
CB_CLASS_UNKNOWN
CB_CLASS_ALPHABETIC
CB_CLASS_ALPHANUMERIC
CB_CLASS_BOOLEAN
CB_CLASS_INDEX
CB_CLASS_NATIONAL
CB_CLASS_NUMERIC
CB_CLASS_OBJECT
CB_CLASS_POINTER
CB_CLASS_UNKNOWN
CB_CLASS_ALPHABETIC
CB_CLASS_ALPHANUMERIC
CB_CLASS_BOOLEAN
CB_CLASS_INDEX
CB_CLASS_NATIONAL
CB_CLASS_NUMERIC
CB_CLASS_OBJECT
CB_CLASS_POINTER

231 {

enum cb_intr_enum

Enumerator
CB_INTR_ABS
CB_INTR_ACOS
CB_INTR_ANNUITY
CB_INTR_ASIN
CB_INTR_ATAN
CB_INTR_BOOLEAN_OF_INTEGER
CB_INTR_BYTE_LENGTH
CB_INTR_CHAR
CB_INTR_CHAR_NATIONAL
CB_INTR_COMBINED_DATETIME
CB_INTR_CONCATENATE
CB_INTR_COS
CB_INTR_CURRENCY_SYMBOL
CB_INTR_CURRENT_DATE
CB_INTR_DATE_OF_INTEGER
CB_INTR_DATE_TO_YYYYMMDD
CB_INTR_DAY_OF_INTEGER
CB_INTR_DAY_TO_YYYYDDD
CB_INTR_DISPLAY_OF
CB_INTR_E
CB_INTR_EXCEPTION_FILE
CB_INTR_EXCEPTION_FILE_N
CB_INTR_EXCEPTION_LOCATION
CB_INTR_EXCEPTION_LOCATION_N
CB_INTR_EXCEPTION_STATEMENT
CB_INTR_EXCEPTION_STATUS
CB_INTR_EXP
CB_INTR_EXP10
CB_INTR_FACTORIAL
CB_INTR_FORMATTED_CURRENT_DATE
CB_INTR_FORMATTED_DATE
CB_INTR_FORMATTED_DATETIME
CB_INTR_FORMATTED_TIME
CB_INTR_FRACTION_PART
CB_INTR_HIGHEST_ALGEBRAIC
CB_INTR_INTEGER
CB_INTR_INTEGER_OF_BOOLEAN
CB_INTR_INTEGER_OF_DATE
CB_INTR_INTEGER_OF_DAY
CB_INTR_INTEGER_OF_FORMATTED_DATE
CB_INTR_INTEGER_PART
CB_INTR_LENGTH
CB_INTR_LOCALE_COMPARE
CB_INTR_LOCALE_DATE
CB_INTR_LOCALE_TIME
CB_INTR_LOCALE_TIME_FROM_SECS
CB_INTR_LOG
CB_INTR_LOG10
CB_INTR_LOWER_CASE
CB_INTR_LOWEST_ALGEBRAIC
CB_INTR_MAX
CB_INTR_MEAN
CB_INTR_MEDIAN
CB_INTR_MIDRANGE
CB_INTR_MIN
CB_INTR_MOD
CB_INTR_MODULE_CALLER_ID
CB_INTR_MODULE_DATE
CB_INTR_MODULE_FORMATTED_DATE
CB_INTR_MODULE_ID
CB_INTR_MODULE_PATH
CB_INTR_MODULE_SOURCE
CB_INTR_MODULE_TIME
CB_INTR_MON_DECIMAL_POINT
CB_INTR_MON_THOUSANDS_SEP
CB_INTR_NATIONAL_OF
CB_INTR_NUM_DECIMAL_POINT
CB_INTR_NUM_THOUSANDS_SEP
CB_INTR_NUMVAL
CB_INTR_NUMVAL_C
CB_INTR_NUMVAL_F
CB_INTR_ORD
CB_INTR_ORD_MAX
CB_INTR_ORD_MIN
CB_INTR_PI
CB_INTR_PRESENT_VALUE
CB_INTR_RANDOM
CB_INTR_RANGE
CB_INTR_REM
CB_INTR_REVERSE
CB_INTR_SECONDS_FROM_FORMATTED_TIME
CB_INTR_SECONDS_PAST_MIDNIGHT
CB_INTR_SIGN
CB_INTR_SIN
CB_INTR_SQRT
CB_INTR_STANDARD_COMPARE
CB_INTR_STANDARD_DEVIATION
CB_INTR_STORED_CHAR_LENGTH
CB_INTR_SUBSTITUTE
CB_INTR_SUBSTITUTE_CASE
CB_INTR_SUM
CB_INTR_TAN
CB_INTR_TEST_DATE_YYYYMMDD
CB_INTR_TEST_DAY_YYYYDDD
CB_INTR_TEST_FORMATTED_DATETIME
CB_INTR_TEST_NUMVAL
CB_INTR_TEST_NUMVAL_C
CB_INTR_TEST_NUMVAL_F
CB_INTR_TRIM
CB_INTR_UPPER_CASE
CB_INTR_USER_FUNCTION
CB_INTR_VARIANCE
CB_INTR_WHEN_COMPILED
CB_INTR_YEAR_TO_YYYY
CB_INTR_ABS
CB_INTR_ACOS
CB_INTR_ANNUITY
CB_INTR_ASIN
CB_INTR_ATAN
CB_INTR_BOOLEAN_OF_INTEGER
CB_INTR_BYTE_LENGTH
CB_INTR_CHAR
CB_INTR_CHAR_NATIONAL
CB_INTR_COMBINED_DATETIME
CB_INTR_CONCATENATE
CB_INTR_COS
CB_INTR_CURRENCY_SYMBOL
CB_INTR_CURRENT_DATE
CB_INTR_DATE_OF_INTEGER
CB_INTR_DATE_TO_YYYYMMDD
CB_INTR_DAY_OF_INTEGER
CB_INTR_DAY_TO_YYYYDDD
CB_INTR_DISPLAY_OF
CB_INTR_E
CB_INTR_EXCEPTION_FILE
CB_INTR_EXCEPTION_FILE_N
CB_INTR_EXCEPTION_LOCATION
CB_INTR_EXCEPTION_LOCATION_N
CB_INTR_EXCEPTION_STATEMENT
CB_INTR_EXCEPTION_STATUS
CB_INTR_EXP
CB_INTR_EXP10
CB_INTR_FACTORIAL
CB_INTR_FORMATTED_CURRENT_DATE
CB_INTR_FORMATTED_DATE
CB_INTR_FORMATTED_DATETIME
CB_INTR_FORMATTED_TIME
CB_INTR_FRACTION_PART
CB_INTR_HIGHEST_ALGEBRAIC
CB_INTR_INTEGER
CB_INTR_INTEGER_OF_BOOLEAN
CB_INTR_INTEGER_OF_DATE
CB_INTR_INTEGER_OF_DAY
CB_INTR_INTEGER_OF_FORMATTED_DATE
CB_INTR_INTEGER_PART
CB_INTR_LENGTH
CB_INTR_LOCALE_COMPARE
CB_INTR_LOCALE_DATE
CB_INTR_LOCALE_TIME
CB_INTR_LOCALE_TIME_FROM_SECS
CB_INTR_LOG
CB_INTR_LOG10
CB_INTR_LOWER_CASE
CB_INTR_LOWEST_ALGEBRAIC
CB_INTR_MAX
CB_INTR_MEAN
CB_INTR_MEDIAN
CB_INTR_MIDRANGE
CB_INTR_MIN
CB_INTR_MOD
CB_INTR_MODULE_CALLER_ID
CB_INTR_MODULE_DATE
CB_INTR_MODULE_FORMATTED_DATE
CB_INTR_MODULE_ID
CB_INTR_MODULE_PATH
CB_INTR_MODULE_SOURCE
CB_INTR_MODULE_TIME
CB_INTR_MON_DECIMAL_POINT
CB_INTR_MON_THOUSANDS_SEP
CB_INTR_NATIONAL_OF
CB_INTR_NUM_DECIMAL_POINT
CB_INTR_NUM_THOUSANDS_SEP
CB_INTR_NUMVAL
CB_INTR_NUMVAL_C
CB_INTR_NUMVAL_F
CB_INTR_ORD
CB_INTR_ORD_MAX
CB_INTR_ORD_MIN
CB_INTR_PI
CB_INTR_PRESENT_VALUE
CB_INTR_RANDOM
CB_INTR_RANGE
CB_INTR_REM
CB_INTR_REVERSE
CB_INTR_SECONDS_FROM_FORMATTED_TIME
CB_INTR_SECONDS_PAST_MIDNIGHT
CB_INTR_SIGN
CB_INTR_SIN
CB_INTR_SQRT
CB_INTR_STANDARD_COMPARE
CB_INTR_STANDARD_DEVIATION
CB_INTR_STORED_CHAR_LENGTH
CB_INTR_SUBSTITUTE
CB_INTR_SUBSTITUTE_CASE
CB_INTR_SUM
CB_INTR_TAN
CB_INTR_TEST_DATE_YYYYMMDD
CB_INTR_TEST_DAY_YYYYDDD
CB_INTR_TEST_FORMATTED_DATETIME
CB_INTR_TEST_NUMVAL
CB_INTR_TEST_NUMVAL_C
CB_INTR_TEST_NUMVAL_F
CB_INTR_TRIM
CB_INTR_UPPER_CASE
CB_INTR_USER_FUNCTION
CB_INTR_VARIANCE
CB_INTR_WHEN_COMPILED
CB_INTR_YEAR_TO_YYYY
CB_INTR_ABS
CB_INTR_ACOS
CB_INTR_ANNUITY
CB_INTR_ASIN
CB_INTR_ATAN
CB_INTR_BOOLEAN_OF_INTEGER
CB_INTR_BYTE_LENGTH
CB_INTR_CHAR
CB_INTR_CHAR_NATIONAL
CB_INTR_COMBINED_DATETIME
CB_INTR_CONCATENATE
CB_INTR_COS
CB_INTR_CURRENCY_SYMBOL
CB_INTR_CURRENT_DATE
CB_INTR_DATE_OF_INTEGER
CB_INTR_DATE_TO_YYYYMMDD
CB_INTR_DAY_OF_INTEGER
CB_INTR_DAY_TO_YYYYDDD
CB_INTR_DISPLAY_OF
CB_INTR_E
CB_INTR_EXCEPTION_FILE
CB_INTR_EXCEPTION_FILE_N
CB_INTR_EXCEPTION_LOCATION
CB_INTR_EXCEPTION_LOCATION_N
CB_INTR_EXCEPTION_STATEMENT
CB_INTR_EXCEPTION_STATUS
CB_INTR_EXP
CB_INTR_EXP10
CB_INTR_FACTORIAL
CB_INTR_FORMATTED_CURRENT_DATE
CB_INTR_FORMATTED_DATE
CB_INTR_FORMATTED_DATETIME
CB_INTR_FORMATTED_TIME
CB_INTR_FRACTION_PART
CB_INTR_HIGHEST_ALGEBRAIC
CB_INTR_INTEGER
CB_INTR_INTEGER_OF_BOOLEAN
CB_INTR_INTEGER_OF_DATE
CB_INTR_INTEGER_OF_DAY
CB_INTR_INTEGER_OF_FORMATTED_DATE
CB_INTR_INTEGER_PART
CB_INTR_LENGTH
CB_INTR_LOCALE_COMPARE
CB_INTR_LOCALE_DATE
CB_INTR_LOCALE_TIME
CB_INTR_LOCALE_TIME_FROM_SECS
CB_INTR_LOG
CB_INTR_LOG10
CB_INTR_LOWER_CASE
CB_INTR_LOWEST_ALGEBRAIC
CB_INTR_MAX
CB_INTR_MEAN
CB_INTR_MEDIAN
CB_INTR_MIDRANGE
CB_INTR_MIN
CB_INTR_MOD
CB_INTR_MODULE_CALLER_ID
CB_INTR_MODULE_DATE
CB_INTR_MODULE_FORMATTED_DATE
CB_INTR_MODULE_ID
CB_INTR_MODULE_PATH
CB_INTR_MODULE_SOURCE
CB_INTR_MODULE_TIME
CB_INTR_MON_DECIMAL_POINT
CB_INTR_MON_THOUSANDS_SEP
CB_INTR_NATIONAL_OF
CB_INTR_NUM_DECIMAL_POINT
CB_INTR_NUM_THOUSANDS_SEP
CB_INTR_NUMVAL
CB_INTR_NUMVAL_C
CB_INTR_NUMVAL_F
CB_INTR_ORD
CB_INTR_ORD_MAX
CB_INTR_ORD_MIN
CB_INTR_PI
CB_INTR_PRESENT_VALUE
CB_INTR_RANDOM
CB_INTR_RANGE
CB_INTR_REM
CB_INTR_REVERSE
CB_INTR_SECONDS_FROM_FORMATTED_TIME
CB_INTR_SECONDS_PAST_MIDNIGHT
CB_INTR_SIGN
CB_INTR_SIN
CB_INTR_SQRT
CB_INTR_STANDARD_COMPARE
CB_INTR_STANDARD_DEVIATION
CB_INTR_STORED_CHAR_LENGTH
CB_INTR_SUBSTITUTE
CB_INTR_SUBSTITUTE_CASE
CB_INTR_SUM
CB_INTR_TAN
CB_INTR_TEST_DATE_YYYYMMDD
CB_INTR_TEST_DAY_YYYYDDD
CB_INTR_TEST_FORMATTED_DATETIME
CB_INTR_TEST_NUMVAL
CB_INTR_TEST_NUMVAL_C
CB_INTR_TEST_NUMVAL_F
CB_INTR_TRIM
CB_INTR_UPPER_CASE
CB_INTR_USER_FUNCTION
CB_INTR_VARIANCE
CB_INTR_WHEN_COMPILED
CB_INTR_YEAR_TO_YYYY

                 {
             *p1 = 0;
             cb_source_file = cobc_parse_strdup (p2);
             cb_source_line = (int)strtol (yytext + 5, NULL, 10) - 1;
         }
         cobc_free (p2);
     }
 }
 
 ^"#".* {
     /* Ignore */
 }
 
 "PIC" |
 "PICTURE" {
     BEGIN PICTURE_STATE;
 }
 
 "FUNCTION" {
     if (cobc_in_repository || cobc_cs_check == CB_CS_EXIT) {
         yylval = NULL;
         return FUNCTION;
     }
     BEGIN FUNCTION_STATE;
 }
 
 [\'\"] {
     /* String literal */
     cobc_force_literal = 0;
     read_literal (yytext[0]);
     return LITERAL;
 }
 
 X\'[^\'\n]*\' |
 X\"[^\"\n]*\" {
     /* X string literal */
     cobc_force_literal = 0;
     return scan_x (yytext + 2, yytext[1]);
 }
 
 Z\'[^\'\n]*\' |
 Z\"[^\"\n]*\" {
     /* Z string literal */
     cobc_force_literal = 0;
     return scan_z (yytext + 2, yytext[1], 0);
 }
 
 L\'[^\'\n]*\' |
 L\"[^\"\n]*\" {
     /* L string literal */
     cobc_force_literal = 0;
     return scan_z (yytext + 2, yytext[1], 1);
 }
 
 H\'[^\'\n]*\' |
 H\"[^\"\n]*\" {
     /* H numeric literal */
     cobc_force_literal = 0;
     return scan_h (yytext + 2, yytext[1]);
 }
 
 \( {
     inside_bracket++;
     return TOK_OPEN_PAREN;
 }
 
 \) {
     if (inside_bracket > 0) {
         inside_bracket--;
     }
     return TOK_CLOSE_PAREN;
 }
 
 [0-9]+ {
     cobc_force_literal = 0;
     if (integer_is_label) {
         /* Integer label or level number */
         yylval = cb_build_reference (yytext);
         SET_LOCATION (yylval);
         return WORD;
     }
     /* Numeric literal */
     return scan_numeric (yytext);
 }
 
 <*>[ ]+ {
     /* Ignore */
 }
 
 <*>;+ {
     if (inside_bracket) {
         return SEMI_COLON;
     }
     /* Ignore */
 }
 
 <DECIMAL_IS_PERIOD>[+-]?[0-9]+\.[0-9]*E[+-]?[0-9]+ {
     /* Numeric floating point literal */
     return scan_floating_numeric (yytext);
 }
 
 <DECIMAL_IS_PERIOD>[+-]?[0-9\.]*[0-9]+ {
     /* Numeric literal */
     return scan_numeric (yytext);

enum cb_operation_type

Enumerator
CB_OPERATION_READ
CB_OPERATION_WRITE
CB_OPERATION_ASSIGN

140 {

enum cb_perform_type

Enumerator
CB_PERFORM_EXIT
CB_PERFORM_ONCE
CB_PERFORM_TIMES
CB_PERFORM_UNTIL
CB_PERFORM_FOREVER
CB_PERFORM_EXIT
CB_PERFORM_ONCE
CB_PERFORM_TIMES
CB_PERFORM_UNTIL
CB_PERFORM_FOREVER
CB_PERFORM_EXIT
CB_PERFORM_ONCE
CB_PERFORM_TIMES
CB_PERFORM_UNTIL
CB_PERFORM_FOREVER

                       {
     if (inside_bracket) {
         return COMMA_DELIM;
     }
     /* Ignore */
 }
 

enum cb_std_def

Enumerator
CB_STD_OC
CB_STD_MF
CB_STD_IBM
CB_STD_MVS
CB_STD_BS2000
CB_STD_85
CB_STD_2002

231 {

enum cb_storage

Enumerator
CB_STORAGE_CONSTANT
CB_STORAGE_FILE
CB_STORAGE_WORKING
CB_STORAGE_LOCAL
CB_STORAGE_LINKAGE
CB_STORAGE_SCREEN
CB_STORAGE_REPORT
CB_STORAGE_COMMUNICATION
CB_STORAGE_CONSTANT
CB_STORAGE_FILE
CB_STORAGE_WORKING
CB_STORAGE_LOCAL
CB_STORAGE_LINKAGE
CB_STORAGE_SCREEN
CB_STORAGE_REPORT
CB_STORAGE_COMMUNICATION
CB_STORAGE_CONSTANT
CB_STORAGE_FILE
CB_STORAGE_WORKING
CB_STORAGE_LOCAL
CB_STORAGE_LINKAGE
CB_STORAGE_SCREEN
CB_STORAGE_REPORT
CB_STORAGE_COMMUNICATION

231 {

enum cb_support

Enumerator
CB_OK
CB_WARNING
CB_ARCHAIC
CB_OBSOLETE
CB_SKIP
CB_IGNORE
CB_ERROR
CB_UNCONFORMABLE

140 {

enum cb_system_name_category

Enumerator
CB_DEVICE_NAME
CB_SWITCH_NAME
CB_FEATURE_NAME
CB_CALL_CONVENTION_NAME
CB_CODE_NAME
CB_COMPUTER_NAME
CB_ENTRY_CONVENTION_NAME
CB_EXTERNAL_LOCALE_NAME
CB_LIBRARY_NAME
CB_TEXT_NAME
CB_DEVICE_NAME
CB_SWITCH_NAME
CB_FEATURE_NAME
CB_CALL_CONVENTION_NAME
CB_CODE_NAME
CB_COMPUTER_NAME
CB_ENTRY_CONVENTION_NAME
CB_EXTERNAL_LOCALE_NAME
CB_LIBRARY_NAME
CB_TEXT_NAME
CB_DEVICE_NAME
CB_SWITCH_NAME
CB_FEATURE_NAME
CB_CALL_CONVENTION_NAME
CB_CODE_NAME
CB_COMPUTER_NAME
CB_ENTRY_CONVENTION_NAME
CB_EXTERNAL_LOCALE_NAME
CB_LIBRARY_NAME
CB_TEXT_NAME

                                               {
     ['-'] = 1,
     ['0'] = 1,
     ['1'] = 1,
     ['2'] = 1,
     ['3'] = 1,
     ['4'] = 1,
     ['5'] = 1,
     ['6'] = 1,

enum cb_tag

Enumerator
CB_TAG_CONST
CB_TAG_INTEGER
CB_TAG_STRING
CB_TAG_ALPHABET_NAME
CB_TAG_CLASS_NAME
CB_TAG_LOCALE_NAME
CB_TAG_SYSTEM_NAME
CB_TAG_LITERAL
CB_TAG_DECIMAL
CB_TAG_FIELD
CB_TAG_FILE
CB_TAG_REPORT
CB_TAG_REFERENCE
CB_TAG_BINARY_OP
CB_TAG_FUNCALL
CB_TAG_CAST
CB_TAG_INTRINSIC
CB_TAG_LABEL
CB_TAG_ASSIGN
CB_TAG_INITIALIZE
CB_TAG_SEARCH
CB_TAG_CALL
CB_TAG_GOTO
CB_TAG_IF
CB_TAG_PERFORM
CB_TAG_STATEMENT
CB_TAG_CONTINUE
CB_TAG_CANCEL
CB_TAG_ALTER
CB_TAG_SET_ATTR
CB_TAG_PERFORM_VARYING
CB_TAG_PICTURE
CB_TAG_LIST
CB_TAG_DIRECT
CB_TAG_DEBUG
CB_TAG_DEBUG_CALL
CB_TAG_CONST
CB_TAG_INTEGER
CB_TAG_STRING
CB_TAG_ALPHABET_NAME
CB_TAG_CLASS_NAME
CB_TAG_LOCALE_NAME
CB_TAG_SYSTEM_NAME
CB_TAG_LITERAL
CB_TAG_DECIMAL
CB_TAG_FIELD
CB_TAG_FILE
CB_TAG_REPORT
CB_TAG_REFERENCE
CB_TAG_BINARY_OP
CB_TAG_FUNCALL
CB_TAG_CAST
CB_TAG_INTRINSIC
CB_TAG_LABEL
CB_TAG_ASSIGN
CB_TAG_INITIALIZE
CB_TAG_SEARCH
CB_TAG_CALL
CB_TAG_GOTO
CB_TAG_IF
CB_TAG_PERFORM
CB_TAG_STATEMENT
CB_TAG_CONTINUE
CB_TAG_CANCEL
CB_TAG_ALTER
CB_TAG_SET_ATTR
CB_TAG_PERFORM_VARYING
CB_TAG_PICTURE
CB_TAG_LIST
CB_TAG_DIRECT
CB_TAG_DEBUG
CB_TAG_DEBUG_CALL
CB_TAG_CONST
CB_TAG_INTEGER
CB_TAG_STRING
CB_TAG_ALPHABET_NAME
CB_TAG_CLASS_NAME
CB_TAG_LOCALE_NAME
CB_TAG_SYSTEM_NAME
CB_TAG_LITERAL
CB_TAG_DECIMAL
CB_TAG_FIELD
CB_TAG_FILE
CB_TAG_REPORT
CB_TAG_REFERENCE
CB_TAG_BINARY_OP
CB_TAG_FUNCALL
CB_TAG_CAST
CB_TAG_INTRINSIC
CB_TAG_LABEL
CB_TAG_ASSIGN
CB_TAG_INITIALIZE
CB_TAG_SEARCH
CB_TAG_CALL
CB_TAG_GOTO
CB_TAG_IF
CB_TAG_PERFORM
CB_TAG_STATEMENT
CB_TAG_CONTINUE
CB_TAG_CANCEL
CB_TAG_ALTER
CB_TAG_SET_ATTR
CB_TAG_PERFORM_VARYING
CB_TAG_PICTURE
CB_TAG_LIST
CB_TAG_DIRECT
CB_TAG_DEBUG
CB_TAG_DEBUG_CALL

                    {                    \
         plexbuff = cobc_malloc ((size_t)COB_MINI_BUFF); \
         plexsize = COB_MINI_BUFF;           \
     }                           \
     if (!picbuff1) {                    \
         picbuff1 = cobc_malloc ((size_t)COB_MINI_BUFF); \
         pic1size = COB_MINI_BUFF;           \
     }                           \
     if (!picbuff2) {                    \
         picbuff2 = cobc_malloc ((size_t)COB_MINI_BUFF); \
         pic2size = COB_MINI_BUFF;           \
     }
 
 #include "config.h"
 
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
 #include <ctype.h>
 
 #ifdef  HAVE_UNISTD_H
 #include <unistd.h>
 #else
 #define YY_NO_UNISTD_H  1
 #endif
 
 #define COB_IN_SCANNER  1
 #include "cobc.h"
 #include "tree.h"
 
 #define YYSTYPE         cb_tree
 #include "parser.h"
 
 #define SET_LOCATION(x)             \
     do {                        \
         (x)->source_file = cb_source_file;  \
         (x)->source_line = cb_source_line;  \
     } while (0)

enum cb_usage

Enumerator
CB_USAGE_BINARY
CB_USAGE_BIT
CB_USAGE_COMP_5
CB_USAGE_COMP_X
CB_USAGE_DISPLAY
CB_USAGE_FLOAT
CB_USAGE_DOUBLE
CB_USAGE_INDEX
CB_USAGE_NATIONAL
CB_USAGE_OBJECT
CB_USAGE_PACKED
CB_USAGE_POINTER
CB_USAGE_PROGRAM
CB_USAGE_LENGTH
CB_USAGE_PROGRAM_POINTER
CB_USAGE_UNSIGNED_CHAR
CB_USAGE_SIGNED_CHAR
CB_USAGE_UNSIGNED_SHORT
CB_USAGE_SIGNED_SHORT
CB_USAGE_UNSIGNED_INT
CB_USAGE_SIGNED_INT
CB_USAGE_UNSIGNED_LONG
CB_USAGE_SIGNED_LONG
CB_USAGE_COMP_6
CB_USAGE_FP_DEC64
CB_USAGE_FP_DEC128
CB_USAGE_FP_BIN32
CB_USAGE_FP_BIN64
CB_USAGE_FP_BIN128
CB_USAGE_LONG_DOUBLE
CB_USAGE_BINARY
CB_USAGE_BIT
CB_USAGE_COMP_5
CB_USAGE_COMP_X
CB_USAGE_DISPLAY
CB_USAGE_FLOAT
CB_USAGE_DOUBLE
CB_USAGE_INDEX
CB_USAGE_NATIONAL
CB_USAGE_OBJECT
CB_USAGE_PACKED
CB_USAGE_POINTER
CB_USAGE_PROGRAM
CB_USAGE_LENGTH
CB_USAGE_PROGRAM_POINTER
CB_USAGE_UNSIGNED_CHAR
CB_USAGE_SIGNED_CHAR
CB_USAGE_UNSIGNED_SHORT
CB_USAGE_SIGNED_SHORT
CB_USAGE_UNSIGNED_INT
CB_USAGE_SIGNED_INT
CB_USAGE_UNSIGNED_LONG
CB_USAGE_SIGNED_LONG
CB_USAGE_COMP_6
CB_USAGE_FP_DEC64
CB_USAGE_FP_DEC128
CB_USAGE_FP_BIN32
CB_USAGE_FP_BIN64
CB_USAGE_FP_BIN128
CB_USAGE_LONG_DOUBLE
CB_USAGE_BINARY
CB_USAGE_BIT
CB_USAGE_COMP_5
CB_USAGE_COMP_X
CB_USAGE_DISPLAY
CB_USAGE_FLOAT
CB_USAGE_DOUBLE
CB_USAGE_INDEX
CB_USAGE_NATIONAL
CB_USAGE_OBJECT
CB_USAGE_PACKED
CB_USAGE_POINTER
CB_USAGE_PROGRAM
CB_USAGE_LENGTH
CB_USAGE_PROGRAM_POINTER
CB_USAGE_UNSIGNED_CHAR
CB_USAGE_SIGNED_CHAR
CB_USAGE_UNSIGNED_SHORT
CB_USAGE_SIGNED_SHORT
CB_USAGE_UNSIGNED_INT
CB_USAGE_SIGNED_INT
CB_USAGE_UNSIGNED_LONG
CB_USAGE_SIGNED_LONG
CB_USAGE_COMP_6
CB_USAGE_FP_DEC64
CB_USAGE_FP_DEC128
CB_USAGE_FP_BIN32
CB_USAGE_FP_BIN64
CB_USAGE_FP_BIN128
CB_USAGE_LONG_DOUBLE

                                                    {
             BEGIN DECIMAL_IS_PERIOD;
         } else {
             BEGIN DECIMAL_IS_COMMA;
         }
     }
 
     /* We treat integer literals immediately after '.' as labels;
        that is, they must be level numbers or section names. */
     if (last_token_is_dot) {
         integer_is_label = 1;
         last_token_is_dot = 0;
     } else {
         integer_is_label = 0;
     }
 %}
 
 
 <*>^[ ]?"#DEFLIT".*\n {
     scan_define_options (yytext);
 }
 
 <*>^[ ]?"#OPTION".*\n {
     scan_options (yytext, 1);
 }
 
 <*>^[ ]?"#DEFOFF".*\n {
     scan_options (yytext, 2);
 }
 
 <*>^[ ]?"#DEFENV".*\n {
     scan_options (yytext, 3);

Function Documentation

if _ ( "Define cutoff depth for IF statements\n\t\t\t- Default : 3" )

if _ ( "Define display sign representation\n\t\t\t- ASCII or EBCDIC (Default : machine native)" )

if fold _ ( "Fold COPY subject to value\n\t\t\t- UPPER or LOWER (Default : no transformation)" )

if fold fold _	(	"Fold PROGRAM-	ID,
		CALL	,
		CANCEL subject to value\n\t\t\t-UPPER or LOWER(Default:no transformation)"
	)

if fold fold _ ( "Initialize fields without VALUE to decimal value\n\t\t\t- 0 to 255 (Default : initialize to picture)" )

if fold fold _ ( "Intrinsics to be used without FUNCTION keyword\n\t\t\t- ALL or intrinsic function name (,name,...)" )

if fold fold static _ ( "Output static function calls for the CALL statement" )

if fold fold static computed _ ( "Generate computed goto C statements" )

if fold fold static computed alternate _ ( "Use restricted ASCII to EBCDIC translate" )

if fold fold static computed alternate extra _ ( "Generate extra braces in generated C code" )

if fold fold static computed alternate extra correct _ ( "Attempt correction of invalid numeric display items" )

if fold fold static computed alternate extra correct stack on _ ( "PERFORM stack allocated on heap" )

if fold fold static computed alternate extra correct stack on _ ( "Generate trace code\n\t\t\t- Executed SECTION/PARAGRAPH" )

if fold fold static computed alternate extra correct stack on _ ( "Generate trace code\n\t\t\t- Executed SECTION/PARAGRAPH/STATEMENTS\n\t\t\t- Turned on by -debug" )

if fold fold static computed alternate extra correct stack on syntax _ ( "Syntax error checking only; don't emit any output" )

if fold fold static computed alternate extra correct stack on syntax debugging _ ( "Enable debugging lines\n\t\t\t- 'D' in indicator column or floating >>D" )

if fold fold static computed alternate extra correct stack on syntax debugging source _ ( "Generate source location code\n\t\t\t- Turned on by -debug/-g/-ftraceall" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit _ ( "Automatic initialization of the Cobol runtime system" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack _ ( "PERFORM stack checking\n\t\t\t- Turned on by -debug or -g" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax _	(	"Allow syntax extensions\n\t\t\t- eg. Switch name	SW1,
		etc."
	)

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write _ ( "Use AFTER 1 for WRITE of LINE SEQUENTIAL\n\t\t\t- Default : BEFORE 1" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write _ ( "'*' or '/' in column 1 treated as comment\n\t\t\t- FIXED format only" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write _	(	"'$' in indicator area treated as '*'	,
		\n\t\t\t'\|'treated as floating comment"
	)

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write _ ( "Allow numeric field overflow\n\t\t\t- Non-ANSI behaviour" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write _ ( "Adjust items following OCCURS DEPENDING\n\t\t\t- Requires implicit/explicit relaxed syntax" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single _ ( "Use a single quote (apostrophe) for QUOTE\n\t\t\t- Default : double quote" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive _ ( "Check recursive program call" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax _ ( "Relax syntax checking\n\t\t\t- eg. REDEFINES position" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional _ ( "Treat all files as OPTIONAL\n\t\t\t- unless NOT OPTIONAL specified" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional _ ( "Warn if obsolete features are used" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional _ ( "Warn if archaic features are used" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional _ ( "Warn incompatible redefinition of data items" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional _ ( "Warn inconsistent constant" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional _ ( "Warn overlapping MOVE items" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional _ ( "Warn lack of parentheses around AND within OR" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict _ ( "Warn type mismatch strictly" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit _ ( "Warn implicitly defined data items" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit _ ( "Warn CORRESPONDING with no matching items" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external _ ( "Warn EXTERNAL item with VALUE clause" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call _ ( "Warn non 01/77 items for CALL params" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column _	(	"Warn text after column	72,
		FIXED format"
	)

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column _ ( "Warn lack of scope terminator END-XXX" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column _ ( "Warn possible field truncation" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column _ ( "Warn dangling LINKAGE items" )

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column _ ( "Warn unreachable statements" )

  {
     if (likely(current_program)) {
         if (current_program->decimal_point == '.') {
             BEGIN DECIMAL_IS_PERIOD;
         } else {
             BEGIN DECIMAL_IS_COMMA;
         }
     }
 
     /* We treat integer literals immediately after '.' as labels;
        that is, they must be level numbers or section names. */
     if (last_token_is_dot) {
         integer_is_label = 1;
         last_token_is_dot = 0;
     } else {
         integer_is_label = 0;
     }
 %}
 
 
 <*>^[ ]?"#DEFLIT".*\n {
     scan_define_options (yytext);
 }
 
 <*>^[ ]?"#OPTION".*\n {
     scan_options (yytext, 1);
 }
 
 <*>^[ ]?"#DEFOFF".*\n {
     scan_options (yytext, 2);

void ambiguous_error ( cb_tree )

 {
     struct cb_word  *w;
     struct cb_field *p;
     struct cb_label *l2;
     cb_tree     l;
     cb_tree     y;
 
     w = CB_REFERENCE (x)->word;
     if (w->error == 0) {
         if (!errnamebuff) {
             errnamebuff = cobc_main_malloc ((size_t)COB_NORMAL_BUFF);
         }
         /* Display error the first time */
         snprintf (errnamebuff, (size_t)COB_NORMAL_MAX, "'%s'", CB_NAME (x));
         for (l = CB_REFERENCE (x)->chain; l; l = CB_REFERENCE (l)->chain) {
             strcat (errnamebuff, " in '");
             strcat (errnamebuff, CB_NAME (l));
             strcat (errnamebuff, "'");
         }
         cb_error_x (x, _("%s ambiguous; need qualification"), errnamebuff);
         w->error = 1;
 
         /* Display all fields with the same name */
         for (l = w->items; l; l = CB_CHAIN (l)) {
             y = CB_VALUE (l);
             snprintf (errnamebuff, (size_t)COB_NORMAL_MAX,
                   "'%s' ", w->name);
             switch (CB_TREE_TAG (y)) {
             case CB_TAG_FIELD:
                 for (p = CB_FIELD (y)->parent; p; p = p->parent) {
                     strcat (errnamebuff, "in '");
                     strcat (errnamebuff, cb_name (CB_TREE(p)));
                     strcat (errnamebuff, "' ");
                 }
                 break;
             case CB_TAG_LABEL:
                 l2 = CB_LABEL (y);
                 if (l2->section) {
                     strcat (errnamebuff, "in '");
                     strcat (errnamebuff,
                         (const char *)(l2->section->name));
                     strcat (errnamebuff, "' ");
                 }
                 break;
             default:
                 break;
             }
             strcat (errnamebuff, _("defined here"));
             cb_error_x (y, errnamebuff);
         }
     }
 }

struct cb_file* build_file ( cb_tree )

read

 {
     struct cb_file *p;
 
     p = make_tree (CB_TAG_FILE, CB_CATEGORY_UNKNOWN, sizeof (struct cb_file));
     p->name = cb_define (name, CB_TREE (p));
     p->cname = cb_to_cname (p->name);
 
     p->organization = COB_ORG_SEQUENTIAL;
     p->access_mode = COB_ACCESS_SEQUENTIAL;
     p->handler = CB_LABEL (cb_standard_error_handler);
     p->handler_prog = current_program;
     return p;
 }

struct cb_literal* build_literal	(	enum	cb_category,
		const void *	,
		const size_t
	)

read

 {
     struct cb_literal *p;
 
     p = make_tree (CB_TAG_LITERAL, category, sizeof (struct cb_literal));
     p->data = cobc_parse_malloc (size + 1U);
     p->size = size;
     memcpy (p->data, data, size);
     return p;
 }

struct cb_report* build_report ( cb_tree )

read

 {
     struct cb_report *p;
 
     p = make_tree (CB_TAG_REPORT, CB_CATEGORY_UNKNOWN, sizeof (struct cb_report));
     p->name = cb_define (name, CB_TREE (p));
     p->cname = cb_to_cname (p->name);
 
 #if 0   /* RXWRXW RP */
     p->organization = COB_ORG_SEQUENTIAL;
     p->access_mode = COB_ACCESS_SEQUENTIAL;
     p->handler = CB_LABEL (cb_standard_error_handler);
     p->handler_prog = current_program;
 #endif
     return p;
 }

void cb_add_78 ( struct cb_field * f )

References CB_VALUE, check_78_replace(), cb_level_78::chk_const, cob_u32_t, cobc_malloc(), const78ptr, current_program, cb_field::flag_is_global, cb_level_78::fld78, globlev78ptr, cb_level_78::globnext, cb_level_78::last, lev78ptr, cb_field::name, cb_level_78::name_len, cb_level_78::next, cb_level_78::pic_len, cb_level_78::pic_replace, cb_level_78::prog, and cb_field::values.

Referenced by cb_validate_78_item().

 {
     struct cb_level_78  *p78;
 
     /* Add a constant (78 level) item */
     p78 = cobc_malloc (sizeof(struct cb_level_78));
     p78->fld78 = f;
     p78->prog = current_program;
     p78->pic_replace = check_78_replace (CB_VALUE(f->values));
     if (p78->pic_replace) {
         p78->pic_len = (cob_u32_t)strlen (p78->pic_replace);
     }
     p78->name_len = (cob_u32_t)strlen (f->name);
     if (f->flag_is_global) {
         if (!globlev78ptr) {
             p78->last = p78;
         } else {
             p78->last = globlev78ptr->last;
         }
         p78->last->globnext = const78ptr;
         p78->next = globlev78ptr;
         p78->globnext = globlev78ptr;
         p78->chk_const = 1;
         globlev78ptr = p78;
         if (lev78ptr) {
             lev78ptr->last->globnext = globlev78ptr;
         } else {
             top78ptr = globlev78ptr;
         }
     } else {
         if (!lev78ptr) {
             p78->last = p78;
         } else {
             p78->last = lev78ptr->last;
         }
         if (globlev78ptr) {
             p78->last->globnext = globlev78ptr;
         } else {
             p78->last->globnext = const78ptr;
         }
         p78->next = lev78ptr;
         p78->globnext = lev78ptr;
         lev78ptr = p78;
         top78ptr = lev78ptr;
     }
 }

void cb_add_common_prog ( struct cb_program * )

 {
     struct cb_program   *q;
 
     /* Here we are sure that nested >= 1 */
     q = container_progs[prog->nested_level - 1];
     q->common_prog_list = add_contained_prog (q->common_prog_list, prog);
 }

cb_tree cb_build_add	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     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) {
         optimize_defs[COB_POINTER_MANIP] = 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_PTR (v);
         f->count++;
     }
     if (CB_REF_OR_FIELD_P (n)) {
         f = CB_FIELD_PTR (n);
         f->count++;
     }
     if (round_opt == cb_high) {
         /* Short circuit from tree.c for perform */
         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_address ( cb_tree )

 {
     cb_tree         v;
     struct cb_reference *r;
     const char      *name;
     int         numsubs;
     int         refsubs;
 
     if (x == cb_error_node) {
         return cb_error_node;
     }
     if (!CB_REFERENCE_P (x)) {
         return CB_BUILD_CAST_ADDRESS (x);
     }
 
     r = CB_REFERENCE (x);
     name = r->word->name;
     v = cb_ref (x);
     if (v == cb_error_node) {
         return cb_error_node;
     }
 
     refsubs = cb_list_length (r->subs);
     if (CB_FIELD_P (v)) {
         numsubs = CB_FIELD (v)->indexes;
         if (refsubs > numsubs) {
             goto subserror;
         } else if (refsubs < numsubs) {
             if (!cb_relaxed_syntax_check) {
                 goto subserror;
             } else {
                 cb_warning_x (x,
                         _("Subscripts missing for '%s' - Defaulting to 1"),
                         name);
                 for (; refsubs < numsubs; ++refsubs) {
                     CB_ADD_TO_CHAIN (cb_one, r->subs);
                 }
             }
         }
     } else {
         numsubs = 0;
         if (r->subs) {
             goto subserror;
         }
         if (r->offset) {
             cb_error_x (x, _("'%s' cannot be reference modified"), name);
             return cb_error_node;
         }
     }
 
     return CB_BUILD_CAST_ADDRESS (x);
 
 subserror:
     switch (numsubs) {
     case 0:
         cb_error_x (x, _("'%s' cannot be subscripted"), name);
         break;
     case 1:
         cb_error_x (x, _("'%s' requires 1 subscript"), name);
         break;
     default:
         cb_error_x (x, _("'%s' requires %d subscripts"),
                 name, numsubs);
         break;
     }
     return cb_error_node;
 }

cb_tree cb_build_alphabet_name ( cb_tree )

 {
     struct cb_alphabet_name *p;
 
     if (!name || name == cb_error_node) {
         return NULL;
     }
     p = make_tree (CB_TAG_ALPHABET_NAME, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_alphabet_name));
     p->name = cb_define (name, CB_TREE (p));
     p->cname = cb_to_cname (p->name);
     return CB_TREE (p);
 }

cb_tree cb_build_alphanumeric_literal	(	const void *	,
		const size_t
	)

 {
     return CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, data, size));
 }

cb_tree cb_build_alter	(	const cb_tree	,
		const cb_tree
	)

 {
     struct cb_alter *p;
 
     p = make_tree (CB_TAG_ALTER, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_alter));
     p->source = source;
     p->target = target;
     current_program->alter_list =
         cb_list_append (current_program->alter_list,
                 CB_BUILD_PAIR (source, target));
     return CB_TREE (p);
 }

cb_tree cb_build_any_intrinsic ( cb_tree )

 {
     struct cb_intrinsic_table   *cbp;
 
     cbp = lookup_intrinsic ("LENGTH", 0, 0);
     return make_intrinsic (NULL, cbp, args, NULL, NULL, 0);
 }

cb_tree cb_build_assign	(	const cb_tree	,
		const cb_tree
	)

 {
     struct cb_assign *p;
 
     p = make_tree (CB_TAG_ASSIGN, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_assign));
     p->var = var;
     p->val = val;
     return CB_TREE (p);
 }

cb_tree cb_build_assignment_name	(	struct cb_file *	,
		cb_tree
	)

 {
     const char  *s;
     const char  *p;
 
     if (name == cb_error_node) {
         return cb_error_node;
     }
     /* For special assignment */
     if (name == NULL) {
         return NULL;
     }
 
     switch (CB_TREE_TAG (name)) {
     case CB_TAG_LITERAL:
         return name;
 
     case CB_TAG_REFERENCE:
         s = CB_NAME (name);
         if (cb_assign_clause == CB_ASSIGN_MF) {
             if (cfile->flag_ext_assign) {
                 p = strrchr (s, '-');
                 if (p) {
                     s = p + 1;
                 }
                 return cb_build_alphanumeric_literal (s, strlen (s));
             }
             current_program->reference_list =
                 cb_list_add (current_program->reference_list, name);
             return name;
         } else if (cb_assign_clause == CB_ASSIGN_IBM) {
             /* Check organization */
             if (strncmp (s, "S-", (size_t)2) == 0 ||
                 strncmp (s, "AS-", (size_t)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-", (size_t)2) == 0 ||
                 strncmp (s, "AS-", (size_t)3) == 0) {
 org:
                 /* Skip it for now */
                 s = strchr (s, '-') + 1;
             }
             /* Convert the name into literal */
             if (warningopt) {
                 cb_warning (_("ASSIGN interpreted as %s"), s);
             }
             return cb_build_alphanumeric_literal (s, strlen (s));
         }
         /* Fall through for CB_ASSIGN_COBOL2002 */
         /* To be looked at */
     default:
         return cb_error_node;
     }
 }

cb_tree cb_build_binary_list	(	cb_tree	,
		const int
	)

 {
     cb_tree e;
 
     e = CB_VALUE (l);
     for (l = CB_CHAIN (l); l; l = CB_CHAIN (l)) {
         e = cb_build_binary_op (e, op, CB_VALUE (l));
     }
     return e;
 }

cb_tree cb_build_binary_op	(	cb_tree	,
		const int	,
		cb_tree
	)

 {
     struct cb_binary_op *p;
     enum cb_category    category = CB_CATEGORY_UNKNOWN;
 
     switch (op) {
     case '+':
     case '-':
     case '*':
     case '/':
     case '^':
         /* Arithmetic operators */
         if (CB_TREE_CLASS (x) == CB_CLASS_POINTER ||
             CB_TREE_CLASS (y) == CB_CLASS_POINTER) {
             category = CB_CATEGORY_DATA_POINTER;
             break;
         }
         x = cb_check_numeric_value (x);
         y = cb_check_numeric_value (y);
         if (x == cb_error_node || y == cb_error_node) {
             return cb_error_node;
         }
         category = CB_CATEGORY_NUMERIC;
         break;
 
     case '=':
     case '~':
     case '<':
     case '>':
     case '[':
     case ']':
         /* Relational operators */
         if ((CB_REF_OR_FIELD_P (x)) &&
             CB_FIELD (cb_ref (x))->level == 88) {
             cb_error_x (x, _("Invalid expression"));
             return cb_error_node;
         }
         if ((CB_REF_OR_FIELD_P (y)) &&
             CB_FIELD (cb_ref (y))->level == 88) {
             cb_error_x (y, _("Invalid expression"));
             return cb_error_node;
         }
         category = CB_CATEGORY_BOOLEAN;
         break;
 
     case '!':
     case '&':
     case '|':
         /* Logical operators */
         if (CB_TREE_CLASS (x) != CB_CLASS_BOOLEAN ||
             (y && CB_TREE_CLASS (y) != CB_CLASS_BOOLEAN)) {
             cb_error_x (x, _("Invalid expression"));
             return cb_error_node;
         }
         category = CB_CATEGORY_BOOLEAN;
         break;
 
     case '@':
         /* Parentheses */
         category = CB_TREE_CATEGORY (x);
         break;
 
     default:
         cobc_abort_pr (_("Unexpected operator -> %d"), op);
         COBC_ABORT ();
     }
 
     p = make_tree (CB_TAG_BINARY_OP, category, sizeof (struct cb_binary_op));
     p->op = op;
     p->x = x;
     p->y = y;
     return CB_TREE (p);
 }

struct cb_picture* cb_build_binary_picture	(	const char *	,
		const cob_u32_t	,
		const cob_u32_t
	)

read

 {
     struct cb_picture   *pic;
 
     pic = make_tree (CB_TAG_PICTURE, CB_CATEGORY_NUMERIC,
              sizeof (struct cb_picture));
     pic->orig = cobc_check_string (str);
     pic->size = size;
     pic->digits = size;
     pic->scale = 0;
     pic->have_sign = sign;
     pic->category = CB_CATEGORY_NUMERIC;
     return pic;
 }

cb_tree cb_build_call	(	const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cob_u32_t	,
		const int
	)

 {
     struct cb_call *p;
 
     p = make_tree (CB_TAG_CALL, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_call));
     p->name = name;
     p->args = args;
     p->stmt1 = stmt1;
     p->stmt2 = stmt2;
     p->call_returning = returning;
     p->is_system = is_system_call;
     p->convention = convention;
     return CB_TREE (p);
 }

cb_tree cb_build_cancel ( const cb_tree )

 {
     struct cb_cancel *p;
 
     p = make_tree (CB_TAG_CANCEL, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_cancel));
     p->target = target;
     return CB_TREE (p);
 }

cb_tree cb_build_cast	(	const enum	cb_cast_type,
		const cb_tree
	)

 {
     struct cb_cast      *p;
     enum cb_category    category;
 
     if (type == CB_CAST_INTEGER) {
         category = CB_CATEGORY_NUMERIC;
     } else {
         category = CB_CATEGORY_UNKNOWN;
     }
     p = make_tree (CB_TAG_CAST, category, sizeof (struct cb_cast));
     p->cast_type = type;
     p->val = val;
     return CB_TREE (p);
 }

cb_tree cb_build_cast_int ( const cb_tree )

 {
     struct cb_cast      *p;
 
     p = make_tree (CB_TAG_CAST, CB_CATEGORY_NUMERIC, sizeof (struct cb_cast));
     p->cast_type = CB_CAST_INTEGER;
     p->val = val;
     return CB_TREE (p);
 }

cb_tree cb_build_cast_llint ( const cb_tree )

 {
     struct cb_cast      *p;
 
     p = make_tree (CB_TAG_CAST, CB_CATEGORY_NUMERIC, sizeof (struct cb_cast));
     p->cast_type = CB_CAST_LONG_INT;
     p->val = val;
     return CB_TREE (p);
 }

cb_tree cb_build_class_name	(	cb_tree	,
		cb_tree
	)

 {
     struct cb_class_name    *p;
 
     if (!name || name == cb_error_node) {
         return NULL;
     }
     p = make_tree (CB_TAG_CLASS_NAME, CB_CATEGORY_BOOLEAN,
                sizeof (struct cb_class_name));
     p->name = cb_define (name, CB_TREE (p));
     if (!scratch_buff) {
         scratch_buff = cobc_main_malloc ((size_t)COB_MINI_BUFF);
     }
     snprintf (scratch_buff, (size_t)COB_MINI_MAX, "cob_is_%s_%d",
           cb_to_cname (p->name), class_id++);
     p->cname = cobc_parse_strdup (scratch_buff);
     p->list = list;
     return CB_TREE (p);
 }

cb_tree cb_build_comment ( const char * )

 {
     struct cb_direct *p;
 
     p = make_tree (CB_TAG_DIRECT, CB_CATEGORY_ALPHANUMERIC,
                sizeof (struct cb_direct));
     p->line = str;
     CB_TREE (p)->source_file = cb_source_file;
     CB_TREE (p)->source_line = cb_source_line;
     return CB_TREE (p);
 }

cb_tree cb_build_cond ( cb_tree )

 {
     struct cb_field     *f;
     struct cb_binary_op *p;
     cb_tree         d1;
     cb_tree         d2;
     int         size1;
     int         size2;
 
     if (x == cb_error_node) {
         return cb_error_node;
     }
     switch (CB_TREE_TAG (x)) {
     case CB_TAG_CONST:
         if (x != cb_any && x != cb_true && x != cb_false) {
             cb_error_x (CB_TREE(current_statement),
                     _("Invalid expression"));
             return cb_error_node;
         }
         return x;
     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_PTR (x);
 
         /* Level 88 condition */
         if (f->level == 88) {
             /* Build an 88 condition at every occurrence */
             /* as it may be subscripted */
             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);
         if (!p->x || p->x == cb_error_node) {
             return cb_error_node;
         }
         switch (p->op) {
         case '!':
             return CB_BUILD_NEGATION (cb_build_cond (p->x));
         case '&':
         case '|':
             if (!p->y || p->y == cb_error_node) {
                 return cb_error_node;
             }
             return cb_build_binary_op (cb_build_cond (p->x), p->op, cb_build_cond (p->y));
         default:
             if (!p->y || p->y == cb_error_node) {
                 return cb_error_node;
             }
             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 {
                 /* DEBUG Bypass optimization for PERFORM */
                 if (current_program->flag_debugging) {
                     x = CB_BUILD_FUNCALL_2 ("cob_cmp", p->x, p->y);
                     break;
                 }
                 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_long_long (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:
         break;
     }
     cb_error_x (x, _("Invalid expression"));
     return cb_error_node;
 }

cb_tree cb_build_const_length ( cb_tree )

 {
     struct cb_field     *f;
     char            buff[32];
 
     if (x == cb_error_node) {
         return cb_error_node;
     }
     if (CB_INTEGER_P (x)) {
         sprintf (buff, "%d", CB_INTEGER(x)->val);
         return cb_build_numeric_literal (0, buff, 0);
     }
     if (CB_REFERENCE_P (x)) {
         if (cb_ref (x) == cb_error_node) {
             return cb_error_node;
         }
         if (CB_REFERENCE (x)->offset) {
             cb_error (_("Reference modification not allowed here"));
             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 (cb_field_variable_size (f)) {
         cb_error (_("Variable length item not allowed here"));
         return cb_error_node;
     }
     if (f->redefines) {
         cb_validate_field (f->redefines);
         if (f->rename_thru) {
             cb_validate_field (f->rename_thru);
         }
         cb_validate_field (f);
         sprintf (buff, "%d", f->size);
     } else {
         cb_validate_field (f);
         sprintf (buff, "%d", f->memory_size);
     }
     return cb_build_numeric_literal (0, buff, 0);
 }

cb_tree cb_build_constant	(	cb_tree	,
		cb_tree
	)

 {
     cb_tree x;
 
     x = cb_build_field (name);
     x->category = cb_tree_category (value);
     CB_FIELD (x)->storage = CB_STORAGE_CONSTANT;
     CB_FIELD (x)->values = CB_LIST_INIT (value);
     return x;
 }

cb_tree cb_build_continue ( void )

 {
     struct cb_continue *p;
 
     p = make_tree (CB_TAG_CONTINUE, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_continue));
     return CB_TREE (p);
 }

cb_tree cb_build_converting	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     validate_inspect (x, y, 2);
     return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_converting", x, y));
 }

cb_tree cb_build_debug	(	const cb_tree	,
		const char *	,
		const cb_tree
	)

 {
     struct cb_debug *p;
 
     p = make_tree (CB_TAG_DEBUG, CB_CATEGORY_ALPHANUMERIC,
                sizeof (struct cb_debug));
     p->target = target;
     if (str) {
         p->value = cobc_parse_strdup (str);
         p->fld = NULL;
         p->size = strlen (str);
     } else {
         p->value = NULL;
         p->fld = fld;
         p->size = (size_t)CB_FIELD_PTR (fld)->size;
     }
     CB_TREE (p)->source_file = cb_source_file;
     CB_TREE (p)->source_line = cb_source_line;
     return CB_TREE (p);
 }

cb_tree cb_build_debug_call ( struct cb_label * )

 {
     struct cb_debug_call    *p;
 
     p = make_tree (CB_TAG_DEBUG_CALL, CB_CATEGORY_ALPHANUMERIC,
                sizeof (struct cb_debug_call));
     p->target = target;
     CB_TREE (p)->source_file = cb_source_file;
     CB_TREE (p)->source_line = cb_source_line;
     return CB_TREE (p);
 }

void cb_build_debug_item ( void )

 {
     cb_tree         l;
     cb_tree         x;
     cb_tree         assign;
 
     /* Set up DEBUG-ITEM */
     l = cb_build_reference ("DEBUG-ITEM");
     assign = cb_build_field_tree (NULL, l, NULL, CB_STORAGE_WORKING,
                  NULL, 1);
     CB_FIELD (assign)->values = CB_LIST_INIT (cb_space);
     cb_debug_item = l;
 
     l = cb_build_reference ("DEBUG-LINE");
     x = cb_build_field_tree (NULL, l, CB_FIELD(assign),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("9(6)"));
     cb_validate_field (CB_FIELD (x));
     cb_debug_line = l;
 
     l = cb_build_filler ();
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
     CB_FIELD (x)->flag_filler = 1;
     cb_validate_field (CB_FIELD (x));
 
     l = cb_build_reference ("DEBUG-NAME");
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X(31)"));
     cb_validate_field (CB_FIELD (x));
     cb_debug_name = l;
 
     l = cb_build_filler ();
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
     CB_FIELD (x)->flag_filler = 1;
     cb_validate_field (CB_FIELD (x));
 
     l = cb_build_reference ("DEBUG-SUB-1");
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
     CB_FIELD (x)->flag_sign_leading = 1;
     CB_FIELD (x)->flag_sign_separate = 1;
     cb_validate_field (CB_FIELD (x));
     cb_debug_sub_1 = l;
 
     l = cb_build_filler ();
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
     CB_FIELD (x)->flag_filler = 1;
     cb_validate_field (CB_FIELD (x));
 
     l = cb_build_reference ("DEBUG-SUB-2");
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
     CB_FIELD (x)->flag_sign_leading = 1;
     CB_FIELD (x)->flag_sign_separate = 1;
     cb_validate_field (CB_FIELD (x));
     cb_debug_sub_2 = l;
 
     l = cb_build_filler ();
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
     CB_FIELD (x)->flag_filler = 1;
     cb_validate_field (CB_FIELD (x));
 
     l = cb_build_reference ("DEBUG-SUB-3");
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
     CB_FIELD (x)->flag_sign_leading = 1;
     CB_FIELD (x)->flag_sign_separate = 1;
     cb_validate_field (CB_FIELD (x));
     cb_debug_sub_3 = l;
 
     l = cb_build_filler ();
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
     CB_FIELD (x)->flag_filler = 1;
     cb_validate_field (CB_FIELD (x));
 
     l = cb_build_reference ("DEBUG-CONTENTS");
     x = cb_build_field_tree (NULL, l, CB_FIELD(x),
                  CB_STORAGE_WORKING, NULL, 3);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X(31)"));
     cb_validate_field (CB_FIELD (x));
     cb_debug_contents = l;
 
     cb_validate_field (CB_FIELD (assign));
     CB_FIELD_ADD (current_program->working_storage, CB_FIELD (assign));
 }

cb_tree cb_build_decimal ( const int )

 {
     struct cb_decimal *p;
 
     p = make_tree (CB_TAG_DECIMAL, CB_CATEGORY_NUMERIC,
                sizeof (struct cb_decimal));
     p->id = id;
     return CB_TREE (p);
 }

cb_tree cb_build_direct	(	const char *	,
		const unsigned	int
	)

 {
     cb_tree     x;
 
     x = cb_build_comment (str);
     CB_DIRECT (x)->flag_is_direct = 1;
     CB_DIRECT (x)->flag_new_line = flagnl;
     return x;
 }

cb_tree cb_build_display_mnemonic ( cb_tree )

 {
     if (x == cb_error_node) {
         return cb_int0;
     }
     if (cb_ref (x) == cb_error_node) {
         return cb_int0;
     }
 
     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 device"));
         return cb_int0;
     }
 }

cb_tree cb_build_display_name ( cb_tree )

 {
     const char  *name;
     cb_tree     sys;
 
     if (x == cb_error_node) {
         return cb_error_node;
     }
     name = CB_NAME (x);
     /* Allow direct reference to a device name */
     sys = lookup_system_name (name);
     if (sys) {
         switch (CB_SYSTEM_NAME (sys)->token) {
         case CB_DEVICE_CONSOLE:
         case CB_DEVICE_SYSOUT:
             if (!cb_relaxed_syntax_check) {
                 cb_warning_x (x, _("'%s' is not defined in SPECIAL-NAMES"), name);
             }
             return cb_int0;
         case CB_DEVICE_SYSERR:
             if (!cb_relaxed_syntax_check) {
                 cb_warning_x (x, _("'%s' is not defined in SPECIAL-NAMES"), name);
             }
             return cb_int1;
         default:
             cb_error_x (x, _("'%s' is not an output device"), name);
             return cb_error_node;
         }
     }
 
     cb_error_x (x, _("'%s' is not defined in SPECIAL-NAMES"), name);
     return cb_error_node;
 }

cb_tree cb_build_expr ( cb_tree )

 {
     cb_tree l;
     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 */
             if (current_statement) {
                 current_statement->null_check = NULL;
             }
             cb_expr_shift_class ("cob_is_omitted");
             break;
         case 'C':
             /* CLASS */
             cb_expr_shift_class (CB_CLASS_NAME (cb_ref (CB_VALUE (l)))->cname);
             break;
         default:
             cb_expr_shift (op, CB_VALUE (l));
             break;
         }
     }
 
     return cb_expr_finish ();
 }

cb_tree cb_build_field ( cb_tree )

 {
     struct cb_field *p;
 
     p = make_tree (CB_TAG_FIELD, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_field));
     p->id = cb_field_id++;
     p->name = cb_define (name, CB_TREE (p));
     p->ename = NULL;
     p->usage = CB_USAGE_DISPLAY;
     p->storage = CB_STORAGE_WORKING;
     p->occurs_max = 1;
     return CB_TREE (p);
 }

cb_tree cb_build_field_reference	(	struct cb_field *	,
		cb_tree
	)

 {
     cb_tree     x;
     struct cb_word  *word;
 
     x = cb_build_reference (f->name);
     word = CB_REFERENCE (x)->word;
     if (ref) {
         memcpy (x, ref, sizeof (struct cb_reference));
     }
     x->category = CB_CATEGORY_UNKNOWN;
     CB_REFERENCE (x)->word = word;
     CB_REFERENCE (x)->value = CB_TREE (f);
     return x;
 }

cb_tree cb_build_field_tree	(	cb_tree	,
		cb_tree	,
		struct cb_field *	,
		enum	cb_storage,
		struct cb_file *	,
		const int
	)

 {
     struct cb_reference *r;
     struct cb_field     *f;
     struct cb_field     *p;
     struct cb_field     *field_fill;
     cb_tree         dummy_fill;
     cb_tree         l;
     cb_tree         x;
     int         lv;
 
     if (!expl_level) {
         if (level == cb_error_node || name == cb_error_node) {
             return cb_error_node;
         }
         /* Check the level number */
         lv = cb_get_level (level);
         if (!lv) {
             return cb_error_node;
         }
     } else {
         lv = expl_level;
     }
 
     /* Build the field */
     r = CB_REFERENCE (name);
     f = CB_FIELD (cb_build_field (name));
     f->storage = storage;
     last_real_field = last_field;
     if (lv == 78) {
         f->level = 01;
         f->flag_item_78 = 1;
         return CB_TREE (f);
     } else {
         f->level = lv;
     }
     if (f->level == 01 && storage == CB_STORAGE_FILE && fn) {
         if (fn->flag_external) {
             f->flag_external = 1;
             current_program->flag_has_external = 1;
         } else if (fn->flag_global) {
             f->flag_is_global = 1;
         }
     }
     if (last_field) {
         if (last_field->level == 77 && f->level != 01 &&
             f->level != 77 && f->level != 66 && f->level != 88) {
             cb_error_x (name, _("Level number must begin with 01 or 77"));
             return cb_error_node;
         }
     }
 
     /* Checks for redefinition */
     if (cb_warn_redefinition && r->word->count > 1 && !r->flag_filler_ref) {
         if (f->level == 01 || f->level == 77) {
             redefinition_warning (name, NULL);
         } else {
             for (l = r->word->items; l; l = CB_CHAIN (l)) {
                 x = CB_VALUE (l);
                 if (!CB_FIELD_P (x) ||
                     CB_FIELD (x)->level == 01 ||
                     CB_FIELD (x)->level == 77 ||
                     (last_field && f->level == last_field->level &&
                      CB_FIELD (x)->parent == last_field->parent)) {
                     redefinition_warning (name, x);
                     break;
                 }
             }
         }
     }
 
     if (last_field && last_field->level == 88) {
         last_field = last_field->parent;
     }
 
     /* Link the field into the tree */
     if (f->level == 01 || f->level == 77) {
         /* Top level */
         cb_needs_01 = 0;
         if (last_field) {
             cb_field_founder (last_field)->sister = f;
         }
     } else if (!last_field || cb_needs_01) {
         /* Invalid top level */
         cb_error_x (name, _("Level number must begin with 01 or 77"));
         return cb_error_node;
     } else if (f->level == 66) {
         /* Level 66 */
         f->parent = cb_field_founder (last_field);
         for (p = f->parent->children; p && p->sister; p = p->sister) ;
         if (p) {
             p->sister = f;
         }
     } else if (f->level == 88) {
         /* Level 88 */
         f->parent = last_field;
     } else if (f->level > last_field->level) {
         /* Lower level */
         last_field->children = f;
         f->parent = last_field;
     } else if (f->level == last_field->level) {
         /* Same level */
 same_level:
         last_field->sister = f;
         f->parent = last_field->parent;
     } else {
         /* Upper level */
         for (p = last_field->parent; p; p = p->parent) {
             if (p->level == f->level) {
                 last_field = p;
                 goto same_level;
             }
             if (cb_relax_level_hierarchy && p->level < f->level) {
                 break;
             }
         }
         if (cb_relax_level_hierarchy) {
             dummy_fill = cb_build_filler ();
             field_fill = CB_FIELD (cb_build_field (dummy_fill));
             cb_warning_x (name,
                       _("No previous data item of level %02d"),
                       f->level);
             field_fill->level = f->level;
             field_fill->flag_filler = 1;
             field_fill->storage = storage;
             field_fill->children = p->children;
             field_fill->parent = p;
             for (p = p->children; p; p = p->sister) {
                 p->parent = field_fill;
             }
             field_fill->parent->children = field_fill;
             field_fill->sister = f;
             f->parent = field_fill->parent;
             /* last_field = field_fill; */
         } else {
             cb_error_x (name,
                     _("No previous data item of level %02d"),
                     f->level);
             return cb_error_node;
         }
     }
 
     /* Inherit parents properties */
     if (f->parent) {
         f->usage = f->parent->usage;
         f->indexes = f->parent->indexes;
         f->flag_sign_leading = f->parent->flag_sign_leading;
         f->flag_sign_separate = f->parent->flag_sign_separate;
         f->flag_is_global = f->parent->flag_is_global;
     }
     return CB_TREE (f);
 }

cb_tree cb_build_filler ( void )

 {
     cb_tree     x;
     char        name[20];
 
     sprintf (name, "FILLER %d", filler_id++);
     x = cb_build_reference (name);
     x->source_line = cb_source_line;
     CB_REFERENCE (x)->flag_filler_ref = 1;
     return x;
 }

cb_tree cb_build_funcall	(	const char *	,
		const int	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree
	)

 {
     struct cb_funcall *p;
 
     p = make_tree (CB_TAG_FUNCALL, CB_CATEGORY_BOOLEAN,
                sizeof (struct cb_funcall));
     p->name = name;
     p->argc = argc;
     p->varcnt = 0;
     p->screenptr = gen_screen_ptr;
     p->argv[0] = a1;
     p->argv[1] = a2;
     p->argv[2] = a3;
     p->argv[3] = a4;
     p->argv[4] = a5;
     p->argv[5] = a6;
     p->argv[6] = a7;
     p->argv[7] = a8;
     p->argv[8] = a9;
     p->argv[9] = a10;
     return CB_TREE (p);
 }

cb_tree cb_build_goto	(	const cb_tree	,
		const cb_tree
	)

 {
     struct cb_goto *p;
 
     p = make_tree (CB_TAG_GOTO, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_goto));
     p->target = target;
     p->depending = depending;
     return CB_TREE (p);
 }

cb_tree cb_build_identifier	(	cb_tree	,
		const int
	)

 {
     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;
     int         numsubs;
     int         refsubs;
     int         pseudosize;
 
     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 (current_statement && CB_EXCEPTION_ENABLE (COB_EC_DATA_PTR_NULL)) {
         p = cb_field_founder (f);
         if (p->redefines) {
             p = p->redefines;
         }
         if (!current_statement->flag_no_based) {
             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 (name));
             }
         }
     }
 
     for (l = r->subs; l; l = CB_CHAIN (l)) {
         if (CB_BINARY_OP_P (CB_VALUE (l))) {
             /* Set special flag for codegen */
             CB_BINARY_OP(CB_VALUE(l))->flag = 1;
         }
     }
 
     /* Check the number of subscripts */
     numsubs = cb_list_length (r->subs);
     cb_check_lit_subs (r, numsubs, f->indexes);
     if (subchk) {
         if (!f->indexes) {
             cb_error_x (x, _("'%s' has no OCCURS clause"), name);
             return cb_error_node;
         }
         numsubs = f->indexes - 1;
     } else {
         numsubs = f->indexes;
     }
     refsubs = cb_list_length (r->subs);
     if (!r->flag_all && refsubs != numsubs) {
         if (refsubs > numsubs) {
             goto refsubserr;
         } else if (refsubs < numsubs) {
             if (!cb_relaxed_syntax_check) {
                 goto refsubserr;
             } else {
                 cb_warning_x (x,
                         _("Subscripts missing for '%s' - Defaulting to 1"),
                         name);
                 for (; refsubs < numsubs; ++refsubs) {
                     CB_ADD_TO_CHAIN (cb_one, r->subs);
                 }
             }
         }
     }
 
     /* Subscript check */
     if (!r->flag_all && r->subs) {
         l = r->subs;
         for (p = f; p; p = p->parent) {
             if (!p->flag_occurs) {
                 continue;
             }
 
 #if 1   /* RXWRXW - Sub check */
             if (!l) {
                 break;
             }
 #endif
             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->depending) {
                     e1 = CB_BUILD_FUNCALL_4 ("cob_check_odo",
                          cb_build_cast_int (p->depending),
                          cb_int (p->occurs_min),
                          cb_int (p->occurs_max),
                          CB_BUILD_STRING0
                          ((CB_FIELD_PTR (p->depending)->name)));
                     e2 = CB_BUILD_FUNCALL_4 ("cob_check_subscript",
                          cb_build_cast_int (sub),
                          cb_int1,
                          cb_build_cast_int (p->depending),
                          CB_BUILD_STRING0 (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_int (sub),
                             cb_int1,
                             cb_int (p->occurs_max),
                             CB_BUILD_STRING0 (name));
                         r->check = cb_list_add (r->check, e1);
                     }
                 }
             }
         }
     }
 
     if (subchk) {
         r->subs = cb_list_reverse (r->subs);
         r->subs = cb_list_add (r->subs, cb_int1);
         r->subs = cb_list_reverse (r->subs);
     }
 
     /* Reference modification check */
     if ( f->usage == CB_USAGE_NATIONAL ) {
         pseudosize = f->size / 2;
     } else {
         pseudosize = f->size;
     }
     if (r->offset) {
         /* Compile-time check */
         if (CB_LITERAL_P (r->offset)) {
             offset = cb_get_int (r->offset);
             if (f->flag_any_length) {
                 if (offset < 1) {
                     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) {
                         cb_error_x (x, _("Length of '%s' out of bounds: %d"),
                                 name, length);
                     }
                 }
             } else {
                 if (offset < 1 || offset > pseudosize) {
                     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 > pseudosize - 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 (f->flag_any_length || !CB_LITERAL_P (r->offset) ||
                 (r->length && !CB_LITERAL_P (r->length))) {
                 e1 = CB_BUILD_FUNCALL_4 ("cob_check_ref_mod",
                              cb_build_cast_int (r->offset),
                              r->length ?
                               cb_build_cast_int (r->length) :
                               cb_int1,
                              f->flag_any_length ?
                               CB_BUILD_CAST_LENGTH (v) :
                               cb_int (pseudosize),
                              CB_BUILD_STRING0 (f->name));
                 r->check = cb_list_add (r->check, e1);
             }
         }
     }
 
     if (f->storage == CB_STORAGE_CONSTANT) {
         return CB_VALUE (f->values);
     }
 
     return x;
 
 refsubserr:
     switch (numsubs) {
     case 0:
         cb_error_x (x, _("'%s' cannot be subscripted"), name);
         break;
     case 1:
         cb_error_x (x, _("'%s' requires 1 subscript"), name);
         break;
     default:
         cb_error_x (x, _("'%s' requires %d subscripts"),
                 name, f->indexes);
         break;
     }
     return cb_error_node;
 }

cb_tree cb_build_if	(	const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const unsigned	int
	)

 {
     struct cb_if *p;
 
     p = make_tree (CB_TAG_IF, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_if));
     p->test = test;
     p->stmt1 = stmt1;
     p->stmt2 = stmt2;
     p->is_if = is_if;
     return CB_TREE (p);
 }

cb_tree cb_build_if_check_break	(	cb_tree	,
		cb_tree
	)

 {
     cb_tree     stmt_lis;
 
     stmt_lis = cb_check_needs_break (stmts);
     return cb_build_if (cond, stmt_lis, NULL, 0);
 }

cb_tree cb_build_implicit_field	(	cb_tree	,
		const int
	)

 {
     cb_tree x;
     char    pic[32];
 
     x = cb_build_field (name);
     memset (pic, 0, sizeof(pic));
     snprintf (pic, sizeof(pic), "X(%d)", len);
     CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture (pic));
     cb_validate_field (CB_FIELD (x));
     return x;
 }

cb_tree cb_build_index	(	cb_tree	,
		cb_tree	,
		const unsigned	int,
		struct cb_field *
	)

 {
     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;
     CB_FIELD_ADD (current_program->working_storage, f);
     return x;
 }

cb_tree cb_build_initialize	(	const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const unsigned	int,
		const unsigned	int,
		const unsigned	int
	)

 {
     struct cb_initialize *p;
 
     p = make_tree (CB_TAG_INITIALIZE, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_initialize));
     p->var = var;
     p->val = val;
     p->rep = rep;
     p->flag_default = (cob_u8_t)def;
     p->flag_init_statement = (cob_u8_t)is_statement;
     p->flag_no_filler_init = (cob_u8_t)no_filler_init;
     return CB_TREE (p);
 }

cb_tree cb_build_inspect_region_start ( void )

 {
     return CB_LIST_INIT (CB_BUILD_FUNCALL_0 ("cob_inspect_start"));
 }

cb_tree cb_build_intrinsic	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		const int
	)

 {
     struct cb_intrinsic_table   *cbp;
     cb_tree             x;
     int             numargs;
     enum cb_category        catg;
 
     numargs = cb_list_length (args);
 
     if (unlikely(isuser)) {
         if (refmod && CB_LITERAL_P(CB_PAIR_X(refmod)) &&
             cb_get_int (CB_PAIR_X(refmod)) < 1) {
             cb_error_x (name, _("FUNCTION '%s' has invalid reference modification"), CB_NAME(name));
             return cb_error_node;
         }
         if (refmod && CB_PAIR_Y(refmod) &&
             CB_LITERAL_P(CB_PAIR_Y(refmod)) &&
             cb_get_int (CB_PAIR_Y(refmod)) < 1) {
             cb_error_x (name, _("FUNCTION '%s' has invalid reference modification"), CB_NAME(name));
             return cb_error_node;
         }
         if (numargs > current_program->max_call_param) {
             current_program->max_call_param = numargs;
         }
         return make_intrinsic (name, &userbp, args, cb_int1, refmod, 1);
     }
 
     cbp = lookup_intrinsic (CB_NAME (name), 0, 1);
     if (!cbp) {
         cb_error_x (name, _("FUNCTION '%s' unknown"), CB_NAME (name));
         return cb_error_node;
     }
     if (!cbp->implemented) {
         cb_error_x (name, _("FUNCTION '%s' not implemented"),
                 cbp->name);
         return cb_error_node;
     }
     if ((cbp->args >= 0 && numargs != cbp->args) ||
         (cbp->args < 0 && numargs < cbp->min_args)) {
         cb_error_x (name,
                 _("FUNCTION '%s' has wrong number of arguments"),
                 cbp->name);
         return cb_error_node;
     }
     if (refmod) {
         if (!cbp->refmod) {
             cb_error_x (name, _("FUNCTION '%s' can not have reference modification"), cbp->name);
             return cb_error_node;
         }
         if (CB_LITERAL_P(CB_PAIR_X(refmod)) &&
             cb_get_int (CB_PAIR_X(refmod)) < 1) {
             cb_error_x (name, _("FUNCTION '%s' has invalid reference modification"), cbp->name);
             return cb_error_node;
         }
         if (CB_PAIR_Y(refmod) && CB_LITERAL_P(CB_PAIR_Y(refmod)) &&
             cb_get_int (CB_PAIR_Y(refmod)) < 1) {
             cb_error_x (name, _("FUNCTION '%s' has invalid reference modification"), cbp->name);
             return cb_error_node;
         }
     }
 
     if (iso_8601_func (cbp->intr_enum)) {
         if (!valid_const_date_time_args (name, cbp, args)) {
             return cb_error_node;
         }
     }
 
     switch (cbp->intr_enum) {
     case CB_INTR_LENGTH:
     case CB_INTR_BYTE_LENGTH:
         x = CB_VALUE (args);
         if (CB_LITERAL_P (x)) {
             return cb_build_length (x);
         } else {
             return make_intrinsic (name, cbp, args, NULL, NULL, 0);
         }
 
     case CB_INTR_WHEN_COMPILED:
         if (refmod) {
             return make_intrinsic (name, cbp,
                 CB_LIST_INIT (cb_intr_whencomp), NULL, refmod, 0);
         } else {
             return cb_intr_whencomp;
         }
 
     case CB_INTR_ABS:
     case CB_INTR_ACOS:
     case CB_INTR_ASIN:
     case CB_INTR_ATAN:
     case CB_INTR_COS:
     case CB_INTR_DATE_OF_INTEGER:
     case CB_INTR_DAY_OF_INTEGER:
     case CB_INTR_EXP:
     case CB_INTR_EXP10:
     case CB_INTR_FACTORIAL:
     case CB_INTR_FRACTION_PART:
     case CB_INTR_INTEGER:
     case CB_INTR_INTEGER_OF_DATE:
     case CB_INTR_INTEGER_OF_DAY:
     case CB_INTR_INTEGER_PART:
     case CB_INTR_LOG:
     case CB_INTR_LOG10:
     case CB_INTR_SIGN:
     case CB_INTR_SIN:
     case CB_INTR_SQRT:
     case CB_INTR_TAN:
     case CB_INTR_TEST_DATE_YYYYMMDD:
     case CB_INTR_TEST_DAY_YYYYDDD:
         x = CB_VALUE (args);
         if (cb_tree_category (x) != CB_CATEGORY_NUMERIC) {
             cb_error_x (name, _("FUNCTION '%s' has invalid parameter"), cbp->name);
             return cb_error_node;
         }
         return make_intrinsic (name, cbp, args, NULL, refmod, 0);
 
     case CB_INTR_ANNUITY:
     case CB_INTR_BOOLEAN_OF_INTEGER:
     case CB_INTR_CHAR:
     case CB_INTR_CHAR_NATIONAL:
     case CB_INTR_COMBINED_DATETIME:
     case CB_INTR_CURRENCY_SYMBOL:
     case CB_INTR_CURRENT_DATE:
     case CB_INTR_E:
     case CB_INTR_EXCEPTION_FILE:
     case CB_INTR_EXCEPTION_FILE_N:
     case CB_INTR_EXCEPTION_LOCATION:
     case CB_INTR_EXCEPTION_LOCATION_N:
     case CB_INTR_EXCEPTION_STATUS:
     case CB_INTR_EXCEPTION_STATEMENT:
     case CB_INTR_FORMATTED_CURRENT_DATE:
     case CB_INTR_FORMATTED_DATE:
     case CB_INTR_INTEGER_OF_BOOLEAN:
     case CB_INTR_INTEGER_OF_FORMATTED_DATE:
     case CB_INTR_LOCALE_DATE:
     case CB_INTR_LOCALE_TIME:
     case CB_INTR_LOCALE_TIME_FROM_SECS:
     case CB_INTR_LOWER_CASE:
     case CB_INTR_MOD:
     case CB_INTR_MODULE_CALLER_ID:
     case CB_INTR_MODULE_DATE:
     case CB_INTR_MODULE_FORMATTED_DATE:
     case CB_INTR_MODULE_ID:
     case CB_INTR_MODULE_PATH:
     case CB_INTR_MODULE_SOURCE:
     case CB_INTR_MODULE_TIME:
     case CB_INTR_MON_DECIMAL_POINT:
     case CB_INTR_MON_THOUSANDS_SEP:
     case CB_INTR_NUM_DECIMAL_POINT:
     case CB_INTR_NUM_THOUSANDS_SEP:
     case CB_INTR_NUMVAL:
     case CB_INTR_NUMVAL_C:
     case CB_INTR_NUMVAL_F:
     case CB_INTR_ORD:
     case CB_INTR_PI:
     case CB_INTR_REM:
     case CB_INTR_REVERSE:
     case CB_INTR_SECONDS_FROM_FORMATTED_TIME:
     case CB_INTR_SECONDS_PAST_MIDNIGHT:
     case CB_INTR_STORED_CHAR_LENGTH:
     case CB_INTR_TEST_FORMATTED_DATETIME:
     case CB_INTR_TEST_NUMVAL:
     case CB_INTR_TEST_NUMVAL_C:
     case CB_INTR_TEST_NUMVAL_F:
     case CB_INTR_TRIM:
     case CB_INTR_UPPER_CASE:
         return make_intrinsic (name, cbp, args, NULL, refmod, 0);
 
     case CB_INTR_HIGHEST_ALGEBRAIC:
     case CB_INTR_LOWEST_ALGEBRAIC:
         x = CB_VALUE (args);
         if (!CB_REF_OR_FIELD_P (x)) {
             cb_error_x (name, _("FUNCTION '%s' has invalid parameter"), cbp->name);
             return cb_error_node;
         }
         catg = cb_tree_category (x);
         if (catg != CB_CATEGORY_NUMERIC &&
             catg != CB_CATEGORY_NUMERIC_EDITED) {
             cb_error_x (name, _("FUNCTION '%s' has invalid parameter"), cbp->name);
             return cb_error_node;
         }
         return make_intrinsic (name, cbp, args, NULL, refmod, 0);
 
 
     case CB_INTR_CONCATENATE:
     case CB_INTR_DISPLAY_OF:
     case CB_INTR_FORMATTED_DATETIME:
     case CB_INTR_FORMATTED_TIME:
     case CB_INTR_NATIONAL_OF:
         return make_intrinsic (name, cbp, args, cb_int1, refmod, 0);
 
     case CB_INTR_DATE_TO_YYYYMMDD:
     case CB_INTR_DAY_TO_YYYYDDD:
     case CB_INTR_LOCALE_COMPARE:
     case CB_INTR_MAX:
     case CB_INTR_MEAN:
     case CB_INTR_MEDIAN:
     case CB_INTR_MIDRANGE:
     case CB_INTR_MIN:
     case CB_INTR_ORD_MAX:
     case CB_INTR_ORD_MIN:
     case CB_INTR_PRESENT_VALUE:
     case CB_INTR_RANDOM:
     case CB_INTR_RANGE:
     case CB_INTR_STANDARD_COMPARE:
     case CB_INTR_STANDARD_DEVIATION:
     case CB_INTR_SUM:
     case CB_INTR_VARIANCE:
     case CB_INTR_YEAR_TO_YYYY:
         return make_intrinsic (name, cbp, args, cb_int1, NULL, 0);
     case CB_INTR_SUBSTITUTE:
     case CB_INTR_SUBSTITUTE_CASE:
         if ((numargs % 2) == 0) {
             cb_error_x (name, _("FUNCTION '%s' has wrong number of arguments"), cbp->name);
             return cb_error_node;
         }
 #if 0   /* RXWRXW - Substitute param 1 */
         x = CB_VALUE (args);
         if (!CB_REF_OR_FIELD_P (x)) {
             cb_error_x (name, _("FUNCTION '%s' has invalid first parameter"), cbp->name);
             return cb_error_node;
         }
 #endif
         return make_intrinsic (name, cbp, args, cb_int1, refmod, 0);
 
     default:
         cb_error_x (name, _("FUNCTION '%s' unknown"), CB_NAME (name));
         return cb_error_node;
     }
 }

cb_tree cb_build_label	(	cb_tree	,
		struct cb_label *
	)

 {
     struct cb_label     *p;
     struct cb_para_label    *l;
 
     p = make_tree (CB_TAG_LABEL, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_label));
     p->id = cb_id++;
     p->name = cb_define (name, CB_TREE (p));
     p->orig_name = p->name;
     p->section = section;
     if (section) {
         l = cobc_parse_malloc (sizeof(struct cb_para_label));
         l->next = section->para_label;
         l->para= p;
         section->para_label = l;
         p->section_id = p->section->id;
     } else {
         p->section_id = p->id;
     }
     return CB_TREE (p);
 }

cb_tree cb_build_length ( cb_tree )

 {
     struct cb_field     *f;
     struct cb_literal   *l;
     cb_tree         temp;
     char            buff[32];
 
     if (x == cb_error_node) {
         return cb_error_node;
     }
     if (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node) {
         return cb_error_node;
     }
 
     if (CB_LITERAL_P (x)) {
         l = CB_LITERAL (x);
         sprintf (buff, "%d", (int)l->size);
         return cb_build_numeric_literal (0, buff, 0);
     }
     if (CB_INTRINSIC_P (x)) {
         return cb_build_any_intrinsic (CB_LIST_INIT (x));
     }
     if (CB_REF_OR_FIELD_P (x)) {
         if (CB_REFERENCE_P (x) && CB_REFERENCE (x)->offset) {
             return cb_build_any_intrinsic (CB_LIST_INIT (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, buff, 0);
         }
     }
     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_list	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     struct cb_list *p;
 
     p = make_tree (CB_TAG_LIST, CB_CATEGORY_UNKNOWN, sizeof (struct cb_list));
     p->chain = chain;
     p->value = value;
     p->purpose = purpose;
     return CB_TREE (p);
 }

cb_tree cb_build_locale_name	(	cb_tree	,
		cb_tree
	)

 {
     struct cb_class_name    *p;
 
     if (!name || name == cb_error_node) {
         return NULL;
     }
     if (!CB_LITERAL_P (list) || CB_NUMERIC_LITERAL_P (list)) {
         cb_error (_("Invalid LOCALE literal"));
         return cb_error_node;
     }
     p = make_tree (CB_TAG_LOCALE_NAME, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_locale_name));
     p->name = cb_define (name, CB_TREE (p));
     p->cname = cb_to_cname (p->name);
     p->list = list;
     return CB_TREE (p);
 }

cb_tree cb_build_move	(	cb_tree	,
		cb_tree
	)

 {
     struct cb_reference *x;
 
     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 0   /* Flag receiving */
     if (CB_REFERENCE_P (src)) {
         CB_REFERENCE (src)->flag_receiving = 0;
     }
 #endif
 
     if (CB_REFERENCE_P (dst)) {
         /* Clone reference */
         x = cobc_parse_malloc (sizeof(struct cb_reference));
         *x = *CB_REFERENCE (dst);
         x->flag_receiving = 1;
         dst = CB_TREE (x);
     }
 
     if ((src == cb_space || src == cb_low ||
          src == cb_high || src == cb_quote) &&
         (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC ||
          CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED)) {
         src = cb_zero;
     }
 
     if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER ||
         CB_TREE_CLASS (src) == 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_FUNCALL_2 ("cob_move", 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_int (src));
     }
 
     if (CB_INTRINSIC_P (src) || CB_INTRINSIC_P (dst)) {
         return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
     }
 
     if (CB_REFERENCE_P (src) && CB_REFERENCE (src)->check) {
         return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
     }
     if (CB_REFERENCE_P (dst) && CB_REFERENCE (dst)->check) {
         return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
     }
 
     /* Output optimal code */
     if (src == cb_zero) {
         return cb_build_move_zero (dst);
     } else if (src == cb_space) {
         return cb_build_move_space (dst);
     } else if (src == cb_high) {
         return cb_build_move_high (dst);
     } else if (src == cb_low) {
         return cb_build_move_low (dst);
     } else if (src == cb_quote) {
         return cb_build_move_quote (dst);
     } else if (CB_LITERAL_P (src)) {
         return cb_build_move_literal (src, dst);
     }
     return cb_build_move_field (src, dst);
 }

cb_tree cb_build_numeric_literal	(	const int	,
		const void *	,
		const int
	)

 {
     struct cb_literal *p;
 
     p = build_literal (CB_CATEGORY_NUMERIC, data, strlen (data));
     p->sign = (short)sign;
     p->scale = scale;
     return CB_TREE (p);
 }

cb_tree cb_build_numsize_literal	(	const void *	,
		const size_t	,
		const int
	)

 {
     struct cb_literal *p;
 
     p = build_literal (CB_CATEGORY_NUMERIC, data, size);
     p->sign = (short)sign;
     return CB_TREE (p);
 }

cb_tree cb_build_perform ( const enum cb_perform_type )

 {
     struct cb_perform *p;
 
     p = make_tree (CB_TAG_PERFORM, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_perform));
     p->perform_type = type;
     return CB_TREE (p);
 }

cb_tree cb_build_perform_exit ( struct cb_label * )

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

cb_tree cb_build_perform_forever ( cb_tree )

 {
     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_once ( cb_tree )

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

 {
     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	,
		cb_tree
	)

 {
     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_varying	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     struct cb_perform_varying   *p;
     cb_tree             x;
     cb_tree             l;
 
     p = make_tree (CB_TAG_PERFORM_VARYING, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_perform_varying));
     p->name = name;
     p->from = from;
     p->until = until;
     if (name) {
         if (name == cb_error_node) {
             p->step = NULL;
             return CB_TREE (p);
         }
         l = cb_ref (name);
         x = cb_build_add (name, by, cb_high);
         if (current_program->flag_debugging &&
             !current_statement->flag_in_debug &&
             CB_FIELD_P (l) && CB_FIELD (l)->flag_field_debug) {
             p->step = CB_LIST_INIT (x);
             x = cb_build_debug (cb_debug_name, CB_FIELD_PTR (name)->name,
                         NULL);
             p->step = cb_list_add (p->step, x);
             x = cb_build_debug (cb_debug_contents, NULL, name);
             p->step = cb_list_add (p->step, x);
             x = cb_build_debug_call (CB_FIELD_PTR (name)->debug_section);
             p->step = cb_list_add (p->step, x);
         } else {
             p->step = x;
         }
     } else {
         p->step = NULL;
     }
     return CB_TREE (p);
 }

cb_tree cb_build_picture ( const char * )

 {
     struct cb_picture   *pic;
     const unsigned char *p;
     size_t          idx;
     size_t          buffcnt;
     cob_u32_t       at_beginning;
     cob_u32_t       at_end;
     cob_u32_t       p_char_seen;
     cob_u32_t       s_char_seen;
     cob_u32_t       dp_char_seen;
     cob_u32_t       real_digits;
     cob_u32_t       s_count;
     cob_u32_t       v_count;
     cob_u32_t       allocated;
     cob_u32_t       x_digits;
     cob_u32_t       digits;
     int         category;
     int         size;
     int         scale;
     int         i;
     int         n;
     unsigned char       c;
     unsigned char       lastonechar;
     unsigned char       lasttwochar;
 
     pic = make_tree (CB_TAG_PICTURE, CB_CATEGORY_UNKNOWN,
              sizeof (struct cb_picture));
     if (strlen (str) > 50) {
         goto error;
     }
     if (!pic_buff) {
         pic_buff = cobc_main_malloc ((size_t)COB_SMALL_BUFF);
     }
 
     idx = 0;
     buffcnt = 0;
     p_char_seen = 0;
     s_char_seen = 0;
     dp_char_seen = 0;
     category = 0;
     size = 0;
     allocated = 0;
     digits = 0;
     x_digits = 0;
     real_digits = 0;
     scale = 0;
     s_count = 0;
     v_count = 0;
     lastonechar = 0;
     lasttwochar = 0;
 
     for (p = (const unsigned char *)str; *p; p++) {
         n = 1;
         c = *p;
 repeat:
         /* Count the number of repeated chars */
         while (p[1] == c) {
             p++, n++;
         }
 
         /* Add parenthesized numbers */
         if (p[1] == '(') {
             i = 0;
             p += 2;
             for (; *p == '0'; p++) {
                 ;
             }
             for (; *p != ')'; p++) {
                 if (!isdigit (*p)) {
                     goto error;
                 } else {
                     allocated++;
                     if (allocated > 9) {
                         goto error;
                     }
                     i = i * 10 + (*p - '0');
                 }
             }
             if (i == 0) {
                 goto error;
             }
             n += i - 1;
             goto repeat;
         }
 
         /* Check grammar and category */
         /* FIXME: need more error checks */
         switch (c) {
         case 'A':
             if (s_char_seen || p_char_seen) {
                 goto error;
             }
             category |= PIC_ALPHABETIC;
             x_digits += n;
             break;
 
         case 'X':
             if (s_char_seen || p_char_seen) {
                 goto error;
             }
             category |= PIC_ALPHANUMERIC;
             x_digits += n;
             break;
 
         case '9':
             category |= PIC_NUMERIC;
             digits += n;
             real_digits += n;
             if (v_count) {
                 scale += n;
             }
             break;
 
         case 'N':
             if (s_char_seen || p_char_seen) {
                 goto error;
             }
             category |= PIC_NATIONAL;
             x_digits += n;
             break;
 
         case 'S':
             category |= PIC_NUMERIC;
             if (category & PIC_ALPHABETIC) {
                 goto error;
             }
             s_count++;
             if (s_count > 1 || idx != 0) {
                 goto error;
             }
             s_char_seen = 1;
             continue;
 
         case ',':
         case '.':
             category |= PIC_NUMERIC_EDITED;
             if (s_char_seen || p_char_seen) {
                 goto error;
             }
             if (c != current_program->decimal_point) {
                 break;
             }
             dp_char_seen = 1;
             /* fall through */
         case 'V':
             category |= PIC_NUMERIC;
             if (category & PIC_ALPHABETIC) {
                 goto error;
             }
             v_count++;
             if (v_count > 1) {
                 goto error;
             }
             break;
 
         case 'P':
             category |= PIC_NUMERIC;
             if (category & PIC_ALPHABETIC) {
                 goto error;
             }
             if (p_char_seen || dp_char_seen) {
                 goto error;
             }
             at_beginning = 0;
             at_end = 0;
             switch (buffcnt) {
             case 0:
                 /* P..... */
                 at_beginning = 1;
                 break;
             case 1:
                 /* VP.... */
                 /* SP.... */
                 if (lastonechar == 'V' || lastonechar == 'S') {
                     at_beginning = 1;
                 }
                 break;
             case 2:
                 /* SVP... */
                 if (lasttwochar == 'S' && lastonechar == 'V') {
                     at_beginning = 1;
                 }
                 break;
             default:
                 break;
             }
             if (p[1] == 0 || (p[1] == 'V' && p[2] == 0)) {
                 /* .....P */
                 /* ....PV */
                 at_end = 1;
             }
             if (!at_beginning && !at_end) {
                 goto error;
             }
             p_char_seen = 1;
             if (at_beginning) {
                 /* Implicit V */
                 v_count++;
             }
             digits += n;
             if (v_count) {
                 scale += n;
             } else {
                 scale -= n;
             }
             break;
 
         case '0':
         case 'B':
         case '/':
             category |= PIC_EDITED;
             if (s_char_seen || p_char_seen) {
                 goto error;
             }
             break;
 
         case '*':
         case 'Z':
             category |= PIC_NUMERIC_EDITED;
             if (category & PIC_ALPHABETIC) {
                 goto error;
             }
             if (s_char_seen || p_char_seen) {
                 goto error;
             }
             digits += n;
             if (v_count) {
                 scale += n;
             }
             break;
 
         case '+':
         case '-':
             category |= PIC_NUMERIC_EDITED;
             if (category & PIC_ALPHABETIC) {
                 goto error;
             }
             if (s_char_seen || p_char_seen) {
                 goto error;
             }
             digits += n - 1;
             s_count++;
             /* FIXME: need more check */
             break;
 
         case 'C':
             category |= PIC_NUMERIC_EDITED;
             if (!(p[1] == 'R' && p[2] == 0)) {
                 goto error;
             }
             if (s_char_seen || p_char_seen) {
                 goto error;
             }
             p++;
             s_count++;
             break;
 
         case 'D':
             category |= PIC_NUMERIC_EDITED;
             if (!(p[1] == 'B' && p[2] == 0)) {
                 goto error;
             }
             if (s_char_seen || p_char_seen) {
                 goto error;
             }
             p++;
             s_count++;
             break;
 
         default:
             if (c == current_program->currency_symbol) {
                 category |= PIC_NUMERIC_EDITED;
                 digits += n - 1;
                 /* FIXME: need more check */
                 break;
             }
 
             goto error;
         }
 
         /* Calculate size */
         if (c != 'V' && c != 'P') {
             size += n;
         }
         if (c == 'C' || c == 'D') {
             size += n;
         }
         if (c == 'N') {
             size += n * (COB_NATIONAL_SIZE - 1);
         }
 
         /* Store in the buffer */
         pic_buff[idx++] = c;
         lasttwochar = lastonechar;
         lastonechar = c;
         memcpy (&pic_buff[idx], (void *)&n, sizeof(int));
         idx += sizeof(int);
         ++buffcnt;
     }
     pic_buff[idx] = 0;
 
     if (size == 0 && v_count) {
         goto error;
     }
     /* Set picture */
     pic->orig = cobc_check_string (str);
     pic->size = size;
     pic->digits = digits;
     pic->scale = scale;
     pic->have_sign = s_count;
     pic->real_digits = real_digits;
 
     /* Set picture category */
     switch (category) {
     case PIC_ALPHABETIC:
         pic->category = CB_CATEGORY_ALPHABETIC;
         break;
     case PIC_NUMERIC:
         pic->category = CB_CATEGORY_NUMERIC;
         if (digits > COB_MAX_DIGITS) {
             cb_error (_("Numeric field cannot be larger than %d digits"), COB_MAX_DIGITS);
         }
         break;
     case PIC_ALPHANUMERIC:
     case PIC_NATIONAL:
         pic->category = CB_CATEGORY_ALPHANUMERIC;
         break;
     case PIC_NUMERIC_EDITED:
         pic->str = cobc_parse_malloc (idx + 1);
         memcpy (pic->str, pic_buff, idx);
         pic->category = CB_CATEGORY_NUMERIC_EDITED;
         pic->lenstr = idx;
         break;
     case PIC_EDITED:
     case PIC_ALPHABETIC_EDITED:
     case PIC_ALPHANUMERIC_EDITED:
     case PIC_NATIONAL_EDITED:
         pic->str = cobc_parse_malloc (idx + 1);
         memcpy (pic->str, pic_buff, idx);
         pic->category = CB_CATEGORY_ALPHANUMERIC_EDITED;
         pic->lenstr = idx;
         pic->digits = x_digits;
         break;
     default:
         goto error;
     }
     goto end;
 
 error:
     cb_error (_("Invalid picture string - '%s'"), str);
 
 end:
     return CB_TREE (pic);
 }

cb_tree cb_build_ppointer ( cb_tree )

 {
     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_PTR (cb_ref(x));
         f->count++;
     }
     return CB_BUILD_CAST_PPOINTER (x);
 }

struct cb_program* cb_build_program	(	struct cb_program *	,
		const int
	)

read

 {
     struct cb_program   *p;
     struct cb_program   *q;
 
     if (!last_program) {
         toplev_count = 0;
     }
     cb_reset_78 ();
     cobc_in_procedure = 0;
     cobc_in_repository = 0;
     cobc_cs_check = 0;
     cb_clear_real_field ();
 
     p = cobc_parse_malloc (sizeof (struct cb_program));
     p->word_table = cobc_parse_malloc (CB_WORD_TABLE_SIZE);
 
     p->next_program = last_program;
     p->nested_level = nest_level;
     p->decimal_point = '.';
     p->currency_symbol = '$';
     p->numeric_separator = ',';
     /* Save current program as actual at it's level */
     container_progs[nest_level] = p;
     if (nest_level) {
         /* Contained program */
         /* Inherit from upper level */
         p->global_file_list = last_program->global_file_list;
         p->collating_sequence = last_program->collating_sequence;
         p->classification = last_program->classification;
         p->mnemonic_spec_list = last_program->mnemonic_spec_list;
         p->class_spec_list = last_program->class_spec_list;
         p->interface_spec_list = last_program->interface_spec_list;
         p->function_spec_list = last_program->function_spec_list;
         p->user_spec_list = last_program->user_spec_list;
         p->program_spec_list = last_program->program_spec_list;
         p->property_spec_list = last_program->property_spec_list;
         p->alphabet_name_list = last_program->alphabet_name_list;
         p->symbolic_char_list = last_program->symbolic_char_list;
         p->class_name_list = last_program->class_name_list;
         p->locale_list = last_program->locale_list;
         p->decimal_point = last_program->decimal_point;
         p->numeric_separator = last_program->numeric_separator;
         p->currency_symbol = last_program->currency_symbol;
         p->flag_trailing_separate = last_program->flag_trailing_separate;
         p->flag_console_is_crt = last_program->flag_console_is_crt;
         /* RETURN-CODE is global for contained programs */
         p->cb_return_code = last_program->cb_return_code;
         CB_FIELD_PTR (last_program->cb_return_code)->flag_is_global = 1;
         p->toplev_count = last_program->toplev_count;
         /* Add program to itself for possible recursion */
         p->nested_prog_list = add_contained_prog (p->nested_prog_list, p);
         /* Add contained program to it's parent */
         q = container_progs[nest_level - 1];
         q->nested_prog_list = add_contained_prog (q->nested_prog_list, p);
     } else {
         /* Top level program */
         p->toplev_count = toplev_count++;
         functions_are_all = cb_flag_functions_all;
         cb_reset_global_78 ();
     }
     return p;
 }

char* cb_build_program_id	(	cb_tree	,
		cb_tree	,
		const cob_u32_t
	)

 {
     char        *s;
     unsigned char   *p;
 
     if (alt_name) {
         current_program->orig_program_id =
             cobc_check_string ((char *)CB_LITERAL (alt_name)->data);
         s = cb_encode_program_id ((char *)CB_LITERAL (alt_name)->data);
     } else if (CB_LITERAL_P (name)) {
         current_program->orig_program_id =
             cobc_check_string ((char *)CB_LITERAL (name)->data);
         s = cb_encode_program_id ((char *)CB_LITERAL (name)->data);
     } else {
         current_program->orig_program_id =
             cobc_check_string (CB_NAME (name));
         s = cb_encode_program_id (CB_NAME (name));
     }
     (void)cobc_check_valid_name (current_program->orig_program_id, 2U);
     if (is_func) {
         for (p = (unsigned char *)s; *p; ++p) {
             if (islower ((int)*p)) {
                 *p = (cob_u8_t)toupper ((int)*p);
             }
         }
     }
     return s;
 }

cb_tree cb_build_reference ( const char * )

 {
     struct cb_reference *p;
 
     p = make_tree (CB_TAG_REFERENCE, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_reference));
     /* Look up / insert word into hash list */
     lookup_word (p, name);
     return CB_TREE (p);
 }

void cb_build_registers ( void )

 {
 #if !defined(__linux__) && !defined(__CYGWIN__) && defined(HAVE_TIMEZONE)
     long    contz;
 #endif
     cb_tree     x;
     struct tm   *tlt;
     time_t      t;
     char        buff[48];
 
     /* RETURN-CODE */
     if (!current_program->nested_level) {
         x = cb_build_index (cb_build_reference ("RETURN-CODE"),
                     cb_zero, 0, NULL);
         CB_FIELD_PTR (x)->special_index = 1;
         current_program->cb_return_code = x;
     }
 
     /* SORT-RETURN */
     x = cb_build_index (cb_build_reference ("SORT-RETURN"),
                 cb_zero, 0, NULL);
     CB_FIELD_PTR (x)->flag_no_init = 1;
     current_program->cb_sort_return = x;
 
     /* NUMBER-OF-CALL-PARAMETERS */
     x = cb_build_index (cb_build_reference ("NUMBER-OF-CALL-PARAMETERS"),
                 cb_zero, 0, NULL);
     CB_FIELD_PTR (x)->flag_no_init = 1;
     CB_FIELD_PTR (x)->flag_local = 1;
     CB_FIELD_PTR (x)->special_index = 2;
     current_program->cb_call_params = x;
 
     t = time (NULL);
     tlt = localtime (&t);
     /* Leap seconds ? */
     if (tlt->tm_sec >= 60) {
         tlt->tm_sec = 59;
     }
 
     /* WHEN-COMPILED */
     memset (buff, 0, sizeof (buff));
     strftime (buff, (size_t)17, "%m/%d/%y%H.%M.%S", tlt);
     cb_build_constant (cb_build_reference ("WHEN-COMPILED"),
                cb_build_alphanumeric_literal (buff, (size_t)16));
 
     /* FUNCTION WHEN-COMPILED */
     memset (buff, 0, sizeof (buff));
 #if defined(__linux__) || defined(__CYGWIN__)
     strftime (buff, (size_t)22, "%Y%m%d%H%M%S00%z", tlt);
 #elif defined(HAVE_TIMEZONE)
     strftime (buff, (size_t)17, "%Y%m%d%H%M%S00", tlt);
     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, (size_t)22, "%Y%m%d%H%M%S0000000", tlt);
 #endif
     cb_intr_whencomp = cb_build_alphanumeric_literal (buff, (size_t)21);
 
 }

cb_tree cb_build_replacing_all	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     validate_inspect (x, y, 1);
     return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_all", y, x));
 }

cb_tree cb_build_replacing_characters	(	cb_tree	,
		cb_tree
	)

 {
     if (CB_LITERAL_P (x) && CB_LITERAL(x)->size != 1) {
         cb_error_x (CB_TREE (current_statement),
                 _("Operand has wrong size"));
     }
     return cb_list_add (l, CB_BUILD_FUNCALL_1 ("cob_inspect_characters", x));
 }

cb_tree cb_build_replacing_first	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     validate_inspect (x, y, 1);
     return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_first", y, x));
 }

cb_tree cb_build_replacing_leading	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     validate_inspect (x, y, 1);
     return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_leading", y, x));
 }

cb_tree cb_build_replacing_trailing	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     validate_inspect (x, y, 1);
     return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_trailing", y, x));
 }

cb_tree cb_build_search	(	const int	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree	,
		const cb_tree
	)

 {
     struct cb_search *p;
 
     p = make_tree (CB_TAG_SEARCH, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_search));
     p->flag_all = flag_all;
     p->table = table;
     p->var = var;
     p->end_stmt = end_stmt;
     p->whens = whens;
     return CB_TREE (p);
 }

cb_tree cb_build_section_name	(	cb_tree	,
		const int
	)

 {
     cb_tree x;
 
     if (name == cb_error_node) {
         return cb_error_node;
     }
 
     if (CB_WORD_COUNT (name) > 0) {
         x = CB_VALUE (CB_WORD_ITEMS (name));
         /* 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)->flag_section)) {
             redefinition_error (name);
             return cb_error_node;
         }
     }
 
     return name;
 }

cb_tree cb_build_set_attribute	(	const struct cb_field *	,
		const int	,
		const int
	)

 {
     struct cb_set_attr *p;
 
     p = make_tree (CB_TAG_SET_ATTR, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_set_attr));
     p->fld = (struct cb_field *)fld;
     p->val_on = val_on;
     p->val_off = val_off;
     return CB_TREE (p);
 }

struct cb_statement* cb_build_statement ( const char * )

read

 {
     struct cb_statement *p;
 
     p = make_tree (CB_TAG_STATEMENT, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_statement));
     p->name = name;
     return p;
 }

cb_tree cb_build_string	(	const void *	,
		const size_t
	)

 {
     struct cb_string *p;
 
     p = make_tree (CB_TAG_STRING, CB_CATEGORY_ALPHANUMERIC,
                sizeof (struct cb_string));
     p->size = size;
     p->data = data;
     return CB_TREE (p);
 }

cb_tree cb_build_sub	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     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) {
         optimize_defs[COB_POINTER_MANIP] = 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_PTR (v);
         f->count++;
     }
     if (CB_REF_OR_FIELD_P (n)) {
         f = CB_FIELD_PTR (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);
 }

void cb_build_symbolic_chars	(	const cb_tree	,
		const cb_tree
	)

 {
     cb_tree         l;
     cb_tree         x;
     cb_tree         x2;
     struct cb_alphabet_name *ap;
     int         n;
     unsigned char       buff[4];
 
     if (alphabet) {
         ap = CB_ALPHABET_NAME (alphabet);
     } else {
         ap = NULL;
     }
     for (l = sym_list; l; l = CB_CHAIN (l)) {
         n = cb_get_int (CB_PURPOSE (l)) - 1;
         if (ap) {
             buff[0] = (unsigned char)ap->alphachr[n];
         } else {
             buff[0] = (unsigned char)n;
         }
         buff[1] = 0;
         x2 = cb_build_alphanumeric_literal (buff, (size_t)1);
         CB_LITERAL (x2)->all = 1;
         x = cb_build_constant (CB_VALUE (l), x2);
         CB_FIELD (x)->flag_item_78 = 1;
         CB_FIELD (x)->flag_is_global = 1;
         CB_FIELD (x)->level = 1;
         (void)cb_validate_78_item (CB_FIELD (x), 0);
     }
 }

cb_tree cb_build_system_name	(	const enum	cb_system_name_category,
		const int
	)

 {
     struct cb_system_name *p;
 
     p = make_tree (CB_TAG_SYSTEM_NAME, CB_CATEGORY_UNKNOWN,
                sizeof (struct cb_system_name));
     p->category = category;
     p->token = token;
     return CB_TREE (p);
 }

cb_tree cb_build_tallying_all ( void )

 {
     if (inspect_data == NULL) {
         cb_error_x (CB_TREE (current_statement),
                 _("Data name expected before ALL"));
     }
     inspect_func = "cob_inspect_all";
     return NULL;
 }

cb_tree cb_build_tallying_characters ( cb_tree )

 {
     if (inspect_data == NULL) {
         cb_error_x (CB_TREE (current_statement),
                 _("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_tallying_data ( cb_tree )

 {
     inspect_data = x;
     return NULL;
 }

cb_tree cb_build_tallying_leading ( void )

 {
     if (inspect_data == NULL) {
         cb_error_x (CB_TREE (current_statement),
                 _("Data name expected before LEADING"));
     }
     inspect_func = "cob_inspect_leading";
     return NULL;
 }

cb_tree cb_build_tallying_trailing ( void )

 {
     if (inspect_data == NULL) {
         cb_error_x (CB_TREE (current_statement),
                 _("Data name expected before TRAILING"));
     }
     inspect_func = "cob_inspect_trailing";
     return NULL;
 }

cb_tree cb_build_tallying_value	(	cb_tree	,
		cb_tree
	)

 {
     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_unstring_delimited	(	cb_tree	,
		cb_tree
	)

 {
     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	,
		cb_tree	,
		cb_tree
	)

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

cb_tree cb_build_write_advancing_lines	(	cb_tree	,
		cb_tree
	)

 {
     cb_tree e;
     int opt;
 
     opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
     opt |= COB_WRITE_LINES;
     if (CB_LITERAL_P (lines)) {
         opt |= cb_get_int (lines);
         return cb_int_hex (opt);
     }
     e = cb_build_binary_op (cb_int (opt), '+', lines);
     return cb_build_cast_int (e);
 }

cb_tree cb_build_write_advancing_mnemonic	(	cb_tree	,
		cb_tree
	)

 {
     int opt;
     int token;
 
     if (mnemonic == cb_error_node) {
         return cb_int0;
     }
     if (cb_ref (mnemonic) == cb_error_node) {
         return cb_int0;
     }
     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_hex (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_hex (opt | COB_WRITE_CHANNEL | COB_WRITE_PAGE | token);
     default:
         cb_error_x (mnemonic, _("Invalid mnemonic name"));
         return cb_int0;
     }
 }

cb_tree cb_build_write_advancing_page ( cb_tree )

 {
     int opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
 
     return cb_int_hex (opt | COB_WRITE_PAGE);
 }

int cb_category_is_alpha ( cb_tree )

 {
     return category_is_alphanumeric[CB_TREE_CATEGORY (x)];
 }

void cb_check_field_debug ( cb_tree )

 {
     cb_tree     l;
     cb_tree     x;
     cb_tree     z;
     size_t      size;
     size_t      found;
     char        buff[COB_MINI_BUFF];
 
     /* Basic reference check */
     if (CB_WORD_COUNT (fld) > 0) {
         if (!CB_WORD_ITEMS (fld)) {
             return;
         }
         z = CB_VALUE(CB_WORD_ITEMS (fld));
         if (!CB_FIELD_P (z)) {
             return;
         }
         x = cb_ref (fld);
         if (x == cb_error_node) {
             return;
         }
     } else {
         return;
     }
 
     found = 0;
     /* Check if reference is being debugged */
     for (l = current_program->debug_list; l; l = CB_CHAIN (l)) {
         if (!CB_PURPOSE (l)) {
             continue;
         }
         if (x == CB_PURPOSE (l)) {
             if (CB_REFERENCE (fld)->flag_target ||
                 CB_REFERENCE (CB_VALUE (l))->flag_all_debug) {
                 found = 1;
             }
             break;
         }
     }
     if (!found) {
         return;
     }
 
     found = 0;
     /* Found it - check if it is already in the statement list */
     for (l = current_statement->debug_nodups; l; l = CB_CHAIN (l)) {
         if (CB_VALUE (l) == x) {
             found = 1;
             break;
         }
     }
     if (found) {
         return;
     }
 
     /* Set up debug info */
     strcpy (buff, CB_FIELD(x)->name);
     size = strlen (buff);
     for (l = CB_REFERENCE (fld)->chain; l; l = CB_REFERENCE (l)->chain) {
         z = cb_ref (l);
         if (z != cb_error_node) {
             size += strlen (CB_FIELD (z)->name);
             size += 4;
             if (size >= sizeof(buff)) {
                 break;
             }
             strcat (buff, " OF ");
             strcat (buff, CB_FIELD (z)->name);
         }
     }
     current_statement->debug_nodups =
         cb_list_add (current_statement->debug_nodups, x);
     current_statement->debug_check =
         cb_list_add (current_statement->debug_check,
                  cb_build_debug (cb_debug_name, buff, NULL));
     current_statement->debug_check =
         cb_list_add (current_statement->debug_check,
                  cb_build_debug (cb_debug_contents, NULL, fld));
     found = 0;
     CB_REFERENCE (fld)->subs = cb_list_reverse (CB_REFERENCE (fld)->subs);
     l = CB_REFERENCE (fld)->subs;
     for (; l && found < 3; l = CB_CHAIN (l), ++found) {
         switch (found) {
         case 0:
             current_statement->debug_check =
                 cb_list_add (current_statement->debug_check,
                          cb_build_move (CB_VALUE (l),
                                 cb_debug_sub_1));
             break;
         case 1:
             current_statement->debug_check =
                 cb_list_add (current_statement->debug_check,
                          cb_build_move (CB_VALUE (l),
                                 cb_debug_sub_2));
             break;
         case 2:
             current_statement->debug_check =
                 cb_list_add (current_statement->debug_check,
                          cb_build_move (CB_VALUE (l),
                                 cb_debug_sub_3));
             break;
         default:
             break;
         }
     }
     CB_REFERENCE (fld)->subs = cb_list_reverse (CB_REFERENCE (fld)->subs);
 
     for (; found < 3; ++found) {
         switch (found) {
         case 0:
             current_statement->debug_check =
                 cb_list_add (current_statement->debug_check,
                          CB_BUILD_FUNCALL_3 ("memset",
                         CB_BUILD_CAST_ADDRESS (cb_debug_sub_1),
                         cb_int (' '),
                         CB_BUILD_CAST_LENGTH (cb_debug_sub_1)));
             break;
         case 1:
             current_statement->debug_check =
                 cb_list_add (current_statement->debug_check,
                          CB_BUILD_FUNCALL_3 ("memset",
                         CB_BUILD_CAST_ADDRESS (cb_debug_sub_2),
                         cb_int (' '),
                         CB_BUILD_CAST_LENGTH (cb_debug_sub_2)));
             break;
         case 2:
             current_statement->debug_check =
                 cb_list_add (current_statement->debug_check,
                          CB_BUILD_FUNCALL_3 ("memset",
                         CB_BUILD_CAST_ADDRESS (cb_debug_sub_3),
                         cb_int (' '),
                         CB_BUILD_CAST_LENGTH (cb_debug_sub_3)));
             break;
         default:
             break;
         }
     }
 
     current_statement->debug_check =
         cb_list_add (current_statement->debug_check,
                  cb_build_debug_call (CB_FIELD(x)->debug_section));
 }

size_t cb_check_index_p ( cb_tree x )

 {
     struct cb_field *f;
 
     if (!CB_REF_OR_FIELD_P (x)) {
         return 0;
     }
     f = CB_FIELD_PTR (x);
     if (f->usage == CB_USAGE_INDEX && !f->children) {
         return 1;
     }
     return 0;
 }

cb_tree cb_check_numeric_value ( cb_tree )

 {
     if (x == cb_error_node) {
         return cb_error_node;
     }
 
     if (CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
         return x;
     }
 
     cb_error_x (x, _("'%s' is not a numeric value"), cb_name (x));
     return cb_error_node;
 }

void cb_clear_real_field ( void )

 {
     last_real_field = NULL;
 }

cb_tree cb_concat_literals	(	const cb_tree	,
		const cb_tree
	)

 {
     unsigned char       *data1;
     unsigned char       *data2;
     struct cb_literal   *p;
     size_t          size1;
     size_t          size2;
 
     if (x1 == cb_error_node || x2 == cb_error_node) {
         return cb_error_node;
     }
     if (CB_LITERAL_P (x1)) {
         data1 = CB_LITERAL (x1)->data;
         size1 = CB_LITERAL (x1)->size;
     } else if (CB_CONST_P (x1)) {
         size1 = 1;
         if (x1 == cb_space) {
             data1 = (unsigned char *)" ";
         } else if (x1 == cb_zero) {
             data1 = (unsigned char *)"0";
         } else if (x1 == cb_quote) {
             if (cb_flag_apostrophe) {
                 data1 = (unsigned char *)"'";
             } else {
                 data1 = (unsigned char *)"\"";
             }
         } else if (x1 == cb_norm_low) {
             data1 = (unsigned char *)"\0";
         } else if (x1 == cb_norm_high) {
             data1 = (unsigned char *)"\255";
         } else if (x1 == cb_null) {
             data1 = (unsigned char *)"\0";
         } else {
             return cb_error_node;
         }
     } else {
         return cb_error_node;
     }
     if (CB_LITERAL_P (x2)) {
         data2 = CB_LITERAL (x2)->data;
         size2 = CB_LITERAL (x2)->size;
     } else if (CB_CONST_P (x2)) {
         size2 = 1;
         if (x2 == cb_space) {
             data2 = (unsigned char *)" ";
         } else if (x2 == cb_zero) {
             data2 = (unsigned char *)"0";
         } else if (x2 == cb_quote) {
             if (cb_flag_apostrophe) {
                 data2 = (unsigned char *)"'";
             } else {
                 data2 = (unsigned char *)"\"";
             }
         } else if (x2 == cb_norm_low) {
             data2 = (unsigned char *)"\0";
         } else if (x2 == cb_norm_high) {
             data2 = (unsigned char *)"\255";
         } else if (x2 == cb_null) {
             data2 = (unsigned char *)"\0";
         } else {
             return cb_error_node;
         }
     } else {
         return cb_error_node;
     }
     p = make_tree (CB_TAG_LITERAL, CB_CATEGORY_ALPHANUMERIC,
             sizeof (struct cb_literal));
     p->data = cobc_parse_malloc (size1 + size2 + 1U);
     p->size = size1 + size2;
     memcpy (p->data, data1, size1);
     memcpy (p->data + size1, data2, size2);
     return CB_TREE (p);
 }

int cb_config_entry	(	char *	,
		const char *	,
		const int
	)

References _, CB_ANY, CB_ARCHAIC, CB_ASSIGN_IBM, CB_ASSIGN_MF, CB_BINARY_SIZE_1_2_4_8, CB_BINARY_SIZE_1__8, CB_BINARY_SIZE_2_4_8, CB_BOOLEAN, CB_BYTEORDER_BIG_ENDIAN, CB_BYTEORDER_NATIVE, CB_CONFIG_SIZE, CB_ERROR, CB_IGNORE, CB_INT, CB_OBSOLETE, CB_OK, CB_SKIP, CB_STRING, CB_SUPPORT, CB_UNCONFORMABLE, CB_WARNING, cobc_main_malloc(), cobc_nores_base, config_table, configuration_error(), invalid_value(), config_struct::name, noreserve::next, noreserve::noresword, NULL, read_string(), unsupported_value(), config_struct::val, and config_struct::var.

Referenced by cb_load_conf(), and process_command_line().

 {
     char            *s;
     const char      *name;
     char            *e;
     struct noreserve    *noresptr;
     size_t          size;
     const char      *val;
     void            *var;
     size_t          i;
     size_t          j;
 
     /* Get tag */
     s = strpbrk (buff, " \t:=");
     if (!s) {
         configuration_error (fname, line,
             _("Invalid configuration '%s'"), buff);
         return -1;
     }
     *s = 0;
     
     /* Find entry */
     for (i = 0; i < CB_CONFIG_SIZE; i++) {
         if (strcmp (buff, config_table[i].name) == 0) {
             break;
         }
     }
     if (i == CB_CONFIG_SIZE) {
         configuration_error (fname, line, _("Unknown configuration tag '%s'"), buff);
         return -1;
     }
 
     /* Get value */
     /* Move pointer to beginning of value */
     for (s++; *s && strchr (" \t:=", *s); s++) {
         ;
     }
     /* Set end pointer to first # (comment) or end of value */
     for (e = s + 1; *e && !strchr ("#", *e); e++) {
         ;
     }
     /* Remove trailing white-spaces */
     for (--e; e >= s && strchr (" \t\r\n", *e); e--) {
         ;
     }
     e[1] = 0;
     config_table[i].val = s;
 
     /* Set value */
     name = config_table[i].name;
     var = config_table[i].var;
     val = config_table[i].val;
     switch (config_table[i].type) {
         case CB_ANY:
             if (strcmp (name, "assign-clause") == 0) {
                 if (strcmp (val, "cobol2002") == 0) {
                     unsupported_value (fname, line, name, val);
                     return -1;
                 } else if (strcmp (val, "mf") == 0) {
                     cb_assign_clause = CB_ASSIGN_MF;
                 } else if (strcmp (val, "ibm") == 0) {
                     cb_assign_clause = CB_ASSIGN_IBM;
                 } else {
                     invalid_value (fname, line, name, val);
                     return -1;
                 }
             } else if (strcmp (name, "binary-size") == 0) {
                 if (strcmp (val, "2-4-8") == 0) {
                     cb_binary_size = CB_BINARY_SIZE_2_4_8;
                 } else if (strcmp (val, "1-2-4-8") == 0) {
                     cb_binary_size = CB_BINARY_SIZE_1_2_4_8;
                 } else if (strcmp (val, "1--8") == 0) {
                     cb_binary_size = CB_BINARY_SIZE_1__8;
                 } else {
                     invalid_value (fname, line, name, val);
                     return -1;
                 }
             } else if (strcmp (name, "binary-byteorder") == 0) {
                 if (strcmp (val, "native") == 0) {
                     cb_binary_byteorder = CB_BYTEORDER_NATIVE;
                 } else if (strcmp (val, "big-endian") == 0) {
                     cb_binary_byteorder = CB_BYTEORDER_BIG_ENDIAN;
                 } else {
                     invalid_value (fname, line, name, val);
                     return -1;
                 }
             }
             break;
         case CB_INT:
             for (j = 0; val[j]; j++) {
                 if (val[j] < '0' || val[j] > '9') {
                     invalid_value (fname, line, name, val);
                     return -1;
                     break;
                 }
             }
             *((int *)var) = atoi (val);
             break;
         case CB_STRING:
             val = read_string (val);
 
             if (strcmp (name, "include") == 0) {
                 if (fname) {
                     /* Include another conf file */
                     return 1;
                 } else {
                     configuration_error (NULL, 0,
                           _("'%s' not supported with -cb_conf"), name);
                     return -1;
                 }
             } else if (strcmp (name, "not-reserved") == 0) {
                 size = strlen (val);
                 noresptr = cobc_main_malloc (sizeof (struct noreserve)
                                              + size + 1U);
                 noresptr->noresword = (char *)noresptr
                                     + sizeof (struct noreserve);
                 memcpy (noresptr->noresword, val, size);
                 noresptr->next = cobc_nores_base;
                 cobc_nores_base = noresptr;
             } else {
                 *((const char **)var) = val;
             }
             break;
         case CB_BOOLEAN:
             if (strcmp (val, "yes") == 0) {
                 *((int *)var) = 1;
             } else if (strcmp (val, "no") == 0) {
                 *((int *)var) = 0;
             } else {
                 invalid_value (fname, line, name, val);
                 return -1;
             }
             break;
         case CB_SUPPORT:
             if (strcmp (val, "ok") == 0) {
                 *((enum cb_support *)var) = CB_OK;
             } else if (strcmp (val, "warning") == 0) {
                 *((enum cb_support *)var) = CB_WARNING;
             } else if (strcmp (val, "archaic") == 0) {
                 *((enum cb_support *)var) = CB_ARCHAIC;
             } else if (strcmp (val, "obsolete") == 0) {
                 *((enum cb_support *)var) = CB_OBSOLETE;
             } else if (strcmp (val, "skip") == 0) {
                 *((enum cb_support *)var) = CB_SKIP;
             } else if (strcmp (val, "ignore") == 0) {
                 *((enum cb_support *)var) = CB_IGNORE;
             } else if (strcmp (val, "error") == 0) {
                 *((enum cb_support *)var) = CB_ERROR;
             } else if (strcmp (val, "unconformable") == 0) {
                 *((enum cb_support *)var) = CB_UNCONFORMABLE;
             } else {
                 invalid_value (fname, line, name, val);
                 return -1;
             }
             break;
         default:
             configuration_error (fname, line, _("Invalid type for '%s'"), name);
             return -1;
     }
     return 0;
 }

const char* cb_define	(	cb_tree	,
		cb_tree
	)

 {
     struct cb_word *w;
 
     w = CB_REFERENCE (name)->word;
     w->items = cb_list_add (w->items, val);
     w->count++;
     val->source_file = name->source_file;
     val->source_line = name->source_line;
     CB_REFERENCE (name)->value = val;
     return w->name;
 }

cb_tree cb_define_switch_name	(	cb_tree	,
		cb_tree	,
		const int
	)

 {
     cb_tree     switch_id;
     cb_tree     value;
 
     if (!name || name == cb_error_node) {
         return NULL;
     }
     if (!sname || sname == cb_error_node ||
         CB_SYSTEM_NAME (sname)->category != CB_SWITCH_NAME) {
         cb_error_x (name, _("ON/OFF usage requires a SWITCH name"));
         return NULL;
     }
     switch_id = cb_int (CB_SYSTEM_NAME (sname)->token);
     value = CB_BUILD_FUNCALL_1 ("cob_get_switch", switch_id);
     if (flag == 0) {
         value = CB_BUILD_NEGATION (value);
     }
     cb_build_constant (name, value);
     return value;
 }

void cb_emit_accept	(	cb_tree	,
		cb_tree	,
		struct cb_attr_struct *
	)

 {
     cb_tree     line;
     cb_tree     column;
     cb_tree     fgc;
     cb_tree     bgc;
     cb_tree     scroll;
     cb_tree     timeout;
     cb_tree     prompt;
     int     dispattrs;
 
     if (attr_ptr) {
         fgc = attr_ptr->fgc;
         bgc = attr_ptr->bgc;
         scroll = attr_ptr->scroll;
         timeout = attr_ptr->timeout;
         prompt = attr_ptr->prompt;
         dispattrs = attr_ptr->dispattrs;
     } else {
         fgc = NULL;
         bgc = NULL;
         scroll = NULL;
         timeout = NULL;
         prompt = NULL;
         dispattrs = 0;
     }
 
     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 (cb_validate_one (timeout)) {
         return;
     }
     if (cb_validate_one (prompt)) {
         return;
     }
 
     if (prompt) {
         /* PROMPT character - 1 character identifier or literal */
         if (CB_LITERAL_P (prompt)) {
             if (CB_LITERAL (prompt)->size != 1) {
                 cb_error_x (prompt, _("Invalid PROMPT literal"));
                 return;
             }
         } else {
             if (CB_FIELD_PTR (prompt)->size != 1) {
                 cb_error_x (prompt, _("Invalid PROMPT identifier"));
                 return;
             }
         }
     }
 
 #if 0   /* RXWRXW - Screen */
     if ((CB_REF_OR_FIELD_P (var)) &&
          CB_FIELD (cb_ref (var))->storage == CB_STORAGE_SCREEN) {
         current_program->flag_screen = 1;
     }
 #endif
 
     if (current_program->flag_screen) {
         /* Bump ref count to force CRT STATUS field generation */
         if (current_program->crt_status) {
             CB_FIELD_PTR (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_LIST_P (pos)) {
                     line = CB_PAIR_X (pos);
                     column = CB_PAIR_Y (pos);
                     cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_accept",
                         var, line, column, timeout));
                 } else {
                     cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_accept",
                         var, pos, NULL, timeout));
                 }
             } else {
                 cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_accept",
                     var, NULL, NULL, timeout));
             }
             gen_screen_ptr = 0;
             output_screen_to (CB_FIELD (cb_ref (var)), 0);
         } else {
             if (var == cb_null) {
                 var = NULL;
             }
             if (pos || fgc || bgc || scroll || dispattrs) {
                 cb_gen_field_accept (var, pos, fgc, bgc, scroll,
                              timeout, prompt, dispattrs);
             } else {
                 cb_emit (CB_BUILD_FUNCALL_9 ("cob_field_accept",
                     var, NULL, NULL, fgc, bgc,
                     scroll, timeout, prompt,
                     cb_int (dispattrs)));
             }
         }
     } else if (pos || fgc || bgc || scroll || dispattrs) {
         /* Bump ref count to force CRT STATUS field generation */
         if (current_program->crt_status) {
             CB_FIELD_PTR (current_program->crt_status)->count++;
         }
         if (var == cb_null) {
             var = NULL;
         }
         cb_gen_field_accept (var, pos, fgc, bgc, scroll,
                      timeout, prompt, dispattrs);
     } else {
         if (var == cb_null) {
             var = NULL;
         }
         cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
     }
 }

void cb_emit_accept_arg_number ( cb_tree )

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

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_arg_value", var));
 }

void cb_emit_accept_command_line ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_command_line", var));
 }

void cb_emit_accept_date ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_date", var));
 }

void cb_emit_accept_date_yyyymmdd ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_date_yyyymmdd", var));
 }

void cb_emit_accept_day ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day", var));
 }

void cb_emit_accept_day_of_week ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day_of_week", var));
 }

void cb_emit_accept_day_yyyyddd ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day_yyyyddd", var));
 }

void cb_emit_accept_environment ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_environment", var));
 }

void cb_emit_accept_escape_key ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_escape_key", var));
 }

void cb_emit_accept_exception_status ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_exception_status", var));
 }

void cb_emit_accept_line_or_col	(	cb_tree	,
		const int
	)

 {
     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_mnemonic	(	cb_tree	,
		cb_tree
	)

 {
     if (cb_validate_one (var)) {
         return;
     }
     if (cb_ref (mnemonic) == cb_error_node) {
         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 device '%s'"),
                 cb_name (mnemonic));
         break;
     }
 }

void cb_emit_accept_name	(	cb_tree	,
		cb_tree
	)

 {
     cb_tree     sys;
 
     if (cb_validate_one (var)) {
         return;
     }
 
     /* Allow direct reference to a device name */
     sys = lookup_system_name (CB_NAME (name));
     if (sys) {
         switch (CB_SYSTEM_NAME (sys)->token) {
         case CB_DEVICE_CONSOLE:
         case CB_DEVICE_SYSIN:
             if (!cb_relaxed_syntax_check) {
                 cb_warning_x (name, _("'%s' is not defined in SPECIAL-NAMES"), CB_NAME (name));
             }
             cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
             return;
         default:
             cb_error_x (name, _("Invalid input device '%s'"),
                     cb_name (name));
             return;
         }
     }
 
     cb_error_x (name, _("'%s' is not defined in SPECIAL-NAMES"),
             CB_NAME (name));
 }

void cb_emit_accept_time ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_time", var));
 }

void cb_emit_accept_user_name ( cb_tree )

 {
     if (cb_validate_one (var)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_user_name", var));
 }

void cb_emit_allocate	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     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 (cb_validate_one (initialize)) {
         return;
     }
     if (target1) {
         if (!(CB_REFERENCE_P(target1) &&
               CB_FIELD_PTR (target1)->flag_item_based)) {
             cb_error_x (CB_TREE(current_statement),
                 _("Target of ALLOCATE is not a BASED item"));
             return;
         }
     }
     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"));
             return;
         }
     }
     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"));
             return;
         }
     }
     if (target1) {
         sprintf (buff, "%d", CB_FIELD_PTR (target1)->memory_size);
         x = cb_build_numeric_literal (0, buff, 0);
         cb_emit (CB_BUILD_FUNCALL_4 ("cob_allocate",
              CB_BUILD_CAST_ADDR_OF_ADDR (target1),
              target2, x, NULL));
     } else {
         if (initialize && !cb_category_is_alpha (initialize)) {
             cb_error_x (CB_TREE(current_statement),
                 _("INITIALIZED TO item is not alphanumeric"));
         }
         cb_emit (CB_BUILD_FUNCALL_4 ("cob_allocate",
              NULL, target2, size, initialize));
     }
     if (initialize && target1) {
         current_statement->handler2 =
             cb_build_initialize (target1, cb_true, NULL, 1, 0, 0);
     }
 }

void cb_emit_alter	(	cb_tree	,
		cb_tree
	)

 {
     if (source == cb_error_node) {
         return;
     }
     if (target == cb_error_node) {
         return;
     }
     CB_REFERENCE(source)->flag_alter_code = 1;
     cb_emit (cb_build_alter (source, target));
 }

void cb_emit_arg_number ( cb_tree )

 {
     if (cb_validate_one (value)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_arg_number", value));
 }

void cb_emit_arithmetic	(	cb_tree	,
		const int	,
		cb_tree
	)

 {
     cb_tree     l;
     cb_tree     x;
 
     x = 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 (x)) {
         return;
     }
     if (cb_validate_list (vars)) {
         return;
     }
 
     if (!CB_BINARY_OP_P (x)) {
         if (op == '+' || op == '-' || op == '*' || op == '/') {
             cb_check_data_incompat (x);
             for (l = vars; l; l = CB_CHAIN (l)) {
                 cb_check_data_incompat (CB_VALUE (l));
                 switch (op) {
                 case '+':
                     CB_VALUE (l) = cb_build_add (CB_VALUE (l), x, CB_PURPOSE (l));
                     break;
                 case '-':
                     CB_VALUE (l) = cb_build_sub (CB_VALUE (l), x, CB_PURPOSE (l));
                     break;
                 case '*':
                     CB_VALUE (l) = cb_build_mul (CB_VALUE (l), x, CB_PURPOSE (l));
                     break;
                 case '/':
                     CB_VALUE (l) = cb_build_div (CB_VALUE (l), x, CB_PURPOSE (l));
                     break;
                 }
             }
             cb_emit_list (vars);
             return;
         }
     }
     if (x == cb_error_node) {
         return;
     }
 
     cb_emit_list (build_decimal_assign (vars, op, x));
 }

void cb_emit_call	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     cb_tree             l;
     cb_tree             x;
     struct cb_field         *f;
     const struct system_table   *psyst;
     const char          *p;
     const char          *entry;
     cob_s64_t           val;
     cob_s64_t           valmin;
     cob_s64_t           valmax;
     cob_u32_t           is_sys_call;
     cob_u32_t           is_sys_idx;
     int             error_ind;
     int             call_conv;
     int             numargs;
 
     if (CB_INTRINSIC_P (prog)) {
         if (CB_INTRINSIC(prog)->intr_tab->category != CB_CATEGORY_ALPHANUMERIC) {
             cb_error_x (CB_TREE (current_statement),
                     _("Only alphanumeric FUNCTION types are allowed here"));
             return;
         }
     }
     if (returning && returning != cb_null) {
         if (CB_TREE_CLASS(returning) != CB_CLASS_NUMERIC &&
             CB_TREE_CLASS(returning) != CB_CLASS_POINTER) {
             cb_error_x (CB_TREE (current_statement),
                     _("Invalid RETURNING field"));
             return;
         }
     }
 
     error_ind = 0;
     numargs = 0;
 
     if (convention) {
         if (CB_INTEGER_P (convention)) {
             call_conv = CB_INTEGER (convention)->val;
         } else {
             call_conv = cb_get_int (convention);
         }
     } else {
         call_conv = 0;
     }
 #ifndef _WIN32
     if (call_conv & CB_CONV_STDCALL) {
         call_conv &= ~CB_CONV_STDCALL;
         if (warningopt) {
             cb_warning (_("STDCALL not available on this platform"));
         }
     }
 #elif   defined(_WIN64)
     if (call_conv & CB_CONV_STDCALL) {
         if (warningopt) {
             cb_warning (_("STDCALL used on 64-bit Windows platform"));
         }
     }
 #endif
     if ((call_conv & CB_CONV_STATIC_LINK) && !CB_LITERAL_P (prog)) {
         cb_error_x (CB_TREE (current_statement),
                 _("STATIC CALL convention requires a literal program name"));
         error_ind = 1;
     }
 
     for (l = par_using; l; l = CB_CHAIN (l), numargs++) {
         x = CB_VALUE (l);
         if (x == cb_error_node) {
             error_ind = 1;
             continue;
         }
         if (CB_NUMERIC_LITERAL_P (x)) {
             if (CB_PURPOSE_INT (l) != CB_CALL_BY_VALUE) {
                 continue;
             }
             if (CB_SIZES_INT_UNSIGNED(l) &&
                 CB_LITERAL (x)->sign < 0) {
                 cb_error_x (x, _("Numeric literal is negative"));
                 error_ind = 1;
                 continue;
             }
             val = 0;
             valmin = 0;
             valmax = 0;
             switch (CB_SIZES_INT (l)) {
             case CB_SIZE_1:
                 val = cb_get_long_long (x);
                 if (CB_SIZES_INT_UNSIGNED(l)) {
                     valmin = 0;
                     valmax = UCHAR_MAX;
                 } else {
                     valmin = CHAR_MIN;
                     valmax = CHAR_MAX;
                 }
                 break;
             case CB_SIZE_2:
                 val = cb_get_long_long (x);
                 if (CB_SIZES_INT_UNSIGNED(l)) {
                     valmin = 0;
                     valmax = USHRT_MAX;
                 } else {
                     valmin = SHRT_MIN;
                     valmax = SHRT_MAX;
                 }
                 break;
             case CB_SIZE_4:
                 val = cb_get_long_long (x);
                 if (CB_SIZES_INT_UNSIGNED(l)) {
                     valmin = 0;
                     valmax = UINT_MAX;
                 } else {
                     valmin = INT_MIN;
                     valmax = INT_MAX;
                 }
                 break;
             case CB_SIZE_8:
             case CB_SIZE_AUTO:
                 if (CB_SIZES_INT_UNSIGNED(l)) {
                     if (CB_LITERAL (x)->size < 20) {
                         break;
                     }
                     if (CB_LITERAL (x)->size > 20) {
                         valmin = 1;
                         break;
                     }
                     if (memcmp (CB_LITERAL (x)->data,
                             "18446744073709551615",
                             (size_t)20) > 0) {
                         valmin = 1;
                         break;
                     }
                 } else {
                     if (CB_LITERAL (x)->size < 19) {
                         break;
                     }
                     if (CB_LITERAL (x)->size > 19) {
                         valmin = 1;
                         break;
                     }
                     if (memcmp (CB_LITERAL (x)->data,
                             "9223372036854775807",
                             (size_t)19) > 0) {
                         valmin = 1;
                         break;
                     }
                 }
                 break;
             default:
                 break;
             }
             if (!valmin && !valmax) {
                 continue;
             }
             if (val < valmin || val > valmax) {
                 cb_error_x (x, _("Numeric literal exceeds size limits"));
                 error_ind = 1;
             }
             continue;
         }
         if (CB_CONST_P (x) && x != cb_null) {
             cb_error_x (x, _("Figurative constant invalid here"));
             error_ind = 1;
             continue;
         }
         if ((CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value)) ||
             CB_FIELD_P (x)) {
             f = CB_FIELD_PTR (x);
             if (f->level == 88) {
                 cb_error_x (x, _("'%s' is not a valid data name"), CB_NAME (x));
                 error_ind = 1;
                 continue;
             }
             if (f->flag_any_length &&
                 CB_PURPOSE_INT (l) != CB_CALL_BY_REFERENCE) {
                 cb_error_x (x, _("'%s' ANY LENGTH item not passed BY REFERENCE"), CB_NAME (x));
                 error_ind = 1;
                 continue;
             }
             if (cb_warn_call_params &&
                 CB_PURPOSE_INT (l) == CB_CALL_BY_REFERENCE) {
                 if (f->level != 01 && f->level != 77) {
                     cb_warning_x (x, _("'%s' is not a 01 or 77 level item"), CB_NAME (x));
                 }
             }
         }
     }
 
     is_sys_call = 0;
     if (CB_LITERAL_P(prog)) {
         entry = NULL;
         p = (const char *)CB_LITERAL(prog)->data;
         for (; *p; ++p) {
             if (*p == '/' || *p == '\\') {
                 entry = p + 1;
             }
         }
         if (!entry) {
             entry = (const char *)CB_LITERAL(prog)->data;
         }
         is_sys_idx = 1;
         for (psyst = system_tab; psyst->syst_name; psyst++, is_sys_idx++) {
             if (!strcmp(entry, (const char *)psyst->syst_name)) {
                 if (psyst->syst_params > cb_list_length (par_using)) {
                     cb_error_x (CB_TREE (current_statement),
                             _("Wrong number of CALL parameters for '%s'"),
                             (char *)psyst->syst_name);
                     return;
                 }
                 is_sys_call = is_sys_idx;
                 break;
             }
         }
     }
 
     if (error_ind) {
         return;
     }
     if (numargs > current_program->max_call_param) {
         current_program->max_call_param = numargs;
     }
     cb_emit (cb_build_call (prog, par_using, on_exception, not_on_exception,
          returning, is_sys_call, call_conv));
 }

void cb_emit_cancel ( cb_tree )

 {
     if (cb_validate_one (prog)) {
         return;
     }
     cb_emit (cb_build_cancel (prog));
 }

void cb_emit_close	(	cb_tree	,
		cb_tree
	)

 {
     struct cb_file  *f;
 
     if (file == cb_error_node) {
         return;
     }
     file = cb_ref (file);
     if (file == cb_error_node) {
         return;
     }
     current_statement->file = file;
     f = CB_FILE (file);
 
     if (f->organization == COB_ORG_SORT) {
         cb_error_x (CB_TREE (current_statement),
                 _("Operation not allowed on SORT files"));
     }
 
     cb_emit (CB_BUILD_FUNCALL_4 ("cob_close", file,
                      f->file_status, opt, cb_int0));
 
     /* Check for file debugging */
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug &&
         CB_FILE(file)->flag_fl_debug) {
         cb_emit (cb_build_debug (cb_debug_name, f->name, NULL));
         cb_emit (cb_build_move (cb_space, cb_debug_contents));
         cb_emit (cb_build_debug_call (f->debug_section));
     }
 }

void cb_emit_command_line ( cb_tree )

 {
     if (cb_validate_one (value)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_command_line", value));
 }

void cb_emit_commit ( void )

 {
     cb_emit (CB_BUILD_FUNCALL_0 ("cob_commit"));
 }

void cb_emit_continue ( void )

 {
     cb_emit (cb_build_continue ());
 }

void cb_emit_corresponding	(	cb_tree(*)(cb_tree, cb_tree, cb_tree)	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

void cb_emit_delete ( cb_tree )

 {
     struct cb_file  *f;
 
     if (file == cb_error_node) {
         return;
     }
     file = cb_ref (file);
     if (file == cb_error_node) {
         return;
     }
     current_statement->file = file;
     f = CB_FILE (file);
 
     if (f->organization == COB_ORG_SORT) {
         cb_error_x (CB_TREE (current_statement),
                 _("Operation not allowed on SORT files"));
         return;
     } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
         cb_error_x (CB_TREE (current_statement),
                 _("Operation not allowed on LINE SEQUENTIAL files"));
         return;
     }
 
     /* Check for file debugging */
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug &&
         f->flag_fl_debug) {
         /* Gen callback after delete but before exception test */
         current_statement->flag_callback = 1;
     }
 
     cb_emit (CB_BUILD_FUNCALL_2 ("cob_delete", file,
                      f->file_status));
 }

void cb_emit_delete_file ( cb_tree )

 {
     if (file == cb_error_node) {
         return;
     }
     file = cb_ref (file);
     if (file == cb_error_node) {
         return;
     }
     if (CB_FILE (file)->organization == COB_ORG_SORT) {
         cb_error_x (CB_TREE (current_statement),
                 _("Operation not allowed on SORT files"));
         return;
     }
 
     /* Check for file debugging */
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug &&
         CB_FILE(file)->flag_fl_debug) {
         /* Gen callback after delete but before exception test */
         current_statement->flag_callback = 1;
     }
 
     cb_emit (CB_BUILD_FUNCALL_2 ("cob_delete_file", file,
                      CB_FILE(file)->file_status));
 }

void cb_emit_display	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree	,
		struct cb_attr_struct *
	)

 {
     cb_tree     l;
     cb_tree     x;
     cb_tree     line;
     cb_tree     column;
     cb_tree     p;
     cb_tree     fgc;
     cb_tree     bgc;
     cb_tree     scroll;
     int     dispattrs;
 
     if (attr_ptr) {
         fgc = attr_ptr->fgc;
         bgc = attr_ptr->bgc;
         scroll = attr_ptr->scroll;
         dispattrs = attr_ptr->dispattrs;
     } else {
         fgc = NULL;
         bgc = NULL;
         scroll = NULL;
         dispattrs = 0;
     }
 
     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 == cb_int0) {
                     line = NULL;
                 }
                 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 || upon == cb_null) {
         for (l = values; l; l = CB_CHAIN (l)) {
             x = CB_VALUE (l);
             if (x == cb_space) {
                 dispattrs |= COB_SCREEN_ERASE_EOS;
                 dispattrs |= COB_SCREEN_NO_DISP;
             } else if (x == cb_low) {
                 dispattrs |= COB_SCREEN_NO_DISP;
             } else if (CB_LITERAL_P (x) && CB_LITERAL (x)->all &&
                    CB_LITERAL (x)->size == 1) {
                 if (CB_LITERAL (x)->data[0] == 1) {
                     dispattrs |= COB_SCREEN_ERASE_EOL;
                     dispattrs |= COB_SCREEN_NO_DISP;
                 } else if (CB_LITERAL (x)->data[0] == 2) {
                     cb_emit (CB_BUILD_FUNCALL_0 ("cob_sys_clear_screen"));
                     return;
                 } else if (CB_LITERAL (x)->data[0] == 7) {
                     dispattrs |= COB_SCREEN_BELL;
                     dispattrs |= COB_SCREEN_NO_DISP;
                 }
             }
             if (!pos) {
                 cb_emit (CB_BUILD_FUNCALL_7 ("cob_field_display",
                     x, 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 == cb_int0) {
                     line = NULL;
                 }
                 cb_emit (CB_BUILD_FUNCALL_7 ("cob_field_display",
                     x, line, column, fgc, bgc,
                     scroll, cb_int (dispattrs)));
             } else {
                 cb_emit (CB_BUILD_FUNCALL_7 ("cob_field_display",
                     x, 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_FUNCALL(p)->nolitcast = 1;
         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++;
             }
         }
     }
 }

void cb_emit_divide	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     if (cb_validate_one (dividend)) {
         return;
     }
     if (cb_validate_one (divisor)) {
         return;
     }
     CB_VALUE (quotient) = cb_check_numeric_edited_name (CB_VALUE (quotient));
     CB_VALUE (remainder) = cb_check_numeric_edited_name (CB_VALUE (remainder));
 
     if (cb_validate_one (CB_VALUE (quotient))) {
         return;
     }
     if (cb_validate_one (CB_VALUE (remainder))) {
         return;
     }
 
     cb_emit (CB_BUILD_FUNCALL_4 ("cob_div_quotient", dividend, divisor,
                      CB_VALUE (quotient),
                      build_store_option (CB_VALUE (quotient),
                              CB_PURPOSE (quotient))));
     cb_emit (CB_BUILD_FUNCALL_2 ("cob_div_remainder", CB_VALUE (remainder),
                      build_store_option (CB_VALUE (remainder),
                              cb_int0)));
 }

void cb_emit_env_name ( cb_tree )

 {
     if (cb_validate_one (value)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_environment", value));
 }

void cb_emit_env_value ( cb_tree )

 {
     if (cb_validate_one (value)) {
         return;
     }
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_env_value", value));
 }

void cb_emit_evaluate	(	cb_tree	,
		cb_tree
	)

 {
     cb_tree x;
     char    sbuf[16];
 
     snprintf (sbuf, sizeof(sbuf), "goto %s%d;", CB_PREFIX_LABEL, cb_id);
     x = cb_build_direct (cobc_parse_strdup (sbuf), 0);
     build_evaluate (subject_list, case_list, x);
     snprintf (sbuf, sizeof(sbuf), "%s%d:;", CB_PREFIX_LABEL, cb_id);
     cb_emit (cb_build_comment ("End EVALUATE"));
     cb_emit (cb_build_direct (cobc_parse_strdup (sbuf), 0));
     cb_id++;
 }

void cb_emit_exit ( const unsigned int )

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

void cb_emit_free ( cb_tree )

 {
     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_PTR (CB_CAST (CB_VALUE(l))->val);
                 if (!f->flag_item_based) {
                     cb_error_x (CB_TREE (current_statement),
                         _("Target %d of FREE is not 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_PTR (CB_VALUE (l));
                 if (!f->flag_item_based) {
                     cb_error_x (CB_TREE (current_statement),
                         _("Target %d of FREE is not 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);
         }
     }
 }

void cb_emit_get_environment	(	cb_tree	,
		cb_tree
	)

 {
     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_goto	(	cb_tree	,
		cb_tree
	)

 {
     if (target == cb_error_node) {
         return;
     }
     if (target == NULL) {
         cb_verify (cb_goto_statement_without_name, "GO TO without procedure-name");
     } else if (depending) {
         /* GO TO procedure-name ... DEPENDING ON identifier */
         if (cb_check_numeric_value (depending) == cb_error_node) {
             return;
         }
         cb_check_data_incompat (depending);
         cb_emit (cb_build_goto (target, depending));
     } else if (CB_CHAIN (target)) {
             cb_error_x (CB_TREE (current_statement),
                     _("GO TO with multiple procedure-names"));
     } else {
         /* GO TO procedure-name */
         cb_emit (cb_build_goto (CB_VALUE (target), NULL));
     }
 }

void cb_emit_if	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

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

void cb_emit_initialize	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     cb_tree     l;
     unsigned int    no_fill_init;
     unsigned int    def_init;
 
     if (cb_validate_list (vars)) {
         return;
     }
     if (value == NULL && replacing == NULL) {
         def = cb_true;
     }
     no_fill_init = (fillinit == NULL);
     def_init = (def != NULL);
     for (l = vars; l; l = CB_CHAIN (l)) {
         cb_emit (cb_build_initialize (CB_VALUE (l), value, replacing,
                           def_init, 1, no_fill_init));
     }
 }

void cb_emit_inspect	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		const unsigned	int
	)

 {
     switch (CB_TREE_TAG(var)) {
     case CB_TAG_REFERENCE:
         break;
     case CB_TAG_INTRINSIC:
         if (replconv) {
             goto rep_error;
         }
         switch (CB_TREE_CATEGORY(var)) {
         case CB_CATEGORY_ALPHABETIC:
         case CB_CATEGORY_ALPHANUMERIC:
         case CB_CATEGORY_NATIONAL:
             break;
         default:
             cb_error_x (CB_TREE (current_statement),
                     _("Invalid target for INSPECT"));
             return;
         }
         break;
     case CB_TAG_LITERAL:
         if (replconv) {
             goto rep_error;
         }
         break;
     default:
         goto rep_error;
     }
     cb_emit (CB_BUILD_FUNCALL_2 ("cob_inspect_init", var, replacing));
     cb_emit_list (body);
     cb_emit (CB_BUILD_FUNCALL_0 ("cob_inspect_finish"));
     return;
 rep_error:
     if (replconv == 1) {
         cb_error_x (CB_TREE (current_statement),
                 _("Invalid target for %s"), "REPLACING");
     } else {
         cb_error_x (CB_TREE (current_statement),
                 _("Invalid target for %s"), "CONVERTING");
     }
 }

void cb_emit_move	(	cb_tree	,
		cb_tree
	)

 {
     cb_tree     l;
     cb_tree     x;
     cb_tree     m;
     unsigned int    tempval;
 
     if (cb_validate_one (src)) {
         return;
     }
     if (cb_validate_list (dsts)) {
         return;
     }
 
     cb_check_data_incompat (src);
 
     tempval = 0;
     if (cb_list_length (dsts) > 1) {
         if (CB_INTRINSIC_P (src) || (CB_REFERENCE_P (src) &&
             (CB_REFERENCE (src)->subs || CB_REFERENCE (src)->offset))) {
             tempval = 1;
             cb_emit (CB_BUILD_FUNCALL_1 ("cob_put_indirect_field",
                              src));
         }
     }
 
     for (l = dsts; l; l = CB_CHAIN (l)) {
         x = CB_VALUE (l);
         if (CB_LITERAL_P (x) || CB_CONST_P (x)) {
             cb_error_x (CB_TREE (current_statement),
                     _("Invalid MOVE target - %s"), cb_name (x));
             continue;
         }
         if (!tempval) {
             m = cb_build_move (src, x);
         } else {
             m = CB_BUILD_FUNCALL_1 ("cob_get_indirect_field", x);
         }
         cb_emit (m);
     }
 }

void cb_emit_move_corresponding	(	cb_tree	,
		cb_tree
	)

 {
     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;
         }
         if (!emit_move_corresponding (x1, v)) {
             if (cb_warn_corresponding) {
                 cb_warning_x (v, _("No CORRESPONDING items found"));
             }
         }
     }
 }

void cb_emit_open	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     struct cb_file  *f;
 
     if (file == cb_error_node) {
         return;
     }
     file = cb_ref (file);
     if (file == cb_error_node) {
         return;
     }
     current_statement->file = file;
     f = CB_FILE (file);
 
     if (f->organization == COB_ORG_SORT) {
         cb_error_x (CB_TREE (current_statement),
                 _("Operation not allowed on SORT files"));
         return;
     } else if (f->organization == COB_ORG_LINE_SEQUENTIAL &&
            mode == cb_int (COB_OPEN_I_O)) {
         cb_error_x (CB_TREE (current_statement),
                 _("OPEN I-O not allowed on LINE SEQUENTIAL files"));
         return;
     }
     if (sharing == NULL) {
         if (f->sharing) {
             sharing = f->sharing;
         } else {
             sharing = cb_int0;
         }
     }
 
     cb_emit (CB_BUILD_FUNCALL_4 ("cob_open", file, mode,
          sharing, f->file_status));
 
     /* Check for file debugging */
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug &&
         f->flag_fl_debug) {
         cb_emit (cb_build_debug (cb_debug_name, f->name, NULL));
         cb_emit (cb_build_move (cb_space, cb_debug_contents));
         cb_emit (cb_build_debug_call (f->debug_section));
     }
 }

void cb_emit_perform	(	cb_tree	,
		cb_tree
	)

 {
     if (perform == cb_error_node) {
         return;
     }
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug && CB_PAIR_P (body)) {
         cb_emit (cb_build_debug (cb_debug_contents, "PERFORM LOOP", NULL));
     }
     CB_PERFORM (perform)->body = body;
     cb_emit (perform);
 }

void cb_emit_read	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     cb_tree     file;
     cb_tree     rec;
     cb_tree     x;
     struct cb_file  *f;
     int     read_opts;
 
     read_opts = 0;
     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;
     }
     f = CB_FILE (file);
 
     rec = cb_build_field_reference (f->record, ref);
     if (f->organization == COB_ORG_SORT) {
         cb_error_x (CB_TREE (current_statement),
                 _("Operation not allowed on SORT files"));
         return;
     }
     if (next == cb_int1 || next == cb_int2 ||
         f->access_mode == COB_ACCESS_SEQUENTIAL) {
         /* READ NEXT/PREVIOUS */
         if (next == cb_int2) {
             switch (f->organization) {
             case COB_ORG_INDEXED:
             case COB_ORG_RELATIVE:
                 break;
             default:
                 cb_error_x (CB_TREE (current_statement),
                 _("READ PREVIOUS not allowed for this file type"));
                 return;
             }
             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_3 ("cob_read_next", file,
              f->file_status,
              cb_int (read_opts)));
     } else {
         /* READ */
         /* DYNAMIC with [NOT] AT END */
         if (f->access_mode == COB_ACCESS_DYNAMIC &&
             current_statement->handler_id == COB_EC_I_O_AT_END) {
             read_opts |= COB_READ_NEXT;
             cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
                  f->file_status,
                  cb_int (read_opts)));
         } else if (key || f->key) {
             cb_emit (CB_BUILD_FUNCALL_4 ("cob_read",
                  file, key ? key : f->key,
                  f->file_status, cb_int (read_opts)));
         } else {
             cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
                  f->file_status,
                  cb_int (read_opts)));
         }
     }
     if (into) {
         current_statement->handler3 = cb_build_move (rec, into);
     }
 
     /* Check for file debugging */
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug &&
         f->flag_fl_debug) {
         if (into) {
             current_statement->handler3 =
                 CB_LIST_INIT (current_statement->handler3);
         }
         x = cb_build_debug (cb_debug_name, f->name, NULL);
         current_statement->handler3 =
             cb_list_add (current_statement->handler3, x);
         x = cb_build_move (rec, cb_debug_contents);
         current_statement->handler3 =
             cb_list_add (current_statement->handler3, x);
         x = cb_build_debug_call (f->debug_section);
         current_statement->handler3 =
             cb_list_add (current_statement->handler3, x);
     }
     current_statement->file = file;
 }

void cb_emit_ready_trace ( void )

 {
     cb_emit (CB_BUILD_FUNCALL_0 ("cob_ready_trace"));
 }

void cb_emit_release	(	cb_tree	,
		cb_tree
	)

 {
     struct cb_field *f;
     cb_tree     file;
 
     if (cb_validate_one (record)) {
         return;
     }
     if (cb_validate_one (from)) {
         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;
     }
     f = CB_FIELD_PTR (record);
     if (f->storage != CB_STORAGE_FILE) {
         cb_error_x (CB_TREE (current_statement),
             _("RELEASE subject does not refer to a record name"));
         return;
     }
     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));
 }

void cb_emit_reset_trace ( void )

 {
     cb_emit (CB_BUILD_FUNCALL_0 ("cob_reset_trace"));
 }

void cb_emit_return	(	cb_tree	,
		cb_tree
	)

 {
     cb_tree     file;
     cb_tree     rec;
 
     if (cb_validate_one (ref)) {
         return;
     }
     if (cb_validate_one (into)) {
         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;
 }

void cb_emit_rewrite	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     cb_tree     file;
     struct cb_file  *f;
     int     opts;
 
     if (cb_validate_one (record)) {
         return;
     }
     if (cb_validate_one (from)) {
         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_PTR (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);
     if (!file || file == cb_error_node) {
         return;
     }
     current_statement->file = file;
     f = CB_FILE (file);
     opts = 0;
 
     if (f->organization == COB_ORG_SORT) {
         cb_error_x (CB_TREE (current_statement),
         _("Operation not allowed on SORT files"));
         return;
     } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
         cb_error_x (CB_TREE (current_statement),
                 _("Operation not allowed on LINE SEQUENTIAL files"));
         return;
     } else if (current_statement->handler_id == COB_EC_I_O_INVALID_KEY &&
           (f->organization != COB_ORG_RELATIVE &&
            f->organization != COB_ORG_INDEXED)) {
             cb_error_x (CB_TREE(current_statement),
             _("INVALID KEY clause invalid with this file type"));
         return;
     } else if ((f->lock_mode & COB_LOCK_AUTOMATIC) && lockopt) {
         cb_error_x (CB_TREE (current_statement),
         _("LOCK clause invalid with file LOCK AUTOMATIC"));
         return;
     } else if (lockopt == cb_int1) {
         opts = COB_WRITE_LOCK;
     }
 
     if (from) {
         cb_emit (cb_build_move (from, record));
     }
 
     /* Check debugging on record name */
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug &&
         CB_FIELD_PTR (record)->flag_field_debug) {
         cb_emit (cb_build_debug (cb_debug_name,
                      CB_FIELD_PTR (record)->name, NULL));
         cb_emit (cb_build_move (record, cb_debug_contents));
         cb_emit (cb_build_debug_call (CB_FIELD_PTR (record)->debug_section));
     }
     cb_emit (CB_BUILD_FUNCALL_4 ("cob_rewrite", file, record,
             cb_int (opts), f->file_status));
 }

void cb_emit_rollback ( void )

 {
     cb_emit (CB_BUILD_FUNCALL_0 ("cob_rollback"));
 }

void cb_emit_search	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     if (cb_validate_one (table)) {
         return;
     }
     if (cb_validate_one (varying)) {
         return;
     }
     if (table == cb_error_node) {
         return;
     }
     if (whens == cb_error_node) {
         return;
     }
     whens = cb_list_reverse (whens);
     cb_emit (cb_build_search (0, table, varying,
                   cb_check_needs_break (at_end), whens));
 }

void cb_emit_search_all	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     cb_tree     x;
     cb_tree     stmt_lis;
 
     if (cb_validate_one (table)) {
         return;
     }
     if (table == cb_error_node) {
         return;
     }
     if (when == cb_error_node) {
         return;
     }
     x = cb_build_search_all (table, when);
     if (!x) {
         return;
     }
 
     stmt_lis = cb_check_needs_break (stmts);
     cb_emit (cb_build_search (1, table, NULL,
                   cb_check_needs_break (at_end),
                   cb_build_if (x, stmt_lis, NULL, 0)));
 }

void cb_emit_set_attribute	(	cb_tree	,
		const int	,
		const int
	)

 {
     struct cb_field     *f;
 
     if (cb_validate_one (x)) {
         return;
     }
     if (!CB_REF_OR_FIELD_P (cb_ref (x))) {
         cb_error_x (CB_TREE (current_statement),
             _("SET ATTRIBUTE requires a screen item as subject"));
         return;
     }
     f = CB_FIELD_PTR (x);
     if (f->storage != CB_STORAGE_SCREEN) {
         cb_error_x (CB_TREE (current_statement),
             _("SET ATTRIBUTE subject does not refer to a screen item"));
         return;
     }
     cb_emit (cb_build_set_attribute (f, val_on, val_off));
 }

void cb_emit_set_false ( cb_tree )

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

void cb_emit_set_on_off	(	cb_tree	,
		cb_tree
	)

 {
     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_to	(	cb_tree	,
		cb_tree
	)

 {
     cb_tree     l;
     cb_tree     v;
     struct cb_cast  *p;
     enum cb_class   class;
 
     if (cb_validate_one (x)) {
         return;
     }
     if (cb_validate_list (vars)) {
         return;
     }
 
 #if 0   /* RXWRXW - target check */
     /* Determine 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->cast_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)) {
             continue;
         }
         p = CB_CAST (v);
         if (p->cast_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)) {
         class = cb_tree_class (CB_VALUE (l));
         switch (class) {
         case CB_CLASS_INDEX:
         case CB_CLASS_NUMERIC:
         case CB_CLASS_POINTER:
             cb_check_data_incompat (x);
             cb_emit (cb_build_move (x, CB_VALUE (l)));
             break;
         default:
             cb_error_x (CB_TREE (current_statement),
                     _("SET target is invalid - '%s'"),
                     cb_name (CB_VALUE(l)));
             break;
         }
     }
 }

void cb_emit_set_true ( cb_tree )

 {
     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_PTR (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_up_down	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     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_setenv	(	cb_tree	,
		cb_tree
	)

 {
     cb_emit (CB_BUILD_FUNCALL_2 ("cob_set_environment", x, y));
 }

void cb_emit_sort_finish ( cb_tree )

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

void cb_emit_sort_giving	(	cb_tree	,
		cb_tree
	)

 {
     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_x (CB_TREE (current_statement),
                     _("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_init	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     cb_tree         l;
     struct cb_field     *f;
 
     if (cb_validate_list (keys)) {
         return;
     }
     if (cb_ref (name) == cb_error_node) {
         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_PTR (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_VALUE (l),
                     CB_PURPOSE (l),
                     cb_int (CB_FIELD_PTR (CB_VALUE(l))->offset)));
         }
     } else {
         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_VALUE (l),
                     CB_PURPOSE (l),
                     cb_int(CB_FIELD_PTR (CB_VALUE(l))->offset
                            - CB_FIELD_PTR (CB_VALUE(l))->parent->offset)));
         }
         f = CB_FIELD (cb_ref (name));
         cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort", name,
                          (f->depending
                           ? cb_build_cast_int (f->depending)
                           : cb_int (f->occurs_max))));
     }
 }

void cb_emit_sort_input ( cb_tree )

 {
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug) {
         cb_emit (cb_build_debug (cb_debug_contents, "SORT INPUT", NULL));
     }
     cb_emit (cb_build_perform_once (proc));
 }

void cb_emit_sort_output ( cb_tree )

 {
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug) {
         if (current_statement->flag_merge) {
             cb_emit (cb_build_debug (cb_debug_contents,
                          "MERGE OUTPUT", NULL));
         } else {
             cb_emit (cb_build_debug (cb_debug_contents,
                          "SORT OUTPUT", NULL));
         }
     }
     cb_emit (cb_build_perform_once (proc));
 }

void cb_emit_sort_using	(	cb_tree	,
		cb_tree
	)

 {
     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_x (CB_TREE (current_statement),
                     _("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_start	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     cb_tree         kfld;
     cb_tree         fl;
     cb_tree         cbtkey;
     struct cb_file      *f;
 
     if (cb_validate_one (key)) {
         return;
     }
     if (cb_validate_one (keylen)) {
         return;
     }
     if (file == cb_error_node) {
         return;
     }
     fl = cb_ref (file);
     if (fl == cb_error_node) {
         return;
     }
     f = CB_FILE (fl);
 
     if (f->organization != COB_ORG_INDEXED &&
         f->organization != COB_ORG_RELATIVE) {
         cb_error_x (CB_TREE (current_statement),
                 _("START not allowed on SEQUENTIAL files"));
         return;
     }
     if (keylen && f->organization != COB_ORG_INDEXED) {
         cb_error_x (CB_TREE (current_statement),
                 _("LENGTH/SIZE clause only allowed on INDEXED files"));
         return;
     }
     if (f->access_mode == COB_ACCESS_RANDOM) {
         cb_error_x (CB_TREE (current_statement),
                 _("START not allowed with ACCESS MODE RANDOM"));
         return;
     }
 
     current_statement->file = fl;
     if (key) {
         kfld = cb_ref (key);
         if (kfld == cb_error_node) {
             return;
         }
         if (check_valid_key (f, CB_FIELD_PTR (kfld))) {
             return;
         }
         cbtkey = key;
     } else {
         cbtkey = f->key;
     }
 
     /* Check for file debugging */
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug &&
         f->flag_fl_debug) {
         /* Gen callback after start but before exception test */
         current_statement->flag_callback = 1;
     }
 
     cb_emit (CB_BUILD_FUNCALL_5 ("cob_start", fl, op, cbtkey, keylen,
                      f->file_status));
 }

void cb_emit_stop_run ( cb_tree )

 {
     cb_emit (CB_BUILD_FUNCALL_1 ("cob_stop_run", cb_build_cast_int (x)));
 }

void cb_emit_string	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     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)) : NULL;
         if (dlm == cb_int0) {
             dlm = NULL;
         }
         cb_emit (CB_BUILD_FUNCALL_1 ("cob_string_delimited", dlm));
 
         /* cob_string_append */
         for (l = start; l != end; l = CB_CHAIN (l)) {
             cb_emit (CB_BUILD_FUNCALL_1 ("cob_string_append",
                              CB_VALUE (l)));
         }
 
         start = end ? CB_CHAIN (end) : NULL;
     }
     cb_emit (CB_BUILD_FUNCALL_0 ("cob_string_finish"));
 }

void cb_emit_unlock ( cb_tree )

 {
     cb_tree file;
 
     if (ref != cb_error_node) {
         file = cb_ref (ref);
         if (file != cb_error_node) {
             cb_emit (CB_BUILD_FUNCALL_2 ("cob_unlock_file",
                  file, CB_FILE(file)->file_status));
             current_statement->file = file;
         }
     }
 }

void cb_emit_unstring	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

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

void cb_emit_write	(	cb_tree	,
		cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     cb_tree     file;
     cb_tree     check_eop;
     struct cb_file  *f;
 
     if (cb_validate_one (record)) {
         return;
     }
     if (cb_validate_one (from)) {
         return;
     }
     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_PTR (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);
     if (!file || file == cb_error_node) {
         return;
     }
     current_statement->file = file;
     f = CB_FILE (file);
 
     if (f->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 &&
           (f->organization != COB_ORG_RELATIVE &&
            f->organization != COB_ORG_INDEXED)) {
             cb_error_x (CB_TREE(current_statement),
             _("INVALID KEY clause invalid with this file type"));
     } else if (lockopt) {
         if (f->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));
     }
 
     /* Check debugging on record name */
     if (current_program->flag_debugging &&
         !current_statement->flag_in_debug &&
         CB_FIELD_PTR (record)->flag_field_debug) {
         cb_emit (cb_build_debug (cb_debug_name,
                      CB_FIELD_PTR (record)->name, NULL));
         cb_emit (cb_build_move (record, cb_debug_contents));
         cb_emit (cb_build_debug_call (CB_FIELD_PTR (record)->debug_section));
     }
     if (f->organization == COB_ORG_LINE_SEQUENTIAL &&
         opt == cb_int0) {
         if (cb_flag_write_after || CB_FILE (file)->flag_line_adv) {
             opt = cb_int_hex (COB_WRITE_AFTER | COB_WRITE_LINES | 1);
         } else {
             opt = cb_int_hex (COB_WRITE_BEFORE | COB_WRITE_LINES | 1);
         }
     }
     if (current_statement->handler_id == COB_EC_I_O_EOP &&
         current_statement->handler1) {
         check_eop = cb_int1;
     } else {
         check_eop = cb_int0;
     }
     cb_emit (CB_BUILD_FUNCALL_5 ("cob_write", file, record, opt,
                      f->file_status, check_eop));
 }

char* cb_encode_program_id ( const char * )

 {
     unsigned char       *p;
     const unsigned char *s;
     const unsigned char *t;
     unsigned char       buff[COB_MINI_BUFF];
 
     s = NULL;
     for (t = (const unsigned char *)name; *t; t++) {
         if (*t == (unsigned char)'/' || *t == (unsigned char)'\\') {
             s = t + 1;
         }
     }
     if (!s) {
         s = (const unsigned char *)name;
     }
     p = buff;
     /* Encode the initial digit */
     if (*s <= (unsigned char)'9' && *s >= (unsigned char)'0') {
         *p++ = (unsigned char)'_';
     }
     /* Encode invalid letters */
     for (; *s; s++) {
         if (likely(valid_char[*s])) {
             *p++ = *s;
         } else {
             *p++ = (unsigned char)'_';
             if (*s == (unsigned char)'-') {
                 *p++ = (unsigned char)'_';
             } else {
                 *p++ = hexval[*s / 16U];
                 *p++ = hexval[*s % 16U];
             }
         }
     }
     *p = 0;
 
     /* Check case folding */
     if (unlikely(cb_fold_call)) {
         if (cb_fold_call == COB_FOLD_UPPER) {
             for (p = buff; *p; p++) {
                 if (islower (*p)) {
                     *p = (cob_u8_t)toupper (*p);
                 }
             }
         } else if (cb_fold_call == COB_FOLD_LOWER) {
             for (p = buff; *p; p++) {
                 if (isupper (*p)) {
                     *p = (cob_u8_t)tolower (*p);
                 }
             }
         }
     }
 
     return cobc_check_string ((char *)buff);
 }

void cb_error	(	const char *	,
			...
	)

References _, cobc_cs_check, cobc_in_repository, cobc_too_many_errors(), errorcount, NULL, and print_error().

Referenced by build_evaluate(), cb_build_const_length(), cb_build_locale_name(), cb_build_picture(), cb_expr_finish(), cb_validate_program_data(), cb_verify(), check_comp_repeated(), check_pic_repeated(), check_relaxed_syntax(), check_repeated(), check_screen_attr(), cobc_error_name(), finalize_file(), if(), increment_depth(), lookup_reserved_word(), make_intrinsic(), ppcopy(), ppopen(), ppp_define_add(), scan_define_options(), scan_floating_numeric(), scan_h(), scan_numeric(), scan_x(), setup_use_file(), and while().

 {
     va_list ap;
 
     cobc_in_repository = 0;
 #if 0   /* RXWRXW - Is this right? */
     cobc_cs_check = 0;
 #endif
     va_start (ap, fmt);
     print_error (NULL, 0, _("Error: "), fmt, ap);
     va_end (ap);
     if (++errorcount > 100) {
         cobc_too_many_errors ();
     }
 }

void cb_error_x	(	cb_tree	,
		const char *	,
			...
	)

 {
     va_list ap;
 
     va_start (ap, fmt);
     print_error (x->source_file, x->source_line, _("Error: "), fmt, ap);
     va_end (ap);
     if (++errorcount > 100) {
         cobc_too_many_errors ();
     }
 }

struct cb_field* cb_field_add	(	struct cb_field *	,
		struct cb_field *
	)

read

 {
     struct cb_field *t;
 
     if (f == NULL) {
         return p;
     }
     for (t = f; t->sister; t = t->sister) {
         ;
     }
     t->sister = p;
     return f;
 }

struct cb_field* cb_field_founder ( const struct cb_field * )

read

 {
     const struct cb_field   *ff;
 
     ff = f;
     while (ff->parent) {
         ff = ff->parent;
     }
     return (struct cb_field *)ff;
 }

int cb_field_subordinate	(	const struct cb_field *	,
		const struct cb_field *
	)

 {
     struct cb_field     *p;
 
     for (p = pfld->parent; p; p = p->parent) {
         if (p == f) {
             return 1;
         }
     }
     return 0;
 }

unsigned int cb_field_variable_address ( const struct cb_field * )

 {
     const struct cb_field       *p;
     const struct cb_field       *f;
 
     f = fld;
     for (p = f->parent; p; f = f->parent, p = f->parent) {
         for (p = p->children; p != f; p = p->sister) {
             if (p->depending || cb_field_variable_size (p)) {
                 return 1;
             }
         }
     }
     return 0;
 }

struct cb_field* cb_field_variable_size ( const struct cb_field * )

read

 {
     struct cb_field     *p;
     struct cb_field     *fc;
 
     for (fc = f->children; fc; fc = fc->sister) {
         if (fc->depending) {
             return fc;
         } else if ((p = cb_field_variable_size (fc)) != NULL) {
             return p;
         }
     }
     return NULL;
 }

int cb_fits_int ( const cb_tree )

 {
     struct cb_literal   *l;
     struct cb_field     *f;
     const char      *s;
     const unsigned char *p;
     size_t          size;
 
     switch (CB_TREE_TAG (x)) {
     case CB_TAG_LITERAL:
         l = CB_LITERAL (x);
         if (l->scale > 0) {
             return 0;
         }
         for (size = 0, p = l->data; size < l->size; ++size, ++p) {
             if (*p != (unsigned char)'0') {
                 break;
             }
         }
         size = l->size - size;
         if (size < 10) {
             return 1;
         }
         if (size > 10) {
             return 0;
         }
         if (l->sign < 0) {
             s = "2147483648";
         } else {
             s = "2147483647";
         }
         if (memcmp (p, s, (size_t)10) > 0) {
             return 0;
         }
         return 1;
     case CB_TAG_FIELD:
         f = CB_FIELD (x);
         if (f->children) {
             return 0;
         }
         switch (f->usage) {
         case CB_USAGE_INDEX:
         case CB_USAGE_LENGTH:
             return 1;
         case CB_USAGE_BINARY:
         case CB_USAGE_COMP_5:
         case CB_USAGE_COMP_X:
             if (f->pic->scale <= 0 && f->size <= (int)sizeof (int)) {
                 return 1;
             }
             return 0;
         case CB_USAGE_DISPLAY:
             if (f->size < 10) {
                 if (!f->pic || f->pic->scale <= 0) {
                     return 1;
                 }
             }
             return 0;
         case CB_USAGE_PACKED:
         case CB_USAGE_COMP_6:
             if (f->pic->scale <= 0 && f->pic->digits < 10) {
                 return 1;
             }
             return 0;
         default:
             return 0;
         }
     case CB_TAG_REFERENCE:
         return cb_fits_int (CB_REFERENCE (x)->value);
     case CB_TAG_INTEGER:
         return 1;
     default:
         return 0;
     }
 }

int cb_fits_long_long ( const cb_tree )

 {
     struct cb_literal   *l;
     struct cb_field     *f;
     const char      *s;
     const unsigned char *p;
     size_t          size;
 
     switch (CB_TREE_TAG (x)) {
     case CB_TAG_LITERAL:
         l = CB_LITERAL (x);
         if (l->scale > 0) {
             return 0;
         }
         for (size = 0, p = l->data; size < l->size; ++size, ++p) {
             if (*p != (unsigned char)'0') {
                 break;
             }
         }
         size = l->size - size;
         if (size < 19) {
             return 1;
         }
         if (size > 19) {
             return 0;
         }
         if (l->sign < 0) {
             s = "9223372036854775808";
         } else {
             s = "9223372036854775807";
         }
         if (memcmp (p, s, (size_t)19) > 0) {
             return 0;
         }
         return 1;
     case CB_TAG_FIELD:
         f = CB_FIELD (x);
         if (f->children) {
             return 0;
         }
         switch (f->usage) {
         case CB_USAGE_INDEX:
         case CB_USAGE_LENGTH:
             return 1;
         case CB_USAGE_BINARY:
         case CB_USAGE_COMP_5:
         case CB_USAGE_COMP_X:
             if (f->pic->scale <= 0 &&
                 f->size <= (int)sizeof (cob_s64_t)) {
                 return 1;
             }
             return 0;
         case CB_USAGE_DISPLAY:
             if (f->pic->scale <= 0 && f->size < 19) {
                 return 1;
             }
             return 0;
         case CB_USAGE_PACKED:
         case CB_USAGE_COMP_6:
             if (f->pic->scale <= 0 && f->pic->digits < 19) {
                 return 1;
             }
             return 0;
         default:
             return 0;
         }
     case CB_TAG_REFERENCE:
         return cb_fits_long_long (CB_REFERENCE (x)->value);
     case CB_TAG_INTEGER:
         return 1;
     default:
         return 0;
     }
 }

CB_FLAG_RQ	(	cb_stack_size	,
		0	,
		"stack-size"	,
		255	,
		1	,
		_("Define PERFORM stack size\n\t\t\t- Default : 255")
	)

int cb_get_int ( const cb_tree )

 {
     struct cb_literal   *l;
 #if 0   /* RXWRXW Fixme SZ */
     const char      *s;
     size_t          size;
 #endif
     size_t          i;
     int         val;
 
     if (!CB_LITERAL_P (x)) {
         cobc_abort_pr (_("Invalid literal cast - Aborting"));
         COBC_ABORT ();
     }
     l = CB_LITERAL (x);
     for (i = 0; i < l->size; i++) {
         if (l->data[i] != '0') {
             break;
         }
     }
 
 #if 0   /* RXWRXW Fixme SZ */
     if (l->sign < 0) {
         s = "2147483648";
     } else {
         s = "2147483647";
     }
     size = l->size - i;
     if (size > 10U || (size == 10U && memcmp (&l->data[i], s, 10) > 0)) {
         cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
         COBC_ABORT ();
     }
 #endif
 
     val = 0;
     for (; i < l->size; i++) {
         val = val * 10 + l->data[i] - '0';
     }
     if (val && l->sign < 0) {
         val = -val;
     }
     return val;
 }

int cb_get_level ( cb_tree )

 {
     const unsigned char *p;
     const char      *name;
     int         level;
 
     if (CB_INVALID_TREE (x)) {
         return 0;
     }
     name = CB_NAME (x);
     level = 0;
     /* Get level */
     for (p = (const unsigned char *)name; *p; p++) {
         if (!isdigit ((int)(*p))) {
             goto level_error;
         }
         level = level * 10 + (*p - '0');
         if (level > 88) {
             goto level_error;
         }
     }
 
     /* Check level */
     switch (level) {
     case 66:
     case 77:
     case 78:
     case 88:
         break;
     default:
         if (level < 1 || level > 49) {
             goto level_error;
         }
         break;
     }
 
     return level;
 
 level_error:
     cb_error_x (x, _("Invalid level number '%s'"), name);
     return 0;
 }

cob_s64_t cb_get_long_long ( const cb_tree )

 {
     struct cb_literal   *l;
     const char      *s;
     size_t          i;
     size_t          size;
     cob_s64_t       val;
 
     if (!CB_LITERAL_P (x)) {
         cobc_abort_pr (_("Invalid literal cast - Aborting"));
         COBC_ABORT ();
     }
     l = CB_LITERAL (x);
     for (i = 0; i < l->size; i++) {
         if (l->data[i] != '0') {
             break;
         }
     }
 
     size = l->size - i;
     if (size > 19U) {
         cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
         COBC_ABORT ();
     }
     if (size == 19U) {
         if (l->sign < 0) {
             s = "9223372036854775808";
         } else {
             s = "9223372036854775807";
         }
         if (memcmp (&(l->data[i]), s, (size_t)19) > 0) {
             cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
             COBC_ABORT ();
         }
     }
 
     val = 0;
     for (; i < l->size; i++) {
         val = val * 10 + (l->data[i] & 0x0F);
     }
     if (val && l->sign < 0) {
         val = -val;
     }
     return val;
 }

struct cb_field* cb_get_real_field ( void )

read

 {
     return last_real_field;
 }

cob_u64_t cb_get_u_long_long ( const cb_tree )

 {
     struct cb_literal   *l;
     size_t          i;
     size_t          size;
     cob_u64_t       val;
 
     l = CB_LITERAL (x);
     for (i = 0; i < l->size; i++) {
         if (l->data[i] != '0') {
             break;
         }
     }
 
     size = l->size - i;
     if (size > 20U) {
         cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
         COBC_ABORT ();
     }
     if (size == 20U) {
         if (memcmp (&(l->data[i]), "18446744073709551615", (size_t)20) > 0) {
             cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
             COBC_ABORT ();
         }
     }
     val = 0;
     for (; i < l->size; i++) {
         val = val * 10 + (l->data[i] & 0x0F);
     }
     return val;
 }

void cb_init_constants ( void )

 {
     int i;
 
     cb_error_node = make_constant (CB_CATEGORY_UNKNOWN, NULL);
     cb_any = make_constant (CB_CATEGORY_UNKNOWN, NULL);
     cb_true = make_constant (CB_CATEGORY_BOOLEAN, "1");
     cb_false = make_constant (CB_CATEGORY_BOOLEAN, "0");
     cb_null = make_constant (CB_CATEGORY_DATA_POINTER, "0");
     cb_zero = make_constant (CB_CATEGORY_NUMERIC, "&cob_all_zero");
     cb_space = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_all_space");
     cb_low = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_all_low");
     cb_norm_low = cb_low;
     cb_high = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_all_high");
     cb_norm_high = cb_high;
     cb_quote = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_all_quote");
     cb_one = cb_build_numeric_literal (0, "1", 0);
     cb_int0 = cb_int (0);
     cb_int1 = cb_int (1);
     cb_int2 = cb_int (2);
     cb_int3 = cb_int (3);
     cb_int4 = cb_int (4);
     cb_int5 = cb_int (5);
     for (i = 0; i < COB_MAX_SUBSCRIPTS; i++) {
         cb_i[i] = make_constant (CB_CATEGORY_NUMERIC, cb_const_subs[i]);
     }
     cb_standard_error_handler = make_constant_label ("Default Error Handler");
     CB_LABEL (cb_standard_error_handler)->flag_default_handler = 1;
     memset (container_progs, 0, sizeof(container_progs));
 }

void cb_init_tallying ( void )

 {
     inspect_func = NULL;
     inspect_data = NULL;
 }

void cb_insert_common_prog	(	struct cb_program *	,
		struct cb_program *
	)

 {
     prog->nested_prog_list = add_contained_prog (prog->nested_prog_list,
                              comprog);
 }

cb_tree cb_int ( const int )

 {
     struct cb_integer   *x;
     struct int_node     *p;
 
     for (p = int_node_table; p; p = p->next) {
         if (p->n == n) {
             return p->node;
         }
     }
 
     /* Do not use make_tree here */
     x = cobc_main_malloc (sizeof (struct cb_integer));
     x->common.tag = CB_TAG_INTEGER;
     x->common.category = CB_CATEGORY_NUMERIC;
     x->val = n;
 
     p = cobc_main_malloc (sizeof (struct int_node));
     p->n = n;
     p->node = CB_TREE (x);
     p->next = int_node_table;
     int_node_table = p;
     return CB_TREE (x);
 }

cb_tree cb_int_hex ( const int )

 {
     cb_tree     x;
 
     x = cb_int (n);
     CB_INTEGER (x)->hexval = 1;
     return x;
 }

cb_tree cb_list_add	(	cb_tree	,
		cb_tree
	)

 {
     return cb_list_append (l, CB_LIST_INIT (x));
 }

cb_tree cb_list_append	(	cb_tree	,
		cb_tree
	)

 {
     cb_tree l;
 
     if (l1 == NULL) {
         return l2;
     }
     l = l1;
     while (CB_CHAIN (l)) {
         l = CB_CHAIN (l);
     }
     CB_CHAIN (l) = l2;
     return l1;
 }

void cb_list_intrinsics ( void )

 {
     const char  *s;
     const char  *t;
     size_t      i;
     size_t      n;
 
     putchar ('\n');
     puts (_("Intrinsic Function\t\tImplemented\tParameters"));
     for (i = 0; i < NUM_INTRINSICS; ++i) {
         n = strlen (function_list[i].name);
         switch (n / 8) {
         case 0:
             s = "\t\t\t\t";
             break;
         case 1:
             s = "\t\t\t";
             break;
         case 2:
             s = "\t\t";
             break;
         default:
             s = "\t";
             break;
         }
         if (function_list[i].implemented) {
             t = _("Y");
         } else {
             t = _("N");
         }
         if (function_list[i].args < 0) {
             printf ("%s%s%s\t\tVariable\n", function_list[i].name,
                 s, t);
         } else {
             printf ("%s%s%s\t\t%d\n", function_list[i].name,
                 s, t, function_list[i].args);
         }
     }
 }

int cb_list_length ( cb_tree )

 {
     int n;
 
     if (l == cb_error_node) {
         return 0;
     }
     n = 0;
     for (; l; l = CB_CHAIN (l)) {
         n++;
     }
     return n;
 }

void cb_list_map	(	cb_tree(*)(cb_tree)	,
		cb_tree
	)

void cb_list_mnemonics ( void )

 {
     const char  *tabs;
     const char  *feature;
     size_t      i;
 
     putchar ('\n');
     puts (_("Mnemonic names"));
     for (i = 0; i < SYSTEM_TAB_SIZE; ++i) {
         if (strlen (system_table[i].name) < 8) {
             tabs = "\t\t";
         } else {
             tabs = "\t";
         }
         feature = res_get_feature (system_table[i].category);
         printf ("%s%s%s\n", system_table[i].name, tabs, feature);
     }
     putchar ('\n');
     puts (_("Extended mnemonic names (with -fsyntax-extension)"));
     for (i = 0; i < EXT_SYSTEM_TAB_SIZE; ++i) {
         if (strlen (ext_system_table[i].name) < 8) {
             tabs = "\t\t";
         } else {
             tabs = "\t";
         }
         feature = res_get_feature (ext_system_table[i].category);
         printf ("%s%s%s\n", ext_system_table[i].name, tabs, feature);
     }
 }

void cb_list_reserved ( void )

 {
     const char  *s;
     const char  *p;
     size_t      i;
     size_t      n;
 
     putchar ('\n');
     printf (_("Reserved Words\t\t\tImplemented (Y/N)"));
     puts ("\n");
     for (i = 0; i < NUM_RESERVED_WORDS; ++i) {
         n = strlen (reserved_words[i].name);
         switch (n / 8) {
         case 0:
             s = "\t\t\t\t";
             break;
         case 1:
             s = "\t\t\t";
             break;
         case 2:
             s = "\t\t";
             break;
         default:
             s = "\t";
             break;
         }
         if (reserved_words[i].token == 0) {
             p = _("N (85 obsolete)");
         } else if (reserved_words[i].token > 0) {
             if (reserved_words[i].context_sens) {
                 p = _("Y (Context sensitive)");
             } else {
                 p = _("Y");
             }
         } else {
             if (reserved_words[i].context_sens) {
                 p = _("N (Context sensitive)");
             } else {
                 p = _("N");
             }
         }
         printf ("%s%s%s\n", reserved_words[i].name, s, p);
     }
     putchar ('\n');
     puts (_("Extra (obsolete) context sensitive words"));
     puts ("AUTHOR");
     puts ("DATE-COMPILED");
     puts ("DATE-MODIFIED");
     puts ("DATE-WRITTEN");
     puts ("INSTALLATION");
     puts ("REMARKS");
     puts ("SECURITY");
     putchar ('\n');
     puts (_("Extra internal registers\tDefinition"));
     puts ("RETURN-CODE\t\t\tUSAGE BINARY-LONG");
     puts ("SORT-RETURN\t\t\tUSAGE BINARY-LONG");
     puts ("NUMBER-OF-CALL-PARAMETERS\tUSAGE BINARY-LONG");
     puts ("COB-CRT-STATUS\t\t\tPIC 9(4)");
     puts ("'LENGTH OF' phrase\t\tUSAGE BINARY-LONG");
 }

cb_tree cb_list_reverse ( cb_tree )

 {
     cb_tree next;
     cb_tree last;
 
     last = NULL;
     for (; l; l = next) {
         next = CB_CHAIN (l);
         CB_CHAIN (l) = last;
         last = l;
     }
     return last;
 }

void cb_list_system ( void )

 {
     const struct system_table   *psyst;
     const char          *s;
     size_t              n;
 
     putchar ('\n');
     printf (_("System routine\t\t\tParameters"));
     puts ("\n");
     for (psyst = system_tab; psyst->syst_name; psyst++) {
         switch (*(unsigned char *)(psyst->syst_name)) {
         case 'C':
         case 'S':
             printf ("%s", psyst->syst_name);
             break;
         case 0xF4:
             printf ("X\"F4\"");
             break;
         case 0xF5:
             printf ("X\"F5\"");
             break;
         case 0x91:
             printf ("X\"91\"");
             break;
         case 0xE4:
             printf ("X\"E4\"");
             break;
         case 0xE5:
             printf ("X\"E5\"");
             break;
         default:
             break;
         }
         n = strlen (psyst->syst_name);
         switch (n / 8) {
         case 0:
             s = "\t\t\t\t";
             break;
         case 1:
             s = "\t\t\t";
             break;
         case 2:
             s = "\t\t";
             break;
         default:
             s = "\t";
             break;
         }
         printf ("%s%d\n", s, psyst->syst_params);
     }
 }

int cb_load_conf	(	const char *	,
		const int	,
		const int
	)

References _, cb_config_entry(), CB_CONFIG_SIZE, cb_load_conf(), cob_config_dir, COB_SMALL_BUFF, COB_SMALL_MAX, config_table, configuration_error(), line, NULL, read_string(), SLASH_STR, and config_struct::val.

Referenced by cb_load_conf(), cb_load_std(), and process_command_line().

 {
     const unsigned char *x;
     const char      *name;
     FILE            *fp;
     size_t          i;
     int         sub_ret, ret;
     int         line;
     char            buff[COB_SMALL_BUFF];
 
     /* Initialize the configuration table */
     if (check_nodef) {
         for (i = 0; i < CB_CONFIG_SIZE; i++) {
             config_table[i].val = NULL;
         }
     }
 
     if (prefix_dir) {
         snprintf (buff, (size_t)COB_SMALL_MAX,
               "%s%s%s", cob_config_dir, SLASH_STR, fname);
         name = buff;
     } else {
         name = fname;
     }
     /* Open the configuration file */
     fp = fopen (name, "r");
     if (fp == NULL) {
         fflush (stderr);
         configuration_error (name, 0, _("No such file or directory"));
         return -1;
     }
 
     /* Read the configuration file */
     ret = 0;
     line = 0;
     while (fgets (buff, COB_SMALL_BUFF, fp)) {
         line++;
 
         /* Skip line comments, empty lines */
         if (buff[0] == '#' || buff[0] == '\n') {
             continue;
         }
 
         /* Skip blank lines */
         for (x = (const unsigned char *)buff; *x; x++) {
             if (isgraph (*x)) {
                 break;
             }
         }
         if (!*x) {
             continue;
         }
 
         sub_ret = cb_config_entry (buff, fname, line);
         if (sub_ret == 1) {
             /* Include another configuration file */
             /* Find entry for getting include value */
             for (i = 0; i < CB_CONFIG_SIZE; i++) {
                 if (strcmp (buff, config_table[i].name) == 0) {
                     break;
                 }
             }
             sub_ret = cb_load_conf (read_string(config_table[i].val), 0, 1);
             if (sub_ret != 0) {
                 fclose (fp);
                 /* Only 1 include allowed */
                 if (sub_ret == 1) {
                     configuration_error (read_string(config_table[i].val), 0,
                         _("Only one include in configuration files allowed"));
                     sub_ret = -1;
                 }
             }
         }
         if (sub_ret != 0) ret = sub_ret;
     }
     fclose (fp);
 
     /* Checks for missing definitions */
     if (check_nodef) {
         for (i = 2U; i < CB_CONFIG_SIZE; i++) {
             if (config_table[i].val == NULL) {
                 configuration_error (fname, 0, _("No definition of '%s'"),
                      config_table[i].name);
                 ret = -1;
             }
         }
     }
 
     return ret;
 }

int cb_load_std ( const char * )

References cb_load_conf().

Referenced by process_command_line().

 {
     return cb_load_conf (name, 1, 1);
 }

char* cb_name ( cb_tree )

 {
     char    *s;
 
     s = cobc_parse_malloc ((size_t)COB_NORMAL_BUFF);
     (void)cb_name_1 (s, x);
     return s;
 }

cb_tree cb_pair_add	(	cb_tree	,
		cb_tree	,
		cb_tree
	)

 {
     return cb_list_append (l, CB_BUILD_PAIR (x, y));
 }

void cb_plex_error	(	const size_t	,
		const char *	,
			...
	)

References _, cb_source_line, cobc_too_many_errors(), errorcount, NULL, and print_error().

Referenced by plex_action_directive(), ppinput(), and ppparse_error().

 {
     va_list ap;
 
     va_start (ap, fmt);
     print_error (NULL, (int)(cb_source_line + sline), _("Error: "), fmt, ap);
     va_end (ap);
     if (++errorcount > 100) {
         cobc_too_many_errors ();
     }
 }

void cb_plex_warning	(	const size_t	,
		const char *	,
			...
	)

References _, cb_source_line, NULL, print_error(), and warningcount.

Referenced by ppinput(), and while().

 {
     va_list ap;
 
     va_start (ap, fmt);
     print_error (NULL, (int)(cb_source_line + sline), _("Warning: "), fmt, ap);
     va_end (ap);
     warningcount++;
 }

cb_tree cb_ref ( cb_tree )

 {
     struct cb_reference *r;
     struct cb_field     *p;
     struct cb_label     *s;
     cb_tree         candidate;
     cb_tree         items;
     cb_tree         cb1;
     cb_tree         cb2;
     cb_tree         v;
     cb_tree         c;
     struct cb_program   *prog;
     struct cb_word      *w;
     size_t          val;
     size_t          ambiguous;
 
     if (CB_INVALID_TREE (x)) {
         return cb_error_node;
     }
     r = CB_REFERENCE (x);
     /* If this reference has already been resolved (and the value
        has been cached), then just return the value */
     if (r->value) {
         return r->value;
     }
 
     /* Resolve the value */
 
     candidate = NULL;
     ambiguous = 0;
     items = r->word->items;
     for (; items; items = CB_CHAIN (items)) {
         /* Find a candidate value by resolving qualification */
         v = CB_VALUE (items);
         c = r->chain;
         switch (CB_TREE_TAG (v)) {
         case CB_TAG_FIELD:
             /* In case the value is a field, it might be qualified
                by its parent names and a file name */
             if (CB_FIELD (v)->flag_indexed_by) {
                 p = CB_FIELD (v)->index_qual;
             } else {
                 p = CB_FIELD (v)->parent;
             }
             /* Resolve by parents */
             for (; p; p = p->parent) {
                 if (c && strcasecmp (CB_NAME (c), p->name) == 0) {
                     c = CB_REFERENCE (c)->chain;
                 }
             }
 
             /* Resolve by file */
             if (c && CB_REFERENCE (c)->chain == NULL) {
                 if (CB_WORD_COUNT (c) == 1 &&
                     CB_FILE_P (cb_ref (c)) &&
                     (CB_FILE (cb_ref (c)) == cb_field_founder (CB_FIELD (v))->file)) {
                     c = CB_REFERENCE (c)->chain;
                 }
             }
 
             break;
         case CB_TAG_LABEL:
             /* In case the value is a label, it might be qualified
                by its section name */
             s = CB_LABEL (v)->section;
 
             /* Unqualified paragraph name referenced within the section
                is resolved without ambiguity check if not duplicated */
             if (c == NULL && r->offset && s == CB_LABEL (r->offset)) {
                 for (cb1 = CB_CHAIN (items); cb1; cb1 = CB_CHAIN (cb1)) {
                     cb2 = CB_VALUE (cb1);
                     if (s == CB_LABEL (cb2)->section) {
                         ambiguous_error (x);
                         goto error;
                     }
                 }
                 candidate = v;
                 goto end;
             }
 
             /* Resolve by section name */
             if (c && s && strcasecmp (CB_NAME (c), (char *)s->name) == 0) {
                 c = CB_REFERENCE (c)->chain;
             }
 
             break;
         default:
             /* Other values cannot be qualified */
             break;
         }
 
         /* A well qualified value is a good candidate */
         if (c == NULL) {
             if (candidate == NULL) {
                 /* Keep the first candidate */
                 candidate = v;
             } else {
                 /* Multiple candidates and possibly ambiguous */
                 ambiguous = 1;
                 /* Continue search because the reference might not
                    be ambiguous and exit loop by "goto end" later */
             }
         }
     }
 
     /* There is no candidate */
     if (candidate == NULL) {
         if (likely(current_program->nested_level <= 0)) {
             goto undef_error;
         }
         /* Nested program - check parents for GLOBAL candidate */
         ambiguous = 0;
 /* RXWRXW
         val = hash ((const unsigned char *)r->word->name);
 */
         val = r->hashval;
         prog = current_program->next_program;
         for (; prog; prog = prog->next_program) {
             if (prog->nested_level >= current_program->nested_level) {
                 continue;
             }
             for (w = prog->word_table[val]; w; w = w->next) {
                 if (strcasecmp (r->word->name, w->name) == 0) {
                     candidate = global_check (r, w->items, &ambiguous);
                     if (candidate) {
                         if (ambiguous) {
                             ambiguous_error (x);
                             goto error;
                         }
                         if (CB_FILE_P(candidate)) {
                             current_program->flag_gen_error = 1;
                         }
                         goto end;
                     }
                 }
             }
             if (prog->nested_level == 0) {
                 break;
             }
         }
         goto undef_error;
     }
 
     /* Reference is ambiguous */
     if (ambiguous) {
         ambiguous_error (x);
         goto error;
     }
 
 end:
     if (CB_FIELD_P (candidate)) {
         CB_FIELD (candidate)->count++;
         if (CB_FIELD (candidate)->flag_invalid) {
             goto error;
         }
     } else if (CB_LABEL_P (candidate) && r->flag_alter_code) {
         CB_LABEL (candidate)->flag_alter = 1;
     }
 
     r->value = candidate;
     return r->value;
 
 undef_error:
     undefined_error (x);
     /* Fall through */
 
 error:
     r->value = cb_error_node;
     return cb_error_node;
 }

void cb_reset_78 ( void )

References cobc_free(), const78ptr, globlev78ptr, cb_level_78::next, cb_level_78::not_const, and NULL.

Referenced by cb_build_program().

 {
     struct cb_level_78  *p78;
     struct cb_level_78  *p782;
 
     /* Remove constant (78 level) items for current program */
     for (p78 = lev78ptr; p78; ) {
         p782 = p78->next;
         cobc_free (p78);
         p78 = p782;
     }
     lev78ptr = NULL;
     for (p78 = globlev78ptr; p78; p78 = p78->next) {
         p78->not_const = 0;
     }
     if (globlev78ptr) {
         top78ptr = globlev78ptr;
     } else {
         top78ptr = const78ptr;
     }
 }

void cb_reset_global_78 ( void )

References cobc_free(), const78ptr, cb_level_78::next, and NULL.

Referenced by cb_build_program().

 {
     struct cb_level_78  *p78;
     struct cb_level_78  *p782;
 
     /* Remove constant (78 level) items for top program */
     for (p78 = globlev78ptr; p78; ) {
         p782 = p78->next;
         cobc_free (p78);
         p78 = p782;
     }
     globlev78ptr = NULL;
     top78ptr = const78ptr;
 }

struct cb_field* cb_resolve_redefines	(	struct cb_field *	,
		cb_tree
	)

read

 {
     struct cb_field     *f;
     struct cb_reference *r;
     const char      *name;
     cb_tree         x;
     cb_tree         candidate;
     cb_tree         items;
 
     r = CB_REFERENCE (redefines);
     name = CB_NAME (redefines);
     x = CB_TREE (field);
 
     /* Check qualification */
     if (r->chain) {
         cb_error_x (x, _("'%s' cannot be qualified here"), name);
         return NULL;
     }
 
     /* Check subscripts */
     if (r->subs) {
         cb_error_x (x, _("'%s' cannot be subscripted here"), name);
         return NULL;
     }
 
     /* Resolve the name in the current group (if any) */
     if (field->parent && field->parent->children) {
         for (f = field->parent->children; f; f = f->sister) {
             if (strcasecmp (f->name, name) == 0) {
                 break;
             }
         }
         if (f == NULL) {
             cb_error_x (x, _("'%s' is not defined in '%s'"), name, field->parent->name);
             return NULL;
         }
     } else {
         /* Get last defined name */
         candidate = NULL;
         items = r->word->items;
         for (; items; items = CB_CHAIN (items)) {
             if (CB_FIELD_P (CB_VALUE (items))) {
                 candidate = CB_VALUE (items);
             }
         }
         if (!candidate) {
             undefined_error (redefines);
             return NULL;
         }
         f = CB_FIELD_PTR (candidate);
     }
 
     /* Check level number */
     if (f->level != field->level) {
         cb_error_x (x, _("Level number of REDEFINES entries must be identical"));
         return NULL;
     }
     if (f->level == 66 || f->level == 88) {
         cb_error_x (x, _("Level number of REDEFINES entry cannot be 66 or 88"));
         return NULL;
     }
 
     if (!cb_indirect_redefines && f->redefines) {
         cb_error_x (x, _("'%s' not the original definition"), f->name);
         return NULL;
     }
 
     /* Return the original definition */
     while (f->redefines) {
         f = f->redefines;
     }
     return f;
 }

void cb_set_system_names ( void )

 {
     cb_define_system_name ("CONSOLE");
     cb_define_system_name ("SYSIN");
     cb_define_system_name ("SYSIPT");
     cb_define_system_name ("STDIN");
     cb_define_system_name ("SYSOUT");
     cb_define_system_name ("STDOUT");
     cb_define_system_name ("SYSERR");
     cb_define_system_name ("STDERR");
     cb_define_system_name ("SYSLST");
     cb_define_system_name ("SYSLIST");
     cb_define_system_name ("FORMFEED");
 }

char* cb_to_cname ( const char * )

 {
     char        *copy;
     unsigned char   *p;
 
     copy = cobc_parse_strdup (s);
     for (p = (unsigned char *)copy; *p; p++) {
         if (*p == '-' || *p == ' ') {
             *p = '_';
         } else {
             *p = (cob_u8_t)toupper (*p);
         }
     }
     return copy;
 }

enum cb_category cb_tree_category ( cb_tree )

 {
     struct cb_cast      *p;
     struct cb_reference *r;
     struct cb_field     *f;
 
     if (x == cb_error_node) {
         return (enum cb_category)0;
     }
     if (x->category != CB_CATEGORY_UNKNOWN) {
         return x->category;
     }
 
     switch (CB_TREE_TAG (x)) {
     case CB_TAG_CAST:
         p = CB_CAST (x);
         switch (p->cast_type) {
         case CB_CAST_ADDRESS:
         case CB_CAST_ADDR_OF_ADDR:
             x->category = CB_CATEGORY_DATA_POINTER;
             break;
         case CB_CAST_PROGRAM_POINTER:
             x->category = CB_CATEGORY_PROGRAM_POINTER;
             break;
         default:
             cobc_abort_pr (_("Unexpected cast type -> %d"),
                     (int)(p->cast_type));
             COBC_ABORT ();
         }
         break;
     case CB_TAG_REFERENCE:
         r = CB_REFERENCE (x);
         if (r->offset) {
             x->category = CB_CATEGORY_ALPHANUMERIC;
         } else {
             x->category = cb_tree_category (r->value);
         }
         break;
     case CB_TAG_FIELD:
         f = CB_FIELD (x);
         if (f->children) {
             x->category = CB_CATEGORY_ALPHANUMERIC;
         } else if (f->usage == CB_USAGE_POINTER && f->level != 88) {
             x->category = CB_CATEGORY_DATA_POINTER;
         } else if (f->usage == CB_USAGE_PROGRAM_POINTER && f->level != 88) {
             x->category = CB_CATEGORY_PROGRAM_POINTER;
         } else {
             switch (f->level) {
             case 66:
                 if (f->rename_thru) {
                     x->category = CB_CATEGORY_ALPHANUMERIC;
                 } else {
                     x->category = cb_tree_category (CB_TREE (f->redefines));
                 }
                 break;
             case 88:
                 x->category = CB_CATEGORY_BOOLEAN;
                 break;
             default:
                 if (f->pic) {
                     x->category = f->pic->category;
                 } else {
                     x->category = (enum cb_category)0;
                 }
                 break;
             }
         }
         break;
     case CB_TAG_ALPHABET_NAME:
     case CB_TAG_LOCALE_NAME:
         x->category = CB_CATEGORY_ALPHANUMERIC;
         break;
     case CB_TAG_BINARY_OP:
         x->category = CB_CATEGORY_BOOLEAN;
         break;
     case CB_TAG_INTRINSIC:
         x->category = CB_INTRINSIC(x)->intr_tab->category;
         break;
     default:
 #if 0   /* RXWRXW - Tree tag */
         cobc_abort_pr (_("Unknown tree tag %d Category %d"),
                 (int)CB_TREE_TAG (x), (int)x->category);
         COBC_ABORT ();
 #endif
         return CB_CATEGORY_UNKNOWN;
     }
 
     return x->category;
 }

enum cb_class cb_tree_class ( cb_tree )

 {
 
     return category_to_class_table[CB_TREE_CATEGORY (x)];
 }

int cb_tree_type	(	const cb_tree	,
		const struct cb_field *
	)

 {
     if (f->children) {
         return COB_TYPE_GROUP;
     }
 
     switch (CB_TREE_CATEGORY (x)) {
     case CB_CATEGORY_ALPHABETIC:
     case CB_CATEGORY_ALPHANUMERIC:
         return COB_TYPE_ALPHANUMERIC;
     case CB_CATEGORY_ALPHANUMERIC_EDITED:
         return COB_TYPE_ALPHANUMERIC_EDITED;
     case CB_CATEGORY_NUMERIC:
         switch (f->usage) {
         case CB_USAGE_DISPLAY:
             return COB_TYPE_NUMERIC_DISPLAY;
         case CB_USAGE_BINARY:
         case CB_USAGE_COMP_5:
         case CB_USAGE_COMP_X:
         case CB_USAGE_INDEX:
         case CB_USAGE_LENGTH:
             return COB_TYPE_NUMERIC_BINARY;
         case CB_USAGE_FLOAT:
             return COB_TYPE_NUMERIC_FLOAT;
         case CB_USAGE_DOUBLE:
             return COB_TYPE_NUMERIC_DOUBLE;
         case CB_USAGE_PACKED:
         case CB_USAGE_COMP_6:
             return COB_TYPE_NUMERIC_PACKED;
         case CB_USAGE_LONG_DOUBLE:
             return COB_TYPE_NUMERIC_L_DOUBLE;
         case CB_USAGE_FP_BIN32:
             return COB_TYPE_NUMERIC_FP_BIN32;
         case CB_USAGE_FP_BIN64:
             return COB_TYPE_NUMERIC_FP_BIN64;
         case CB_USAGE_FP_BIN128:
             return COB_TYPE_NUMERIC_FP_BIN128;
         case CB_USAGE_FP_DEC64:
             return COB_TYPE_NUMERIC_FP_DEC64;
         case CB_USAGE_FP_DEC128:
             return COB_TYPE_NUMERIC_FP_DEC128;
         default:
             cobc_abort_pr (_("Unexpected numeric usage -> %d"),
                     (int)f->usage);
             COBC_ABORT ();
         }
     case CB_CATEGORY_NUMERIC_EDITED:
         return COB_TYPE_NUMERIC_EDITED;
     case CB_CATEGORY_OBJECT_REFERENCE:
     case CB_CATEGORY_DATA_POINTER:
     case CB_CATEGORY_PROGRAM_POINTER:
         return COB_TYPE_NUMERIC_BINARY;
     default:
         cobc_abort_pr (_("Unexpected category -> %d"),
                 (int)CB_TREE_CATEGORY (x));
         /* Use dumb variant */
         COBC_DUMB_ABORT ();
     }
     /* NOT REACHED */
 #ifndef _MSC_VER
     return 0;
 #endif
 }

void cb_unput_dot ( void )

References unput.

 {
     unput ('.');
 }

struct cb_field* cb_validate_78_item	(	struct cb_field *	,
		const cob_u32_t
	)

read

 {
     cb_tree         x;
     cob_u32_t       noadd;
 
     x = CB_TREE (f);
     noadd = no78add;
     if (CB_INVALID_TREE(f->values) ||
         CB_INVALID_TREE(CB_VALUE(f->values))) {
         level_require_error (x, "VALUE");
         noadd = 1;
     }
 
     if (f->pic || f->flag_occurs) {
         level_except_error (x, "VALUE");
         noadd = 1;
     }
     if (!noadd) {
         cb_add_78 (f);
     }
     return last_real_field;
 }

void cb_validate_88_item ( struct cb_field * )

 {
     cb_tree x;
     cb_tree l;
     cb_tree t;
 
     x = CB_TREE (f);
     if (!f->values) {
         level_require_error (x, "VALUE");
         return;
     }
 
     if (f->pic || f->flag_occurs) {
         level_except_error (x, "VALUE");
         return;
     }
     if (CB_VALID_TREE(f->parent) &&
         CB_TREE_CLASS (f->parent) == CB_CLASS_NUMERIC) {
         for (l = f->values; l; l = CB_CHAIN (l)) {
             t = CB_VALUE (l);
             if (t == cb_space || t == cb_low ||
                 t == cb_high || t == cb_quote) {
                 cb_error_x (x, _("Literal type does not match data type"));
             }
         }
     }
 }

void cb_validate_field ( struct cb_field * )

 {
     struct cb_field     *c;
 
     if (f->flag_is_verified) {
         return;
     }
     if (validate_field_1 (f) != 0) {
         f->flag_invalid = 1;
         return;
     }
     if (f->flag_item_78) {
         f->flag_is_verified = 1;
         return;
     }
 
     /* Set up parameters */
     if (f->storage == CB_STORAGE_LOCAL ||
         f->storage == CB_STORAGE_LINKAGE ||
         f->flag_item_based) {
         f->flag_local = 1;
     }
     if (f->storage == CB_STORAGE_LINKAGE || f->flag_item_based) {
         f->flag_base = 1;
     }
     setup_parameters (f);
 
     /* Compute size */
     occur_align_size = 1;
     compute_size (f);
     if (!f->redefines) {
         f->memory_size = f->size * f->occurs_max;
     } else if (f->redefines->memory_size < f->size * f->occurs_max) {
         f->redefines->memory_size = f->size * f->occurs_max;
     }
 
     validate_field_value (f);
     if (f->flag_is_global) {
         f->count++;
         for (c = f->children; c; c = c->sister) {
             c->flag_is_global = 1;
             c->count++;
         }
     }
     f->flag_is_verified = 1;
 }

void cb_validate_program_body ( struct cb_program * )

 {
     cb_tree         l;
     cb_tree         x;
     cb_tree         v;
     struct cb_label     *save_section;
     struct cb_label     *save_paragraph;
     struct cb_alter_id  *aid;
     struct cb_label     *l1;
     struct cb_label     *l2;
     struct cb_field     *f;
     int         size;
 
     /* Resolve all labels */
     save_section = current_section;
     save_paragraph = current_paragraph;
     for (l = cb_list_reverse (prog->label_list); l; l = CB_CHAIN (l)) {
         x = CB_VALUE (l);
         current_section = CB_REFERENCE (x)->section;
         current_paragraph = CB_REFERENCE (x)->paragraph;
         v = cb_ref (x);
         /* Check refs in to / out of DECLARATIVES */
         if (CB_LABEL_P (v)) {
             if (CB_REFERENCE (x)->flag_in_decl &&
                 !CB_LABEL (v)->flag_declaratives) {
                 if (!cb_relaxed_syntax_check) {
                     cb_error_x (x, _("'%s' is not in DECLARATIVES"),
                             CB_LABEL (v)->name);
                 } else {
                     cb_warning_x (x, _("'%s' is not in DECLARATIVES"),
                             CB_LABEL (v)->name);
                 }
             }
             if (CB_LABEL (v)->flag_declaratives &&
                 !CB_REFERENCE (x)->flag_in_decl &&
                 !CB_REFERENCE (x)->flag_decl_ok) {
                 cb_error_x (x, _("Invalid reference to '%s' (In DECLARATIVES)"), CB_LABEL (v)->name);
             }
             CB_LABEL (v)->flag_begin = 1;
             if (CB_REFERENCE (x)->length) {
                 CB_LABEL (v)->flag_return = 1;
             }
         } else if (v != cb_error_node) {
             cb_error_x (x, _("'%s' not a procedure name"), cb_name (x));
         }
     }
 
     /* Resolve DEBUG references */
     /* For data items, we may need to adjust the size of DEBUG-CONTENTS */
     /* Basic size of DEBUG-CONTENTS is 31 */
     size = 31;
     for (l = prog->debug_list; l; l = CB_CHAIN (l)) {
         x = CB_VALUE (l);
         current_section = CB_REFERENCE (x)->section;
         current_paragraph = CB_REFERENCE (x)->paragraph;
         v = cb_ref (x);
         if (v == cb_error_node) {
             continue;
         }
         switch (CB_TREE_TAG (v)) {
         case CB_TAG_LABEL:
             if (current_program->all_procedure) {
                 cb_error_x (x, _("'%s' - DEBUGGING target invalid with ALL PROCEDURES"),
                         cb_name (x));
             }
             if (!CB_LABEL (v)->flag_real_label) {
                 cb_error_x (x, _("'%s' - DEBUGGING target invalid"),
                         cb_name (x));
             }
             CB_LABEL (v)->debug_section =
                 CB_REFERENCE (x)->debug_section;
             CB_LABEL (v)->flag_debugging_mode = 1;
             break;
         case CB_TAG_FILE:
             break;
         case CB_TAG_FIELD:
             if (CB_FIELD (v)->size > size) {
                 size = CB_FIELD (v)->size;
             }
             break;
         default:
             cb_error_x (x, _("'%s' is not a valid DEBUGGING target"),
                     cb_name (x));
             break;
         }
     }
     /* If necessary, adjust size of DEBUG-CONTENTS (and DEBUG-ITEM) */
     if (current_program->flag_debugging) {
         if (size != 31) {
             f = CB_FIELD_PTR (cb_debug_contents);
             f->size = size;
             f->memory_size = size;
             size -= 31;
             f = CB_FIELD_PTR (cb_debug_item);
             f->size += size;
             f->memory_size += size;
         }
     }
 
     /* Build ALTER ids - We need to remove duplicates */
     for (l = prog->alter_list; l; l = CB_CHAIN (l)) {
         if (CB_PURPOSE (l) == cb_error_node) {
             continue;
         }
         if (CB_VALUE (l) == cb_error_node) {
             continue;
         }
         x = CB_PURPOSE (l);
         v = CB_VALUE (l);
         if (CB_REFERENCE (x)->value == cb_error_node) {
             continue;
         }
         if (CB_REFERENCE (v)->value == cb_error_node) {
             continue;
         }
         l1 = CB_LABEL (CB_REFERENCE (x)->value);
         l2 = CB_LABEL (CB_REFERENCE (v)->value);
         current_section = CB_REFERENCE (x)->section;
         current_paragraph = CB_REFERENCE (x)->paragraph;
         /* First statement in paragraph must be a GO TO */
         if (!l1->flag_first_is_goto) {
             cb_error_x (x, _("'%s' is not an alterable paragraph"),
                     l1->name);
             continue;
         }
         for (aid = l1->alter_gotos; aid; aid = aid->next) {
             if (aid->goto_id == l2->id) {
                 break;
             }
         }
         if (!aid) {
             aid = cobc_parse_malloc (sizeof(struct cb_alter_id));
             aid->next = l1->alter_gotos;
             aid->goto_id = l2->id;
             l1->alter_gotos = aid;
         }
         for (aid = prog->alter_gotos; aid; aid = aid->next) {
             if (aid->goto_id == l1->id) {
                 break;
             }
         }
         if (!aid) {
             aid = cobc_parse_malloc (sizeof(struct cb_alter_id));
             aid->next = prog->alter_gotos;
             aid->goto_id = l1->id;
             prog->alter_gotos = aid;
         }
     }
 
     current_section = save_section;
     current_paragraph = save_paragraph;
     cobc_cs_check = 0;
 
     prog->file_list = cb_list_reverse (prog->file_list);
     prog->exec_list = cb_list_reverse (prog->exec_list);
 }

void cb_validate_program_data ( struct cb_program * )

 {
     cb_tree         l;
     cb_tree         x;
     cb_tree         assign;
     struct cb_field     *p;
     struct cb_field     *q;
     struct cb_field     *depfld;
     struct cb_file      *f;
     struct cb_report    *rep;
     unsigned char       *c;
     char            buff[COB_MINI_BUFF];
 
     for (l = current_program->report_list; l; l = CB_CHAIN (l)) {
         /* Set up LINE-COUNTER / PAGE-COUNTER */
         rep = CB_REPORT (CB_VALUE (l));
         snprintf (buff, (size_t)COB_MINI_MAX,
               "LINE-COUNTER %s", rep->cname);
         x = cb_build_field (cb_build_reference (buff));
         CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
         CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
         CB_FIELD (x)->count++;
         cb_validate_field (CB_FIELD (x));
         rep->line_counter = cb_build_field_reference (CB_FIELD (x), NULL);
         CB_FIELD_ADD (current_program->working_storage, CB_FIELD (x));
         snprintf (buff, (size_t)COB_MINI_MAX,
               "PAGE-COUNTER %s", rep->cname);
         x = cb_build_field (cb_build_reference (buff));
         CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
         CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
         CB_FIELD (x)->count++;
         cb_validate_field (CB_FIELD (x));
         rep->page_counter = cb_build_field_reference (CB_FIELD (x), NULL);
         CB_FIELD_ADD (current_program->working_storage, CB_FIELD (x));
     }
 
     for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
         f = CB_FILE (CB_VALUE (l));
         if (!f->flag_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_NAME (assign))) {
                         redefinition_error (assign);
                     }
                 }
                 p = check_level_78 (CB_NAME (assign));
                 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_WORD_COUNT (assign) == 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);
                 CB_FIELD (x)->count++;
                 p = current_program->working_storage;
                 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++;
         */
         CB_FIELD_ADD (current_program->working_storage, p);
         prog->crt_status = l;
     }
 
     /* Resolve all references so far */
     for (l = cb_list_reverse (prog->reference_list); l; l = CB_CHAIN (l)) {
         cb_ref (CB_VALUE (l));
     }
 
     /* Check ODO items */
     for (l = cb_depend_check; l; l = CB_CHAIN (l)) {
         x = CB_VALUE(l);
         if (x == cb_error_node) {
             continue;
         }
         q = CB_FIELD_PTR (x);
         if (cb_ref (q->depending) != cb_error_node) {
             depfld = CB_FIELD_PTR (q->depending);
         } else {
             depfld = NULL;
         }
         /* The data item that contains a OCCURS DEPENDING clause must be
            the last data item in the group */
         for (p = q; p->parent; p = p->parent) {
             for (; p->sister; p = p->sister) {
                 if (p->sister == depfld) {
                         cb_error_x (x,
                                 _("'%s' ODO field item invalid here"),
                                 p->sister->name);
                 }
                 if (!p->sister->redefines) {
                     if (!cb_complex_odo) {
                         cb_error_x (x,
                                 _("'%s' cannot have OCCURS DEPENDING"),
                                 cb_name (x));
                         break;
                     }
                     p->flag_odo_item = 1;
                 }
             }
         }
         /* If the field is GLOBAL, then the ODO must also be GLOBAL */
         if (q->flag_is_global && depfld) {
             if (!depfld->flag_is_global) {
                 cb_error_x (x, _("'%s' ODO item must have GLOBAL attribute"),
                     depfld->name);
             }
         }
     }
     cb_depend_check = NULL;
     cb_needs_01 = 0;
 
     for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
         f = CB_FILE (CB_VALUE (l));
         if (CB_VALID_TREE(f->record_depending)) {
             x = f->record_depending;
             if (cb_ref (x) != cb_error_node) {
 #if 0           /* RXWRXW - This breaks old legacy programs */
                 if (CB_REF_OR_FIELD_P(x)) {
                     p = CB_FIELD_PTR (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 {
 #endif
                 if (!CB_REF_OR_FIELD_P(x)) {
                     cb_error (_("Invalid RECORD DEPENDING item"));
                 }
             }
         }
     }
 }

void cb_validate_program_environment ( struct cb_program * )

 {
     cb_tree         x;
     cb_tree         y;
     cb_tree         l;
     cb_tree         ls;
     struct cb_alphabet_name *ap;
     struct cb_class_name    *cp;
     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         tableval;
     int         values[256];
     int         charvals[256];
 
     /* Check ALPHABET clauses */
     /* Complicated by difference between code set and collating sequence */
     for (l = current_program->alphabet_name_list; l; l = CB_CHAIN (l)) {
         ap = CB_ALPHABET_NAME (CB_VALUE (l));
 
         /* Native */
         if (ap->alphabet_type == CB_ALPHABET_NATIVE) {
             for (n = 0; n < 256; n++) {
                 ap->values[n] = n;
                 ap->alphachr[n] = n;
             }
             continue;
         }
 
         /* ASCII */
         if (ap->alphabet_type == CB_ALPHABET_ASCII) {
             for (n = 0; n < 256; n++) {
 #ifdef  COB_EBCDIC_MACHINE
                 ap->values[n] = (int)cob_refer_ascii[n];
                 ap->alphachr[n] = (int)cob_refer_ascii[n];
 #else
                 ap->values[n] = n;
                 ap->alphachr[n] = n;
 #endif
             }
             continue;
         }
 
         /* EBCDIC */
         if (ap->alphabet_type == CB_ALPHABET_EBCDIC) {
             for (n = 0; n < 256; n++) {
 #ifdef  COB_EBCDIC_MACHINE
                 ap->values[n] = n;
                 ap->alphachr[n] = n;
 #else
                 ap->values[n] = (int)cob_refer_ebcdic[n];
                 ap->alphachr[n] = (int)cob_refer_ebcdic[n];
 #endif
             }
             continue;
         }
 
         /* Custom alphabet */
         dupls = 0;
         unvals = 0;
         count = 0;
         lastval = 0;
         tableval = 0;
         for (n = 0; n < 256; n++) {
             values[n] = -1;
             charvals[n] = -1;
             ap->values[n] = -1;
             ap->alphachr[n] = -1;
         }
         ap->low_val_char = 0;
         ap->high_val_char = 255;
         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;
                         charvals[i] = i;
                         ap->alphachr[tableval] = i;
                         ap->values[i] = tableval++;
                         count++;
                     }
                 } else {
                     for (i = lower; i >= upper; i--) {
                         if (values[i] != -1) {
                             dupls = 1;
                         }
                         values[i] = i;
                         charvals[i] = i;
                         ap->alphachr[tableval] = i;
                         ap->values[i] = tableval++;
                         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;
                     ap->values[n] = tableval;
                     if (ls == x) {
                         ap->alphachr[tableval] = n;
                         charvals[n] = n;
                     }
                     count++;
                 }
                 tableval++;
             } else {
                 /* Literal */
                 if (CB_NUMERIC_LITERAL_P (x)) {
                     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;
                     charvals[n] = n;
                     ap->alphachr[tableval] = n;
                     ap->values[n] = tableval++;
                     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;
                         charvals[n] = n;
                         ap->alphachr[tableval] = n;
                         ap->values[n] = tableval++;
                         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;
                     charvals[n] = n;
                     ap->alphachr[tableval] = n;
                     ap->values[n] = tableval++;
                     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;
                 }
             }
         }
 
         /* Get rest of code set */
         for (n = tableval; n < 256; ++n) {
             for (i = 0; i < 256; ++i) {
                 if (charvals[i] < 0) {
                     charvals[i] = 0;
                     ap->alphachr[n] = i;
                     break;
                 }
             }
         }
 
         /* Fill in missing characters */
         for (n = 0; n < 256; n++) {
             if (ap->values[n] < 0) {
                 ap->values[n] = tableval++;
             }
         }
     }
 
     /* Reset HIGH/LOW-VALUES */
     cb_low = cb_norm_low;
     cb_high = cb_norm_high;
 
     /* Check and generate SYMBOLIC clauses */
     for (l = current_program->symbolic_char_list; l; l = CB_CHAIN (l)) {
         if (CB_VALUE (l)) {
             y = cb_ref (CB_VALUE (l));
             if (y == cb_error_node) {
                 continue;
             }
             if (!CB_ALPHABET_NAME_P (y)) {
                 cb_error_x (y, _("Invalid ALPHABET name"));
                 continue;
             }
         } else {
             y = NULL;
         }
         cb_build_symbolic_chars (CB_PURPOSE (l), y);
     }
 
     /* Check CLASS clauses */
     for (l = current_program->class_name_list; l; l = CB_CHAIN (l)) {
         dupls = 0;
         memset (values, 0, sizeof(values));
         cp = CB_CLASS_NAME (CB_VALUE (l));
         for (y = cp->list; y; y = CB_CHAIN (y)) {
             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));
                 for (i = lower; i <= upper; i++) {
                     if (values[i]) {
                         dupls = 1;
                     }
                     values[i] = 1;
                 }
             } else {
                 if (CB_NUMERIC_LITERAL_P (x)) {
                     n = get_value (x);
                     if (values[n]) {
                         dupls = 1;
                     }
                     values[n] = 1;
                 } else if (CB_LITERAL_P (x)) {
                     size = (int)CB_LITERAL (x)->size;
                     data = CB_LITERAL (x)->data;
                     for (i = 0; i < size; i++) {
                         n = data[i];
                         if (values[n]) {
                             dupls = 1;
                         }
                         values[n] = 1;
                     }
                 } else {
                     n = get_value (x);
                     if (values[n]) {
                         dupls = 1;
                     }
                     values[n] = 1;
                 }
             }
         }
         if (dupls) {
             if (!cb_relaxed_syntax_check) {
                 cb_error_x (CB_VALUE(l),
                         _("Duplicate values in class '%s'"),
                         cb_name (CB_VALUE(l)));
             } else {
                 cb_warning_x (CB_VALUE(l),
                         _("Duplicate values in class '%s'"),
                         cb_name (CB_VALUE(l)));
             }
         }
     }
 
     /* Resolve the program collating sequence */
     if (prog->collating_sequence) {
         cb_validate_collating (prog);
     }
 
     /* Resolve the program classification */
     if (prog->classification && prog->classification != cb_int1) {
         x = cb_ref (prog->classification);
         if (!CB_LOCALE_NAME_P (x)) {
             cb_error_x (prog->classification,
                     _("'%s' is not a locale name"),
                     cb_name (prog->classification));
             prog->classification = NULL;
             return;
         }
     }
 }

unsigned int cb_verify	(	const enum	cb_support,
		const char *
	)

References _, CB_ARCHAIC, CB_ERROR, cb_error(), CB_IGNORE, CB_OBSOLETE, CB_OK, CB_SKIP, CB_UNCONFORMABLE, CB_WARNING, cb_warning(), and warningopt.

Referenced by cb_emit_goto(), check_comments(), compute_size(), validate_field_1(), and while().

 {
     switch (tag) {
     case CB_OK:
         return 1;
     case CB_WARNING:
         return 1;
     case CB_ARCHAIC:
         if (cb_warn_archaic) {
             cb_warning (_("%s is archaic in %s"), feature, cb_config_name);
         }
         return 1;
     case CB_OBSOLETE:
         if (cb_warn_obsolete) {
             cb_warning (_("%s is obsolete in %s"), feature, cb_config_name);
         }
         return 1;
     case CB_SKIP:
         return 0;
     case CB_IGNORE:
         if (warningopt) {
             cb_warning (_("%s ignored"), feature);
         }
         return 0;
     case CB_ERROR:
         return 0;
     case CB_UNCONFORMABLE:
         cb_error (_("%s does not conform to %s"), feature, cb_config_name);
         return 0;
     default:
         break;
     }
     return 0;
 }

void cb_warning	(	const char *	,
			...
	)

References _, NULL, print_error(), and warningcount.

Referenced by begin_statement(), cb_build_assignment_name(), cb_emit_call(), cb_emit_read(), cb_validate_program_data(), cb_verify(), check_comp_repeated(), check_pic_repeated(), check_relaxed_syntax(), check_repeated(), check_screen_attr(), emit_entry(), expr_reduce(), ppp_compare_vals(), read_literal(), and warning_destination().

 {
     va_list ap;
 
     va_start (ap, fmt);
     print_error (NULL, 0, _("Warning: "), fmt, ap);
     va_end (ap);
     warningcount++;
 }

void cb_warning_x	(	cb_tree	,
		const char *	,
			...
	)

 {
     va_list ap;
 
     va_start (ap, fmt);
     print_error (x->source_file, x->source_line, _("Warning: "), fmt, ap);
     va_end (ap);
     warningcount++;
 }

struct cb_field* check_level_78 ( const char * name )

read

References cb_level_78::fld78, cb_field::name, cb_level_78::next, and NULL.

Referenced by cb_validate_program_data().

 {
     const struct cb_level_78    *p78;
 
     /* Check against a current constant (78 level) */
     for (p78 = lev78ptr; p78; p78 = p78->next) {
         if (strcasecmp (name, p78->fld78->name) == 0) {
             return p78->fld78;
         }
     }
     /* Check against a global constant (78 level) */
     for (p78 = globlev78ptr; p78; p78 = p78->next) {
         if (strcasecmp (name, p78->fld78->name) == 0) {
             return p78->fld78;
         }
     }
     return NULL;
 }

COB_EXPIMP void cob_accept ( cob_field * )

 {
     unsigned char   *p;
     size_t      size;
     int     ipchr;
     cob_field   temp;
 
     if (cobglobptr->cob_screen_initialized) {
         cob_field_accept (f, NULL, NULL, NULL, NULL,
                   NULL, NULL, NULL, COB_SCREEN_PROMPT);
         return;
     }
     if (COB_MODULE_PTR->crt_status) {
         if (COB_FIELD_IS_NUMERIC (COB_MODULE_PTR->crt_status)) {
             cob_set_int (COB_MODULE_PTR->crt_status, 0);
         } else {
             memset (COB_MODULE_PTR->crt_status->data, '0', (size_t)4);
         }
     }
     /* extension: ACCEPT OMITTED */
     if (unlikely(!f)) {
         for (; ; ) {
             ipchr = getchar ();
             if (ipchr == '\n' || ipchr == EOF) {
                 break;
             }
         }
         return;
     }
     p = COB_TERM_BUFF;
     temp.data = p;
     temp.attr = &const_alpha_attr;
     size = 0;
     /* Read a line */
     for (; size < COB_MEDIUM_MAX; ) {
         ipchr = getchar ();
         if (unlikely(ipchr == EOF)) {
             cob_set_exception (COB_EC_IMP_ACCEPT);
             if (!size) {
                 size = 1;
                 p[0] = ' ';
                 p[1] = 0;
             }
             break;
         } else if (ipchr == '\n') {
             break;
         }
         p[size++] = (char) ipchr;
     }
     temp.size = size;
     if (COB_FIELD_TYPE(f) == COB_TYPE_NUMERIC_DISPLAY) {
         if (temp.size > f->size) {
             temp.size = f->size;
         }
     }
     cob_move (&temp, f);
 }

COB_EXPIMP void cob_accept_arg_number ( cob_field * )

 {
     int     n;
     cob_field_attr  attr;
     cob_field   temp;
 
     n = cob_argc - 1;
     temp.size = 4;
     temp.data = (unsigned char *)&n;
     temp.attr = &attr;
     COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL);
     cob_move (&temp, f);
 }

COB_EXPIMP void cob_accept_arg_value ( cob_field * )

 {
     if (current_arg >= cob_argc) {
         cob_set_exception (COB_EC_IMP_ACCEPT);
         return;
     }
     cob_memcpy (f, cob_argv[current_arg],
             strlen (cob_argv[current_arg]));
     current_arg++;
 }

COB_EXPIMP void cob_accept_command_line ( cob_field * )

 {
     char    *buff;
     size_t  i;
     size_t  size;
     size_t  len;
 
     if (commlncnt) {
         cob_memcpy (f, commlnptr, commlncnt);
         return;
     }
 
     if (cob_argc <= 1) {
         cob_memcpy (f, " ", (size_t)1);
         return;
     }
 
     size = 0;
     for (i = 1; i < (size_t)cob_argc; ++i) {
         size += (strlen (cob_argv[i]) + 1);
         if (size > f->size) {
             break;
         }
     }
     buff = cob_malloc (size);
     buff[0] = ' ';
     size = 0;
     for (i = 1; i < (size_t)cob_argc; ++i) {
         len = strlen (cob_argv[i]);
         memcpy (buff + size, cob_argv[i], len);
         size += len;
         if (i != (size_t)cob_argc - 1U) {
             buff[size++] = ' ';
         }
         if (size > f->size) {
             break;
         }
     }
     cob_memcpy (f, buff, size);
     cob_free (buff);
 }

COB_EXPIMP void cob_accept_date ( cob_field * )

 {
     time_t  t;
     char    s[8];
 
     t = time (NULL);
     strftime (s, (size_t)7, "%y%m%d", localtime (&t));
     cob_memcpy (f, s, (size_t)6);
 }

COB_EXPIMP void cob_accept_date_yyyymmdd ( cob_field * )

 {
     time_t  t;
     char    s[12];
 
     t = time (NULL);
     strftime (s, (size_t)9, "%Y%m%d", localtime (&t));
     cob_memcpy (f, s, (size_t)8);
 }

COB_EXPIMP void cob_accept_day ( cob_field * )

 {
     time_t  t;
     char    s[8];
 
     t = time (NULL);
     strftime (s, (size_t)6, "%y%j", localtime (&t));
     cob_memcpy (f, s, (size_t)5);
 }

COB_EXPIMP void cob_accept_day_of_week ( cob_field * )

 {
     struct tm   *tm;
     time_t      t;
     unsigned char   s[4];
 
     t = time (NULL);
     tm = localtime (&t);
     if (tm->tm_wday == 0) {
         s[0] = (unsigned char)'7';
     } else {
         s[0] = (unsigned char)(tm->tm_wday + '0');
     }
     cob_memcpy (f, s, (size_t)1);
 }

COB_EXPIMP void cob_accept_day_yyyyddd ( cob_field * )

 {
     time_t  t;
     char    s[12];
 
     t = time (NULL);
     strftime (s, (size_t)8, "%Y%j", localtime (&t));
     cob_memcpy (f, s, (size_t)7);
 }

COB_EXPIMP void cob_accept_environment ( cob_field * )

 {
     const char *p = NULL;
 
     if (cob_local_env) {
         p = getenv (cob_local_env);
     }
     if (!p) {
         cob_set_exception (COB_EC_IMP_ACCEPT);
         p = " ";
     }
     cob_memcpy (f, p, strlen (p));
 }

COB_EXPIMP void cob_accept_escape_key ( cob_field * )

 {
     cob_set_int (f, COB_ACCEPT_STATUS);
 }

COB_EXPIMP void cob_accept_exception_status ( cob_field * )

 {
     cob_set_int (f, cobglobptr->cob_exception_code);
 }

COB_EXPIMP void cob_accept_time ( cob_field * )

 {
 #ifdef  _WIN32
     SYSTEMTIME  syst;
 #else
     struct tm   *tlt;
     time_t      t;
 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
     struct timeval  tmv;
     char        buff2[8];
 #endif
 #endif
     char        s[12];
 
 #ifdef  _WIN32
     GetLocalTime (&syst);
     sprintf (s, "%2.2d%2.2d%2.2d%2.2d", syst.wHour, syst.wMinute,
         syst.wSecond, syst.wMilliseconds / 10);
 #else
 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
     gettimeofday (&tmv, NULL);
     t = tmv.tv_sec;
 #else
     t = time (NULL);
 #endif
     tlt = localtime (&t);
     /* Leap seconds ? */
     if (tlt->tm_sec >= 60) {
         tlt->tm_sec = 59;
     }
     strftime (s, (size_t)9, "%H%M%S00", tlt);
 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
     sprintf(buff2, "%2.2ld", (long int)(tmv.tv_usec / 10000));
     memcpy (&s[6], buff2, (size_t)2);
 #endif
 #endif
     cob_memcpy (f, s, (size_t)8);
 }

COB_EXPIMP void cob_accept_user_name ( cob_field * )

 {
     if (cob_user_name) {
         cob_memcpy (f, cob_user_name,
                 strlen (cob_user_name));
     } else {
         cob_memcpy (f, " ", (size_t)1);
     }
 }

COB_EXPIMP void cob_add	(	cob_field *	,
		cob_field *	,
		const int
	)

 {
     cob_decimal_set_field (&cob_d1, f1);
     cob_decimal_set_field (&cob_d2, f2);
     cob_decimal_add (&cob_d1, &cob_d2);
     (void)cob_decimal_get_field (&cob_d1, f1, opt);
 }

COB_EXPIMP int cob_add_int	(	cob_field *	,
		const int	,
		const int
	)

 {
     int scale;
     int val;
 
     if (unlikely(n == 0)) {
         return 0;
     }
 #if 0   /* RXWRXW - Buggy */
     if (COB_FIELD_TYPE (f) == COB_TYPE_NUMERIC_PACKED) {
         return cob_add_packed (f, n, opt);
     } else if (COB_FIELD_TYPE (f) == COB_TYPE_NUMERIC_DISPLAY) {
         return cob_display_add_int (f, n, opt);
     }
 #endif
 
     /* Not optimized */
     cob_decimal_set_field (&cob_d1, f);
 
     if (COB_FIELD_TYPE (f) >= COB_TYPE_NUMERIC_FLOAT
     &&  COB_FIELD_TYPE (f) <= COB_TYPE_NUMERIC_FP_BIN128) {
         mpz_set_si (cob_d2.value, (cob_sli_t) n);
         cob_d2.scale = 0;
         mpz_add (cob_d1.value, cob_d1.value, cob_d2.value);
         return cob_decimal_get_field (&cob_d1, f, opt);
     }
     else {
         scale = COB_FIELD_SCALE (f);
         val = n;
         if (unlikely(scale < 0)) {
             /* PIC 9(n)P(m) */
             if (-scale < 10) {
                 while (scale++) {
                     val /= 10;
                 }
             } else {
                 val = 0;
             }
             scale = 0;
             if (!val) {
                 return 0;
             }
         }
         mpz_set_si (cob_d2.value, (cob_sli_t)val);
         cob_d2.scale = 0;
         if (scale > 0) {
             mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)scale);
             mpz_mul (cob_d2.value, cob_d2.value, cob_mexp);
             cob_d2.scale = cob_d1.scale;
         }
         mpz_add (cob_d1.value, cob_d1.value, cob_d2.value);
         return cob_decimal_get_field (&cob_d1, f, opt);
     }
 }

COB_EXPIMP void cob_allocate	(	unsigned char **	,
		cob_field *	,
		cob_field *	,
		cob_field *
	)

 {
     void            *mptr;
     struct cob_alloc_cache  *cache_ptr;
     int         fsize;
     cob_field       temp;
 
     /* ALLOCATE */
     cobglobptr->cob_exception_code = 0;
     mptr = NULL;
     fsize = cob_get_int (sizefld);
     if (fsize > 0) {
         cache_ptr = cob_malloc (sizeof (struct cob_alloc_cache));
         mptr = malloc ((size_t)fsize);
         if (!mptr) {
             cob_set_exception (COB_EC_STORAGE_NOT_AVAIL);
             cob_free (cache_ptr);
         } else {
             if (initialize) {
                 temp.size = (size_t)fsize;
                 temp.data = mptr;
                 temp.attr = &const_alpha_attr;
                 cob_move (initialize, &temp);
             } else {
                 memset (mptr, 0, (size_t)fsize);
             }
             cache_ptr->cob_pointer = mptr;
             cache_ptr->size = (size_t)fsize;
             cache_ptr->next = cob_alloc_base;
             cob_alloc_base = cache_ptr;
         }
     }
     if (dataptr) {
         *dataptr = mptr;
     }
     if (retptr) {
         *(void **)(retptr->data) = mptr;
     }
 }

COB_EXPIMP void cob_cache_free ( void * )

 {
     struct cob_alloc_cache  *cache_ptr;
     struct cob_alloc_cache  *prev_ptr;
 
     if (!ptr) {
         return;
     }
     cache_ptr = cob_alloc_base;
     prev_ptr = cob_alloc_base;
     for (; cache_ptr; cache_ptr = cache_ptr->next) {
         if (ptr == cache_ptr->cob_pointer) {
             cob_free (cache_ptr->cob_pointer);
             if (cache_ptr == cob_alloc_base) {
                 cob_alloc_base = cache_ptr->next;
             } else {
                 prev_ptr->next = cache_ptr->next;
             }
             cob_free (cache_ptr);
             return;
         }
         prev_ptr = cache_ptr;
     }
 }

COB_EXPIMP void* cob_cache_malloc ( const size_t )

 {
     struct cob_alloc_cache  *cache_ptr;
     void            *mptr;
 
     cache_ptr = cob_malloc (sizeof (struct cob_alloc_cache));
     mptr = cob_malloc (size);
     cache_ptr->cob_pointer = mptr;
     cache_ptr->size = size;
     cache_ptr->next = cob_alloc_base;
     cob_alloc_base = cache_ptr;
     return mptr;
 }

COB_EXPIMP void* cob_cache_realloc	(	void *	,
		const size_t
	)

 {
     struct cob_alloc_cache  *cache_ptr;
     void            *mptr;
 
     if (!ptr) {
         return cob_cache_malloc (size);
     }
     cache_ptr = cob_alloc_base;
     for (; cache_ptr; cache_ptr = cache_ptr->next) {
         if (ptr == cache_ptr->cob_pointer) {
             if (size <= cache_ptr->size) {
                 return ptr;
             }
             mptr = cob_malloc (size);
             memcpy (mptr, cache_ptr->cob_pointer, cache_ptr->size);
             cob_free (cache_ptr->cob_pointer);
             cache_ptr->cob_pointer = mptr;
             cache_ptr->size = size;
             return mptr;
         }
     }
     return ptr;
 }

COB_EXPIMP int cob_call	(	const char *	,
		const int	,
		void **
	)

 {
     void            **pargv;
     cob_call_union      unifunc;
     int         i;
 
     if (unlikely(!cobglobptr)) {
         cob_fatal_error (COB_FERROR_INITIALIZED);
     }
     if (argc < 0 || argc > COB_MAX_FIELD_PARAMS) {
         cob_runtime_error (_("Invalid number of arguments to 'cob_call'"));
         cob_stop_run (1);
     }
     if (unlikely(!name)) {
         cob_runtime_error (_("NULL name parameter passed to 'cob_call'"));
         cob_stop_run (1);
     }
     unifunc.funcvoid = cob_resolve_cobol (name, 0, 1);
     pargv = cob_malloc (COB_MAX_FIELD_PARAMS * sizeof(void *));
     /* Set number of parameters */
     cobglobptr->cob_call_params = argc;
     for (i = 0; i < argc; ++i) {
         pargv[i] = argv[i];
     }
     i =  unifunc.funcint (pargv[0], pargv[1], pargv[2], pargv[3],
                 pargv[4], pargv[5], pargv[6], pargv[7],
                 pargv[8], pargv[9], pargv[10], pargv[11],
 #if COB_MAX_FIELD_PARAMS == 16
                 pargv[12], pargv[13], pargv[14], pargv[15]);
 #elif   COB_MAX_FIELD_PARAMS == 36
                 pargv[12], pargv[13], pargv[14], pargv[15],
                 pargv[16], pargv[17], pargv[18], pargv[19],
                 pargv[20], pargv[21], pargv[22], pargv[23],
                 pargv[24], pargv[25], pargv[26], pargv[27],
                 pargv[28], pargv[29], pargv[30], pargv[31],
                 pargv[32], pargv[33], pargv[34], pargv[35]);
 #else
 #error  "Invalid COB_MAX_FIELD_PARAMS value"
 #endif
     cob_free (pargv);
     return i;
 }

DECLNORET COB_EXPIMP void cob_call_error ( void )

 {
     cob_runtime_error ("%s", cob_resolve_error ());
     cob_stop_run (1);
 }

COB_EXPIMP void* cob_call_field	(	const cob_field *	,
		const struct cob_call_struct *	,
		const unsigned	int,
		const int
	)

 {
     void                *p;
     const struct cob_call_struct    *s;
     const struct system_table   *psyst;
     char                *buff;
     char                *entry;
     char                *dirent;
 
     if (unlikely(!cobglobptr)) {
         cob_fatal_error (COB_FERROR_INITIALIZED);
     }
 
     buff = cob_get_buff (f->size + 1);
     cob_field_to_string (f, buff, f->size);
 
     entry = cob_chk_call_path (buff, &dirent);
 
     /* Check if system routine */
     for (psyst = system_tab; psyst->syst_name; ++psyst) {
         if (!strcmp (entry, psyst->syst_name)) {
             if (dirent) {
                 cob_free (dirent);
             }
             return psyst->syst_call.funcvoid;
         }
     }
 
 
     /* Check if contained program */
     for (s = cs; s && s->cob_cstr_name; s++) {
         if (!strcmp (entry, s->cob_cstr_name)) {
             if (dirent) {
                 cob_free (dirent);
             }
             return s->cob_cstr_call.funcvoid;
         }
     }
 
     p = cob_resolve_internal (entry, dirent, fold_case);
     if (dirent) {
         cob_free (dirent);
     }
     if (unlikely(!p)) {
         if (errind) {
             cob_call_error ();
         } else {
             cob_set_exception (COB_EC_PROGRAM_NOT_FOUND);
             return NULL;
         }
     }
     return p;
 }

COB_EXPIMP void cob_cancel ( const char * )

 {
     const char      *entry;
     struct call_hash    *p;
     struct call_hash    **q;
     struct call_hash    *r;
 
     if (unlikely(!cobglobptr)) {
         cob_fatal_error (COB_FERROR_INITIALIZED);
     }
     if (unlikely(!name)) {
         cob_runtime_error (_("NULL parameter passed to 'cob_cancel'"));
         cob_stop_run (1);
     }
     entry = cob_chk_dirp (name);
 
 #ifdef  COB_ALT_HASH
     q = &call_table;
     p = *q;
 #else
     q = &call_table[hash ((const unsigned char *)entry)];
     p = *q;
 #endif
     r = NULL;
     for (; p; p = p->next) {
         if (strcmp (entry, p->name) == 0) {
             do_cancel_module (p, q, r);
             return;
         }
         r = p;
     }
 }

COB_EXPIMP void cob_cancel_field	(	const cob_field *	,
		const struct cob_call_struct *
	)

 {
     char                *name;
     const char          *entry;
     const struct cob_call_struct    *s;
     
     int (*cancel_func)(const int, void *, void *, void *, void *);
 
     if (unlikely(!cobglobptr)) {
         cob_fatal_error (COB_FERROR_INITIALIZED);
     }
     if (!f || f->size == 0) {
         return;
     }
     name = cob_get_buff (f->size + 1);
     cob_field_to_string (f, name, f->size);
     entry = cob_chk_dirp (name);
 
     /* Check if contained program */
     for (s = cs; s && s->cob_cstr_name; s++) {
         if (!strcmp (entry, s->cob_cstr_name)) {
             if (s->cob_cstr_cancel.funcvoid) {
                 cancel_func = s->cob_cstr_cancel.funcint;
                 (void)cancel_func (-1, NULL, NULL, NULL,
                            NULL);
             }
             return;
         }
     }
     cob_cancel (entry);
 }

COB_EXPIMP void cob_chain_setup	(	void *	,
		const size_t	,
		const size_t
	)

 {
     size_t  len;
 
     memset (data, ' ', size);
     if (parm <= (size_t)cob_argc - 1) {
         len = strlen (cob_argv[parm]);
         if (len <= size) {
             memcpy (data, cob_argv[parm], len);
         } else {
             memcpy (data, cob_argv[parm], size);
         }
     } else {
         memset (data, ' ', size);
     }
     cobglobptr->cob_call_params = cob_argc - 1;
 }

COB_EXPIMP void cob_check_based	(	const unsigned char *	,
		const char *
	)

 {
     if (!x) {
         cob_runtime_error (_("BASED/LINKAGE item '%s' has NULL address"), name);
         cob_stop_run (1);
     }
 }

COB_EXPIMP void cob_check_numeric	(	const cob_field *	,
		const char *
	)

 {
     unsigned char   *data;
     char        *p;
     char        *buff;
     size_t      i;
 
     if (!cob_is_numeric (f)) {
         buff = cob_fast_malloc ((size_t)COB_SMALL_BUFF);
         p = buff;
         data = f->data;
         for (i = 0; i < f->size; ++i) {
             if (isprint (data[i])) {
                 *p++ = data[i];
             } else {
                 p += sprintf (p, "\\%03o", data[i]);
             }
         }
         *p = '\0';
         cob_runtime_error (_("'%s' not numeric: '%s'"), name, buff);
         cob_free (buff);
         cob_stop_run (1);
     }
 }

COB_EXPIMP void cob_check_odo	(	const int	,
		const int	,
		const int	,
		const char *
	)

 {
     /* Check OCCURS DEPENDING ON item */
     if (i < min || max < i) {
         cob_set_exception (COB_EC_BOUND_ODO);
         cob_runtime_error (_("OCCURS DEPENDING ON '%s' out of bounds: %d"), name, i);
         cob_stop_run (1);
     }
 }

COB_EXPIMP void cob_check_ref_mod	(	const int	,
		const int	,
		const int	,
		const char *
	)

 {
     /* Check offset */
     if (offset < 1 || offset > size) {
         cob_set_exception (COB_EC_BOUND_REF_MOD);
         cob_runtime_error (_("Offset of '%s' out of bounds: %d"), name, offset);
         cob_stop_run (1);
     }
 
     /* Check length */
     if (length < 1 || offset + length - 1 > size) {
         cob_set_exception (COB_EC_BOUND_REF_MOD);
         cob_runtime_error (_("Length of '%s' out of bounds: %d"), name, length);
         cob_stop_run (1);
     }
 }

COB_EXPIMP void cob_check_subscript	(	const int	,
		const int	,
		const int	,
		const char *
	)

 {
     /* Check subscript */
     if (i < min || max < i) {
         cob_set_exception (COB_EC_BOUND_SUBSCRIPT);
         cob_runtime_error (_("Subscript of '%s' out of bounds: %d"), name, i);
         cob_stop_run (1);
     }
 }

COB_EXPIMP void cob_check_version	(	const char *	,
		const char *	,
		const int
	)

 {
     if (strcmp (packver, PACKAGE_VERSION) || patchlev != PATCH_LEVEL) {
         cob_runtime_error (_("Error - Version mismatch"));
         cob_runtime_error (_("%s has version/patch level %s/%d"), prog,
                    packver, patchlev);
         cob_runtime_error (_("Library has version/patch level %s/%d"),
                    PACKAGE_VERSION, PATCH_LEVEL);
         cob_stop_run (1);
     }
 }

COB_EXPIMP void cob_close	(	cob_file *	,
		cob_field *	,
		const int	,
		const int
	)

 {
     struct file_list    *l;
     struct file_list    *m;
     int         ret;
 
     f->flag_read_done = 0;
     f->flag_operation = 0;
 
     f->lock_mode &= ~COB_LOCK_OPEN_EXCLUSIVE;
 
     if (COB_FILE_SPECIAL (f)) {
         f->open_mode = COB_OPEN_CLOSED;
         f->file = NULL;
         f->fd = -1;
         save_status (f, fnstatus, COB_STATUS_00_SUCCESS);
         return;
     }
 
     if (unlikely(remfil)) {
         /* Remove from cache - Needed for CANCEL */
         /* Setting m silences false compiler warning */
         m = file_cache;
         for (l = file_cache; l; l = l->next) {
             if (f == l->file) {
                 if (l == file_cache) {
                     file_cache = l->next;
                 } else {
                     m->next = l->next;
                 }
                 cob_free (l);
                 break;
             }
             m = l;
         }
     }
 
     if (f->open_mode == COB_OPEN_CLOSED) {
         save_status (f, fnstatus, COB_STATUS_42_NOT_OPEN);
         return;
     }
 
     if (f->flag_nonexistent) {
         ret = COB_STATUS_00_SUCCESS;
     } else {
         ret = fileio_funcs[(int)f->organization]->close (f, opt);
     }
 
     if (ret == COB_STATUS_00_SUCCESS) {
         switch (opt) {
         case COB_CLOSE_LOCK:
             f->open_mode = COB_OPEN_LOCKED;
             break;
         default:
             f->open_mode = COB_OPEN_CLOSED;
             break;
         }
     }
 
     save_status (f, fnstatus, ret);
 }

COB_EXPIMP int cob_cmp	(	cob_field *	,
		cob_field *
	)

 {
     cob_field   temp;
     cob_field_attr  attr;
     unsigned char   buff[256];
 
     if (COB_FIELD_IS_NUMERIC (f1) && COB_FIELD_IS_NUMERIC (f2)) {
         return cob_numeric_cmp (f1, f2);
     }
     if (COB_FIELD_TYPE (f2) == COB_TYPE_ALPHANUMERIC_ALL) {
         if (f2->size == 1 && f2->data[0] == '0' &&
             COB_FIELD_IS_NUMERIC (f1)) {
             return cob_cmp_int (f1, 0);
         }
         return cob_cmp_all (f1, f2);
     }
     if (COB_FIELD_TYPE (f1) == COB_TYPE_ALPHANUMERIC_ALL) {
         if (f1->size == 1 && f1->data[0] == '0' &&
             COB_FIELD_IS_NUMERIC (f2)) {
             return -cob_cmp_int (f2, 0);
         }
         return -cob_cmp_all (f2, f1);
     }
     if (COB_FIELD_IS_NUMERIC (f1) &&
         COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_DISPLAY) {
         temp.size = COB_FIELD_DIGITS(f1);
         temp.data = buff;
         temp.attr = &attr;
         attr = *f1->attr;
         attr.type = COB_TYPE_NUMERIC_DISPLAY;
         attr.flags &= ~COB_FLAG_HAVE_SIGN;
         cob_move (f1, &temp);
         f1 = &temp;
     }
     if (COB_FIELD_IS_NUMERIC (f2) &&
         COB_FIELD_TYPE (f2) != COB_TYPE_NUMERIC_DISPLAY) {
         temp.size = COB_FIELD_DIGITS(f2);
         temp.data = buff;
         temp.attr = &attr;
         attr = *f2->attr;
         attr.type = COB_TYPE_NUMERIC_DISPLAY;
         attr.flags &= ~COB_FLAG_HAVE_SIGN;
         cob_move (f2, &temp);
         f2 = &temp;
     }
     return cob_cmp_alnum (f1, f2);
 }

COB_EXPIMP int cob_cmp_float	(	cob_field *	,
		cob_field *
	)

 {
     double  d1,d2;
     float   flt;
     if(COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_FLOAT) {
         memcpy(&flt,f1->data,sizeof(float));
         d1 = flt;
     } else if(COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_DOUBLE) {
         memcpy(&d1,f1->data,sizeof(double));
     } else {
         cob_decimal_set_field (&cob_d1, f1);
         d1 = cob_decimal_get_double(&cob_d1);
     }
     if(COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_FLOAT) {
         memcpy(&flt,f2->data,sizeof(float));
         d2 = flt;
     } else if(COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_DOUBLE) {
         memcpy(&d2,f2->data,sizeof(double));
     } else {
         cob_decimal_set_field (&cob_d1, f2);
         d2 = cob_decimal_get_double(&cob_d1);
     }
     if(d1 == d2)
         return 0;
     if(d1 != 0.0
     && FLOAT_EQ(d1,d2,TOLERANCE))
         return 0;
     if(d1 < d2)
         return -1;
     return 1;
 }

COB_EXPIMP int cob_cmp_int	(	cob_field *	,
		const int
	)

 {
     cob_decimal_set_field (&cob_d1, f1);
     mpz_set_si (cob_d2.value, (cob_sli_t)n);
     cob_d2.scale = 0;
     return cob_decimal_cmp (&cob_d1, &cob_d2);
 }

COB_EXPIMP int cob_cmp_llint	(	cob_field *	,
		const cob_s64_t
	)

 {
 #ifdef  COB_LI_IS_LL
     mpz_set_si (cob_d2.value, (cob_sli_t)n);
 #else
     cob_u64_t   uval;
     cob_u32_t   negative;
 
     negative = 0;
     if (n < 0) {
         negative = 1;
         uval = (cob_u64_t)-n;
     } else {
         uval = (cob_u64_t)n;
     }
     mpz_set_ui (cob_d2.value, (cob_uli_t)(uval >> 32));
     mpz_mul_2exp (cob_d2.value, cob_d2.value, 32);
     mpz_add_ui (cob_d2.value, cob_d2.value, (cob_uli_t)(uval & 0xFFFFFFFFU));
     if (negative) {
         mpz_neg (cob_d2.value, cob_d2.value);
     }
 #endif
 
     cob_d2.scale = 0;
     cob_decimal_set_field (&cob_d1, f1);
     return cob_decimal_cmp (&cob_d1, &cob_d2);
 }

COB_EXPIMP int cob_cmp_numdisp	(	const unsigned char *	,
		const size_t	,
		const cob_s64_t	,
		const cob_u32_t
	)

 {
     const unsigned char *p;
     cob_s64_t       val = 0;
     size_t          inc;
 
     p = data;
     if (!has_sign) {
         if (unlikely(n < 0)) {
             return 1;
         }
         for (inc = 0; inc < size; inc++, p++) {
             val = (val * 10) + COB_D2I (*p);
         }
         return (val < n) ? -1 : (val > n);
     }
     for (inc = 0; inc < size - 1; inc++, p++) {
         val = (val * 10) + COB_D2I (*p);
     }
     val *= 10;
     if (*p >= (unsigned char)'0' && *p <= (unsigned char)'9') {
         val += COB_D2I (*p);
     } else {
         if (unlikely(COB_MODULE_PTR->ebcdic_sign)) {
             if (cob_get_long_ebcdic_sign (p, &val)) {
                 val = -val;
             }
         } else {
 #ifdef  COB_EBCDIC_MACHINE
             if (cob_get_long_ascii_sign (p, &val)) {
                 val = -val;
             }
 #else
             if (*p >= (unsigned char)'p' && *p <= (unsigned char)'y') {
                 val += (*p - (unsigned char)'p');
                 val = -val;
             }
 #endif
         }
     }
     return (val < n) ? -1 : (val > n);
 }

COB_EXPIMP int cob_cmp_packed	(	cob_field *	,
		const cob_s64_t
	)

 {
     unsigned char       *p;
     cob_u64_t       n;
     size_t          size;
     size_t          inc;
     int         sign;
     unsigned char       val1[20];
 
     sign = cob_packed_get_sign (f);
     /* Field positive, value negative */
     if (sign >= 0 && val < 0) {
         return 1;
     }
     /* Field negative, value positive */
     if (sign < 0 && val >= 0) {
         return -1;
     }
     /* Both positive or both negative */
     if (val < 0) {
         n = (cob_u64_t)-val;
     } else {
         n = (cob_u64_t)val;
     }
     inc = 0;
     p = f->data;
     for (size = 0; size < 20; size++) {
         if (size < 20 - f->size) {
             val1[size] = 0;
         } else {
             val1[size] = p[inc++];
         }
     }
     if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
         if ((COB_FIELD_DIGITS(f) % 2) == 1) {
             val1[20 - f->size] &= 0x0F;
         }
     } else {
         val1[19] &= 0xF0;
         if ((COB_FIELD_DIGITS(f) % 2) == 0) {
             val1[20 - f->size] &= 0x0F;
         }
     }
     if (n != last_packed_val) {
         last_packed_val = n;
         memset (packed_value, 0, sizeof(packed_value));
         if (n) {
             p = &packed_value[19];
             if (!COB_FIELD_NO_SIGN_NIBBLE (f)) {
                 *p =  (n % 10) << 4;
                 p--;
                 n /= 10;
             }
             for (; n;) {
                 size = n % 100;
                 *p = (unsigned char)((size % 10) | ((size / 10) << 4));
                 n /= 100;
                 p--;
             }
         }
     }
     for (size = 0; size < 20; size++) {
         if (val1[size] != packed_value[size]) {
             if (sign < 0) {
                 return packed_value[size] - val1[size];
             } else {
                 return val1[size] - packed_value[size];
             }
         }
     }
     return 0;
 }

COB_EXPIMP int cob_cmp_uint	(	cob_field *	,
		const unsigned	int
	)

 {
     cob_decimal_set_field (&cob_d1, f1);
     mpz_set_ui (cob_d2.value, (cob_uli_t)n);
     cob_d2.scale = 0;
     return cob_decimal_cmp (&cob_d1, &cob_d2);
 }

COB_EXPIMP void* cob_command_line	(	int	,
		int *	,
		char ***	,
		char ***	,
		char **
	)

 {
 #if 0   /* RXWRXW cob_command_line */
     char        **spenvp;
     char        *spname;
 #else
     COB_UNUSED (penvp);
     COB_UNUSED (pname);
 #endif
 
     COB_UNUSED (flags);
 
     if (!cob_initialized) {
         cob_runtime_error (_("'cobcommandline' - Runtime has not been initialized"));
         cob_stop_run (1);
     }
     if (pargc && pargv) {
         cob_argc = *pargc;
         cob_argv = *pargv;
     }
 
 #if 0   /* RXWRXW cob_command_line */
     if (penvp) {
         spenvp = *penvp;
     }
     if (pname) {
         spname = *pname;
     }
 #endif
 
     /* What are we supposed to return here? */
     return NULL;
 }

COB_EXPIMP void cob_commit ( void )

 {
     struct file_list    *l;
 
     for (l = file_cache; l; l = l->next) {
         if (l->file) {
             cob_file_unlock (l->file);
         }
     }
 }

COB_EXPIMP void cob_correct_numeric ( cob_field * )

 {
     unsigned char   *p;
     unsigned char   *data;
     size_t      size;
     size_t      i;
 
     if (!COB_FIELD_IS_NUMDISP(f)) {
         return;
     }
     size = f->size;
     data = f->data;
     if (COB_FIELD_HAVE_SIGN (f)) {
         /* Adjust for sign byte */
         size--;
         if (unlikely(COB_FIELD_SIGN_LEADING (f))) {
             p = f->data;
             data = p + 1;
         } else {
             p = f->data + f->size - 1;
         }
         if (unlikely(COB_FIELD_SIGN_SEPARATE (f))) {
             if (*p != '+' && *p != '-') {
                 *p = '+';
             }
         } else if (unlikely(COB_MODULE_PTR->ebcdic_sign)) {
             switch (*p) {
             case '{':
             case 'A':
             case 'B':
             case 'C':
             case 'D':
             case 'E':
             case 'F':
             case 'G':
             case 'H':
             case 'I':
             case '}':
             case 'J':
             case 'K':
             case 'L':
             case 'M':
             case 'N':
             case 'O':
             case 'P':
             case 'Q':
             case 'R':
                 break;
             case '0':
                 *p = '{';
                 break;
             case '1':
                 *p = 'A';
                 break;
             case '2':
                 *p = 'B';
                 break;
             case '3':
                 *p = 'C';
                 break;
             case '4':
                 *p = 'D';
                 break;
             case '5':
                 *p = 'E';
                 break;
             case '6':
                 *p = 'F';
                 break;
             case '7':
                 *p = 'G';
                 break;
             case '8':
                 *p = 'H';
                 break;
             case '9':
                 *p = 'I';
                 break;
             case 0:
             case ' ':
                 *p = '{';
                 break;
             default:
                 break;
             }
         } else {
             if(!*p || *p == ' ') {
                 *p = '0';
             }
         }
     } else {
         p = f->data + f->size - 1;
         if (unlikely(COB_MODULE_PTR->ebcdic_sign)) {
             switch (*p) {
             case 0:
             case ' ':
             case '{':
             case '}':
                 *p = '0';
                 break;
             case 'A':
             case 'B':
             case 'C':
             case 'D':
             case 'E':
             case 'F':
             case 'G':
             case 'H':
             case 'I':
                 *p = '1' + (*p - 'A');
                 break;
             case 'J':
             case 'K':
             case 'L':
             case 'M':
             case 'N':
             case 'O':
             case 'P':
             case 'Q':
             case 'R':
                 *p = '1' + (*p - 'J');
                 break;
             default:
                 break;
             }
         } else {
             switch (*p) {
             case 0:
             case ' ':
             case 'p':
                 *p = '0';
                 break;
             case 'q':
                 *p = '1';
                 break;
             case 'r':
                 *p = '2';
                 break;
             case 's':
                 *p = '3';
                 break;
             case 't':
                 *p = '4';
                 break;
             case 'u':
                 *p = '5';
                 break;
             case 'v':
                 *p = '6';
                 break;
             case 'w':
                 *p = '7';
                 break;
             case 'x':
                 *p = '8';
                 break;
             case 'y':
                 *p = '9';
                 break;
             default:
                 break;
             }
         }
     }
     for (i = 0, p = data; i < size; ++i, ++p) {
         switch (*p) {
         case '0':
         case '1':
         case '2':
         case '3':
         case '4':
         case '5':
         case '6':
         case '7':
         case '8':
         case '9':
             break;
         case 0:
         case ' ':
             *p = '0';
             break;
         default:
             if ((*p & 0x0F) <= 9) {
                 *p = (*p & 0x0F) + '0';
             }
             break;
         }
     }
 }

COB_EXPIMP void cob_decimal_add	(	cob_decimal *	,
		cob_decimal *
	)

 {
     DECIMAL_CHECK (d1, d2);
     align_decimal (d1, d2);
     mpz_add (d1->value, d1->value, d2->value);
 }

COB_EXPIMP void cob_decimal_alloc	(	const cob_u32_t	,
			...
	)

 {
     cob_decimal **dec;
     cob_u32_t   i;
     va_list     args;
 
     va_start (args, params);
     for (i = 0; i < params; ++i) {
         dec = va_arg (args, cob_decimal **);
         *dec = cob_decimal_base + i;
     }
     va_end (args);
 }

COB_EXPIMP int cob_decimal_cmp	(	cob_decimal *	,
		cob_decimal *
	)

 {
     align_decimal (d1, d2);
     return mpz_cmp (d1->value, d2->value);
 }

COB_EXPIMP void cob_decimal_div	(	cob_decimal *	,
		cob_decimal *
	)

 {
     DECIMAL_CHECK (d1, d2);
 
     /* Check for division by zero */
     if (unlikely(mpz_sgn (d2->value) == 0)) {
         d1->scale = COB_DECIMAL_NAN;
         cob_set_exception (COB_EC_SIZE_ZERO_DIVIDE);
         return;
     }
     if (unlikely(mpz_sgn (d1->value) == 0)) {
         d1->scale = 0;
         return;
     }
     d1->scale -= d2->scale;
     shift_decimal (d1, COB_MAX_DIGITS + ((d1->scale < 0) ? -d1->scale : 0));
 #if 0   /* RXWRXW - cdiv */
     mpz_cdiv_q (d1->value, d1->value, d2->value);
 #endif
     mpz_tdiv_q (d1->value, d1->value, d2->value);
 }

COB_EXPIMP int cob_decimal_get_field	(	cob_decimal *	,
		cob_field *	,
		const int
	)

 {
     cob_field       temp;
     cob_field_attr      attr;
     union {
         double          val;
         float           fval;
     } uval;
 
     if (unlikely(d->scale == COB_DECIMAL_NAN)) {
         cob_set_exception (COB_EC_SIZE_OVERFLOW);
         return cobglobptr->cob_exception_code;
     }
 
     /* work copy */
     if (d != &cob_d1) {
         mpz_set (cob_d1.value, d->value);
         cob_d1.scale = d->scale;
         d = &cob_d1;
     }
 
 #if 0   /* RXWRXW - Round FP */
     if (!COB_FIELD_IS_FP(f)) {
 #endif
         /* Rounding */
         if ((opt & COB_STORE_ROUND)) {
             cob_decimal_do_round (d, f, opt);
         }
         /* Append or truncate decimal digits */
         shift_decimal (d, COB_FIELD_SCALE(f) - d->scale);
 #if 0   /* RXWRXW - Round FP */
     }
 #endif
 
     /* Store number */
     switch (COB_FIELD_TYPE (f)) {
     case COB_TYPE_NUMERIC_BINARY:
         return cob_decimal_get_binary (d, f, opt);
     case COB_TYPE_NUMERIC_DISPLAY:
         return cob_decimal_get_display (d, f, opt);
     case COB_TYPE_NUMERIC_PACKED:
         return cob_decimal_get_packed (d, f, opt);
     case COB_TYPE_NUMERIC_FLOAT:
         uval.fval = (float) cob_decimal_get_double (d);
         memcpy (f->data, &uval.fval, sizeof (float));
         return 0;
     case COB_TYPE_NUMERIC_DOUBLE:
         uval.val = cob_decimal_get_double (d);
         memcpy (f->data, &uval.val, sizeof (double));
         return 0;
     case COB_TYPE_NUMERIC_FP_DEC64:
         return cob_decimal_get_ieee64dec (d, f, opt);
     case COB_TYPE_NUMERIC_FP_DEC128:
         return cob_decimal_get_ieee128dec (d, f, opt);
     default:
         break;
     }
     COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, COB_FIELD_DIGITS(f),
             COB_FIELD_SCALE(f), COB_FLAG_HAVE_SIGN, NULL);
     temp.size = COB_FIELD_DIGITS(f);
     temp.data = cob_malloc (COB_FIELD_DIGITS(f));
     temp.attr = &attr;
     if (cob_decimal_get_display (d, &temp, opt) == 0) {
         cob_move (&temp, f);
         cob_free (temp.data);
         return 0;
     }
     cob_free (temp.data);
     return cobglobptr->cob_exception_code;
 }

COB_EXPIMP void cob_decimal_init ( cob_decimal * )

 {
     mpz_init2 (d->value, COB_MPZ_DEF);
     d->scale = 0;
 }

COB_EXPIMP void cob_decimal_mul	(	cob_decimal *	,
		cob_decimal *
	)

 {
     DECIMAL_CHECK (d1, d2);
     d1->scale += d2->scale;
     mpz_mul (d1->value, d1->value, d2->value);
 }

COB_EXPIMP void cob_decimal_pop	(	const cob_u32_t	,
			...
	)

 {
     cob_decimal *dec;
     cob_u32_t   i;
     va_list     args;
 
     va_start (args, params);
     for (i = 0; i < params; ++i) {
         dec = va_arg (args, cob_decimal *);
         mpz_clear (dec->value);
         cob_free (dec);
     }
     va_end (args);
 }

COB_EXPIMP void cob_decimal_pow	(	cob_decimal *	,
		cob_decimal *
	)

 {
     cob_uli_t       n;
     int         sign;
 
     if (unlikely(pd1->scale == COB_DECIMAL_NAN)) {
         return;
     }
     if (unlikely(pd2->scale == COB_DECIMAL_NAN)) {
         pd1->scale = COB_DECIMAL_NAN;
         return;
     }
 
     sign = mpz_sgn (pd1->value);
 
     if (!mpz_sgn (pd2->value)) {
         /* Exponent is zero */
         if (!sign) {
             /* 0 ^ 0 */
             cob_set_exception (COB_EC_SIZE_EXPONENTIATION);
         }
         mpz_set_ui (pd1->value, 1UL);
         pd1->scale = 0;
         return;
     }
     if (!sign) {
         /* Value is zero */
         pd1->scale = 0;
         return;
     }
 
     cob_trim_decimal (pd2);
 
     if (sign < 0 && pd2->scale) {
         /* Negative exponent and non-integer power */
         pd1->scale = COB_DECIMAL_NAN;
         cob_set_exception (COB_EC_SIZE_EXPONENTIATION);
         return;
     }
 
     cob_trim_decimal (pd1);
 
     if (!pd2->scale) {
         /* Integer power */
         if (!mpz_cmp_ui (pd2->value, 1UL)) {
             /* Power is 1 */
             return;
         }
         if (mpz_sgn (pd2->value) < 0 && mpz_fits_slong_p (pd2->value)) {
             /* Negative power */
             mpz_abs (pd2->value, pd2->value);
             n = mpz_get_ui (pd2->value);
             mpz_pow_ui (pd1->value, pd1->value, n);
             if (pd1->scale) {
                 pd1->scale *= n;
                 cob_trim_decimal (pd1);
             }
             cob_decimal_set (pd2, pd1);
             mpz_set_ui (pd1->value, 1UL),
             pd1->scale = 0;
             cob_decimal_div (pd1, pd2);
             cob_trim_decimal (pd1);
             return;
         }
         if (mpz_fits_ulong_p (pd2->value)) {
             /* Positive power */
             n = mpz_get_ui (pd2->value);
             mpz_pow_ui (pd1->value, pd1->value, n);
             if (pd1->scale) {
                 pd1->scale *= n;
                 cob_trim_decimal (pd1);
             }
             return;
         }
     }
 
     if (sign < 0) {
         mpz_abs (pd1->value, pd1->value);
     }
     cob_decimal_get_mpf (cob_mpft, pd1);
     if (pd2->scale == 1 && !mpz_cmp_ui (pd2->value, 5UL)) {
         /* Square root short cut */
         mpf_sqrt (cob_mpft2, cob_mpft);
     } else {
         cob_decimal_get_mpf (cob_mpft2, pd2);
         cob_mpf_log (cob_mpft, cob_mpft);
         mpf_mul (cob_mpft, cob_mpft, cob_mpft2);
         cob_mpf_exp (cob_mpft2, cob_mpft);
     }
     cob_decimal_set_mpf (pd1, cob_mpft2);
     if (sign < 0) {
         mpz_neg (pd1->value, pd1->value);
     }
 }

COB_EXPIMP void cob_decimal_push	(	const cob_u32_t	,
			...
	)

 {
     cob_decimal **dec;
     cob_u32_t   i;
     va_list     args;
 
     va_start (args, params);
     for (i = 0; i < params; ++i) {
         dec = va_arg (args, cob_decimal **);
         *dec = cob_malloc (sizeof(cob_decimal));
         cob_decimal_init (*dec);
     }
     va_end (args);
 }

COB_EXPIMP void cob_decimal_set_field	(	cob_decimal *	,
		cob_field *
	)

 {
     union {
         double  dval;
         float   fval;
     } uval;
 
     switch (COB_FIELD_TYPE (f)) {
     case COB_TYPE_NUMERIC_BINARY:
         cob_decimal_set_binary (d, f);
         break;
     case COB_TYPE_NUMERIC_PACKED:
         cob_decimal_set_packed (d, f);
         break;
     case COB_TYPE_NUMERIC_FLOAT:
         memcpy ((void *)&uval.fval, f->data, sizeof(float));
         cob_decimal_set_double (d, (double)uval.fval);
         break;
     case COB_TYPE_NUMERIC_DOUBLE:
         memcpy ((void *)&uval.dval, f->data, sizeof(double));
         cob_decimal_set_double (d, uval.dval);
         break;
     case COB_TYPE_NUMERIC_FP_DEC64:
         cob_decimal_set_ieee64dec (d, f);
         break;
     case COB_TYPE_NUMERIC_FP_DEC128:
         cob_decimal_set_ieee128dec (d, f);
         break;
     default:
         cob_decimal_set_display (d, f);
         break;
     }
 }

COB_EXPIMP void cob_decimal_set_llint	(	cob_decimal *	,
		const cob_s64_t
	)

 {
 #ifdef  COB_LI_IS_LL
     mpz_set_si (d->value, (cob_sli_t)n);
 #else
     cob_u64_t   uval;
     cob_u32_t   negative;
 
     negative = 0;
     if (n < 0) {
         negative = 1;
         uval = (cob_u64_t)-n;
     } else {
         uval = (cob_u64_t)n;
     }
     mpz_set_ui (d->value, (cob_uli_t)(uval >> 32));
     mpz_mul_2exp (d->value, d->value, 32);
     mpz_add_ui (d->value, d->value, (cob_uli_t)(uval & 0xFFFFFFFFU));
     if (negative) {
         mpz_neg (d->value, d->value);
     }
 #endif
     d->scale = 0;
 }

COB_EXPIMP void cob_decimal_sub	(	cob_decimal *	,
		cob_decimal *
	)

 {
     DECIMAL_CHECK (d1, d2);
     align_decimal (d1, d2);
     mpz_sub (d1->value, d1->value, d2->value);
 }

COB_EXPIMP void cob_delete	(	cob_file *	,
		cob_field *
	)

 {
     int read_done;
 
     read_done = f->flag_read_done;
     f->flag_read_done = 0;
 
     if (unlikely(f->open_mode != COB_OPEN_I_O)) {
         save_status (f, fnstatus, COB_STATUS_49_I_O_DENIED);
         return;
     }
 
     if (f->access_mode == COB_ACCESS_SEQUENTIAL && !read_done) {
         save_status (f, fnstatus, COB_STATUS_43_READ_NOT_DONE);
         return;
     }
 
     save_status (f, fnstatus,
              fileio_funcs[(int)f->organization]->fdelete (f));
 }

COB_EXPIMP void cob_delete_file	(	cob_file *	,
		cob_field *
	)

 {
     if (f->organization == COB_ORG_SORT) {
         save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR);
         return;
     }
 
     /* File was previously closed with lock */
     if (f->open_mode == COB_OPEN_LOCKED) {
         save_status (f, fnstatus, COB_STATUS_38_CLOSED_WITH_LOCK);
         return;
     }
 
     /* File is open */
     if (f->open_mode != COB_OPEN_CLOSED) {
         save_status (f, fnstatus, COB_STATUS_41_ALREADY_OPEN);
         return;
     }
 
     if (unlikely(COB_FILE_STDIN (f))) {
         save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR);
         return;
     }
     if (unlikely(COB_FILE_STDOUT (f))) {
         save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR);
         return;
     }
 
     /* Obtain the file name */
     cob_field_to_string (f->assign, file_open_name, (size_t)COB_FILE_MAX);
     cob_chk_file_mapping ();
 
     if (f->organization != COB_ORG_INDEXED) {
 #ifdef  WITH_SEQRA_EXTFH
         save_status (f, fnstatus, COB_STATUS_91_NOT_AVAILABLE);
         return;
 #else
         unlink (file_open_name);
 #endif
     } else {
 #ifdef  WITH_INDEX_EXTFH
         save_status (f, fnstatus, COB_STATUS_91_NOT_AVAILABLE);
         return;
 #else
         indexed_file_delete (f, file_open_name);
 #endif
     }
     save_status (f, fnstatus, COB_STATUS_00_SUCCESS);
 }

COB_EXPIMP void cob_display	(	const int	,
		const int	,
		const int	,
			...
	)

 {
     FILE        *fp;
     cob_field   *f;
     int     i;
     int     nlattr;
     cob_u32_t   disp_redirect;
     va_list     args;
 
     disp_redirect = 0;
     if (to_stderr) {
         fp = stderr;
     } else {
         fp = stdout;
         if (cobglobptr->cob_screen_initialized) {
             if (!COB_DISP_TO_STDERR) {
                 disp_redirect = 1;
             } else {
                 fp = stderr;
             }
         }
     }
 
     nlattr = newline ? COB_SCREEN_EMULATE_NL : 0;
     va_start (args, varcnt);
     for (i = 0; i < varcnt; ++i) {
         f = va_arg (args, cob_field *);
         if (unlikely(disp_redirect)) {
             cob_field_display (f, NULL, NULL, NULL, NULL,
                        NULL, nlattr);
         } else {
             display_common (f, fp);
         }
     }
     va_end (args);
 
     if (newline && !disp_redirect) {
         putc ('\n', fp);
         fflush (fp);
     }
 }

COB_EXPIMP void cob_display_arg_number ( cob_field * )

 {
     int     n;
     cob_field_attr  attr;
     cob_field   temp;
 
     temp.size = 4;
     temp.data = (unsigned char *)&n;
     temp.attr = &attr;
     COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL);
     cob_move (f, &temp);
     if (n < 0 || n >= cob_argc) {
         cob_set_exception (COB_EC_IMP_DISPLAY);
         return;
     }
     current_arg = n;
 }

COB_EXPIMP void cob_display_command_line ( cob_field * )

 {
     if (commlnptr) {
         cob_free (commlnptr);
     }
     commlnptr = cob_malloc (f->size + 1U);
     commlncnt = f->size;
     memcpy (commlnptr, f->data, commlncnt);
 }

COB_EXPIMP void cob_display_env_value ( const cob_field * )

 {
     char    *env2;
 #if !HAVE_SETENV
     char    *p;
     size_t  len;
 #endif
     int     ret;
 
     if (!cob_local_env) {
         cob_set_exception (COB_EC_IMP_DISPLAY);
         return;
     }
     if (!*cob_local_env) {
         cob_set_exception (COB_EC_IMP_DISPLAY);
         return;
     }
     env2 = cob_malloc (f->size + 1U);
     cob_field_to_string (f, env2, f->size);
 #if HAVE_SETENV
     ret = setenv(cob_local_env, env2, 1);
 #else
     len = strlen (cob_local_env) + strlen (env2) + 3U;
     p = cob_fast_malloc (len);
     sprintf (p, "%s=%s", cob_local_env, env2);
     ret = putenv (p);
 #endif
     cob_free (env2);
     if (ret != 0) {
         cob_set_exception (COB_EC_IMP_DISPLAY);
         return;
     }
     /* Rescan term/screen variables */
     cob_rescan_env_vals ();
 }

COB_EXPIMP void cob_display_environment ( const cob_field * )

 {
     size_t  i;
 
     if (cob_local_env_size < f->size) {
         cob_local_env_size = f->size;
         if (cob_local_env) {
             cob_free (cob_local_env);
         }
         cob_local_env = cob_malloc (cob_local_env_size + 1U);
     }
     cob_field_to_string (f, cob_local_env, cob_local_env_size);
     if (unlikely(cobglobptr->cob_env_mangle)) {
         for (i = 0; i < strlen (cob_local_env); ++i) {
             if (!isalnum ((int)cob_local_env[i])) {
                 cob_local_env[i] = '_';
             }
         }
     }
 }

COB_EXPIMP void cob_div	(	cob_field *	,
		cob_field *	,
		const int
	)

 {
     cob_decimal_set_field (&cob_d1, f1);
     cob_decimal_set_field (&cob_d2, f2);
     cob_decimal_div (&cob_d1, &cob_d2);
     (void)cob_decimal_get_field (&cob_d1, f1, opt);
 }

COB_EXPIMP void cob_div_quotient	(	cob_field *	,
		cob_field *	,
		cob_field *	,
		const int
	)

 {
     /* Note that cob_div_quotient and cob_div_remainder must remain */
     /* separate because of COBOL rules. The quotient must be fully */
     /* evaluated before the remainder item is evaluated */
     /* eg. DIVIDE A BY B GIVING Z REMAINDER FLD (Z). */
 
     cob_decimal_set_field (&cob_d1, dividend);
     cob_decimal_set_field (&cob_d2, divisor);
     cob_decimal_set (&cob_d_remainder, &cob_d1);
 
     /* Compute quotient */
     cob_decimal_div (&cob_d1, &cob_d2);
     /* Check divide by zero - Exception is set in cob_decimal_div */
     if (cob_d1.scale == COB_DECIMAL_NAN) {
         /* Forces an early return from cob_div_remainder */
         cob_d_remainder.scale = COB_DECIMAL_NAN;
         return;
     }
 
     /* Set quotient */
     cob_decimal_set (&cob_d3, &cob_d1);
     (void)cob_decimal_get_field (&cob_d1, quotient, opt);
 
     /* Truncate digits from the quotient */
     shift_decimal (&cob_d3, COB_FIELD_SCALE(quotient) - cob_d3.scale);
 
     /* Compute remainder */
     cob_decimal_mul (&cob_d3, &cob_d2);
     cob_decimal_sub (&cob_d_remainder, &cob_d3);
 }

COB_EXPIMP void cob_div_remainder	(	cob_field *	,
		const int
	)

 {
     (void)cob_decimal_get_field (&cob_d_remainder, fld_remainder, opt);
 }

COB_EXPIMP int cob_extern_init ( void )

 {
     cob_init (0, NULL);
     return 0;
 }

COB_EXPIMP void* cob_external_addr	(	const char *	,
		const int
	)

 {
     struct cob_external *eptr;
 
     /* Locate or allocate EXTERNAL item */
     for (eptr = basext; eptr; eptr = eptr->next) {
         if (!strcmp (exname, eptr->ename)) {
             if (exlength > eptr->esize) {
                 cob_runtime_error (_("EXTERNAL item '%s' previously allocated with size %d, requested size is %d"),
                            exname, eptr->esize, exlength);
                 cob_stop_run (1);
             }
             cobglobptr->cob_initial_external = 0;
             return eptr->ext_alloc;
         }
     }
     eptr = cob_malloc (sizeof (struct cob_external));
     eptr->next = basext;
     eptr->esize = exlength;
     eptr->ename = cob_malloc (strlen (exname) + 1U);
     strcpy (eptr->ename, exname);
     eptr->ext_alloc = cob_malloc ((size_t)exlength);
     basext = eptr;
     cobglobptr->cob_initial_external = 1;
     return eptr->ext_alloc;
 }

COB_EXPIMP void* cob_fast_malloc ( const size_t )

 {
     void    *mptr;
 
     mptr = malloc (size);
     if (unlikely(!mptr)) {
         cob_fatal_error (COB_FERROR_MEMORY);
     }
     return mptr;
 }

DECLNORET COB_EXPIMP void cob_fatal_error ( const int )

 {
     const char  *msg;
     unsigned char   *file_status;
     char        *filename;
     int     status;
 
     switch (fatal_error) {
     case COB_FERROR_NONE:
         cob_runtime_error (_("cob_init() has not been called"));
         break;
     case COB_FERROR_CANCEL:
         cob_runtime_error (_("Attempt to CANCEL active program"));
         break;
     case COB_FERROR_INITIALIZED:
         cob_runtime_error (_("cob_init() has not been called"));
         break;
     case COB_FERROR_CODEGEN:
         cob_runtime_error (_("Codegen error - Please report this"));
         break;
     case COB_FERROR_CHAINING:
         cob_runtime_error (_("Recursive call of chained program"));
         break;
     case COB_FERROR_STACK:
         cob_runtime_error (_("Stack overflow, possible PERFORM depth exceeded"));
         break;
     case COB_FERROR_GLOBAL:
         cob_runtime_error (_("Invalid entry/exit in GLOBAL USE procedure"));
         break;
     case COB_FERROR_MEMORY:
         cob_runtime_error (_("Unable to allocate memory"));
         break;
     case COB_FERROR_MODULE:
         cob_runtime_error (_("Invalid entry into module"));
         break;
     case COB_FERROR_RECURSIVE:
         cob_runtime_error (_("Invalid recursive COBOL CALL"));
         break;
     case COB_FERROR_FREE:
         cob_runtime_error (_("Call to cob_free with NULL pointer"));
         break;
     case COB_FERROR_FILE:
         file_status = cobglobptr->cob_error_file->file_status;
         status = COB_D2I(file_status[0]) * 10 + COB_D2I(file_status[1]);
         switch (status) {
         case COB_STATUS_10_END_OF_FILE:
             msg = _("End of file");
             break;
         case COB_STATUS_14_OUT_OF_KEY_RANGE:
             msg = _("Key out of range");
             break;
         case COB_STATUS_21_KEY_INVALID:
             msg = _("Key order not ascending");
             break;
         case COB_STATUS_22_KEY_EXISTS:
             msg = _("Record key already exists");
             break;
         case COB_STATUS_23_KEY_NOT_EXISTS:
             msg = _("Record key does not exist");
             break;
         case COB_STATUS_30_PERMANENT_ERROR:
             msg = _("Permanent file error");
             break;
         case COB_STATUS_35_NOT_EXISTS:
             msg = _("File does not exist");
             break;
         case COB_STATUS_37_PERMISSION_DENIED:
             msg = _("Permission denied");
             break;
         case COB_STATUS_41_ALREADY_OPEN:
             msg = _("File already open");
             break;
         case COB_STATUS_42_NOT_OPEN:
             msg = _("File not open");
             break;
         case COB_STATUS_43_READ_NOT_DONE:
             msg = _("READ must be executed first");
             break;
         case COB_STATUS_44_RECORD_OVERFLOW:
             msg = _("Record overflow");
             break;
         case COB_STATUS_46_READ_ERROR:
             msg = _("Failed to read");
             break;
         case COB_STATUS_47_INPUT_DENIED:
             msg = _("READ/START not allowed");
             break;
         case COB_STATUS_48_OUTPUT_DENIED:
             msg = _("WRITE not allowed");
             break;
         case COB_STATUS_49_I_O_DENIED:
             msg = _("DELETE/REWRITE not allowed");
             break;
         case COB_STATUS_51_RECORD_LOCKED:
             msg = _("Record locked by another file connector");
             break;
         case COB_STATUS_57_I_O_LINAGE:
             msg = _("LINAGE values invalid");
             break;
         case COB_STATUS_61_FILE_SHARING:
             msg = _("File sharing conflict");
             break;
         case COB_STATUS_91_NOT_AVAILABLE:
             msg = _("Runtime library is not configured for this operation");
             break;
         default:
             msg = _("Unknown file error");
             break;
         }
         filename = cob_malloc ((size_t)COB_FILE_BUFF);
         cob_field_to_string (cobglobptr->cob_error_file->assign,
                      filename, (size_t)COB_FILE_MAX);
         cob_runtime_error (_("%s (Status = %02d) File : '%s'"),
                    msg, status, filename);
         cob_free (filename);
         break;
     case COB_FERROR_FUNCTION:
         cob_runtime_error (_("Attempt to use non-implemented function"));
         break;
     default:
         cob_runtime_error (_("Unknown failure : %d"), fatal_error);
         break;
     }
     cob_stop_run (1);
 }

COB_EXPIMP void cob_field_accept	(	cob_field *	,
		cob_field *	,
		cob_field *	,
		cob_field *	,
		cob_field *	,
		cob_field *	,
		cob_field *	,
		cob_field *	,
		const int
	)

 {
     COB_UNUSED (f);
     COB_UNUSED (line);
     COB_UNUSED (column);
     COB_UNUSED (fgc);
     COB_UNUSED (bgc);
     COB_UNUSED (fscroll);
     COB_UNUSED (ftimeout);
     COB_UNUSED (prompt);
     COB_UNUSED (attr);
 }

COB_EXPIMP void cob_field_display	(	cob_field *	,
		cob_field *	,
		cob_field *	,
		cob_field *	,
		cob_field *	,
		cob_field *	,
		const int
	)

 {
     COB_UNUSED (f);
     COB_UNUSED (line);
     COB_UNUSED (column);
     COB_UNUSED (fgc);
     COB_UNUSED (bgc);
     COB_UNUSED (fscroll);
     COB_UNUSED (attr);
 }

COB_EXPIMP void cob_file_release ( cob_file * )

 {
     struct cobsort  *hp;
     cob_field   *fnstatus;
     int     ret;
 
     fnstatus = NULL;
     hp = f->file;
     if (likely(hp)) {
         fnstatus = hp->fnstatus;
     }
     ret = cob_file_sort_submit (f, f->record->data);
     if (!ret) {
         save_status (f, fnstatus, COB_STATUS_00_SUCCESS);
         return;
     }
     if (likely(hp)) {
         *(int *)(hp->sort_return) = 16;
     }
     save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR);
 }

COB_EXPIMP void cob_file_return ( cob_file * )

 {
     struct cobsort  *hp;
     cob_field   *fnstatus;
     int     ret;
 
     fnstatus = NULL;
     hp = f->file;
     if (likely(hp)) {
         fnstatus = hp->fnstatus;
     }
     ret = cob_file_sort_retrieve (f, f->record->data);
     switch (ret) {
     case 0:
         save_status (f, fnstatus, COB_STATUS_00_SUCCESS);
         return;
     case COBSORTEND:
         save_status (f, fnstatus, COB_STATUS_10_END_OF_FILE);
         return;
     }
     if (likely(hp)) {
         *(int *)(hp->sort_return) = 16;
     }
     save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR);
 }

COB_EXPIMP void cob_file_sort_close ( cob_file * )

 {
     struct cobsort  *hp;
     cob_field   *fnstatus;
     size_t      i;
 
     fnstatus = NULL;
     hp = f->file;
     if (likely(hp)) {
         fnstatus = hp->fnstatus;
         cob_free_list (hp);
         for (i = 0; i < 4; ++i) {
             if (hp->file[i].fp != NULL) {
                 fclose (hp->file[i].fp);
             }
         }
         cob_free (hp);
     }
     if (f->keys) {
         cob_free (f->keys);
     }
     f->file = NULL;
     save_status (f, fnstatus, COB_STATUS_00_SUCCESS);
 }

COB_EXPIMP void cob_file_sort_giving	(	cob_file *	,
		const size_t	,
			...
	)

 {
     cob_file    **fbase;
     struct cobsort  *hp;
     size_t      i;
     int     ret;
     int     opt;
     va_list     args;
 
     fbase = cob_malloc (varcnt * sizeof(cob_file *));
     va_start (args, varcnt);
     for (i = 0; i < varcnt; ++i) {
         fbase[i] = va_arg (args, cob_file *);
     }
     va_end (args);
     for (i = 0; i < varcnt; ++i) {
         cob_open (fbase[i], COB_OPEN_OUTPUT, 0, NULL);
     }
     for (;;) {
         ret = cob_file_sort_retrieve (sort_file, sort_file->record->data);
         if (ret) {
             if (ret == COBSORTEND) {
                 sort_file->file_status[0] = '1';
                 sort_file->file_status[1] = '0';
             } else {
                 hp = sort_file->file;
                 *(int *)(hp->sort_return) = 16;
                 sort_file->file_status[0] = '3';
                 sort_file->file_status[1] = '0';
             }
             break;
         }
         for (i = 0; i < varcnt; ++i) {
             if (COB_FILE_SPECIAL (fbase[i]) ||
                 fbase[i]->organization == COB_ORG_LINE_SEQUENTIAL) {
                 opt = COB_WRITE_BEFORE | COB_WRITE_LINES | 1;
             } else {
                 opt = 0;
             }
             fbase[i]->record->size = fbase[i]->record_max;
             cob_copy_check (fbase[i], sort_file);
             cob_write (fbase[i], fbase[i]->record, opt, NULL, 0);
         }
     }
     for (i = 0; i < varcnt; ++i) {
         cob_close (fbase[i], NULL, COB_CLOSE_NORMAL, 0);
     }
     cob_free (fbase);
 }

COB_EXPIMP void cob_file_sort_init	(	cob_file *	,
		const unsigned	int,
		const unsigned char *	,
		void *	,
		cob_field *
	)

 {
     struct cobsort  *p;
     size_t      n;
 
     p = cob_malloc (sizeof (struct cobsort));
     p->fnstatus = fnstatus;
     p->size = f->record_max;
     p->r_size = f->record_max + sizeof(size_t);
     p->w_size = f->record_max + sizeof(size_t) + 1;
     n = sizeof (struct cobitem) - offsetof (struct cobitem, item);
     if (f->record_max <= n) {
         p->alloc_size = sizeof (struct cobitem);
     } else {
         p->alloc_size = offsetof (struct cobitem, item) + f->record_max;
     }
     if (p->alloc_size % sizeof(void *)) {
         p->alloc_size += sizeof(void *) - (p->alloc_size % sizeof(void *));
     }
     p->chunk_size = cob_sort_chunk;
     if (p->chunk_size % p->alloc_size) {
         p->chunk_size += p->alloc_size - (p->chunk_size % p->alloc_size);
     }
     p->pointer = f;
     p->sort_return = sort_return;
     *(int *)sort_return = 0;
     p->mem_base = cob_fast_malloc (sizeof (struct sort_mem_struct));
     p->mem_base->mem_ptr = cob_fast_malloc (p->chunk_size);
     p->mem_base->next = NULL;
     p->mem_size = p->chunk_size;
     p->mem_total = p->chunk_size;
     f->file = p;
     f->keys = cob_malloc (sizeof (cob_file_key) * nkeys);
     f->nkeys = 0;
     if (collating_sequence) {
         f->sort_collating = collating_sequence;
     } else {
         f->sort_collating = COB_MODULE_PTR->collating_sequence;
     }
     save_status (f, fnstatus, COB_STATUS_00_SUCCESS);
 }

COB_EXPIMP void cob_file_sort_init_key	(	cob_file *	,
		cob_field *	,
		const int	,
		const unsigned	int
	)

 {
     f->keys[f->nkeys].field = field;
     f->keys[f->nkeys].flag = flag;
     f->keys[f->nkeys].offset = offset;
     f->nkeys++;
 }

COB_EXPIMP void cob_file_sort_using	(	cob_file *	,
		cob_file *
	)

 {
     int     ret;
 
     cob_open (data_file, COB_OPEN_INPUT, 0, NULL);
     for (;;) {
         cob_read_next (data_file, NULL, COB_READ_NEXT);
         if (data_file->file_status[0] != '0') {
             break;
         }
         cob_copy_check (sort_file, data_file);
         ret = cob_file_sort_submit (sort_file, sort_file->record->data);
         if (ret) {
             break;
         }
     }
     cob_close (data_file, NULL, COB_CLOSE_NORMAL, 0);
 }

COB_EXPIMP void cob_free ( void * )

 {
 #ifdef _DEBUG
     if (unlikely(!mptr)) {
         cob_fatal_error (COB_FERROR_FREE);
     }
 #endif
     free (mptr);
 
 }

COB_EXPIMP void cob_free_alloc	(	unsigned char **	,
		unsigned char *
	)

 {
     struct cob_alloc_cache  *cache_ptr;
     struct cob_alloc_cache  *prev_ptr;
     void            *vptr1;
 
     /* FREE */
     cobglobptr->cob_exception_code = 0;
     cache_ptr = cob_alloc_base;
     prev_ptr = cob_alloc_base;
     if (ptr1 && *ptr1) {
         vptr1 = *ptr1;
         for (; cache_ptr; cache_ptr = cache_ptr->next) {
             if (vptr1 == cache_ptr->cob_pointer) {
                 cob_free (cache_ptr->cob_pointer);
                 if (cache_ptr == cob_alloc_base) {
                     cob_alloc_base = cache_ptr->next;
                 } else {
                     prev_ptr->next = cache_ptr->next;
                 }
                 cob_free (cache_ptr);
                 *ptr1 = NULL;
                 return;
             }
             prev_ptr = cache_ptr;
         }
         cob_set_exception (COB_EC_STORAGE_NOT_ALLOC);
         return;
     }
     if (ptr2 && *(void **)ptr2) {
         for (; cache_ptr; cache_ptr = cache_ptr->next) {
             if (*(void **)ptr2 == cache_ptr->cob_pointer) {
                 cob_free (cache_ptr->cob_pointer);
                 if (cache_ptr == cob_alloc_base) {
                     cob_alloc_base = cache_ptr->next;
                 } else {
                     prev_ptr->next = cache_ptr->next;
                 }
                 cob_free (cache_ptr);
                 *(void **)ptr2 = NULL;
                 return;
             }
             prev_ptr = cache_ptr;
         }
         cob_set_exception (COB_EC_STORAGE_NOT_ALLOC);
         return;
     }
 }

COB_EXPIMP int cob_func	(	const char *	,
		const int	,
		void **
	)

 {
     int ret;
 
     ret = cob_call (name, argc, argv);
     cob_cancel (name);
     return ret;
 }

void cob_gen_optim ( const enum cb_optim )

References _, COBC_ABORT, cobc_abort_pr(), and output_storage().

Referenced by codegen().

 {
     switch (val) {
 
     case COB_SET_SCREEN:
         output_storage ("static void COB_NOINLINE");
         output_storage ("cob_set_screen (cob_screen *s, cob_screen *next,");
         output_storage ("       cob_screen *child, cob_field *field, cob_field *value,");
         output_storage ("       cob_field *line, cob_field *column,");
         output_storage ("       cob_field *foreg, cob_field *backg, cob_field *prompt,");
         output_storage ("       const int type, const int occurs, const int attr)");
         output_storage ("{");
         output_storage ("   s->next = next;");
         output_storage ("   s->child = child;");
         output_storage ("   s->field = field;");
         output_storage ("   s->value = value;");
         output_storage ("   s->line = line;");
         output_storage ("   s->column = column;");
         output_storage ("   s->foreg = foreg;");
         output_storage ("   s->backg = backg;");
         output_storage ("   s->prompt = prompt;");
         output_storage ("   s->type = type;");
         output_storage ("   s->occurs = occurs;");
         output_storage ("   s->attr = attr;");
         output_storage ("}");
         return;
 
     case COB_POINTER_MANIP:
         output_storage ("static void COB_NOINLINE");
         output_storage ("cob_pointer_manip (cob_field *f1, cob_field *f2, const unsigned int addsub)");
         output_storage ("{");
         output_storage ("   unsigned char   *tmptr;");
         output_storage ("   memcpy (&tmptr, f1->data, sizeof(void *));");
         output_storage ("   if (addsub) {");
         output_storage ("       tmptr -= cob_get_int (f2);");
         output_storage ("   } else {");
         output_storage ("       tmptr += cob_get_int (f2);");
         output_storage ("   }");
         output_storage ("   memcpy (f1->data, &tmptr, sizeof(void *));");
         output_storage ("}");
         return;
 
     case COB_GET_NUMDISP:
         output_storage ("static int COB_NOINLINE");
         output_storage ("cob_get_numdisp (const void *data, const size_t size)");
         output_storage ("{");
         output_storage ("   const unsigned char *p;");
         output_storage ("   size_t          n;");
         output_storage ("   int              retval;");
 
         output_storage ("   p = (const unsigned char *)data;");
         output_storage ("   retval = 0;");
         output_storage ("   for (n = 0; n < size; ++n, ++p) {");
         output_storage ("       retval *= 10;");
         output_storage ("       retval += (*p & 0x0F);");
         output_storage ("   }");
         output_storage ("   return retval;");
         output_storage ("}");
         return;
 
     case COB_CMP_PACKED_INT:
         output_storage ("static int COB_NOINLINE");
         output_storage ("cob_cmp_packed_int (const cob_field *f, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   unsigned char   *p;");
         output_storage ("   size_t      size;");
         output_storage ("   cob_s64_t   val;");
 
         output_storage ("   val = 0;");
         output_storage ("   p = f->data;");
         output_storage ("   for (size = 0; size < f->size - 1; ++size, ++p) {");
         output_storage ("       val *= 10;");
         output_storage ("       val += *p >> 4;");
         output_storage ("       val *= 10;");
         output_storage ("       val += *p & 0x0f;");
         output_storage ("   }");
         output_storage ("   val *= 10;");
         output_storage ("   val += *p >> 4;");
         output_storage ("   if ((*p & 0x0f) == 0x0d) {");
         output_storage ("       val = -val;");
         output_storage ("   }");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_GET_PACKED_INT:
         output_storage ("static int COB_NOINLINE");
         output_storage ("cob_get_packed_int (const cob_field *f)");
         output_storage ("{");
         output_storage ("   unsigned char   *p;");
         output_storage ("   size_t      size;");
         output_storage ("   int     val = 0;");
 
         output_storage ("   p = f->data;");
         output_storage ("   for (size = 0; size < f->size - 1; ++size, ++p) {");
         output_storage ("       val *= 10;");
         output_storage ("       val += *p >> 4;");
         output_storage ("       val *= 10;");
         output_storage ("       val += *p & 0x0f;");
         output_storage ("   }");
         output_storage ("   val *= 10;");
         output_storage ("   val += *p >> 4;");
         output_storage ("   if ((*p & 0x0f) == 0x0d) {");
         output_storage ("       val = -val;");
         output_storage ("   }");
         output_storage ("   return val;");
         output_storage ("}");
         return;
 
     case COB_ADD_PACKED_INT:
         output_storage ("static int COB_NOINLINE");
         output_storage ("cob_add_packed_int (cob_field *f, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *p;");
         output_storage ("   size_t      size;");
         output_storage ("   int     carry = 0;");
         output_storage ("   int     n;");
         output_storage ("   int     inc;");
 
         output_storage ("   if (val == 0) {");
         output_storage ("       return 0;");
         output_storage ("   }");
         output_storage ("   p = f->data + f->size - 1;");
         output_storage ("   if ((*p & 0x0f) == 0x0d) {");
         output_storage ("       if (val > 0) {");
         output_storage ("           return cob_add_int (f, val, 0);");
         output_storage ("       }");
         output_storage ("       n = -val;");
         output_storage ("   } else {");
         output_storage ("       if (val < 0) {");
         output_storage ("           return cob_add_int (f, val, 0);");
         output_storage ("       }");
         output_storage ("       n = val;");
         output_storage ("   }");
         output_storage ("   inc = (*p >> 4) + (n %% 10);");
         output_storage ("   n /= 10;");
         output_storage ("   carry = inc / 10;");
         output_storage ("   *p = ((inc %% 10) << 4) | (*p & 0x0f);");
         output_storage ("   p--;");
 
         output_storage ("   for (size = 0; size < f->size - 1; ++size, --p) {");
         output_storage ("       if (!carry && !n) {");
         output_storage ("           break;");
         output_storage ("       }");
         output_storage ("       inc = ((*p >> 4) * 10) + (*p & 0x0f) + carry + (n %% 100);");
         output_storage ("       carry = inc / 100;");
         output_storage ("       n /= 100;");
         output_storage ("       inc %%= 100;");
         output_storage ("       *p = ((inc / 10) << 4) | (inc %% 10);");
         output_storage ("   }");
         output_storage ("   return 0;");
         output_storage ("}");
         return;
 
     /* Aligned variants */
 
     /* Aligned compares */
 
     case COB_CMP_ALIGN_U16:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_align_u16 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   unsigned short  val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   val = *(unsigned short __unaligned *)p;");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_ALIGN_S16:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_align_s16 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   short   val;");
 
         output_storage ("   val = *(short __unaligned *)p;");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_ALIGN_U32:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_align_u32 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   unsigned int    val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   val = *(unsigned int __unaligned *)p;");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_ALIGN_S32:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_align_s32 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   int val;");
 
         output_storage ("   val = *(int __unaligned *)p;");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_ALIGN_U64:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_align_u64 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_u64_t   val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   val = *(cob_u64_t __unaligned *)p;");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_ALIGN_S64:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_align_s64 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t   val;");
 
         output_storage ("   val = *(cob_s64_t __unaligned *)p;");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     /* Aligned adds */
 
     case COB_ADD_ALIGN_U16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_align_u16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(unsigned short __unaligned *)p += val;");
         output_storage ("}");
         return;
 
     case COB_ADD_ALIGN_S16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_align_s16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(short __unaligned *)p += val;");
         output_storage ("}");
         return;
 
     case COB_ADD_ALIGN_U32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_align_u32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(unsigned int __unaligned *)p += val;");
         output_storage ("}");
         return;
 
     case COB_ADD_ALIGN_S32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_align_s32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(int __unaligned *)p += val;");
         output_storage ("}");
         return;
 
     case COB_ADD_ALIGN_U64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_align_u64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(cob_u64_t __unaligned *)p += val;");
         output_storage ("}");
         return;
 
     case COB_ADD_ALIGN_S64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_align_s64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(cob_s64_t __unaligned *)p += val;");
         output_storage ("}");
         return;
 
     /* Aligned subtracts */
 
     case COB_SUB_ALIGN_U16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_align_u16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(unsigned short __unaligned *)p -= val;");
         output_storage ("}");
         return;
 
     case COB_SUB_ALIGN_S16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_align_s16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(short __unaligned *)p -= val;");
         output_storage ("}");
         return;
 
     case COB_SUB_ALIGN_U32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_align_u32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(unsigned int __unaligned *)p -= val;");
         output_storage ("}");
         return;
 
     case COB_SUB_ALIGN_S32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_align_s32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(int __unaligned *)p -= val;");
         output_storage ("}");
         return;
 
     case COB_SUB_ALIGN_U64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_align_u64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(cob_u64_t __unaligned *)p -= val;");
         output_storage ("}");
         return;
 
     case COB_SUB_ALIGN_S64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_align_s64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(cob_s64_t __unaligned *)p -= val;");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_ALIGN_U16:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_align_u16 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   unsigned short  val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   val = COB_BSWAP_16 (*(unsigned short __unaligned *)p);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_ALIGN_S16:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_align_s16 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   short   val;");
 
         output_storage ("   val = COB_BSWAP_16 (*(short __unaligned *)p);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_ALIGN_U32:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_align_u32 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   unsigned int    val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   val = COB_BSWAP_32 (*(unsigned int __unaligned *)p);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_ALIGN_S32:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_align_s32 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   int val;");
 
         output_storage ("   val = COB_BSWAP_32 (*(int __unaligned *)p);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_ALIGN_U64:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_align_u64 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_u64_t   val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   val = COB_BSWAP_64 (*(cob_u64_t __unaligned *)p);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_ALIGN_S64:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_align_s64 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t   val;");
 
         output_storage ("   val = COB_BSWAP_64 (*(cob_s64_t __unaligned *)p);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     /* Binary compare */
 
     case COB_CMP_U8:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_u8 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   return (*(const unsigned char *)p < n) ? -1 : (*(const unsigned char *)p > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_S8:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_s8 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   return (*(const signed char *)p < n) ? -1 : (*(const signed char *)p > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_U16:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_u16 (const void *p, const cob_s64_t n)");
         output_storage ("{");
 #ifndef COB_ALLOW_UNALIGNED
         output_storage ("   void        *x;");
 #endif
         output_storage ("   unsigned short  val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = *(const unsigned short __unaligned *)p;");
 #else
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 2);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_S16:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_s16 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   short   val;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = *(const short __unaligned *)p;");
 #else
         output_storage ("   void    *x;");
 
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 2);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_U24:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_u24 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned int    val = 0;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&val) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&val;");
 #endif
         output_storage ("   optim_memcpy (x, p, 3);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_S24:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_s24 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   int     val = 0;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&val;");
 #else
         output_storage ("   x = ((unsigned char *)&val) + 1;");
 #endif
         output_storage ("   optim_memcpy (x, p, 3);");
         output_storage ("   val >>= 8;  /* Shift with sign */");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_U32:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_u32 (const void *p, const cob_s64_t n)");
         output_storage ("{");
 #ifndef COB_ALLOW_UNALIGNED
         output_storage ("   void        *x;");
 #endif
         output_storage ("   unsigned int    val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = *(const unsigned int __unaligned *)p;");
 #else
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 4);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_S32:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_s32 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   int val;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = *(const int __unaligned *)p;");
 #else
         output_storage ("   void    *x;");
 
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 4);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_U40:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_u40 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_u64_t       val = 0;");
         output_storage ("   unsigned char       *x;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&val) + 3;");
 #else
         output_storage ("   x = (unsigned char *)&val;");
 #endif
         output_storage ("   optim_memcpy (x, p, 5);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_S40:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_s40 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t       val = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&val;");
 #else
         output_storage ("   x = ((unsigned char *)&val) + 3;");
 #endif
         output_storage ("   optim_memcpy (x, p, 5);");
         output_storage ("   val >>= 24; /* Shift with sign */");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_U48:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_u48 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_u64_t       val = 0;");
         output_storage ("   unsigned char       *x;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&val) + 2;");
 #else
         output_storage ("   x = (unsigned char *)&val;");
 #endif
         output_storage ("   optim_memcpy (x, p, 6);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_S48:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_s48 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t       val = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&val;");
 #else
         output_storage ("   x = ((unsigned char *)&val) + 2;");
 #endif
         output_storage ("   optim_memcpy (x, p, 6);");
         output_storage ("   val >>= 16; /* Shift with sign */");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_U56:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_u56 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_u64_t       val = 0;");
         output_storage ("   unsigned char       *x;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&val) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&val;");
 #endif
         output_storage ("   optim_memcpy (x, p, 7);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_S56:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_s56 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t       val = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&val;");
 #else
         output_storage ("   x = ((unsigned char *)&val) + 1;");
 #endif
         output_storage ("   optim_memcpy (x, p, 7);");
         output_storage ("   val >>= 8;  /* Shift with sign */");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_U64:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_u64 (const void *p, const cob_s64_t n)");
         output_storage ("{");
 #ifndef COB_ALLOW_UNALIGNED
         output_storage ("   void        *x;");
 #endif
         output_storage ("   cob_u64_t   val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = *(const cob_u64_t __unaligned *)p;");
 #else
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 8);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMP_S64:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmp_s64 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t   val;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = *(const cob_s64_t __unaligned *)p;");
 #else
         output_storage ("   void        *x;");
 
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 8);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     /* Add/Subtract */
 
     case COB_ADD_U8:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_u8 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(unsigned char *)p += val;");
         output_storage ("}");
         return;
 
     case COB_ADD_S8:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_s8 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(signed char *)p += val;");
         output_storage ("}");
         return;
 
     case COB_ADD_U16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_u16 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(unsigned short __unaligned *)p += val;");
 #else
         output_storage ("   void        *x;");
         output_storage ("   unsigned short  n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 2);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 2);");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADD_S16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_s16 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(short __unaligned *)p += val;");
 #else
         output_storage ("   void    *x;");
         output_storage ("   short   n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 2);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 2);");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADD_U24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_u24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned int    n = 0;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (x, p, 3);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 3);");
         output_storage ("}");
         return;
 
     case COB_ADD_S24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_s24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   int     n = 0;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&n;");
 #else
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #endif
         output_storage ("   optim_memcpy (x, p, 3);");
         output_storage ("   n >>= 8;    /* Shift with sign */");
         output_storage ("   n += val;");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (p, x, 3);");
         output_storage ("}");
         return;
 
     case COB_ADD_U32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_u32 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(unsigned int __unaligned *)p += val;");
 #else
         output_storage ("   void        *x;");
         output_storage ("   unsigned int    n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 4);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 4);");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADD_S32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_s32 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(int __unaligned *)p += val;");
 #else
         output_storage ("   void    *x;");
         output_storage ("   int n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 4);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 4);");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADD_U40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_u40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 3;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (x, p, 5);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 5);");
         output_storage ("}");
         return;
 
     case COB_ADD_S40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_s40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&n;");
 #else
         output_storage ("   x = ((unsigned char *)&n) + 3;");
 #endif
         output_storage ("   optim_memcpy (x, p, 5);");
         output_storage ("   n >>= 24;   /* Shift with sign */");
         output_storage ("   n += val;");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 3;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (p, x, 5);");
         output_storage ("}");
         return;
 
     case COB_ADD_U48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_u48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 2;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (x, p, 6);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 6);");
         output_storage ("}");
         return;
 
     case COB_ADD_S48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_s48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&n;");
 #else
         output_storage ("   x = ((unsigned char *)&n) + 2;");
 #endif
         output_storage ("   optim_memcpy (x, p, 6);");
         output_storage ("   n >>= 16;   /* Shift with sign */");
         output_storage ("   n += val;");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 2;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (p, x, 6);");
         output_storage ("}");
         return;
 
     case COB_ADD_U56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_u56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (x, p, 7);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 7);");
         output_storage ("}");
         return;
 
     case COB_ADD_S56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_s56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&n;");
 #else
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #endif
         output_storage ("   optim_memcpy (x, p, 7);");
         output_storage ("   n >>= 8;    /* Shift with sign */");
         output_storage ("   n += val;");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (p, x, 7);");
         output_storage ("}");
         return;
 
     case COB_ADD_U64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_u64 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(cob_u64_t __unaligned *)p += val;");
 #else
         output_storage ("   void        *x;");
         output_storage ("   cob_u64_t   n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 8);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 8);");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADD_S64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_add_s64 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(cob_s64_t __unaligned *)p += val;");
 #else
         output_storage ("   void        *x;");
         output_storage ("   cob_s64_t   n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 8);");
         output_storage ("   n += val;");
         output_storage ("   optim_memcpy (p, x, 8);");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUB_U8:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_u8 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(unsigned char *)p -= val;");
         output_storage ("}");
         return;
 
     case COB_SUB_S8:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_s8 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   *(signed char *)p -= val;");
         output_storage ("}");
         return;
 
     case COB_SUB_U16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_u16 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(unsigned short __unaligned *)p -= val;");
 #else
         output_storage ("   void        *x;");
         output_storage ("   unsigned short  n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 2);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 2);");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUB_S16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_s16 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(short __unaligned *)p -= val;");
 #else
         output_storage ("   void    *x;");
         output_storage ("   short   n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 2);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 2);");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUB_U24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_u24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned int    n = 0;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (x, p, 3);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 3);");
         output_storage ("}");
         return;
 
     case COB_SUB_S24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_s24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   int     n = 0;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&n;");
 #else
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #endif
         output_storage ("   optim_memcpy (x, p, 3);");
         output_storage ("   n >>= 8;    /* Shift with sign */");
         output_storage ("   n -= val;");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (p, x, 3);");
         output_storage ("}");
         return;
 
     case COB_SUB_U32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_u32 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(unsigned int __unaligned *)p -= val;");
 #else
         output_storage ("   void        *x;");
         output_storage ("   unsigned int    n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 4);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 4);");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUB_S32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_s32 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(int __unaligned *)p -= val;");
 #else
         output_storage ("   void    *x;");
         output_storage ("   int n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 4);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 4);");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUB_U40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_u40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 3;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (x, p, 5);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 5);");
         output_storage ("}");
         return;
 
     case COB_SUB_S40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_s40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&n;");
 #else
         output_storage ("   x = ((unsigned char *)&n) + 3;");
 #endif
         output_storage ("   optim_memcpy (x, p, 5);");
         output_storage ("   n >>= 24;   /* Shift with sign */");
         output_storage ("   n -= val;");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 3;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (p, x, 5);");
         output_storage ("}");
         return;
 
     case COB_SUB_U48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_u48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 2;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (x, p, 6);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 6);");
         output_storage ("}");
         return;
 
     case COB_SUB_S48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_s48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&n;");
 #else
         output_storage ("   x = ((unsigned char *)&n) + 2;");
 #endif
         output_storage ("   optim_memcpy (x, p, 6);");
         output_storage ("   n >>= 16;   /* Shift with sign */");
         output_storage ("   n -= val;");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 2;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (p, x, 6);");
         output_storage ("}");
         return;
 
     case COB_SUB_U56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_u56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (x, p, 7);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 7);");
         output_storage ("}");
         return;
 
     case COB_SUB_S56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_s56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
 
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = (unsigned char *)&n;");
 #else
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #endif
         output_storage ("   optim_memcpy (x, p, 7);");
         output_storage ("   n >>= 8;    /* Shift with sign */");
         output_storage ("   n -= val;");
 #ifdef  WORDS_BIGENDIAN
         output_storage ("   x = ((unsigned char *)&n) + 1;");
 #else
         output_storage ("   x = (unsigned char *)&n;");
 #endif
         output_storage ("   optim_memcpy (p, x, 7);");
         output_storage ("}");
         return;
 
     case COB_SUB_U64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_u64 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(cob_u64_t __unaligned *)p -= val;");
 #else
         output_storage ("   void        *x;");
         output_storage ("   cob_u64_t   n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 8);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 8);");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUB_S64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_sub_s64 (void *p, const int val)");
         output_storage ("{");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   *(cob_s64_t __unaligned *)p -= val;");
 #else
         output_storage ("   void        *x;");
         output_storage ("   cob_s64_t   n;");
 
         output_storage ("   x = &n;");
         output_storage ("   optim_memcpy (x, p, 8);");
         output_storage ("   n -= val;");
         output_storage ("   optim_memcpy (p, x, 8);");
 #endif
         output_storage ("}");
         return;
 
     /* Binary swapped compare */
 
     case COB_CMPSWP_U16:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_u16 (const void *p, const cob_s64_t n)");
         output_storage ("{");
 #ifndef COB_ALLOW_UNALIGNED
         output_storage ("   void        *x;");
 #endif
         output_storage ("   unsigned short  val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = COB_BSWAP_16 (*(unsigned short __unaligned *)p);");
 #else
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 2);");
         output_storage ("   val = COB_BSWAP_16 (val);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_S16:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_s16 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   short   val;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = COB_BSWAP_16 (*(short __unaligned *)p);");
 #else
         output_storage ("   void    *x;");
 
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 2);");
         output_storage ("   val = COB_BSWAP_16 (val);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_U24:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_u24 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned int    val = 0;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   x = ((unsigned char *)&val) + 1;");
         output_storage ("   optim_memcpy (x, p, 3);");
         output_storage ("   val = COB_BSWAP_32 (val);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_S24:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_s24 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   int     val = 0;");
 
         output_storage ("   x = (unsigned char *)&val;");
         output_storage ("   optim_memcpy (x, p, 3);");
         output_storage ("   val = COB_BSWAP_32 (val);");
         output_storage ("   val >>= 8;  /* Shift with sign */");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_U32:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_u32 (const void *p, const cob_s64_t n)");
         output_storage ("{");
 #ifndef COB_ALLOW_UNALIGNED
         output_storage ("   void        *x;");
 #endif
         output_storage ("   unsigned int    val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = COB_BSWAP_32 (*(const unsigned int __unaligned *)p);");
 #else
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 4);");
         output_storage ("   val = COB_BSWAP_32 (val);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_S32:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_s32 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   int val;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = COB_BSWAP_32 (*(const int __unaligned *)p);");
 #else
         output_storage ("   void    *x;");
 
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 4);");
         output_storage ("   val = COB_BSWAP_32 (val);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_U40:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_u40 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_u64_t   val = 0;");
         output_storage ("   unsigned char   *x;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   x = ((unsigned char *)&val) + 3;");
         output_storage ("   optim_memcpy (x, p, 5);");
         output_storage ("   val = COB_BSWAP_64 (val);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_S40:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_s40 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t   val = 0;");
         output_storage ("   unsigned char   *x;");
 
         output_storage ("   x = (unsigned char *)&val;");
         output_storage ("   optim_memcpy (x, p, 5);");
         output_storage ("   val = COB_BSWAP_64 (val);");
         output_storage ("   val >>= 24; /* Shift with sign */");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_U48:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_u48 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_u64_t   val = 0;");
         output_storage ("   unsigned char   *x;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   x = ((unsigned char *)&val) + 2;");
         output_storage ("   optim_memcpy (x, p, 6);");
         output_storage ("   val = COB_BSWAP_64 (val);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_S48:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_s48 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t   val = 0;");
         output_storage ("   unsigned char   *x;");
 
         output_storage ("   x = (unsigned char *)&val;");
         output_storage ("   optim_memcpy (x, p, 6);");
         output_storage ("   val = COB_BSWAP_64 (val);");
         output_storage ("   val >>= 16; /* Shift with sign */");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_U56:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_u56 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_u64_t   val = 0;");
         output_storage ("   unsigned char   *x;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
         output_storage ("   x = ((unsigned char *)&val) + 1;");
         output_storage ("   optim_memcpy (x, p, 7);");
         output_storage ("   val = COB_BSWAP_64 (val);");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_S56:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_s56 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t   val = 0;");
         output_storage ("   unsigned char   *x;");
 
         output_storage ("   x = (unsigned char *)&val;");
         output_storage ("   optim_memcpy (x, p, 7);");
         output_storage ("   val = COB_BSWAP_64 (val);");
         output_storage ("   val >>= 8;  /* Shift with sign */");
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_U64:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_u64 (const void *p, const cob_s64_t n)");
         output_storage ("{");
 #ifndef COB_ALLOW_UNALIGNED
         output_storage ("   void        *x;");
 #endif
         output_storage ("   cob_u64_t   val;");
 
         output_storage ("   if (unlikely(n < 0)) {");
         output_storage ("       return 1;");
         output_storage ("   }");
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = COB_BSWAP_64 (*(const cob_u64_t __unaligned *)p);");
 #else
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 8);");
         output_storage ("   val = COB_BSWAP_64 (val);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     case COB_CMPSWP_S64:
         output_storage ("static COB_INLINE COB_A_INLINE int");
         output_storage ("cob_cmpswp_s64 (const void *p, const cob_s64_t n)");
         output_storage ("{");
         output_storage ("   cob_s64_t   val;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   val = COB_BSWAP_64 (*(const cob_s64_t __unaligned *)p);");
 #else
         output_storage ("   void        *x;");
         output_storage ("   x = &val;");
         output_storage ("   optim_memcpy (x, p, 8);");
         output_storage ("   val = COB_BSWAP_64 (val);");
 #endif
         output_storage ("   return (val < n) ? -1 : (val > n);");
         output_storage ("}");
         return;
 
     /* Binary swapped add */
 
     case COB_ADDSWP_U16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_u16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned short  n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_16 (*(unsigned short __unaligned *)p);");
         output_storage ("   n += val;");
         output_storage ("   *(unsigned short __unaligned *)p = COB_BSWAP_16(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[1];");
         output_storage ("   x[1] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[1];");
         output_storage ("   px[1] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADDSWP_S16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_s16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   short       n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_16 (*(short __unaligned *)p);");
         output_storage ("   n += val;");
         output_storage ("   *(short __unaligned *)p = COB_BSWAP_16(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[1];");
         output_storage ("   x[1] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[1];");
         output_storage ("   px[1] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADDSWP_U24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_u24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
         output_storage ("   unsigned int    n = 0;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[2];");
         output_storage ("   x[1] = px[1];");
         output_storage ("   x[2] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[2];");
         output_storage ("   px[1] = x[1];");
         output_storage ("   px[2] = x[0];");
         output_storage ("}");
         return;
 
     case COB_ADDSWP_S24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_s24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
         output_storage ("   int     n = 0;");
 
         output_storage ("   x = ((unsigned char *)&n) + 1;");
         output_storage ("   x[0] = px[2];");
         output_storage ("   x[1] = px[1];");
         output_storage ("   x[2] = px[0];");
         output_storage ("   n >>= 8;    /* Shift with sign */");
         output_storage ("   n += val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[2];");
         output_storage ("   px[1] = x[1];");
         output_storage ("   px[2] = x[0];");
         output_storage ("}");
         return;
 
     case COB_ADDSWP_U32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_u32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned int    n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_32 (*(unsigned int __unaligned *)p);");
         output_storage ("   n += val;");
         output_storage ("   *(unsigned int __unaligned *)p = COB_BSWAP_32(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[3];");
         output_storage ("   x[1] = px[2];");
         output_storage ("   x[2] = px[1];");
         output_storage ("   x[3] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[3];");
         output_storage ("   px[1] = x[2];");
         output_storage ("   px[2] = x[1];");
         output_storage ("   px[3] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADDSWP_S32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_s32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   int     n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_32 (*(int __unaligned *)p);");
         output_storage ("   n += val;");
         output_storage ("   *(int __unaligned *)p = COB_BSWAP_32(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[3];");
         output_storage ("   x[1] = px[2];");
         output_storage ("   x[2] = px[1];");
         output_storage ("   x[3] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[3];");
         output_storage ("   px[1] = x[2];");
         output_storage ("   px[2] = x[1];");
         output_storage ("   px[3] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADDSWP_U40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_u40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[4];");
         output_storage ("   x[1] = px[3];");
         output_storage ("   x[2] = px[2];");
         output_storage ("   x[3] = px[1];");
         output_storage ("   x[4] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[4];");
         output_storage ("   px[1] = x[3];");
         output_storage ("   px[2] = x[2];");
         output_storage ("   px[3] = x[1];");
         output_storage ("   px[4] = x[0];");
         output_storage ("}");
         return;
 
     case COB_ADDSWP_S40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_s40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = ((unsigned char *)&n) + 3;");
         output_storage ("   x[0] = px[4];");
         output_storage ("   x[1] = px[3];");
         output_storage ("   x[2] = px[2];");
         output_storage ("   x[3] = px[1];");
         output_storage ("   x[4] = px[0];");
         output_storage ("   n >>= 24;   /* Shift with sign */");
         output_storage ("   n += val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[4];");
         output_storage ("   px[1] = x[3];");
         output_storage ("   px[2] = x[2];");
         output_storage ("   px[3] = x[1];");
         output_storage ("   px[4] = x[0];");
         output_storage ("}");
         return;
 
     case COB_ADDSWP_U48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_u48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[5];");
         output_storage ("   x[1] = px[4];");
         output_storage ("   x[2] = px[3];");
         output_storage ("   x[3] = px[2];");
         output_storage ("   x[4] = px[1];");
         output_storage ("   x[5] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[5];");
         output_storage ("   px[1] = x[4];");
         output_storage ("   px[2] = x[3];");
         output_storage ("   px[3] = x[2];");
         output_storage ("   px[4] = x[1];");
         output_storage ("   px[5] = x[0];");
         output_storage ("}");
         return;
 
     case COB_ADDSWP_S48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_s48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = ((unsigned char *)&n) + 2;");
         output_storage ("   x[0] = px[5];");
         output_storage ("   x[1] = px[4];");
         output_storage ("   x[2] = px[3];");
         output_storage ("   x[3] = px[2];");
         output_storage ("   x[4] = px[1];");
         output_storage ("   x[5] = px[0];");
         output_storage ("   n >>= 16;   /* Shift with sign */");
         output_storage ("   n += val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[5];");
         output_storage ("   px[1] = x[4];");
         output_storage ("   px[2] = x[3];");
         output_storage ("   px[3] = x[2];");
         output_storage ("   px[4] = x[1];");
         output_storage ("   px[5] = x[0];");
         output_storage ("}");
         return;
 
     case COB_ADDSWP_U56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_u56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[6];");
         output_storage ("   x[1] = px[5];");
         output_storage ("   x[2] = px[4];");
         output_storage ("   x[3] = px[3];");
         output_storage ("   x[4] = px[2];");
         output_storage ("   x[5] = px[1];");
         output_storage ("   x[6] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[6];");
         output_storage ("   px[1] = x[5];");
         output_storage ("   px[2] = x[4];");
         output_storage ("   px[3] = x[3];");
         output_storage ("   px[4] = x[2];");
         output_storage ("   px[5] = x[1];");
         output_storage ("   px[6] = x[0];");
         output_storage ("}");
         return;
 
     case COB_ADDSWP_S56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_s56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = ((unsigned char *)&n) + 1;");
         output_storage ("   x[0] = px[6];");
         output_storage ("   x[1] = px[5];");
         output_storage ("   x[2] = px[4];");
         output_storage ("   x[3] = px[3];");
         output_storage ("   x[4] = px[2];");
         output_storage ("   x[5] = px[1];");
         output_storage ("   x[6] = px[0];");
         output_storage ("   n >>= 8;    /* Shift with sign */");
         output_storage ("   n += val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[6];");
         output_storage ("   px[1] = x[5];");
         output_storage ("   px[2] = x[4];");
         output_storage ("   px[3] = x[3];");
         output_storage ("   px[4] = x[2];");
         output_storage ("   px[5] = x[1];");
         output_storage ("   px[6] = x[0];");
         output_storage ("}");
         return;
 
     case COB_ADDSWP_U64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_u64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_64 (*(cob_u64_t __unaligned *)p);");
         output_storage ("   n += val;");
         output_storage ("   *(cob_u64_t __unaligned *)p = COB_BSWAP_64(n);");
 #else
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[7];");
         output_storage ("   x[1] = px[6];");
         output_storage ("   x[2] = px[5];");
         output_storage ("   x[3] = px[4];");
         output_storage ("   x[4] = px[3];");
         output_storage ("   x[5] = px[2];");
         output_storage ("   x[6] = px[1];");
         output_storage ("   x[7] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[7];");
         output_storage ("   px[1] = x[6];");
         output_storage ("   px[2] = x[5];");
         output_storage ("   px[3] = x[4];");
         output_storage ("   px[4] = x[3];");
         output_storage ("   px[5] = x[2];");
         output_storage ("   px[6] = x[1];");
         output_storage ("   px[7] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_ADDSWP_S64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_addswp_s64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_64 (*(cob_s64_t __unaligned *)p);");
         output_storage ("   n += val;");
         output_storage ("   *(cob_s64_t __unaligned *)p = COB_BSWAP_64(n);");
 #else
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[7];");
         output_storage ("   x[1] = px[6];");
         output_storage ("   x[2] = px[5];");
         output_storage ("   x[3] = px[4];");
         output_storage ("   x[4] = px[3];");
         output_storage ("   x[5] = px[2];");
         output_storage ("   x[6] = px[1];");
         output_storage ("   x[7] = px[0];");
         output_storage ("   n += val;");
         output_storage ("   px[0] = x[7];");
         output_storage ("   px[1] = x[6];");
         output_storage ("   px[2] = x[5];");
         output_storage ("   px[3] = x[4];");
         output_storage ("   px[4] = x[3];");
         output_storage ("   px[5] = x[2];");
         output_storage ("   px[6] = x[1];");
         output_storage ("   px[7] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     /* Binary swapped subtract */
 
     case COB_SUBSWP_U16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_u16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned short  n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_16 (*(unsigned short __unaligned *)p);");
         output_storage ("   n -= val;");
         output_storage ("   *(unsigned short __unaligned *)p = COB_BSWAP_16(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[1];");
         output_storage ("   x[1] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[1];");
         output_storage ("   px[1] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUBSWP_S16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_s16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   short       n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_16 (*(short __unaligned *)p);");
         output_storage ("   n -= val;");
         output_storage ("   *(short __unaligned *)p = COB_BSWAP_16(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[1];");
         output_storage ("   x[1] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[1];");
         output_storage ("   px[1] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUBSWP_U24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_u24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
         output_storage ("   unsigned int    n = 0;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[2];");
         output_storage ("   x[1] = px[1];");
         output_storage ("   x[2] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[2];");
         output_storage ("   px[1] = x[1];");
         output_storage ("   px[2] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SUBSWP_S24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_s24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
         output_storage ("   int     n = 0;");
 
         output_storage ("   x = ((unsigned char *)&n) + 1;");
         output_storage ("   x[0] = px[2];");
         output_storage ("   x[1] = px[1];");
         output_storage ("   x[2] = px[0];");
         output_storage ("   n >>= 8;    /* Shift with sign */");
         output_storage ("   n -= val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[2];");
         output_storage ("   px[1] = x[1];");
         output_storage ("   px[2] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SUBSWP_U32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_u32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned int    n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_32 (*(unsigned int __unaligned *)p);");
         output_storage ("   n -= val;");
         output_storage ("   *(unsigned int __unaligned *)p = COB_BSWAP_32(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[3];");
         output_storage ("   x[1] = px[2];");
         output_storage ("   x[2] = px[1];");
         output_storage ("   x[3] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[3];");
         output_storage ("   px[1] = x[2];");
         output_storage ("   px[2] = x[1];");
         output_storage ("   px[3] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUBSWP_S32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_s32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   int     n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_32 (*(int __unaligned *)p);");
         output_storage ("   n -= val;");
         output_storage ("   *(int __unaligned *)p = COB_BSWAP_32(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[3];");
         output_storage ("   x[1] = px[2];");
         output_storage ("   x[2] = px[1];");
         output_storage ("   x[3] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[3];");
         output_storage ("   px[1] = x[2];");
         output_storage ("   px[2] = x[1];");
         output_storage ("   px[3] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUBSWP_U40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_u40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[4];");
         output_storage ("   x[1] = px[3];");
         output_storage ("   x[2] = px[2];");
         output_storage ("   x[3] = px[1];");
         output_storage ("   x[4] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[4];");
         output_storage ("   px[1] = x[3];");
         output_storage ("   px[2] = x[2];");
         output_storage ("   px[3] = x[1];");
         output_storage ("   px[4] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SUBSWP_S40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_s40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = ((unsigned char *)&n) + 3;");
         output_storage ("   x[0] = px[4];");
         output_storage ("   x[1] = px[3];");
         output_storage ("   x[2] = px[2];");
         output_storage ("   x[3] = px[1];");
         output_storage ("   x[4] = px[0];");
         output_storage ("   n >>= 24;   /* Shift with sign */");
         output_storage ("   n -= val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[4];");
         output_storage ("   px[1] = x[3];");
         output_storage ("   px[2] = x[2];");
         output_storage ("   px[3] = x[1];");
         output_storage ("   px[4] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SUBSWP_U48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_u48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[5];");
         output_storage ("   x[1] = px[4];");
         output_storage ("   x[2] = px[3];");
         output_storage ("   x[3] = px[2];");
         output_storage ("   x[4] = px[1];");
         output_storage ("   x[5] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[5];");
         output_storage ("   px[1] = x[4];");
         output_storage ("   px[2] = x[3];");
         output_storage ("   px[3] = x[2];");
         output_storage ("   px[4] = x[1];");
         output_storage ("   px[5] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SUBSWP_S48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_s48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = ((unsigned char *)&n) + 2;");
         output_storage ("   x[0] = px[5];");
         output_storage ("   x[1] = px[4];");
         output_storage ("   x[2] = px[3];");
         output_storage ("   x[3] = px[2];");
         output_storage ("   x[4] = px[1];");
         output_storage ("   x[5] = px[0];");
         output_storage ("   n >>= 16;   /* Shift with sign */");
         output_storage ("   n -= val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[5];");
         output_storage ("   px[1] = x[4];");
         output_storage ("   px[2] = x[3];");
         output_storage ("   px[3] = x[2];");
         output_storage ("   px[4] = x[1];");
         output_storage ("   px[5] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SUBSWP_U56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_u56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[6];");
         output_storage ("   x[1] = px[5];");
         output_storage ("   x[2] = px[4];");
         output_storage ("   x[3] = px[3];");
         output_storage ("   x[4] = px[2];");
         output_storage ("   x[5] = px[1];");
         output_storage ("   x[6] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[6];");
         output_storage ("   px[1] = x[5];");
         output_storage ("   px[2] = x[4];");
         output_storage ("   px[3] = x[3];");
         output_storage ("   px[4] = x[2];");
         output_storage ("   px[5] = x[1];");
         output_storage ("   px[6] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SUBSWP_S56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_s56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n = 0;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = ((unsigned char *)&n) + 1;");
         output_storage ("   x[0] = px[6];");
         output_storage ("   x[1] = px[5];");
         output_storage ("   x[2] = px[4];");
         output_storage ("   x[3] = px[3];");
         output_storage ("   x[4] = px[2];");
         output_storage ("   x[5] = px[1];");
         output_storage ("   x[6] = px[0];");
         output_storage ("   n >>= 8;    /* Shift with sign */");
         output_storage ("   n -= val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[6];");
         output_storage ("   px[1] = x[5];");
         output_storage ("   px[2] = x[4];");
         output_storage ("   px[3] = x[3];");
         output_storage ("   px[4] = x[2];");
         output_storage ("   px[5] = x[1];");
         output_storage ("   px[6] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SUBSWP_U64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_u64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t   n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_64 (*(cob_u64_t __unaligned *)p);");
         output_storage ("   n -= val;");
         output_storage ("   *(cob_u64_t __unaligned *)p = COB_BSWAP_64(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[7];");
         output_storage ("   x[1] = px[6];");
         output_storage ("   x[2] = px[5];");
         output_storage ("   x[3] = px[4];");
         output_storage ("   x[4] = px[3];");
         output_storage ("   x[5] = px[2];");
         output_storage ("   x[6] = px[1];");
         output_storage ("   x[7] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[7];");
         output_storage ("   px[1] = x[6];");
         output_storage ("   px[2] = x[5];");
         output_storage ("   px[3] = x[4];");
         output_storage ("   px[4] = x[3];");
         output_storage ("   px[5] = x[2];");
         output_storage ("   px[6] = x[1];");
         output_storage ("   px[7] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SUBSWP_S64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_subswp_s64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = COB_BSWAP_64 (*(cob_s64_t __unaligned *)p);");
         output_storage ("   n -= val;");
         output_storage ("   *(cob_s64_t __unaligned *)p = COB_BSWAP_64(n);");
 #else
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   x[0] = px[7];");
         output_storage ("   x[1] = px[6];");
         output_storage ("   x[2] = px[5];");
         output_storage ("   x[3] = px[4];");
         output_storage ("   x[4] = px[3];");
         output_storage ("   x[5] = px[2];");
         output_storage ("   x[6] = px[1];");
         output_storage ("   x[7] = px[0];");
         output_storage ("   n -= val;");
         output_storage ("   px[0] = x[7];");
         output_storage ("   px[1] = x[6];");
         output_storage ("   px[2] = x[5];");
         output_storage ("   px[3] = x[4];");
         output_storage ("   px[4] = x[3];");
         output_storage ("   px[5] = x[2];");
         output_storage ("   px[6] = x[1];");
         output_storage ("   px[7] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     /* Binary set swapped value */
     case COB_SETSWP_U16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_u16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned short  n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = val;");
         output_storage ("   *(unsigned short __unaligned *)p = COB_BSWAP_16(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[1];");
         output_storage ("   px[1] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SETSWP_S16:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_s16 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   short       n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = val;");
         output_storage ("   *(short __unaligned *)p = COB_BSWAP_16(n);");
 #else
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[1];");
         output_storage ("   px[1] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SETSWP_U24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_u24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
         output_storage ("   unsigned int    n;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[2];");
         output_storage ("   px[1] = x[1];");
         output_storage ("   px[2] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SETSWP_S24:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_s24 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned char   *x;");
         output_storage ("   unsigned char   *px = p;");
         output_storage ("   int     n;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[2];");
         output_storage ("   px[1] = x[1];");
         output_storage ("   px[2] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SETSWP_U32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_u32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   unsigned int    n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = val;");
         output_storage ("   *(unsigned int __unaligned *)p = COB_BSWAP_32(n);");
 #else
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[3];");
         output_storage ("   px[1] = x[2];");
         output_storage ("   px[2] = x[1];");
         output_storage ("   px[3] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SETSWP_S32:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_s32 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   int     n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = val;");
         output_storage ("   *(int __unaligned *)p = COB_BSWAP_32(n);");
 #else
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[3];");
         output_storage ("   px[1] = x[2];");
         output_storage ("   px[2] = x[1];");
         output_storage ("   px[3] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SETSWP_U40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_u40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[4];");
         output_storage ("   px[1] = x[3];");
         output_storage ("   px[2] = x[2];");
         output_storage ("   px[3] = x[1];");
         output_storage ("   px[4] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SETSWP_S40:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_s40 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[4];");
         output_storage ("   px[1] = x[3];");
         output_storage ("   px[2] = x[2];");
         output_storage ("   px[3] = x[1];");
         output_storage ("   px[4] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SETSWP_U48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_u48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[5];");
         output_storage ("   px[1] = x[4];");
         output_storage ("   px[2] = x[3];");
         output_storage ("   px[3] = x[2];");
         output_storage ("   px[4] = x[1];");
         output_storage ("   px[5] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SETSWP_S48:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_s48 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[5];");
         output_storage ("   px[1] = x[4];");
         output_storage ("   px[2] = x[3];");
         output_storage ("   px[3] = x[2];");
         output_storage ("   px[4] = x[1];");
         output_storage ("   px[5] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SETSWP_U56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_u56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[6];");
         output_storage ("   px[1] = x[5];");
         output_storage ("   px[2] = x[4];");
         output_storage ("   px[3] = x[3];");
         output_storage ("   px[4] = x[2];");
         output_storage ("   px[5] = x[1];");
         output_storage ("   px[6] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SETSWP_S56:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_s56 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n;");
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[6];");
         output_storage ("   px[1] = x[5];");
         output_storage ("   px[2] = x[4];");
         output_storage ("   px[3] = x[3];");
         output_storage ("   px[4] = x[2];");
         output_storage ("   px[5] = x[1];");
         output_storage ("   px[6] = x[0];");
         output_storage ("}");
         return;
 
     case COB_SETSWP_U64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_u64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_u64_t       n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = val;");
         output_storage ("   *(cob_u64_t __unaligned *)p = COB_BSWAP_64(n);");
 #else
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[7];");
         output_storage ("   px[1] = x[6];");
         output_storage ("   px[2] = x[5];");
         output_storage ("   px[3] = x[4];");
         output_storage ("   px[4] = x[3];");
         output_storage ("   px[5] = x[2];");
         output_storage ("   px[6] = x[1];");
         output_storage ("   px[7] = x[0];");
 #endif
         output_storage ("}");
         return;
 
     case COB_SETSWP_S64:
         output_storage ("static COB_INLINE COB_A_INLINE void");
         output_storage ("cob_setswp_s64 (void *p, const int val)");
         output_storage ("{");
         output_storage ("   cob_s64_t       n;");
 
 #ifdef  COB_ALLOW_UNALIGNED
         output_storage ("   n = val;");
         output_storage ("   *(cob_s64_t __unaligned *)p = COB_BSWAP_64(n);");
 #else
         output_storage ("   unsigned char       *x;");
         output_storage ("   unsigned char       *px = p;");
 
         output_storage ("   n = val;");
         output_storage ("   x = (unsigned char *)&n;");
         output_storage ("   px[0] = x[7];");
         output_storage ("   px[1] = x[6];");
         output_storage ("   px[2] = x[5];");
         output_storage ("   px[3] = x[4];");
         output_storage ("   px[4] = x[3];");
         output_storage ("   px[5] = x[2];");
         output_storage ("   px[6] = x[1];");
         output_storage ("   px[7] = x[0];");
 #endif
         output_storage ("}");
         return;
     default:
         break;
     }
     cobc_abort_pr (_("Unexpected optimization value"));
     COBC_ABORT ();
 }

COB_EXPIMP void cob_get_environment	(	const cob_field *	,
		cob_field *
	)

 {
     const char  *p;
     char        *buff;
     size_t      size;
 
     if (envname->size == 0 || envval->size == 0) {
         cob_set_exception (COB_EC_IMP_ACCEPT);
         return;
     }
 
     buff = cob_malloc (envname->size + 1U);
     cob_field_to_string (envname, buff, envname->size);
     if (unlikely(cobglobptr->cob_env_mangle)) {
         for (size = 0; size < strlen (buff); ++size) {
             if (!isalnum ((int)buff[size])) {
                 buff[size] = '_';
             }
         }
     }
     p = getenv (buff);
     if (!p) {
         cob_set_exception (COB_EC_IMP_ACCEPT);
         p = " ";
     }
     cob_memcpy (envval, p, strlen (p));
     cob_free (buff);
 }

COB_EXPIMP cob_global* cob_get_global_ptr ( void )

 {
     if (unlikely(!cob_initialized)) {
         cob_fatal_error (COB_FERROR_INITIALIZED);
     }
     return cobglobptr;
 }

COB_EXPIMP void cob_get_indirect_field ( cob_field * )

 {
     cob_move (move_field, f);
 }

COB_EXPIMP int cob_get_int ( cob_field * )

 {
     int     n;
     cob_s64_t   val;
     cob_field   temp;
     cob_field_attr  attr;
 
     switch (COB_FIELD_TYPE (f)) {
     case COB_TYPE_NUMERIC_DISPLAY:
         return cob_display_get_int (f);
     case COB_TYPE_NUMERIC_PACKED:
         return cob_packed_get_int (f);
     case COB_TYPE_NUMERIC_BINARY:
         val = cob_binary_mget_sint64 (f);
         for (n = COB_FIELD_SCALE (f); n > 0 && val; --n) {
             val /= 10;
         }
         return (int)val;
     default:
         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0,
                 COB_FLAG_HAVE_SIGN, NULL);
         temp.size = 4;
         temp.data = (unsigned char *)&n;
         temp.attr = &attr;
         cob_move (f, &temp);
         return n;
     }
 }

COB_EXPIMP cob_s64_t cob_get_llint ( cob_field * )

 {
     cob_s64_t   n;
     int     inc;
     cob_field   temp;
 
     switch (COB_FIELD_TYPE (f)) {
     case COB_TYPE_NUMERIC_DISPLAY:
         return cob_display_get_long_long (f);
     case COB_TYPE_NUMERIC_PACKED:
         return cob_packed_get_long_long (f);
     case COB_TYPE_NUMERIC_BINARY:
         n = cob_binary_mget_sint64 (f);
         for (inc = COB_FIELD_SCALE (f); inc > 0 && n; --inc) {
             n /= 10;
         }
         return n;
     default:
         temp.size = 8;
         temp.data = (unsigned char *)&n;
         temp.attr = &const_binll_attr;
         cob_move (f, &temp);
         return n;
     }
 }

COB_EXPIMP unsigned char* cob_get_pointer ( const void * )

 {
     void    *tmptr;
 
     memcpy (&tmptr, srcptr, sizeof (void *));
     return (cob_u8_ptr)tmptr;
 }

COB_EXPIMP void* cob_get_prog_pointer ( const void * )

 {
     void    *tmptr;
 
     memcpy (&tmptr, srcptr, sizeof (void *));
     return tmptr;
 }

COB_EXPIMP int cob_get_switch ( const int )

 {
     if (n < 0 || n > (COB_SWITCH_MAX - 1)) {
         return 0;
     }
     return cob_switch[n];
 }

COB_EXPIMP char* cob_getenv ( const char * )

 {
     char    *p;
 
     if (name) {
         p = getenv (name);
         if (p) {
             return cob_strdup (p);
         }
     }
     return NULL;
 }

COB_EXPIMP void cob_gmp_free ( void * )

                           {
 /* mpir/gmp free functions */
 #ifdef HAVE_MP_GET_MEMORY_FUNCTIONS
     void (*freefunc)(void *, size_t);
     mp_get_memory_functions (NULL, NULL, &freefunc);
     freefunc (ptr, strlen((char*) ptr) + 1);
 #else
     free (ptr);
 #endif
 }

COB_EXPIMP void cob_incr_temp_iteration ( void )

 {
     cob_temp_iteration++;
 }

COB_EXPIMP void cob_init	(	const int	,
		char **
	)

 {
     char        *s;
 #if defined(HAVE_READLINK) || defined(HAVE_GETEXECNAME)
     const char  *path;
 #endif
     int     i;
 
     if (cob_initialized) {
         return;
     }
 
     cobglobptr = NULL;
     runtimeptr = (struct runtime_env*) cob_malloc(sizeof(struct runtime_env));
 
     cob_set_signal ();
 
     cob_alloc_base = NULL;
     cob_local_env = NULL;
     cob_last_sfile = NULL;
     commlnptr = NULL;
     basext = NULL;
     sort_keys = NULL;
     sort_collate = NULL;
     cob_current_program_id = NULL;
     cob_current_section = NULL;
     cob_current_paragraph = NULL;
     cob_source_file = NULL;
     cob_source_statement = NULL;
     cob_user_name = NULL;
     exit_hdlrs = NULL;
     hdlrs = NULL;
     commlncnt = 0;
     sort_nkeys = 0;
     cob_source_line = 0;
     cob_line_trace = 0;
     cob_local_env_size = 0;
 
     current_arg = 1;
 
     cob_argc = argc;
     cob_argv = argv;
 
     /* Get emergency buffer */
     runtime_err_str = cob_fast_malloc ((size_t)COB_ERRBUF_SIZE);
 
     /* Get global structure */
     cobglobptr = cob_malloc (sizeof(cob_global));
 
     cob_initialized = 1;
 
     if (argc) {
         cobglobptr->cob_first_init = 1;
     }
 
 #ifdef  HAVE_SETLOCALE
     /* Prime the locale from user settings */
     s = setlocale (LC_ALL, "");
     if (s) {
         /* Save initial values */
         cobglobptr->cob_locale_orig = cob_strdup (s);
         s = setlocale (LC_CTYPE, NULL);
         if (s) {
             cobglobptr->cob_locale_ctype = cob_strdup (s);
         }
         s = setlocale (LC_COLLATE, NULL);
         if (s) {
             cobglobptr->cob_locale_collate = cob_strdup (s);
         }
 #ifdef  LC_MESSAGES
         s = setlocale (LC_MESSAGES, NULL);
         if (s) {
             cobglobptr->cob_locale_messages = cob_strdup (s);
         }
 #endif
         s = setlocale (LC_MONETARY, NULL);
         if (s) {
             cobglobptr->cob_locale_monetary = cob_strdup (s);
         }
         s = setlocale (LC_NUMERIC, NULL);
         if (s) {
             cobglobptr->cob_locale_numeric = cob_strdup (s);
         }
         s = setlocale (LC_TIME, NULL);
         if (s) {
             cobglobptr->cob_locale_time = cob_strdup (s);
         }
         /* Set to standard "C" locale for COBOL */
         setlocale (LC_NUMERIC, "C");
         setlocale (LC_CTYPE, "C");
         /* Save changed locale */
         s = setlocale (LC_ALL, NULL);
         if (s) {
             cobglobptr->cob_locale = cob_strdup (s);
         }
     }
 #endif
 
 #ifdef  _WIN32
     /* Allows running of tests under Win */
     s = getenv ("COB_UNIX_LF");
     if (s) {
         runtimeptr->cob_unix_lf_env = cob_save_env_value(runtimeptr->cob_unix_lf_env, s);
 
         if (cob_check_env_true(s)) {
 
             cobglobptr->cob_unix_lf = 1;
             _setmode (_fileno (stdin), _O_BINARY);
             _setmode (_fileno (stdout), _O_BINARY);
             _setmode (_fileno (stderr), _O_BINARY);
         }
     }
 #endif
 
     /* Call inits with runtimeptr to get the adresses of all */
     cob_init_numeric(cobglobptr);
     cob_init_strings();
     cob_init_move(cobglobptr, runtimeptr);
     cob_init_intrinsic(cobglobptr);
     /* Screen-IO might be needed for error outputs */
     cob_init_screenio(cobglobptr, runtimeptr);
     cob_init_fileio(cobglobptr, runtimeptr);
     cob_init_call(cobglobptr, runtimeptr);
     cob_init_termio(cobglobptr);
 
     /* Set up library routine stuff */
     cobglobptr->cob_term_buff = cob_malloc ((size_t)COB_MEDIUM_BUFF);
     cob_rescan_env_vals ();
 
     /* Set switches */
     for (i = 0; i < COB_SWITCH_MAX; ++i) {
         sprintf (runtime_err_str, "COB_SWITCH_%d", i);
         s = getenv (runtime_err_str);
         if (s && (*s == '1' || strcasecmp (s, "ON") == 0)) {
                 cob_switch[i] = 1;
         } else {
                 cob_switch[i] = 0;
             }
         }
 
     /* Trace enable */
     s = getenv ("COB_SET_TRACE");
     if (s) {
         runtimeptr->cob_line_trace_env = cob_save_env_value(runtimeptr->cob_line_trace_env, s);
 
         if (cob_check_env_true(s)) {
             cob_line_trace = 1;
         }
     }
 
     /* Trace file */
     s = getenv ("COB_TRACE_FILE");
     if (s) {
         cob_trace_env = (const char*) cob_save_env_value((char*) cob_trace_env, s);
         cob_trace_file = NULL;
     } else {
         cob_trace_env = NULL;
         cob_trace_file = stderr;
     }
 
     /* Disable runtime warnings */
     cobglobptr->cob_display_warn = 1;
     s = getenv ("COB_DISABLE_WARNINGS");
     if (s) {
         runtimeptr->cob_display_warn_env = cob_save_env_value(runtimeptr->cob_display_warn_env, s);
 
         if (cob_check_env_true(s)) {
             cobglobptr->cob_display_warn = 0;
         }
     }
 
     /* Mangle environment names */
     s = getenv ("COB_ENV_MANGLE");
     if (s) {
         runtimeptr->cob_env_mangle_env = cob_save_env_value(runtimeptr->cob_env_mangle_env, s);
 
         if (cob_check_env_true(s)) {
             cobglobptr->cob_env_mangle = 1;
         }
     }
 
     /* Get user name */
     s = getenv ("USERNAME");
     if (s) {
         cob_user_name = cob_strdup (s);
     } else {
         s = getenv ("LOGNAME");
         if (s) {
             cob_user_name = cob_strdup (s);
         } else {
 #ifdef  _WIN32
             unsigned long bsiz = COB_ERRBUF_SIZE;
             if (GetUserName (runtime_err_str, &bsiz)) {
                 cob_user_name = cob_strdup (runtime_err_str);
             }
 #elif   !defined(__OS400__)
             s = getlogin ();
             if (s) {
                 cob_user_name = cob_strdup (s);
             }
 #endif
         }
     }
     if (!cob_user_name) {
         cob_user_name = cob_strdup (_("Unknown"));
     }
 
     /* This must be last in this function as we do early return */
     /* from certain ifdef's */
 
 #ifdef  _WIN32
     s = cob_malloc ((size_t)COB_LARGE_BUFF);
     i = GetModuleFileNameA (NULL, s, COB_LARGE_MAX);
     if (i > 0 && i < COB_LARGE_BUFF) {
         cobglobptr->cob_main_argv0 = cob_strdup (s);
         cob_free (s);
         return;
     }
     cob_free (s);
 #elif   defined(HAVE_READLINK)
     path = NULL;
     if (!access ("/proc/self/exe", R_OK)) {
         path = "/proc/self/exe";
     } else if (!access ("/proc/curproc/file", R_OK)) {
         path = "/proc/curproc/file";
     } else if (!access ("/proc/self/path/a.out", R_OK)) {
         path = "/proc/self/path/a.out";
     }
     if (path) {
         s = cob_malloc ((size_t)COB_LARGE_BUFF);
         i = (int)readlink (path, s, (size_t)COB_LARGE_MAX);
         if (i > 0 && i < COB_LARGE_BUFF) {
             cobglobptr->cob_main_argv0 = cob_strdup (s);
             cob_free (s);
             return;
         }
         cob_free (s);
     }
 #endif
 
 #ifdef  HAVE_GETEXECNAME
     path = getexecname ();
     if (path) {
 #ifdef  HAVE_REALPATH
         s = cob_malloc ((size_t)COB_LARGE_BUFF);
         if (realpath (path, s) != NULL) {
             cobglobptr->cob_main_argv0 = cob_strdup (s);
         } else {
             cobglobptr->cob_main_argv0 = cob_strdup (path);
         }
         cob_free (s);
 #else
         cobglobptr->cob_main_argv0 = cob_strdup (path);
 #endif
         return;
     }
 #endif
 
     if (argc && argv && argv[0]) {
 #ifdef  _WIN32
         /* Returns malloced path or NULL */
         cobglobptr->cob_main_argv0 = _fullpath (NULL, argv[0], 1);
 #elif   defined(HAVE_CANONICALIZE_FILE_NAME)
         /* Returns malloced path or NULL */
         cobglobptr->cob_main_argv0 = canonicalize_file_name (argv[0]);
 #elif   defined(HAVE_REALPATH)
         s = cob_malloc ((size_t)COB_LARGE_BUFF);
         if (realpath (argv[0], s) != NULL) {
             cobglobptr->cob_main_argv0 = cob_strdup (s);
         }
         cob_free (s);
 #endif
         if (!cobglobptr->cob_main_argv0) {
             cobglobptr->cob_main_argv0 = cob_strdup (argv[0]);
         }
     } else {
         cobglobptr->cob_main_argv0 = cob_strdup (_("Unknown"));
     }
     /* The above must be last in this function as we do early return */
     /* from certain ifdef's */
 }

COB_EXPIMP void cob_inspect_after ( const cob_field * )

 {
     unsigned char   *p;
 
     for (p = inspect_start; p < inspect_end - str->size + 1; ++p) {
         if (memcmp (p, str->data, str->size) == 0) {
             inspect_start = p + str->size;
             return;
         }
     }
     inspect_start = inspect_end;
 }

COB_EXPIMP void cob_inspect_all	(	cob_field *	,
		cob_field *
	)

 {
     inspect_common (f1, f2, INSPECT_ALL);
 }

COB_EXPIMP void cob_inspect_before ( const cob_field * )

 {
     unsigned char   *p;
 
     for (p = inspect_start; p < inspect_end - str->size + 1; ++p) {
         if (memcmp (p, str->data, str->size) == 0) {
             inspect_end = p;
             return;
         }
     }
 }

COB_EXPIMP void cob_inspect_characters ( cob_field * )

 {
     int *mark;
     int i;
     int n;
     int len;
 
     mark = &inspect_mark[inspect_start - inspect_data];
     len = (int)(inspect_end - inspect_start);
     if (inspect_replacing) {
         /* INSPECT REPLACING CHARACTERS f1 */
         for (i = 0; i < len; ++i) {
             if (mark[i] == -1) {
                 mark[i] = f1->data[0];
             }
         }
     } else {
         /* INSPECT TALLYING f1 CHARACTERS */
         n = 0;
         for (i = 0; i < len; ++i) {
             if (mark[i] == -1) {
                 mark[i] = 1;
                 n++;
             }
         }
         if (n > 0) {
             cob_add_int (f1, n, 0);
         }
     }
 }

COB_EXPIMP void cob_inspect_converting	(	const cob_field *	,
		const cob_field *
	)

 {
     size_t  i;
     size_t  j;
     size_t  len;
 
     if (unlikely(!f1)) {
         f1 = &str_cob_low;
     }
     if (unlikely(!f2)) {
         f2 = &str_cob_low;
     }
     if (f1->size != f2->size) {
         if (COB_FIELD_TYPE (f2) == COB_TYPE_ALPHANUMERIC_ALL) {
             alloc_figurative (f2, f1);
             f2 = &alpha_fld;
         } else {
             cob_set_exception (COB_EC_RANGE_INSPECT_SIZE);
             return;
         }
     }
 
     len = (size_t)(inspect_end - inspect_start);
     for (j = 0; j < f1->size; ++j) {
         for (i = 0; i < len; ++i) {
             if (inspect_mark[i] == -1 &&
                 inspect_start[i] == f1->data[j]) {
                 inspect_start[i] = f2->data[j];
                 inspect_mark[i] = 1;
             }
         }
     }
 }

COB_EXPIMP void cob_inspect_finish ( void )

 {
     size_t  i;
 
     if (inspect_replacing) {
         for (i = 0; i < inspect_size; ++i) {
             if (inspect_mark[i] != -1) {
                 inspect_data[i] = inspect_mark[i];
             }
         }
     }
 
     if (unlikely(inspect_var)) {
         COB_PUT_SIGN (inspect_var, inspect_sign);
     }
 }

COB_EXPIMP void cob_inspect_first	(	cob_field *	,
		cob_field *
	)

 {
     inspect_common (f1, f2, INSPECT_FIRST);
 }

COB_EXPIMP void cob_inspect_init	(	cob_field *	,
		const cob_u32_t
	)

 {
     size_t      i;
     size_t      digcount;
 
     if (unlikely(COB_FIELD_IS_NUMDISP (var))) {
         inspect_var_copy = *var;
         inspect_var = &inspect_var_copy;
         inspect_sign = COB_GET_SIGN (var);
     } else {
         inspect_var = NULL;
     }
     inspect_size = COB_FIELD_SIZE (var);
     inspect_data = COB_FIELD_DATA (var);
     inspect_replacing = replacing;
     inspect_start = NULL;
     inspect_end = NULL;
     digcount = inspect_size * sizeof (int);
     if (digcount > inspect_mark_size) {
         if (inspect_mark) {
             cob_free (inspect_mark);
         }
         inspect_mark = cob_fast_malloc (digcount);
         inspect_mark_size = digcount;
     }
     for (i = 0; i < inspect_size; ++i) {
         inspect_mark[i] = -1;
     }
     cob_set_exception (0);
 }

COB_EXPIMP void cob_inspect_leading	(	cob_field *	,
		cob_field *
	)

 {
     inspect_common (f1, f2, INSPECT_LEADING);
 }

COB_EXPIMP void cob_inspect_start ( void )

 {
     inspect_start = inspect_data;
     inspect_end = inspect_data + inspect_size;
 }

COB_EXPIMP void cob_inspect_trailing	(	cob_field *	,
		cob_field *
	)

 {
     inspect_common (f1, f2, INSPECT_TRAILING);
 }

char* cob_int_to_formatted_bytestring	(	int	,
		char *
	)

                                                      {
 
     double d;
     char* strB;
 
     if(!number) return NULL;
 
     strB = (char*) cob_fast_malloc(3);
 
     if (i > (1024 * 1024)) {
         d = i / 1024.0 / 1024.0;
         strB = (char*) "MB";
     } else if (i > 1024) {
         d = i / 1024.0;
         strB = (char*) "kB";
     } else {
         d = 0;
         strB = (char*) "B";
     }
     sprintf(number, "%3.2f %s", d, strB);
     return number;
 }

char* cob_int_to_string	(	int	,
		char *
	)

                                        {
     if(!number) return NULL;
     sprintf(number, "%i", i);
     return number;
 }

COB_EXPIMP cob_field* cob_intr_abs ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
     mpz_abs (d1.value, d1.value);
 
     make_field_entry (srcfield);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_acos ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     mpz_set (d4.value, d1.value);
     mpz_set (d5.value, d1.value);
     d4.scale = d1.scale;
     d5.scale = d1.scale;
     mpz_set_si (d2.value, -1L);
     d2.scale = 0;
     mpz_set_ui (d3.value, 1UL);
     d3.scale = 0;
 
     cob_set_exception (0);
     if (cob_decimal_cmp (&d4, &d2) < 0 || cob_decimal_cmp (&d5, &d3) > 0) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     cob_decimal_get_mpf (cob_mpft, &d1);
     cob_mpf_acos (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_annuity	(	cob_field *	,
		cob_field *
	)

 {
     int     sign;
 
     cob_decimal_set_field (&d1, srcfield1);
     cob_decimal_set_field (&d2, srcfield2);
 
     /* P1 >= 0, P2 > 0 and integer */
     sign = mpz_sgn (d1.value);
     if (sign < 0 || mpz_sgn (d2.value) <= 0 || d2.scale != 0) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     if (!sign) {
         mpz_set_ui (d1.value, 1UL);
         d1.scale = 0;
         cob_decimal_div (&d1, &d2);
         cob_alloc_field (&d1);
         (void)cob_decimal_get_field (&d1, curr_field, 0);
         return curr_field;
     }
 
     /* x = P1 / (1 - (1 + P1) ^ (-P2)) */
     mpz_neg (d2.value, d2.value);
 
     mpz_set (d3.value, d1.value);
     d3.scale = d1.scale;
     mpz_set_ui (d4.value, 1UL);
     d4.scale = 0;
     cob_decimal_add (&d3, &d4);
     cob_trim_decimal (&d3);
     cob_trim_decimal (&d2);
     cob_decimal_pow (&d3, &d2);
     mpz_set_ui (d4.value, 1UL);
     d4.scale = 0;
     cob_decimal_sub (&d4, &d3);
     cob_trim_decimal (&d4);
     cob_trim_decimal (&d1);
     cob_decimal_div (&d1, &d4);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_asin ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     mpz_set (d4.value, d1.value);
     mpz_set (d5.value, d1.value);
     d4.scale = d1.scale;
     d5.scale = d1.scale;
     mpz_set_si (d2.value, -1L);
     d2.scale = 0;
     mpz_set_ui (d3.value, 1UL);
     d3.scale = 0;
 
     cob_set_exception (0);
     if (cob_decimal_cmp (&d4, &d2) < 0 || cob_decimal_cmp (&d5, &d3) > 0) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     if (!mpz_sgn (d1.value)) {
         /* Asin (0) = 0 */
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     cob_decimal_get_mpf (cob_mpft, &d1);
     cob_mpf_asin (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_atan ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     cob_set_exception (0);
 
     if (!mpz_sgn (d1.value)) {
         /* Atan (0) = 0 */
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     cob_decimal_get_mpf (cob_mpft, &d1);
     cob_mpf_atan (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_binop	(	cob_field *	,
		const int	,
		cob_field *
	)

 {
     cob_decimal_set_field (&d1, f1);
     cob_decimal_set_field (&d2, f2);
     switch (op) {
     case '+':
         cob_decimal_add (&d1, &d2);
         break;
     case '-':
         cob_decimal_sub (&d1, &d2);
         break;
     case '*':
         cob_decimal_mul (&d1, &d2);
         break;
     case '/':
         cob_set_exception (0);
         if (!mpz_sgn (d2.value)) {
             /* Divide by zero */
             cob_set_exception (COB_EC_SIZE_ZERO_DIVIDE);
             mpz_set_ui (d1.value, 0UL);
             d1.scale = 0;
         } else {
             cob_decimal_div (&d1, &d2);
         }
         break;
     case '^':
         cob_decimal_pow (&d1, &d2);
         break;
     default:
         break;
     }
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_boolean_of_integer	(	cob_field *	,
		cob_field *
	)

 {
     COB_UNUSED (f1);
     COB_UNUSED (f2);
 
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_byte_length ( cob_field * )

 {
     cob_alloc_set_field_uint ((cob_u32_t)srcfield->size);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_char ( cob_field * )

 {
     int     i;
     cob_field   field;
 
     COB_FIELD_INIT (1, NULL, &const_alpha_attr);
     make_field_entry (&field);
 
     i = cob_get_int (srcfield);
     if (i < 1 || i > 256) {
         *curr_field->data = 0;
     } else {
         *curr_field->data = i - 1;
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_char_national ( cob_field * )

 {
     COB_UNUSED (srcfield);
 
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_combined_datetime	(	cob_field *	,
		cob_field *
	)

 {
     int     srdays;
     int     srtime;
     cob_field_attr  attr;
     cob_field   field;
     char        buff[16];
 
     COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 12, 5, 0, NULL);
     COB_FIELD_INIT (12, NULL, &attr);
     make_field_entry (&field);
 
     cob_set_exception (0);
     srdays = cob_get_int (srcdays);
     if (!valid_integer_date (srdays)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         memset (curr_field->data, '0', (size_t)12);
         return curr_field;
     }
     srtime = cob_get_int (srctime);
     if (!valid_time (srtime)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         memset (curr_field->data, '0', (size_t)12);
         return curr_field;
     }
     snprintf (buff, (size_t)15, "%7.7d%5.5d", srdays, srtime);
     memcpy (curr_field->data, buff, (size_t)12);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_concatenate	(	const int	,
		const int	,
		const int	,
			...
	)

 {
     cob_field   **f;
     unsigned char   *p;
     size_t      calcsize;
     int     i;
     cob_field   field;
     va_list     args;
 
     f = cob_malloc ((size_t)params * sizeof (cob_field *));
 
     va_start (args, params);
 
     /* Extract args / calculate size */
     calcsize = 0;
     for (i = 0; i < params; ++i) {
         f[i] = va_arg (args, cob_field *);
         calcsize += f[i]->size;
     }
     va_end (args);
 
     COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
     make_field_entry (&field);
 
     p = curr_field->data;
     for (i = 0; i < params; ++i) {
         memcpy (p, f[i]->data, f[i]->size);
         p += f[i]->size;
     }
 
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     cob_free (f);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_cos ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     cob_set_exception (0);
 
     cob_decimal_get_mpf (cob_mpft, &d1);
     cob_mpf_cos (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_currency_symbol ( void )

 {
 #ifdef  HAVE_LOCALECONV
     struct lconv    *p;
     size_t      size;
 #endif
     cob_field   field;
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     cob_set_exception (0);
 
 #ifdef  HAVE_LOCALECONV
     p = localeconv ();
     size = strlen (p->currency_symbol);
     if (size) {
         field.size = size;
     } else {
         field.size = 1;
     }
     make_field_entry (&field);
     if (size) {
         memcpy (curr_field->data, p->currency_symbol, size);
     } else {
         curr_field->size = 0;
         curr_field->data[0] = 0;
     }
 #else
     field.size = 1;
     make_field_entry (&field);
     curr_field->data[0] = COB_MODULE_PTR->currency_symbol;
 #endif
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_current_date	(	const int	,
		const int
	)

 {
 #if defined(_WIN32) && !defined(__CYGWIN__)
     struct tm   *tmptr;
     long        contz;
     struct _timeb   tmb;
     cob_field   field;
 #else
 
     struct tm   *tmptr;
 #if !defined(__linux__) && !defined(__CYGWIN__) && !defined(COB_STRFTIME) && defined(HAVE_TIMEZONE)
     long        contz;
 #endif
     time_t      curtime;
     cob_field   field;
 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
     struct timeval  tmv;
     char        buff2[8];
 #endif
 #endif
     char        buff[24];
 
     COB_FIELD_INIT (21, NULL, &const_alpha_attr);
     make_field_entry (&field);
     memset (buff, 0, sizeof(buff));
 
 #if defined(_WIN32) && !defined(__CYGWIN__)
     _ftime (&tmb);
     tmptr = localtime (&(tmb.time));
     /* Leap seconds ? */
     if (tmptr->tm_sec >= 60) {
         tmptr->tm_sec = 59;
     }
     if (tmb.timezone <= 0) {
         contz = -tmb.timezone;
         snprintf (buff, (size_t)23,
             "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d+%2.2ld%2.2ld",
             tmptr->tm_year + 1900, tmptr->tm_mon + 1, tmptr->tm_mday,
             tmptr->tm_hour, tmptr->tm_min, tmptr->tm_sec,
             tmb.millitm / 100, contz / 60, contz % 60);
     } else {
         contz = tmb.timezone;
         snprintf (buff, (size_t)23,
             "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d-%2.2ld%2.2ld",
             tmptr->tm_year + 1900, tmptr->tm_mon + 1, tmptr->tm_mday,
             tmptr->tm_hour, tmptr->tm_min, tmptr->tm_sec,
             tmb.millitm / 100, contz / 60, contz % 60);
     }
 #else   /* defined(_WIN32) && !defined(__CYGWIN__) */
 
 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
     gettimeofday (&tmv, NULL);
     curtime = tmv.tv_sec;
 #else
     curtime = time (NULL);
 #endif
     tmptr = localtime (&curtime);
     /* Leap seconds ? */
     if (tmptr->tm_sec >= 60) {
         tmptr->tm_sec = 59;
     }
 
 #if defined(__linux__) || defined(__CYGWIN__) || defined(COB_STRFTIME)
     strftime (buff, (size_t)22, "%Y%m%d%H%M%S00%z", tmptr);
 #elif defined(HAVE_TIMEZONE)
     strftime (buff, (size_t)17, "%Y%m%d%H%M%S00", tmptr);
     contz = timezone;
     if (tmptr->tm_isdst > 0) {
         contz -= 3600;
     }
     if (contz <= 0) {
         contz = -contz;
         buff[16] = '+';
     } else {
         buff[16] = '-';
     }
     sprintf(&buff[17], "%2.2ld%2.2ld", contz / 3600, (contz % 3600) / 60);
 #else
     strftime (buff, (size_t)22, "%Y%m%d%H%M%S0000000", tmptr);
 #endif
 
 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
     snprintf(buff2, (size_t)7, "%2.2ld", tmv.tv_usec / 10000);
     memcpy (&buff[14], buff2, (size_t)2);
 #endif
 #endif
 
     memcpy (curr_field->data, buff, (size_t)21);
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_date_of_integer ( cob_field * )

 {
     int     days;
     int     month;
     int         year;
     cob_field_attr  attr;
     cob_field   field;
     char        buff[16];
 
     COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 8, 0, 0, NULL);
     COB_FIELD_INIT (8, NULL, &attr);
     make_field_entry (&field);
 
     cob_set_exception (0);
     /* Base 1601-01-01 */
     days = cob_get_int (srcdays);
     if (!valid_integer_date (days)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         memset (curr_field->data, '0', (size_t)8);
         return curr_field;
     }
 
     date_of_integer (days, &year, &month, &days);
 
     snprintf (buff, (size_t)15, "%4.4d%2.2d%2.2d", year, month, days);
     memcpy (curr_field->data, buff, (size_t)8);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_date_to_yyyymmdd	(	const int	,
			...
	)

 {
     cob_field   *f;
     struct tm   *timeptr;
     va_list     args;
     time_t      t;
     int     year;
     int     mmdd;
     int     interval;
     int     xqtyear;
     int     maxyear;
 
     cob_set_exception (0);
     va_start (args, params);
     f = va_arg (args, cob_field *);
     year = cob_get_int (f);
     mmdd = year % 10000;
     year /= 10000;
     if (params > 1) {
         f = va_arg (args, cob_field *);
         interval = cob_get_int (f);
     } else {
         interval = 50;
     }
     if (params > 2) {
         f = va_arg (args, cob_field *);
         xqtyear = cob_get_int (f);
     } else {
         t = time (NULL);
         timeptr = localtime (&t);
         xqtyear = 1900 + timeptr->tm_year;
     }
     va_end (args);
 
     if (year < 0 || year > 999999) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     if (!valid_year (xqtyear)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     maxyear = xqtyear + interval;
     if (maxyear < 1700 || maxyear > 9999) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     if (maxyear % 100 >= year) {
         year += 100 * (maxyear / 100);
     } else {
         year += 100 * ((maxyear / 100) - 1);
     }
     year *= 10000;
     year += mmdd;
     cob_alloc_set_field_int (year);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_day_of_integer ( cob_field * )

 {
     int     days;
     int     baseyear;
     cob_field_attr  attr;
     cob_field   field;
     char        buff[16];
 
     COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 7, 0, 0, NULL);
     COB_FIELD_INIT (7, NULL, &attr);
     make_field_entry (&field);
 
     cob_set_exception (0);
     /* Base 1601-01-01 */
     days = cob_get_int (srcdays);
     if (!valid_integer_date (days)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         memset (curr_field->data, '0', (size_t)7);
         return curr_field;
     }
 
     day_of_integer (days, &baseyear, &days);
     snprintf (buff, (size_t)15, "%4.4d%3.3d", baseyear, days);
 
     memcpy (curr_field->data, buff, (size_t)7);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_day_to_yyyyddd	(	const int	,
			...
	)

 {
     cob_field   *f;
     struct tm   *timeptr;
     va_list     args;
     time_t      t;
     int     year;
     int     days;
     int     interval;
     int     xqtyear;
     int     maxyear;
 
     cob_set_exception (0);
     va_start (args, params);
     f = va_arg (args, cob_field *);
     year = cob_get_int (f);
     days = year % 1000;
     year /= 1000;
     if (params > 1) {
         f = va_arg (args, cob_field *);
         interval = cob_get_int (f);
     } else {
         interval = 50;
     }
     if (params > 2) {
         f = va_arg (args, cob_field *);
         xqtyear = cob_get_int (f);
     } else {
         t = time (NULL);
         timeptr = localtime (&t);
         xqtyear = 1900 + timeptr->tm_year;
     }
     va_end (args);
 
     if (year < 0 || year > 999999) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     if (!valid_year (xqtyear)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     maxyear = xqtyear + interval;
     if (maxyear < 1700 || maxyear > 9999) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     if (maxyear % 100 >= year) {
         year += 100 * (maxyear / 100);
     } else {
         year += 100 * ((maxyear / 100) - 1);
     }
     year *= 1000;
     year += days;
     cob_alloc_set_field_int (year);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_display_of	(	const int	,
		const int	,
		const int	,
			...
	)

 {
     COB_UNUSED (offset);
     COB_UNUSED (length);
     COB_UNUSED (params);
 
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_e ( void )

 {
     mpf_set_ui (cob_mpft, 1UL);
     cob_mpf_exp (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_exception_file ( void )

 {
     size_t      flen;
     cob_field   field;
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     if (cobglobptr->cob_exception_code == 0 || !cobglobptr->cob_error_file ||
         (cobglobptr->cob_exception_code & 0x0500) != 0x0500) {
         field.size = 2;
         make_field_entry (&field);
         memcpy (curr_field->data, "00", (size_t)2);
     } else {
         flen = strlen (cobglobptr->cob_error_file->select_name);
         field.size = flen + 2;
         make_field_entry (&field);
         memcpy (curr_field->data,
             cobglobptr->cob_error_file->file_status, (size_t)2);
         memcpy (&(curr_field->data[2]),
             cobglobptr->cob_error_file->select_name, flen);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_exception_file_n ( void )

 {
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_exception_location ( void )

 {
     char        *buff;
     cob_field   field;
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     if (!cobglobptr->cob_got_exception || !cobglobptr->cob_orig_program_id) {
         field.size = 1;
         make_field_entry (&field);
         *(curr_field->data) = ' ';
         return curr_field;
     }
     buff = cob_malloc ((size_t)COB_SMALL_BUFF);
     if (cobglobptr->cob_orig_section && cobglobptr->cob_orig_paragraph) {
         snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s OF %s; %u",
               cobglobptr->cob_orig_program_id,
               cobglobptr->cob_orig_paragraph,
               cobglobptr->cob_orig_section,
               cobglobptr->cob_orig_line);
     } else if (cobglobptr->cob_orig_section) {
         snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u",
               cobglobptr->cob_orig_program_id,
               cobglobptr->cob_orig_section,
               cobglobptr->cob_orig_line);
     } else if (cobglobptr->cob_orig_paragraph) {
         snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u",
               cobglobptr->cob_orig_program_id,
               cobglobptr->cob_orig_paragraph,
               cobglobptr->cob_orig_line);
     } else {
         snprintf (buff, (size_t)COB_SMALL_MAX, "%s; ; %u",
               cobglobptr->cob_orig_program_id,
               cobglobptr->cob_orig_line);
     }
     field.size = strlen (buff);
     make_field_entry (&field);
     memcpy (curr_field->data, buff, field.size);
     cob_free (buff);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_exception_location_n ( void )

 {
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_exception_statement ( void )

 {
     size_t      flen;
     cob_field   field;
 
     COB_FIELD_INIT (31, NULL, &const_alpha_attr);
     make_field_entry (&field);
 
     memset (curr_field->data, ' ', (size_t)31);
     if (cobglobptr->cob_exception_code && cobglobptr->cob_orig_statement) {
         flen = strlen (cobglobptr->cob_orig_statement);
         if (flen > 31) {
             memcpy (curr_field->data,
                 cobglobptr->cob_orig_statement, (size_t)31);
         } else {
             memcpy (curr_field->data,
                 cobglobptr->cob_orig_statement, flen);
         }
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_exception_status ( void )

 {
     const char  *except_name;
     cob_field   field;
 
     COB_FIELD_INIT (31, NULL, &const_alpha_attr);
     make_field_entry (&field);
 
     memset (curr_field->data, ' ', (size_t)31);
     if (cobglobptr->cob_exception_code) {
         except_name = cob_get_exception_name ();
         if (except_name == NULL) {
             except_name = "EXCEPTION-OBJECT";
         }
         memcpy (curr_field->data, except_name, strlen (except_name));
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_exp ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     cob_set_exception (0);
 
     if (!mpz_sgn (d1.value)) {
         /* Power is zero */
         cob_alloc_set_field_uint (1);
         return curr_field;
     }
 
     cob_decimal_get_mpf (cob_mpft, &d1);
     cob_mpf_exp (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_exp10 ( cob_field * )

 {
     int     sign;
 
     cob_decimal_set_field (&d1, srcfield);
 
     cob_set_exception (0);
 
     sign = mpz_sgn (d1.value);
     if (!sign) {
         /* Power is zero */
         cob_alloc_set_field_uint (1);
         return curr_field;
     }
 
     cob_trim_decimal (&d1);
 
     if (!d1.scale) {
         /* Integer positive/negative powers */
         if (sign < 0 && mpz_fits_sint_p (d1.value)) {
             mpz_abs (d1.value, d1.value);
             d1.scale = mpz_get_si (d1.value);
             mpz_set_ui (d1.value, 1UL);
             cob_alloc_field (&d1);
             (void)cob_decimal_get_field (&d1, curr_field, 0);
             return curr_field;
         }
         if (sign > 0 && mpz_fits_ulong_p (d1.value)) {
             mpz_ui_pow_ui (d1.value, 10UL, mpz_get_ui (d1.value));
             cob_alloc_field (&d1);
             (void)cob_decimal_get_field (&d1, curr_field, 0);
             return curr_field;
         }
     }
 
     mpz_set_ui (d2.value, 10UL);
     d2.scale = 0;
     cob_decimal_pow (&d2, &d1);
     cob_alloc_field (&d2);
     (void)cob_decimal_get_field (&d2, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_factorial ( cob_field * )

 {
     int     srcval;
 
     cob_set_exception (0);
     srcval = cob_get_int (srcfield);
     d1.scale = 0;
     if (srcval < 0) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     } else {
         mpz_fac_ui (d1.value, (cob_uli_t)srcval);
     }
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_formatted_current_date	(	const int	,
		const int	,
		cob_field *
	)

 {
     COB_UNUSED (offset);
     COB_UNUSED (length);
     COB_UNUSED (srcfield);
 
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_formatted_date	(	const int	,
		const int	,
		cob_field *	,
		cob_field *
	)

 {
     cob_field   field;
     size_t      field_length =
         num_leading_nonspace ((char *) format_field->data);
     char        format_str[MAX_DATE_STR_LENGTH] = { '\0' };
     int     days;
     struct date_format  format;
     char        buff[MAX_DATE_STR_LENGTH] = { '\0' };
 
     memcpy (format_str, format_field->data, field_length);
 
     COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
     make_field_entry (&field);
 
     cob_set_exception (0);
     days = cob_get_int (days_field);
 
     if (!valid_day_and_format (days, format_str)) {
         goto invalid_args;
     }
 
     format = parse_date_format_string (format_str);
     format_date (format, days, buff);
 
     memcpy (curr_field->data, buff, (size_t) field_length);
     goto end_of_func;
 
  invalid_args:
     cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
     memset (curr_field->data, ' ', strlen (format_str));
 
  end_of_func:
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_formatted_datetime	(	const int	,
		const int	,
		const int	,
			...
	)

 {
     va_list     args;
     cob_field   *fmt_field;
     cob_field   *days_field;
     cob_field   *time_field;
     cob_field   *offset_time_field;
     cob_field   field;
     size_t      field_length;
     char        fmt_str[MAX_DATETIME_STR_LENGTH] = { '\0' };
     char        date_fmt_str[MAX_DATE_STR_LENGTH] = { '\0' };
     char        time_fmt_str[MAX_TIME_STR_LENGTH] = { '\0' };
     struct date_format     date_fmt;
     struct time_format     time_fmt;
     char        formatted_date[MAX_DATE_STR_LENGTH] = { '\0' };
     char        formatted_time[MAX_TIME_STR_LENGTH] = { '\0' };
     int     days;
     int     time;
     int     offset_time;
     int     *offset_time_ptr;
     char        buff[MAX_DATETIME_STR_LENGTH] = { '\0' };
 
     if (!(params == 3 || params == 4)) {
         COB_FIELD_INIT (0, NULL, &const_alpha_attr);
         make_field_entry (&field);
         goto invalid_args;
     }
 
     /* Get arguments */
     va_start (args, params);
 
     fmt_field = va_arg (args, cob_field *);
     days_field = va_arg (args, cob_field *);
     time_field = va_arg (args, cob_field *);
     if (params == 4) {
         offset_time_field = va_arg (args, cob_field *);
     } else {
         offset_time_field = NULL;
     }
 
     va_end (args);
 
     field_length = num_leading_nonspace ((char *) fmt_field->data);
     memcpy (fmt_str, fmt_field->data, field_length);
 
     COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
     make_field_entry (&field);
 
     cob_set_exception (0);
 
     /* Validate the formats, dates and times */
     if (!cob_valid_datetime_format (fmt_str)) {
         goto invalid_args;
     }
 
     days = cob_get_int (days_field);
     time = cob_get_int (time_field);
 
     if (!valid_integer_date (days) || !valid_time (time)) {
         goto invalid_args;
     }
 
     split_around_t (fmt_str, date_fmt_str, time_fmt_str);
 
     time_fmt = parse_time_format_string (time_fmt_str);
     if (try_get_valid_offset_time (time_fmt, offset_time_field,
                        &offset_time, &offset_time_ptr)) {
         goto invalid_args;
     }
 
     date_fmt = parse_date_format_string (date_fmt_str);
 
     /* Format */
 
     format_date (date_fmt, days, formatted_date);
     format_time (time_fmt, time, offset_time_ptr, formatted_time);
 
     sprintf (buff, "%sT%s", formatted_date, formatted_time);
 
     memcpy (curr_field->data, buff, (size_t) field_length);
     goto end_of_func;
 
  invalid_args:
     cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
     if (fmt_str != NULL) {
         memset (curr_field->data, ' ', strlen (fmt_str));
     }
 
  end_of_func:
     if (unlikely (offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_formatted_time	(	const int	,
		const int	,
		const int	,
			...
	)

 {
     va_list     args;
     cob_field   *format_field;
     cob_field   *time_field;
     cob_field   *offset_time_field;
     cob_field   field;
     size_t      field_length;
     char        buff[MAX_TIME_STR_LENGTH] = { '\0' };
     char        format_str[MAX_TIME_STR_LENGTH] = { '\0' };
     int     time;
     int     offset_time;
     int     *offset_time_ptr;
     struct time_format  format;
 
     if (!(params == 2 || params == 3)) {
         COB_FIELD_INIT (0, NULL, &const_alpha_attr);
         make_field_entry (&field);
         goto invalid_args;
     }
 
     /* Get args */
     va_start (args, params);
 
     format_field = va_arg (args, cob_field *);
     time_field = va_arg (args, cob_field *);
     if (params == 3) {
         offset_time_field = va_arg (args, cob_field *);
     } else {
         offset_time_field = NULL;
     }
 
     va_end (args);
 
     /* Initialise buffers */
     field_length = num_leading_nonspace ((char *) format_field->data);
     memcpy (format_str, format_field->data, field_length);
 
     COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
     make_field_entry (&field);
 
     cob_set_exception (0);
 
     /* Extract and validate the times and time format */
 
     time = cob_get_int (time_field);
     if (!valid_time (time)) {
         goto invalid_args;
     }
 
     if (!cob_valid_time_format (format_str)) {
         goto invalid_args;
     }
     format = parse_time_format_string (format_str);
 
     if (try_get_valid_offset_time (format, offset_time_field,
                        &offset_time, &offset_time_ptr)) {
         goto invalid_args;
     }
 
     format_time (format, time, offset_time_ptr, buff);
 
     memcpy (curr_field->data, buff, (size_t) field_length);
     goto end_of_func;
 
 invalid_args:
     cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
     if (format_str != NULL) {
         memset (curr_field->data, ' ', strlen (format_str));
     }
 
  end_of_func:
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_fraction_part ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
     /* Check scale */
     if (d1.scale > 0) {
         mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d1.scale);
         mpz_tdiv_r (d1.value, d1.value, cob_mexp);
     } else {
         /* No decimals */
         mpz_set_ui (d1.value, 0UL);
         d1.scale = 0;
     }
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_highest_algebraic ( cob_field * )

 {
     cob_uli_t   expo;
     size_t      size;
     cob_field   field;
 
     switch (COB_FIELD_TYPE (srcfield)) {
     case COB_TYPE_ALPHANUMERIC:
     case COB_TYPE_NATIONAL:
         size = COB_FIELD_SIZE (srcfield);
         COB_FIELD_INIT (size, NULL, &const_alpha_attr);
         make_field_entry (&field);
         memset (curr_field->data, 255, size);
         break;
 
     case COB_TYPE_ALPHANUMERIC_EDITED:
     case COB_TYPE_NATIONAL_EDITED:
         size = COB_FIELD_DIGITS (srcfield);
         COB_FIELD_INIT (size, NULL, &const_alpha_attr);
         make_field_entry (&field);
         memset (curr_field->data, 255, size);
         break;
 
     case COB_TYPE_NUMERIC_BINARY:
         if (COB_FIELD_REAL_BINARY (srcfield) ||
             !COB_FIELD_BINARY_TRUNC (srcfield)) {
             if (!COB_FIELD_HAVE_SIGN (srcfield)) {
                 expo = COB_FIELD_SIZE (srcfield) * 8U;
             } else {
                 expo = (COB_FIELD_SIZE (srcfield) * 8U) - 1U;
             }
             mpz_ui_pow_ui (d1.value, 2UL, expo);
             mpz_sub_ui (d1.value, d1.value, 1UL);
             d1.scale = COB_FIELD_SCALE (srcfield);
             cob_alloc_field (&d1);
             (void)cob_decimal_get_field (&d1, curr_field, 0);
             break;
         }
         expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
         mpz_ui_pow_ui (d1.value, 10UL, expo);
         mpz_sub_ui (d1.value, d1.value, 1UL);
         d1.scale = COB_FIELD_SCALE (srcfield);
         cob_alloc_field (&d1);
         (void)cob_decimal_get_field (&d1, curr_field, 0);
         break;
 
     case COB_TYPE_NUMERIC_FLOAT:
     case COB_TYPE_NUMERIC_DOUBLE:
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         break;
 
     case COB_TYPE_NUMERIC_DISPLAY:
     case COB_TYPE_NUMERIC_PACKED:
     case COB_TYPE_NUMERIC_EDITED:
         expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
         mpz_ui_pow_ui (d1.value, 10UL, expo);
         mpz_sub_ui (d1.value, d1.value, 1UL);
         d1.scale = COB_FIELD_SCALE (srcfield);
         cob_alloc_field (&d1);
         (void)cob_decimal_get_field (&d1, curr_field, 0);
         break;
     default:
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         break;
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_integer ( cob_field * )

 {
     int     sign;
 
     cob_decimal_set_field (&d1, srcfield);
     /* Check scale */
     if (d1.scale < 0) {
         mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-d1.scale);
         mpz_mul (d1.value, d1.value, cob_mexp);
     } else if (d1.scale > 0) {
         sign = mpz_sgn (d1.value);
         mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d1.scale);
         mpz_tdiv_qr (d1.value, cob_mpzt, d1.value, cob_mexp);
         /* Check negative and has decimal places */
         if (sign < 0 && mpz_sgn (cob_mpzt)) {
             mpz_sub_ui (d1.value, d1.value, 1UL);
         }
     }
     d1.scale = 0;
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_integer_of_boolean ( cob_field * )

 {
     COB_UNUSED (srcfield);
 
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_integer_of_date ( cob_field * )

 {
     int     indate;
     int     days;
     int     totaldays;
     int     month;
     int     year;
     int     baseyear;
 
     cob_set_exception (0);
     /* Base 1601-01-01 */
     indate = cob_get_int (srcfield);
     year = indate / 10000;
     if (!valid_year (year)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     indate %= 10000;
     month = indate / 100;
     if (month < 1 || month > 12) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     days = indate % 100;
     if (days < 1 || days > 31) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     if (leap_year (year)) {
         if (days > leap_month_days[month]) {
             cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
             cob_alloc_set_field_uint (0);
             return curr_field;
         }
     } else {
         if (days > normal_month_days[month]) {
             cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
             cob_alloc_set_field_uint (0);
             return curr_field;
         }
     }
     totaldays = 0;
     baseyear = 1601;
     while (baseyear != year) {
         if (leap_year (baseyear)) {
             totaldays += 366;
         } else {
             totaldays += 365;
         }
         ++baseyear;
     }
     if (leap_year (baseyear)) {
         totaldays += leap_days[month - 1];
     } else {
         totaldays += normal_days[month - 1];
     }
     totaldays += days;
     cob_alloc_set_field_int (totaldays);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_integer_of_day ( cob_field * )

 {
     int     indate;
     int     days;
     cob_u32_t   totaldays;
     int     year;
     int     baseyear;
 
     cob_set_exception (0);
     /* Base 1601-01-01 */
     indate = cob_get_int (srcfield);
     year = indate / 1000;
     if (!valid_year (year)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     days = indate % 1000;
     if (days < 1 || days > 365 + leap_year (year)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     totaldays = 0;
     baseyear = 1601;
     while (baseyear != year) {
         if (leap_year (baseyear)) {
             totaldays += 366;
         } else {
             totaldays += 365;
         }
         ++baseyear;
     }
     totaldays += days;
     cob_alloc_set_field_uint (totaldays);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_integer_of_formatted_date	(	cob_field *	,
		cob_field *
	)

 {
     COB_UNUSED (format_field);
     COB_UNUSED (date_field);
 
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_integer_part ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
     /* Check scale */
     if (d1.scale < 0) {
         mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-d1.scale);
         mpz_mul (d1.value, d1.value, cob_mexp);
     } else if (d1.scale > 0) {
         mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d1.scale);
         mpz_tdiv_q (d1.value, d1.value, cob_mexp);
     }
     d1.scale = 0;
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_lcl_time_from_secs	(	const int	,
		const int	,
		cob_field *	,
		cob_field *
	)

 {
     cob_field   field;
 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
     size_t      len;
     int     indate;
     int     hours;
     int     minutes;
     int     seconds;
 #ifdef  HAVE_LANGINFO_CODESET
     char        *deflocale = NULL;
     struct tm   tstruct;
     char        buff2[128];
 #else
     unsigned char   *p;
     LCID        localeid = LOCALE_USER_DEFAULT;
     SYSTEMTIME  syst;
 #endif
     char        buff[128];
     char        locale_buff[COB_SMALL_BUFF];
 #endif
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     cob_set_exception (0);
 
 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
     if (COB_FIELD_IS_NUMERIC (srcfield)) {
         indate = cob_get_int (srcfield);
     } else {
         goto derror;
     }
     if (!valid_time (indate)) {
         goto derror;
     }
     hours = indate / 3600;
     indate %= 3600;
     minutes = indate / 60;
     seconds = indate % 60;
 
 #ifdef  HAVE_LANGINFO_CODESET
     memset ((void *)&tstruct, 0, sizeof(struct tm));
     tstruct.tm_hour = hours;
     tstruct.tm_min = minutes;
     tstruct.tm_sec = seconds;
     if (locale_field) {
         if (locale_field->size >= COB_SMALL_BUFF) {
             goto derror;
         }
         cob_field_to_string (locale_field, locale_buff,
                      (size_t)COB_SMALL_MAX);
         deflocale = locale_buff;
         (void) setlocale (LC_TIME, deflocale);
     }
     memset (buff2, 0, sizeof(buff2));
     snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(T_FMT));
     if (deflocale) {
         (void) setlocale (LC_ALL, cobglobptr->cob_locale);
     }
     strftime (buff, sizeof(buff), buff2, &tstruct);
 #else
     memset ((void *)&syst, 0, sizeof(syst));
     syst.wHour = hours;
     syst.wMinute = minutes;
     syst.wSecond = seconds;
     if (locale_field) {
         if (locale_field->size >= COB_SMALL_BUFF) {
             goto derror;
         }
         cob_field_to_string (locale_field, locale_buff,
                         COB_SMALL_MAX);
         for (p = (unsigned char *)locale_buff; *p; ++p) {
             if (isalnum(*p) || *p == '_') {
                 continue;
             }
             break;
         }
         *p = 0;
         for (len = 0; len < WINLOCSIZE; ++len) {
             if (!strcmp(locale_buff, wintable[len].winlocalename)) {
                 localeid = wintable[len].winlocaleid;
                 break;
             }
         }
         if (len == WINLOCSIZE) {
             goto derror;
         }
     }
     if (!GetTimeFormat (localeid, LOCALE_NOUSEROVERRIDE, &syst, NULL, buff, sizeof(buff))) {
 
         goto derror;
     }
 #endif
     len = strlen (buff);
     field.size = len;
     make_field_entry (&field);
     memcpy (curr_field->data, buff, len);
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 derror:
 #endif
     field.size = 10;
     make_field_entry (&field);
     memset (curr_field->data, ' ', (size_t)10);
     cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_length ( cob_field * )

 {
     if (COB_FIELD_IS_NATIONAL (srcfield)) {
         cob_alloc_set_field_uint ((cob_u32_t)srcfield->size / COB_NATIONAL_SIZE);
     } else {
         cob_alloc_set_field_uint ((cob_u32_t)srcfield->size);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_locale_compare	(	const int	,
			...
	)

 {
     cob_field   *f1;
     cob_field   *f2;
     cob_field   *locale_field;
 #ifdef  HAVE_STRCOLL
     unsigned char   *p;
     unsigned char   *p1;
     unsigned char   *p2;
     char        *deflocale;
     size_t      size;
     size_t      size2;
     int     ret;
 #endif
     cob_field   field;
     va_list     args;
 
     cob_set_exception (0);
     va_start (args, params);
     f1 = va_arg (args, cob_field *);
     f2 = va_arg (args, cob_field *);
     if (params > 2) {
         locale_field = va_arg (args, cob_field *);
     } else {
         locale_field = NULL;
     }
     va_end (args);
 
     COB_FIELD_INIT (1, NULL, &const_alpha_attr);
     make_field_entry (&field);
 
 #ifdef  HAVE_STRCOLL
     deflocale = NULL;
 
     size = f1->size;
     size2 = size;
     for (p = f1->data + size - 1U; p != f1->data; --p) {
         if (*p != ' ') {
             break;
         }
         size2--;
     }
     p1 = cob_malloc (size2 + 1U);
     memcpy (p1, f1->data, size2);
 
     size = f2->size;
     size2 = size;
     for (p = f2->data + size - 1U; p != f2->data; --p) {
         if (*p != ' ') {
             break;
         }
         size2--;
     }
     p2 = cob_malloc (size2 + 1U);
     memcpy (p2, f2->data, size2);
 
     if (locale_field) {
         if (!locale_field->size) {
             goto derror;
         }
 #ifdef  HAVE_SETLOCALE
         deflocale = cob_malloc (locale_field->size + 1U);
         cob_field_to_string (locale_field, deflocale,
                      (size_t)(locale_field->size + 1U));
         (void) setlocale (LC_COLLATE, deflocale);
 #else
         goto derror;
 #endif
     }
 
     ret = strcoll ((char *)p1, (char *)p2);
     if (ret < 0) {
         curr_field->data[0] = '<';
     } else if (ret > 0) {
         curr_field->data[0] = '>';
     } else {
         curr_field->data[0] = '=';
     }
     cob_free (p1);
     cob_free (p2);
 
 #ifdef  HAVE_SETLOCALE
     if (deflocale) {
         (void) setlocale (LC_ALL, cobglobptr->cob_locale);
         cob_free (deflocale);
     }
 #endif
 
     return curr_field;
 derror:
 #endif
     curr_field->data[0] = ' ';
     cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_locale_date	(	const int	,
		const int	,
		cob_field *	,
		cob_field *
	)

 {
     cob_field   field;
 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
     size_t      len;
     int     indate;
     int     days;
     int     month;
     int     year;
 #ifdef  HAVE_LANGINFO_CODESET
     unsigned char   *p;
     char        *deflocale = NULL;
     struct tm   tstruct;
     char        buff2[128];
 #else
     unsigned char   *p;
     LCID        localeid = LOCALE_USER_DEFAULT;
     SYSTEMTIME  syst;
 #endif
     char        buff[128];
     char        locale_buff[COB_SMALL_BUFF];
 #endif
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     cob_set_exception (0);
 
 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
     if (COB_FIELD_IS_NUMERIC (srcfield)) {
         indate = cob_get_int (srcfield);
     } else {
         if (srcfield->size < 8) {
             goto derror;
         }
         p = srcfield->data;
         indate = 0;
         for (len = 0; len < 8; ++len, ++p) {
             if (isdigit (*p)) {
                 indate *= 10;
                 indate += (*p - '0');
             } else {
                 goto derror;
             }
         }
     }
     year = indate / 10000;
     if (!valid_year (year)) {
         goto derror;
     }
     indate %= 10000;
     month = indate / 100;
     if (month < 1 || month > 12) {
         goto derror;
     }
     days = indate % 100;
     if (days < 1 || days > 31) {
         goto derror;
     }
     if (leap_year (year)) {
         if (days > leap_month_days[month]) {
             goto derror;
         }
     } else {
         if (days > normal_month_days[month]) {
             goto derror;
         }
     }
 #ifdef  HAVE_LANGINFO_CODESET
     month--;
 
     memset ((void *)&tstruct, 0, sizeof(struct tm));
     tstruct.tm_year = year - 1900;
     tstruct.tm_mon = month;
     tstruct.tm_mday = days;
     if (locale_field) {
         if (locale_field->size >= COB_SMALL_BUFF) {
             goto derror;
         }
         cob_field_to_string (locale_field, locale_buff,
                      (size_t)COB_SMALL_MAX);
         deflocale = locale_buff;
         (void) setlocale (LC_TIME, deflocale);
     }
     memset (buff2, 0, sizeof(buff2));
     snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(D_FMT));
     if (deflocale) {
         (void) setlocale (LC_ALL, cobglobptr->cob_locale);
     }
     strftime (buff, sizeof(buff), buff2, &tstruct);
 #else
     memset ((void *)&syst, 0, sizeof(syst));
     syst.wYear = year;
     syst.wMonth = month;
     syst.wDay = days;
     if (locale_field) {
         if (locale_field->size >= COB_SMALL_BUFF) {
             goto derror;
         }
         cob_field_to_string (locale_field, locale_buff,
                         COB_SMALL_MAX);
         for (p = (unsigned char *)locale_buff; *p; ++p) {
             if (isalnum(*p) || *p == '_') {
                 continue;
             }
             break;
         }
         *p = 0;
         for (len = 0; len < WINLOCSIZE; ++len) {
             if (!strcmp(locale_buff, wintable[len].winlocalename)) {
                 localeid = wintable[len].winlocaleid;
                 break;
             }
         }
         if (len == WINLOCSIZE) {
             goto derror;
         }
     }
     if (!GetDateFormat (localeid, DATE_SHORTDATE, &syst, NULL, buff, sizeof(buff))) {
         goto derror;
     }
 #endif
     len = strlen (buff);
     field.size = len;
     make_field_entry (&field);
     memcpy (curr_field->data, buff, len);
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 derror:
 #endif
     field.size = 10;
     make_field_entry (&field);
     memset (curr_field->data, ' ', (size_t)10);
     cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_locale_time	(	const int	,
		const int	,
		cob_field *	,
		cob_field *
	)

 {
     cob_field   field;
 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
     size_t      len;
     int     indate;
     int     hours;
     int     minutes;
     int     seconds;
 #ifdef  HAVE_LANGINFO_CODESET
     unsigned char   *p;
     char        *deflocale = NULL;
     struct tm   tstruct;
     char        buff2[128];
 #else
     unsigned char   *p;
     LCID        localeid = LOCALE_USER_DEFAULT;
     SYSTEMTIME  syst;
 #endif
     char        buff[128];
     char        locale_buff[COB_SMALL_BUFF];
 #endif
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     cob_set_exception (0);
 
 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
     if (COB_FIELD_IS_NUMERIC (srcfield)) {
         indate = cob_get_int (srcfield);
     } else {
         if (srcfield->size < 6) {
             goto derror;
         }
         p = srcfield->data;
         indate = 0;
         for (len = 0; len < 6; ++len, ++p) {
             if (isdigit (*p)) {
                 indate *= 10;
                 indate += (*p - '0');
             } else {
                 goto derror;
             }
         }
     }
     hours = indate / 10000;
     if (hours < 0 || hours > 24) {
         goto derror;
     }
     indate %= 10000;
     minutes = indate / 100;
     if (minutes < 0 || minutes > 59) {
         goto derror;
     }
     seconds = indate % 100;
     if (seconds < 0 || seconds > 59) {
         goto derror;
     }
 
 #ifdef  HAVE_LANGINFO_CODESET
     memset ((void *)&tstruct, 0, sizeof(struct tm));
     tstruct.tm_hour = hours;
     tstruct.tm_min = minutes;
     tstruct.tm_sec = seconds;
     if (locale_field) {
         if (locale_field->size >= COB_SMALL_BUFF) {
             goto derror;
         }
         cob_field_to_string (locale_field, locale_buff,
                      (size_t)COB_SMALL_MAX);
         deflocale = locale_buff;
         (void) setlocale (LC_TIME, deflocale);
     }
     memset (buff2, 0, sizeof(buff2));
     snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(T_FMT));
     if (deflocale) {
         (void) setlocale (LC_ALL, cobglobptr->cob_locale);
     }
     strftime (buff, sizeof(buff), buff2, &tstruct);
 #else
     memset ((void *)&syst, 0, sizeof(syst));
     syst.wHour = hours;
     syst.wMinute = minutes;
     syst.wSecond = seconds;
     if (locale_field) {
         if (locale_field->size >= COB_SMALL_BUFF) {
             goto derror;
         }
         cob_field_to_string (locale_field, locale_buff,
                         COB_SMALL_MAX);
         for (p = (unsigned char *)locale_buff; *p; ++p) {
             if (isalnum((int)*p) || *p == '_') {
                 continue;
             }
             break;
         }
         *p = 0;
         for (len = 0; len < WINLOCSIZE; ++len) {
             if (!strcmp(locale_buff, wintable[len].winlocalename)) {
                 localeid = wintable[len].winlocaleid;
                 break;
             }
         }
         if (len == WINLOCSIZE) {
             goto derror;
         }
     }
     if (!GetTimeFormat (localeid, LOCALE_NOUSEROVERRIDE, &syst, NULL, buff, sizeof(buff))) {
 
         goto derror;
     }
 #endif
     len = strlen (buff);
     field.size = len;
     make_field_entry (&field);
     memcpy (curr_field->data, buff, len);
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 derror:
 #endif
     field.size = 10;
     make_field_entry (&field);
     memset (curr_field->data, ' ', (size_t)10);
     cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_log ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     cob_set_exception (0);
     if (mpz_sgn (d1.value) <= 0) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     if (d1.scale) {
         cob_trim_decimal (&d1);
     }
 
     if (!d1.scale && !mpz_cmp_ui (d1.value, 1UL)) {
         /* Log (1) = 0 */
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     cob_decimal_get_mpf (cob_mpft, &d1);
     cob_mpf_log (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_log10 ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     cob_set_exception (0);
     if (mpz_sgn (d1.value) <= 0) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     if (d1.scale) {
         cob_trim_decimal (&d1);
     }
 
     if (!d1.scale && !mpz_cmp_ui (d1.value, 1UL)) {
         /* Log10 (1) = 0 */
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     cob_decimal_get_mpf (cob_mpft, &d1);
     cob_mpf_log10 (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_lower_case	(	const int	,
		const int	,
		cob_field *
	)

 {
     size_t      i, size;
 
     make_field_entry (srcfield);
 
     size = srcfield->size;
     for (i = 0; i < size; ++i) {
         curr_field->data[i] = (cob_u8_t)tolower (srcfield->data[i]);
     }
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_lowest_algebraic ( cob_field * )

 {
     cob_uli_t   expo;
     cob_field   field;
 
     switch (COB_FIELD_TYPE (srcfield)) {
     case COB_TYPE_ALPHANUMERIC:
     case COB_TYPE_NATIONAL:
         COB_FIELD_INIT (COB_FIELD_SIZE (srcfield), NULL, &const_alpha_attr);
         make_field_entry (&field);
         break;
 
     case COB_TYPE_ALPHANUMERIC_EDITED:
     case COB_TYPE_NATIONAL_EDITED:
         COB_FIELD_INIT (COB_FIELD_DIGITS (srcfield), NULL, &const_alpha_attr);
         make_field_entry (&field);
         break;
 
     case COB_TYPE_NUMERIC_BINARY:
         if (!COB_FIELD_HAVE_SIGN (srcfield)) {
             cob_alloc_set_field_uint (0);
             break;
         }
         if (COB_FIELD_REAL_BINARY (srcfield) ||
             !COB_FIELD_BINARY_TRUNC (srcfield)) {
             expo = (cob_uli_t)((COB_FIELD_SIZE (srcfield) * 8U) - 1U);
             mpz_ui_pow_ui (d1.value, 2UL, expo);
             mpz_neg (d1.value, d1.value);
             d1.scale = COB_FIELD_SCALE (srcfield);
             cob_alloc_field (&d1);
             (void)cob_decimal_get_field (&d1, curr_field, 0);
             break;
         }
         expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
         mpz_ui_pow_ui (d1.value, 10UL, expo);
         mpz_sub_ui (d1.value, d1.value, 1UL);
         mpz_neg (d1.value, d1.value);
         d1.scale = COB_FIELD_SCALE (srcfield);
         cob_alloc_field (&d1);
         (void)cob_decimal_get_field (&d1, curr_field, 0);
         break;
 
     case COB_TYPE_NUMERIC_FLOAT:
     case COB_TYPE_NUMERIC_DOUBLE:
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         break;
 
     case COB_TYPE_NUMERIC_DISPLAY:
     case COB_TYPE_NUMERIC_PACKED:
     case COB_TYPE_NUMERIC_EDITED:
         if (!COB_FIELD_HAVE_SIGN (srcfield)) {
             cob_alloc_set_field_uint (0);
             break;
         }
         expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
         mpz_ui_pow_ui (d1.value, 10UL, expo);
         mpz_sub_ui (d1.value, d1.value, 1UL);
         mpz_neg (d1.value, d1.value);
         d1.scale = COB_FIELD_SCALE (srcfield);
         cob_alloc_field (&d1);
         (void)cob_decimal_get_field (&d1, curr_field, 0);
         break;
     default:
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         break;
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_max	(	const int	,
			...
	)

 {
     cob_field   *f;
     cob_field   *basef;
     va_list     args;
     int     i;
 
     va_start (args, params);
 
     basef = va_arg (args, cob_field *);
     for (i = 1; i < params; ++i) {
         f = va_arg (args, cob_field *);
         if (cob_cmp (f, basef) > 0) {
             basef = f;
         }
     }
     va_end (args);
 
     make_field_entry (basef);
     memcpy (curr_field->data, basef->data, basef->size);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_mean	(	const int	,
			...
	)

 {
     cob_field   *f;
     va_list     args;
     int     i;
 
     va_start (args, params);
 
     if (params == 1) {
         f = va_arg (args, cob_field *);
         va_end (args);
         make_field_entry (f);
         memcpy (curr_field->data, f->data, f->size);
         return curr_field;
     }
 
     mpz_set_ui (d1.value, 0UL);
     d1.scale = 0;
 
     for (i = 0; i < params; ++i) {
         f = va_arg (args, cob_field *);
         cob_decimal_set_field (&d2, f);
         cob_decimal_add (&d1, &d2);
     }
     va_end (args);
 
     mpz_set_ui (d2.value, (cob_uli_t)params);
     d2.scale = 0;
     cob_decimal_div (&d1, &d2);
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_median	(	const int	,
			...
	)

 {
     cob_field   *f;
     cob_field   **field_alloc;
     va_list     args;
     int     i;
 
     va_start (args, params);
 
     f = va_arg (args, cob_field *);
     if (params == 1) {
         va_end (args);
         make_field_entry (f);
         memcpy (curr_field->data, f->data, f->size);
         return curr_field;
     }
 
     field_alloc = cob_malloc ((size_t)params * sizeof (cob_field *));
     field_alloc[0] = f;
 
     for (i = 1; i < params; ++i) {
         field_alloc[i] = va_arg (args, cob_field *);
     }
     va_end (args);
 
     qsort (field_alloc, (size_t)params, (size_t)sizeof (cob_field *),
            comp_field);
 
     i = params / 2;
     if (params % 2) {
         f = field_alloc[i];
         make_field_entry (f);
         memcpy (curr_field->data, f->data, f->size);
     } else {
         cob_decimal_set_field (&d1, field_alloc[i-1]);
         cob_decimal_set_field (&d2, field_alloc[i]);
         cob_decimal_add (&d1, &d2);
         mpz_set_ui (d2.value, 2UL);
         d2.scale = 0;
         cob_decimal_div (&d1, &d2);
         cob_alloc_field (&d1);
         (void)cob_decimal_get_field (&d1, curr_field, 0);
     }
     cob_free (field_alloc);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_midrange	(	const int	,
			...
	)

 {
     cob_field   *f;
     cob_field   *basemin;
     cob_field   *basemax;
     va_list     args;
     int     i;
 
     va_start (args, params);
 
     basemin = va_arg (args, cob_field *);
     basemax = basemin;
     for (i = 1; i < params; ++i) {
         f = va_arg (args, cob_field *);
         if (cob_cmp (f, basemin) < 0) {
             basemin = f;
         }
         if (cob_cmp (f, basemax) > 0) {
             basemax = f;
         }
     }
     va_end (args);
 
     cob_decimal_set_field (&d1, basemin);
     cob_decimal_set_field (&d2, basemax);
     cob_decimal_add (&d1, &d2);
     mpz_set_ui (d2.value, 2UL);
     d2.scale = 0;
     cob_decimal_div (&d1, &d2);
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_min	(	const int	,
			...
	)

 {
     cob_field   *f;
     cob_field   *basef;
     va_list     args;
     int     i;
 
     va_start (args, params);
 
     basef = va_arg (args, cob_field *);
     for (i = 1; i < params; ++i) {
         f = va_arg (args, cob_field *);
         if (cob_cmp (f, basef) < 0) {
             basef = f;
         }
     }
     va_end (args);
 
     make_field_entry (basef);
     memcpy (curr_field->data, basef->data, basef->size);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_mod	(	cob_field *	,
		cob_field *
	)

 {
     return cob_mod_or_rem (srcfield1, srcfield2, 0);
 }

COB_EXPIMP cob_field* cob_intr_module_caller_id ( void )

 {
     size_t      calcsize;
     cob_field   field;
 
     if (!COB_MODULE_PTR->next) {
         COB_FIELD_INIT (1, NULL, &const_alpha_attr);
         make_field_entry (&field);
         curr_field->size = 0;
         curr_field->data[0] = ' ';
         return curr_field;
     }
     calcsize = strlen (COB_MODULE_PTR->next->module_name);
     COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
     make_field_entry (&field);
     memcpy (curr_field->data, COB_MODULE_PTR->next->module_name,
         calcsize);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_module_date ( void )

 {
     cob_field_attr  attr;
     cob_field   field;
     char        buff[16];
 
     COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 8, 0, 0, NULL);
     COB_FIELD_INIT (8, NULL, &attr);
     make_field_entry (&field);
     snprintf (buff, sizeof(buff), "%8.8u", COB_MODULE_PTR->module_date);
     memcpy (curr_field->data, buff, (size_t)8);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_module_formatted_date ( void )

 {
     size_t      calcsize;
     cob_field   field;
 
     calcsize = strlen (COB_MODULE_PTR->module_formatted_date);
     COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
     make_field_entry (&field);
     memcpy (curr_field->data, COB_MODULE_PTR->module_formatted_date,
         calcsize);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_module_id ( void )

 {
     size_t      calcsize;
     cob_field   field;
 
     calcsize = strlen (COB_MODULE_PTR->module_name);
     COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
     make_field_entry (&field);
     memcpy (curr_field->data, COB_MODULE_PTR->module_name, calcsize);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_module_path ( void )

 {
     size_t      calcsize;
     cob_field   field;
 
     if (!COB_MODULE_PTR->module_path ||
         !*(COB_MODULE_PTR->module_path)) {
         COB_FIELD_INIT (1, NULL, &const_alpha_attr);
         make_field_entry (&field);
         curr_field->size = 0;
         curr_field->data[0] = ' ';
         return curr_field;
     }
     calcsize = strlen (*(COB_MODULE_PTR->module_path));
     COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
     make_field_entry (&field);
     memcpy (curr_field->data, *(COB_MODULE_PTR->module_path),
         calcsize);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_module_source ( void )

 {
     size_t      calcsize;
     cob_field   field;
 
     calcsize = strlen (COB_MODULE_PTR->module_source);
     COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
     make_field_entry (&field);
     memcpy (curr_field->data, COB_MODULE_PTR->module_source, calcsize);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_module_time ( void )

 {
     cob_field_attr  attr;
     cob_field   field;
     char        buff[8];
 
     COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 6, 0, 0, NULL);
     COB_FIELD_INIT (6, NULL, &attr);
     make_field_entry (&field);
     snprintf (buff, sizeof(buff), "%6.6u", COB_MODULE_PTR->module_time);
     memcpy (curr_field->data, buff, (size_t)6);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_mon_decimal_point ( void )

 {
 #ifdef  HAVE_LOCALECONV
     struct lconv    *p;
     size_t      size;
 #endif
     cob_field   field;
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     cob_set_exception (0);
 
 #ifdef  HAVE_LOCALECONV
     p = localeconv ();
     size = strlen (p->mon_decimal_point);
     if (size) {
         field.size = size;
     } else {
         field.size = 1;
     }
     make_field_entry (&field);
     if (size) {
         memcpy (curr_field->data, p->mon_decimal_point, size);
     } else {
         curr_field->size = 0;
         curr_field->data[0] = 0;
     }
 #else
     field.size = 1;
     make_field_entry (&field);
     curr_field->data[0] = COB_MODULE_PTR->decimal_point;
 #endif
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_mon_thousands_sep ( void )

 {
 #ifdef  HAVE_LOCALECONV
     struct lconv    *p;
     size_t      size;
 #endif
     cob_field   field;
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     cob_set_exception (0);
 
 #ifdef  HAVE_LOCALECONV
     p = localeconv ();
     size = strlen (p->mon_thousands_sep);
     if (size) {
         field.size = size;
     } else {
         field.size = 1;
     }
     make_field_entry (&field);
     if (size) {
         memcpy (curr_field->data, p->mon_thousands_sep, size);
     } else {
         curr_field->size = 0;
         curr_field->data[0] = 0;
     }
 #else
     field.size = 1;
     make_field_entry (&field);
     curr_field->data[0] = COB_MODULE_PTR->decimal_point;
 #endif
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_national_of	(	const int	,
		const int	,
		const int	,
			...
	)

 {
     COB_UNUSED (offset);
     COB_UNUSED (length);
     COB_UNUSED (params);
 
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_num_decimal_point ( void )

 {
 #ifdef  HAVE_LOCALECONV
     struct lconv    *p;
     size_t      size;
 #endif
     cob_field   field;
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     cob_set_exception (0);
 
 #ifdef  HAVE_LOCALECONV
     p = localeconv ();
     size = strlen (p->decimal_point);
     if (size) {
         field.size = size;
     } else {
         field.size = 1;
     }
     make_field_entry (&field);
     if (size) {
         memcpy (curr_field->data, p->decimal_point, size);
     } else {
         curr_field->size = 0;
         curr_field->data[0] = 0;
     }
 #else
     field.size = 1;
     make_field_entry (&field);
     curr_field->data[0] = COB_MODULE_PTR->decimal_point;
 #endif
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_num_thousands_sep ( void )

 {
 #ifdef  HAVE_LOCALECONV
     struct lconv    *p;
     size_t      size;
 #endif
     cob_field   field;
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     cob_set_exception (0);
 
 #ifdef  HAVE_LOCALECONV
     p = localeconv ();
     size = strlen (p->thousands_sep);
     if (size) {
         field.size = size;
     } else {
         field.size = 1;
     }
     make_field_entry (&field);
     if (size) {
         memcpy (curr_field->data, p->thousands_sep, size);
     } else {
         curr_field->size = 0;
         curr_field->data[0] = 0;
     }
 #else
     field.size = 1;
     make_field_entry (&field);
     curr_field->data[0] = COB_MODULE_PTR->decimal_point;
 #endif
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_numval ( cob_field * )

 {
     unsigned char   *final_buff;
     size_t      i;
     int     final_digits;
     int     decimal_digits;
     int     sign;
     int     decimal_seen;
     unsigned char   dec_pt;
 
     /* Validate source field */
     if (cob_check_numval (srcfield, NULL, 0, 0)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     final_digits = 0;
     decimal_digits = 0;
     sign = 0;
     decimal_seen = 0;
     dec_pt = COB_MODULE_PTR->decimal_point;
     final_buff = cob_malloc (srcfield->size + 1U);
 
     for (i = 0; i < srcfield->size; ++i) {
         if (i < (srcfield->size - 1)) {
             if (memcmp (&srcfield->data[i], "CR", (size_t)2) == 0 ||
                 memcmp (&srcfield->data[i], "DB", (size_t)2) == 0) {
                 sign = 1;
                 break;
             }
         }
         if (srcfield->data[i] == ' ') {
             continue;
         }
         if (srcfield->data[i] == '+') {
             continue;
         }
         if (srcfield->data[i] == '-') {
             sign = 1;
             continue;
         }
         if (srcfield->data[i] == dec_pt) {
             decimal_seen = 1;
             continue;
         }
         if (srcfield->data[i] >= (unsigned char)'0' &&
             srcfield->data[i] <= (unsigned char)'9') {
             if (decimal_seen) {
                 decimal_digits++;
             }
             final_buff[final_digits++] = srcfield->data[i];
         }
         if (final_digits > COB_MAX_DIGITS) {
             break;
         }
     }
 
     if (!final_digits) {
         final_buff[0] = '0';
     }
     mpz_set_str (d1.value, (char *)final_buff, 10);
     cob_free (final_buff);
     if (sign && mpz_sgn (d1.value)) {
         mpz_neg (d1.value, d1.value);
     }
     d1.scale = decimal_digits;
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_numval_c	(	cob_field *	,
		cob_field *
	)

 {
     unsigned char   *final_buff;
     unsigned char   *currency_data;
     size_t      i;
     int     decimal_digits;
     int     final_digits;
     int     sign;
     int     decimal_seen;
     unsigned char   dec_pt;
     unsigned char   cur_symb;
 
     /* Validate source field */
     if (cob_check_numval (srcfield, currency, 1, 0)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     decimal_digits = 0;
     final_digits = 0;
     sign = 0;
     decimal_seen = 0;
     dec_pt = COB_MODULE_PTR->decimal_point;
     cur_symb = COB_MODULE_PTR->currency_symbol;
     final_buff = cob_malloc (srcfield->size + 1U);
 
     currency_data = NULL;
     if (currency) {
         if (currency->size < srcfield->size) {
             currency_data = currency->data;
         }
     }
     for (i = 0; i < srcfield->size; ++i) {
         if (i < (srcfield->size - 1)) {
             if (memcmp (&srcfield->data[i], "CR", (size_t)2) == 0 ||
                 memcmp (&srcfield->data[i], "DB", (size_t)2) == 0) {
                 sign = 1;
                 break;
             }
         }
         if (currency_data) {
             if (i < (srcfield->size - currency->size)) {
                 if (!memcmp (&srcfield->data[i],
                          currency_data, currency->size)) {
                     i += (currency->size - 1);
                     continue;
                 }
             }
         } else if (srcfield->data[i] == cur_symb) {
             continue;
         }
         if (srcfield->data[i] == ' ') {
             continue;
         }
         if (srcfield->data[i] == '+') {
             continue;
         }
         if (srcfield->data[i] == '-') {
             sign = 1;
             continue;
         }
         if (srcfield->data[i] == dec_pt) {
             decimal_seen = 1;
             continue;
         }
         if (srcfield->data[i] >= (unsigned char)'0' &&
             srcfield->data[i] <= (unsigned char)'9') {
             if (decimal_seen) {
                 decimal_digits++;
             }
             final_buff[final_digits++] = srcfield->data[i];
         }
         if (final_digits > COB_MAX_DIGITS) {
             break;
         }
     }
 
     if (!final_digits) {
         final_buff[0] = '0';
     }
     mpz_set_str (d1.value, (char *)final_buff, 10);
     cob_free (final_buff);
     if (sign && mpz_sgn (d1.value)) {
         mpz_neg (d1.value, d1.value);
     }
     d1.scale = decimal_digits;
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_numval_f ( cob_field * )

 {
     unsigned char   *final_buff;
     unsigned char   *p;
     size_t      plus_minus;
     size_t      digits;
     size_t      decimal_digits;
     size_t      dec_seen;
     size_t      e_seen;
     size_t      exponent;
     size_t      e_plus_minus;
     size_t      n;
     unsigned char   dec_pt;
 
     /* Validate source field */
     if (cob_check_numval_f (srcfield)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     plus_minus = 0;
     digits = 0;
     decimal_digits = 0;
     dec_seen = 0;
     e_seen = 0;
     exponent = 0;
     e_plus_minus = 0;
     dec_pt = COB_MODULE_PTR->decimal_point;
 
     final_buff = cob_malloc (srcfield->size + 1U);
     p = srcfield->data;
     for (n = 0; n < srcfield->size; ++n, ++p) {
         switch (*p) {
         case '0':
         case '1':
         case '2':
         case '3':
         case '4':
         case '5':
         case '6':
         case '7':
         case '8':
         case '9':
             if (e_seen) {
                 exponent *= 10;
                 exponent += (*p & 0x0F);
             } else  {
                 if (dec_seen) {
                     decimal_digits++;
                 }
                 final_buff[digits++] = *p;
             }
             continue;
         case 'E':
             e_seen = 1;
             continue;
         case '-':
             if (e_seen) {
                 e_plus_minus = 1;
             } else {
                 plus_minus = 1;
             }
             continue;
         default:
             if (*p == dec_pt) {
                 dec_seen = 1;
             }
             continue;
         }
     }
 
     if (!digits) {
         final_buff[0] = '0';
     }
 
     mpz_set_str (d1.value, (char *)final_buff, 10);
     cob_free (final_buff);
     if (!mpz_sgn (d1.value)) {
         /* Value is zero ; sign and exponent irrelevant */
         d1.scale = 0;
         cob_alloc_field (&d1);
         (void)cob_decimal_get_field (&d1, curr_field, 0);
         return curr_field;
     }
     if (plus_minus) {
         mpz_neg (d1.value, d1.value);
     }
     if (exponent) {
         if (e_plus_minus) {
             /* Negative exponent */
             d1.scale = decimal_digits + exponent;
         } else {
             /* Positive exponent */
             if (decimal_digits >= exponent) {
                 d1.scale = decimal_digits - exponent;
             } else {
                 exponent -= decimal_digits;
                 mpz_ui_pow_ui (cob_mexp, 10UL,
                            (cob_uli_t)exponent);
                 mpz_mul (d1.value, d1.value, cob_mexp);
                 d1.scale = 0;
             }
         }
     } else {
         /* No exponent */
         d1.scale = decimal_digits;
     }
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_ord ( cob_field * )

 {
     cob_alloc_set_field_uint ((cob_u32_t)(*srcfield->data + 1U));
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_ord_max	(	const int	,
			...
	)

 {
     cob_field   *f;
     cob_field   *basef;
     cob_u32_t   ordmax;
     int     i;
     va_list     args;
 
     va_start (args, params);
 
     ordmax = 1;
     basef = va_arg (args, cob_field *);
     for (i = 1; i < params; ++i) {
         f = va_arg (args, cob_field *);
         if (cob_cmp (f, basef) > 0) {
             basef = f;
             ordmax = i + 1;
         }
     }
     va_end (args);
 
     cob_alloc_set_field_uint (ordmax);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_ord_min	(	const int	,
			...
	)

 {
     cob_field   *f;
     cob_field   *basef;
     int     i;
     cob_u32_t   ordmin;
     va_list     args;
 
     va_start (args, params);
 
     ordmin = 1;
     basef = va_arg (args, cob_field *);
     for (i = 1; i < params; ++i) {
         f = va_arg (args, cob_field *);
         if (cob_cmp (f, basef) < 0) {
             basef = f;
             ordmin = i + 1;
         }
     }
     va_end (args);
 
     cob_alloc_set_field_uint (ordmin);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_pi ( void )

 {
     mpf_set (cob_mpft, cob_pi);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_present_value	(	const int	,
			...
	)

 {
     cob_field   *f;
     va_list     args;
     int     i;
 
     va_start (args, params);
 
     f = va_arg (args, cob_field *);
 
     cob_decimal_set_field (&d1, f);
     mpz_set_ui (d2.value, 1UL);
     d2.scale = 0;
     cob_decimal_add (&d1, &d2);
 
     mpz_set_ui (d4.value, 0UL);
     d4.scale = 0;
 
     for (i = 1; i < params; ++i) {
         f = va_arg (args, cob_field *);
         cob_decimal_set_field (&d2, f);
         mpz_set (d3.value, d1.value);
         d3.scale = d1.scale;
         if (i > 1) {
             mpz_pow_ui (d3.value, d3.value, (cob_uli_t)i);
             d3.scale *= i;
         }
         cob_decimal_div (&d2, &d3);
         cob_decimal_add (&d4, &d2);
     }
     va_end (args);
 
     cob_alloc_field (&d4);
     (void)cob_decimal_get_field (&d4, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_random	(	const int	,
			...
	)

 {
     cob_field   *f;
     va_list     args;
     double      val;
     int     seed;
     int     randnum;
     cob_field_attr  attr;
     cob_field   field;
 
     COB_ATTR_INIT (COB_TYPE_NUMERIC_DOUBLE, 20, 9, COB_FLAG_HAVE_SIGN, NULL);
     COB_FIELD_INIT (sizeof(double), NULL, &attr);
     va_start (args, params);
 
     if (params) {
         f = va_arg (args, cob_field *);
         seed = cob_get_int (f);
         if (seed < 0) {
             seed = 0;
         }
 #ifdef  __CYGWIN__
         srandom ((unsigned int)seed);
 #else
         srand ((unsigned int)seed);
 #endif
     }
     va_end (args);
 
 #ifdef  __CYGWIN__
     randnum = (int)random ();
 #else
     randnum = rand ();
 #endif
     make_field_entry (&field);
     val = (double)randnum / (double)RAND_MAX;
     memcpy (curr_field->data, &val, sizeof(val));
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_range	(	const int	,
			...
	)

 {
     cob_field   *f, *basemin, *basemax;
     va_list     args;
     int     i;
 
     va_start (args, params);
 
     basemin = va_arg (args, cob_field *);
     basemax = basemin;
     for (i = 1; i < params; ++i) {
         f = va_arg (args, cob_field *);
         if (cob_cmp (f, basemin) < 0) {
             basemin = f;
         }
         if (cob_cmp (f, basemax) > 0) {
             basemax = f;
         }
     }
     va_end (args);
 
     cob_decimal_set_field (&d1, basemax);
     cob_decimal_set_field (&d2, basemin);
     cob_decimal_sub (&d1, &d2);
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_rem	(	cob_field *	,
		cob_field *
	)

 {
     return cob_mod_or_rem (srcfield1, srcfield2, 1);
 }

COB_EXPIMP cob_field* cob_intr_reverse	(	const int	,
		const int	,
		cob_field *
	)

 {
     size_t      i, size;
 
     make_field_entry (srcfield);
 
     size = srcfield->size;
     for (i = 0; i < size; ++i) {
         curr_field->data[i] = srcfield->data[size - i - 1];
     }
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_seconds_from_formatted_time	(	cob_field *	,
		cob_field *
	)

 {
     unsigned char   *p1;
     unsigned char   *p2;
     size_t      n;
     cob_u32_t   seconds = 0;
     cob_u32_t   minutes = 0;
     cob_u32_t   hours = 0;
     cob_u32_t   seconds_seen = 0;
     cob_u32_t   minutes_seen = 0;
     cob_u32_t   hours_seen = 0;
 
     cob_set_exception (0);
     if (value->size < format->size) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     p1 = format->data;
     p2 = value->data;
     for (n = 0; n < format->size - 1; ++n, ++p1, ++p2) {
         if (!memcmp (p1, "hh", (size_t)2) && !hours_seen) {
             if (*p2 >= (unsigned char)'0' &&
                 *p2 <= (unsigned char)'9' &&
                 *(p2 + 1) >= (unsigned char)'0' &&
                 *(p2 + 1) <= (unsigned char)'9') {
                 hours = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
                 hours_seen = 1;
                 continue;
             }
         }
         if (!memcmp (p1, "mm", (size_t)2) && !minutes_seen) {
             if (*p2 >= (unsigned char)'0' &&
                 *p2 <= (unsigned char)'9' &&
                 *(p2 + 1) >= (unsigned char)'0' &&
                 *(p2 + 1) <= (unsigned char)'9') {
                 minutes = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
                 minutes_seen = 1;
                 continue;
             }
         }
         if (!memcmp (p1, "ss", (size_t)2) && !seconds_seen) {
             if (*p2 >= (unsigned char)'0' &&
                 *p2 <= (unsigned char)'9' &&
                 *(p2 + 1) >= (unsigned char)'0' &&
                 *(p2 + 1) <= (unsigned char)'9') {
                 seconds = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
                 seconds_seen = 1;
                 continue;
             }
         }
     }
     if (hours_seen && minutes_seen && seconds_seen) {
         seconds += (hours * 3600) + (minutes * 60);
     } else {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         seconds = 0;
     }
     cob_alloc_set_field_uint (seconds);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_seconds_past_midnight ( void )

 {
     struct tm   *timeptr;
     time_t      t;
     int     seconds;
 
     t = time (NULL);
     timeptr = localtime (&t);
     /* Leap seconds ? */
     if (timeptr->tm_sec >= 60) {
         timeptr->tm_sec = 59;
     }
     seconds = (timeptr->tm_hour * 3600) + (timeptr->tm_min * 60) +
             timeptr->tm_sec;
     cob_alloc_set_field_int (seconds);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_sign ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
     cob_alloc_set_field_int (mpz_sgn (d1.value));
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_sin ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     cob_set_exception (0);
 
     cob_decimal_get_mpf (cob_mpft, &d1);
     cob_mpf_sin (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_sqrt ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     cob_set_exception (0);
     if (mpz_sgn (d1.value) < 0) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     mpz_set_ui (d2.value, 5UL);
     d2.scale = 1;
     cob_trim_decimal (&d1);
     cob_decimal_pow (&d1, &d2);
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_standard_compare	(	const int	,
			...
	)

 {
     COB_UNUSED (params);
 
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_standard_deviation	(	const int	,
			...
	)

 {
     cob_field   *f;
     va_list     args;
     int     i;
 
     va_start (args, params);
 
     if (params == 1) {
         va_end (args);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     /* MEAN for all params */
     mpz_set_ui (d1.value, 0UL);
     d1.scale = 0;
 
     for (i = 0; i < params; ++i) {
         f = va_arg (args, cob_field *);
         cob_decimal_set_field (&d2, f);
         cob_decimal_add (&d1, &d2);
     }
     va_end (args);
 
     mpz_set_ui (d2.value, (cob_uli_t)params);
     d2.scale = 0;
     cob_decimal_div (&d1, &d2);
 
     /* Got the MEAN in d1, iterate again */
 
     mpz_set_ui (d4.value, 0UL);
     d4.scale = 0;
 
     va_start (args, params);
 
     for (i = 0; i < params; ++i) {
         f = va_arg (args, cob_field *);
         cob_decimal_set_field (&d2, f);
         cob_decimal_sub (&d2, &d1);
         cob_decimal_mul (&d2, &d2);
         cob_decimal_add (&d4, &d2);
     }
     va_end (args);
 
     mpz_set_ui (d3.value, (cob_uli_t)params);
     d3.scale = 0;
     cob_decimal_div (&d4, &d3);
 
     /* We have the VARIANCE in d4, sqrt = STANDARD-DEVIATION */
 
     cob_trim_decimal (&d4);
 
     cob_set_exception (0);
 
     mpz_set_ui (d3.value, 5UL);
     d3.scale = 1;
 
     cob_trim_decimal (&d4);
     cob_decimal_pow (&d4, &d3);
 
     cob_alloc_field (&d4);
     (void)cob_decimal_get_field (&d4, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_stored_char_length ( cob_field * )

 {
     unsigned char   *p;
     cob_u32_t   count;
 
     count = srcfield->size;
     p = srcfield->data + srcfield->size - 1;
     for (; count > 0; count--, p--) {
         if (*p != ' ') {
             break;
         }
     }
 
     cob_alloc_set_field_uint (count);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_substitute	(	const int	,
		const int	,
		const int	,
			...
	)

 {
     cob_field   *var;
     cob_field   **f1;
     cob_field   **f2;
     unsigned char   *p1;
     unsigned char   *p2;
     size_t      varsize;
     size_t      calcsize;
     size_t      n;
     size_t      found;
     int     numreps;
     int     i;
     cob_field   field;
     va_list     args;
 
     numreps = params / 2;
     f1 = cob_malloc ((size_t)numreps * sizeof (cob_field *));
     f2 = cob_malloc ((size_t)numreps * sizeof (cob_field *));
 
     va_start (args, params);
 
     var = va_arg (args, cob_field *);
     varsize = var->size;
 
     /* Extract args */
     for (i = 0; i < params - 1; ++i) {
         if ((i % 2) == 0) {
             f1[i / 2] = va_arg (args, cob_field *);
         } else {
             f2[i / 2] = va_arg (args, cob_field *);
         }
     }
     va_end (args);
 
     /* Calculate required size */
     calcsize = 0;
     found = 0;
     p1 = var->data;
     for (n = 0; n < varsize; ) {
         for (i = 0; i < numreps; ++i) {
             if (n + f1[i]->size <= varsize) {
                 if (!memcmp (p1, f1[i]->data, f1[i]->size)) {
                     p1 += f1[i]->size;
                     n += f1[i]->size;
                     calcsize += f2[i]->size;
                     found = 1;
                     break;
                 }
             }
         }
         if (found) {
             found = 0;
             continue;
         }
         ++n;
         ++p1;
         ++calcsize;
     }
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     field.size = calcsize;
     make_field_entry (&field);
 
     found = 0;
     p1 = var->data;
     p2 = curr_field->data;
     for (n = 0; n < varsize; ) {
         for (i = 0; i < numreps; ++i) {
             if (n + f1[i]->size <= varsize) {
                 if (!memcmp (p1, f1[i]->data, f1[i]->size)) {
                     memcpy (p2, f2[i]->data, f2[i]->size);
                     p1 += f1[i]->size;
                     p2 += f2[i]->size;
                     n += f1[i]->size;
                     found = 1;
                     break;
                 }
             }
         }
         if (found) {
             found = 0;
             continue;
         }
         ++n;
         *p2++ = *p1++;
     }
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     cob_free (f1);
     cob_free (f2);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_substitute_case	(	const int	,
		const int	,
		const int	,
			...
	)

 {
     cob_field   *var;
     cob_field   **f1;
     cob_field   **f2;
     unsigned char   *p1;
     unsigned char   *p2;
     size_t      varsize;
     size_t      calcsize;
     size_t      n;
     size_t      found;
     int     numreps;
     int     i;
     cob_field   field;
     va_list     args;
 
     numreps = params / 2;
     f1 = cob_malloc ((size_t)numreps * sizeof (cob_field *));
     f2 = cob_malloc ((size_t)numreps * sizeof (cob_field *));
 
     va_start (args, params);
 
     var = va_arg (args, cob_field *);
     varsize = var->size;
 
     /* Extract args */
     for (i = 0; i < params - 1; ++i) {
         if ((i % 2) == 0) {
             f1[i / 2] = va_arg (args, cob_field *);
         } else {
             f2[i / 2] = va_arg (args, cob_field *);
         }
     }
     va_end (args);
 
     /* Calculate required size */
     calcsize = 0;
     found = 0;
     p1 = var->data;
     for (n = 0; n < varsize; ) {
         for (i = 0; i < numreps; ++i) {
             if (n + f1[i]->size <= varsize) {
                 if (!strncasecmp ((const char *)p1,
                           (const char *)(f1[i]->data),
                           f1[i]->size)) {
                     p1 += f1[i]->size;
                     n += f1[i]->size;
                     calcsize += f2[i]->size;
                     found = 1;
                     break;
                 }
             }
         }
         if (found) {
             found = 0;
             continue;
         }
         ++n;
         ++p1;
         ++calcsize;
     }
 
     COB_FIELD_INIT (0, NULL, &const_alpha_attr);
     field.size = calcsize;
     make_field_entry (&field);
 
     found = 0;
     p1 = var->data;
     p2 = curr_field->data;
     for (n = 0; n < varsize; ) {
         for (i = 0; i < numreps; ++i) {
             if (n + f1[i]->size <= varsize) {
                 if (!strncasecmp ((const char *)p1,
                           (const char *)(f1[i]->data),
                           f1[i]->size)) {
                     memcpy (p2, f2[i]->data, f2[i]->size);
                     p1 += f1[i]->size;
                     p2 += f2[i]->size;
                     n += f1[i]->size;
                     found = 1;
                     break;
                 }
             }
         }
         if (found) {
             found = 0;
             continue;
         }
         ++n;
         *p2++ = *p1++;
     }
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     cob_free (f1);
     cob_free (f2);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_sum	(	const int	,
			...
	)

 {
     cob_field   *f;
     va_list     args;
     int     i;
 
     mpz_set_ui (d1.value, 0UL);
     d1.scale = 0;
 
     va_start (args, params);
 
     for (i = 0; i < params; ++i) {
         f = va_arg (args, cob_field *);
         cob_decimal_set_field (&d2, f);
         cob_decimal_add (&d1, &d2);
     }
     va_end (args);
 
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_tan ( cob_field * )

 {
     cob_decimal_set_field (&d1, srcfield);
 
     cob_set_exception (0);
 
     cob_decimal_get_mpf (cob_mpft, &d1);
     cob_mpf_tan (cob_mpft, cob_mpft);
     cob_decimal_set_mpf (&d1, cob_mpft);
     cob_alloc_field (&d1);
     (void)cob_decimal_get_field (&d1, curr_field, 0);
 
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_test_date_yyyymmdd ( cob_field * )

 {
     int     indate;
     int     days;
     int     month;
     int     year;
 
     /* Base 1601-01-01 */
     indate = cob_get_int (srcfield);
     year = indate / 10000;
     if (!valid_year (year)) {
         cob_alloc_set_field_uint (1);
         return curr_field;
     }
     indate %= 10000;
     month = indate / 100;
     if (month < 1 || month > 12) {
         cob_alloc_set_field_uint (2);
         return curr_field;
     }
     days = indate % 100;
     if (days < 1 || days > 31) {
         cob_alloc_set_field_uint (3);
         return curr_field;
     }
     if (leap_year (year)) {
         if (days > leap_month_days[month]) {
             cob_alloc_set_field_uint (3);
             return curr_field;
         }
     } else {
         if (days > normal_month_days[month]) {
             cob_alloc_set_field_uint (3);
             return curr_field;
         }
     }
     cob_alloc_set_field_uint (0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_test_day_yyyyddd ( cob_field * )

 {
     int     indate;
     int     days;
     int     year;
 
     /* Base 1601-01-01 */
     indate = cob_get_int (srcfield);
     year = indate / 1000;
     if (!valid_year (year)) {
         cob_alloc_set_field_uint (1);
         return curr_field;
     }
     days = indate % 1000;
     if (days < 1 || days > 365 + leap_year (year)) {
         cob_alloc_set_field_uint (2);
         return curr_field;
     }
     cob_alloc_set_field_uint (0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_test_formatted_datetime	(	cob_field *	,
		cob_field *
	)

 {
     COB_UNUSED (f1);
     COB_UNUSED (f2);
 
     cob_fatal_error (COB_FERROR_FUNCTION);
 }

COB_EXPIMP cob_field* cob_intr_test_numval ( cob_field * )

 {
     cob_alloc_set_field_int (cob_check_numval (srcfield, NULL, 0, 0));
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_test_numval_c	(	cob_field *	,
		cob_field *
	)

 {
     cob_alloc_set_field_int (cob_check_numval (srcfield, currency, 1, 0));
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_test_numval_f ( cob_field * )

 {
     cob_alloc_set_field_int (cob_check_numval_f (srcfield));
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_trim	(	const int	,
		const int	,
		cob_field *	,
		const int
	)

 {
     unsigned char   *begin;
     unsigned char   *end;
     size_t      i;
     size_t      size;
 
     make_field_entry (srcfield);
 
     for (i = 0; i < srcfield->size; ++i) {
         if (srcfield->data[i] != ' ') {
             break;
         }
     }
     if (i == srcfield->size) {
         curr_field->size = 0;
         curr_field->data[0] = ' ';
         return curr_field;
     }
 
     begin = srcfield->data;
     if (direction != 2) {
         for (; *begin == ' '; ++begin) ;
     }
     end = srcfield->data + srcfield->size - 1;
     if (direction != 1) {
         for (; *end == ' '; end--) ;
     }
 
     size = 0;
     for (i = 0; begin <= end; ++begin, ++i) {
         curr_field->data[i] = *begin;
         ++size;
     }
     curr_field->size = size;
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_upper_case	(	const int	,
		const int	,
		cob_field *
	)

 {
     size_t      i, size;
 
     make_field_entry (srcfield);
 
     size = srcfield->size;
     for (i = 0; i < size; ++i) {
         curr_field->data[i] = (cob_u8_t)toupper (srcfield->data[i]);
     }
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_variance	(	const int	,
			...
	)

 {
     cob_field   *f;
     va_list     args;
     int     i;
 
     va_start (args, params);
 
     if (params == 1) {
         va_end (args);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
 
     /* MEAN for all params */
     mpz_set_ui (d1.value, 0UL);
     d1.scale = 0;
 
     for (i = 0; i < params; ++i) {
         f = va_arg (args, cob_field *);
         cob_decimal_set_field (&d2, f);
         cob_decimal_add (&d1, &d2);
     }
     va_end (args);
 
     mpz_set_ui (d2.value, (cob_uli_t)params);
     d2.scale = 0;
     cob_decimal_div (&d1, &d2);
 
     /* Got the MEAN in d1, iterate again */
 
     mpz_set_ui (d4.value, 0UL);
     d4.scale = 0;
 
     va_start (args, params);
 
     for (i = 0; i < params; ++i) {
         f = va_arg (args, cob_field *);
         cob_decimal_set_field (&d2, f);
         cob_decimal_sub (&d2, &d1);
         cob_decimal_mul (&d2, &d2);
         cob_decimal_add (&d4, &d2);
     }
     va_end (args);
 
     mpz_set_ui (d3.value, (cob_uli_t)params);
     d3.scale = 0;
     cob_decimal_div (&d4, &d3);
 
     cob_alloc_field (&d4);
     (void)cob_decimal_get_field (&d4, curr_field, 0);
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_when_compiled	(	const int	,
		const int	,
		cob_field *
	)

 {
     make_field_entry (f);
 
     memcpy (curr_field->data, f->data, f->size);
     if (unlikely(offset > 0)) {
         calc_ref_mod (curr_field, offset, length);
     }
     return curr_field;
 }

COB_EXPIMP cob_field* cob_intr_year_to_yyyy	(	const int	,
			...
	)

 {
     cob_field   *f;
     struct tm   *timeptr;
     va_list     args;
     time_t      t;
     int     year;
     int     interval;
     int     xqtyear;
     int     maxyear;
 
     cob_set_exception (0);
     va_start (args, params);
     f = va_arg (args, cob_field *);
     year = cob_get_int (f);
     if (params > 1) {
         f = va_arg (args, cob_field *);
         interval = cob_get_int (f);
     } else {
         interval = 50;
     }
     if (params > 2) {
         f = va_arg (args, cob_field *);
         xqtyear = cob_get_int (f);
     } else {
         t = time (NULL);
         timeptr = localtime (&t);
         xqtyear = 1900 + timeptr->tm_year;
     }
     va_end (args);
 
     if (year < 0 || year > 99) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     if (!valid_year (xqtyear)) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     maxyear = xqtyear + interval;
     if (maxyear < 1700 || maxyear > 9999) {
         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
         cob_alloc_set_field_uint (0);
         return curr_field;
     }
     if (maxyear % 100 >= year) {
         year += 100 * (maxyear / 100);
     } else {
         year += 100 * ((maxyear / 100) - 1);
     }
     cob_alloc_set_field_int (year);
     return curr_field;
 }

COB_EXPIMP int cob_is_alpha ( const cob_field * )

 {
     size_t  i;
 
     for (i = 0; i < f->size; ++i) {
         if (!isalpha (f->data[i]) && f->data[i] != (unsigned char)' ') {
             return 0;
         }
     }
     return 1;
 }

COB_EXPIMP int cob_is_lower ( const cob_field * )

 {
     size_t  i;
 
     for (i = 0; i < f->size; ++i) {
         if (!islower (f->data[i]) && f->data[i] != (unsigned char)' ') {
             return 0;
         }
     }
     return 1;
 }

COB_EXPIMP int cob_is_numeric ( const cob_field * )

 {
     size_t      i;
     union {
         float       fpf;
         double      fpd;
     } fval;
     int     sign;
 
     switch (COB_FIELD_TYPE (f)) {
     case COB_TYPE_NUMERIC_BINARY:
         return 1;
     case COB_TYPE_NUMERIC_FLOAT:
         memcpy (&fval.fpf, f->data, sizeof(float));
         return !finite ((double)fval.fpf);
     case COB_TYPE_NUMERIC_DOUBLE:
         memcpy (&fval.fpd, f->data, sizeof(double));
         return !finite (fval.fpd);
     case COB_TYPE_NUMERIC_PACKED:
         /* Check digits */
         for (i = 0; i < f->size - 1; ++i) {
             if ((f->data[i] & 0xF0) > 0x90 ||
                 (f->data[i] & 0x0F) > 0x09) {
                 return 0;
             }
         }
         /* Check high nibble of last byte */
         if ((f->data[i] & 0xF0) > 0x90) {
             return 0;
         }
 
         if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
             /* COMP-6 - Check last nibble */
             if ((f->data[i] & 0x0F) > 0x09) {
                 return 0;
             }
             return 1;
         }
 
         /* Check sign */
         sign = f->data[i] & 0x0F;
         if (COB_FIELD_HAVE_SIGN (f)) {
             if (sign == 0x0C || sign == 0x0D) {
                 return 1;
             }
             if (COB_MODULE_PTR->flag_host_sign &&
                 sign == 0x0F) {
                 return 1;
             }
         } else if (sign == 0x0F) {
             return 1;
         }
         return 0;
     case COB_TYPE_NUMERIC_DISPLAY:
         return cob_check_numdisp (f);
     case COB_TYPE_NUMERIC_FP_DEC64:
 #ifdef  WORDS_BIGENDIAN
         return (f->data[0] & 0x78U) != 0x78U;
 #else
         return (f->data[7] & 0x78U) != 0x78U;
 #endif
     case COB_TYPE_NUMERIC_FP_DEC128:
 #ifdef  WORDS_BIGENDIAN
         return (f->data[0] & 0x78U) != 0x78U;
 #else
         return (f->data[15] & 0x78U) != 0x78U;
 #endif
     default:
         for (i = 0; i < f->size; ++i) {
             if (!isdigit (f->data[i])) {
                 return 0;
             }
         }
         return 1;
     }
 }

COB_EXPIMP int cob_is_omitted ( const cob_field * )

 {
     return f->data == NULL;
 }

COB_EXPIMP int cob_is_upper ( const cob_field * )

 {
     size_t  i;
 
     for (i = 0; i < f->size; ++i) {
         if (!isupper (f->data[i]) && f->data[i] != (unsigned char)' ') {
             return 0;
         }
     }
     return 1;
 }

COB_EXPIMP void cob_longjmp ( struct cobjmp_buf * )

 {
     if (unlikely(!cobglobptr)) {
         cob_fatal_error (COB_FERROR_INITIALIZED);
     }
     if (unlikely(!jbuf)) {
         cob_runtime_error (_("NULL parameter passed to 'cob_longjmp'"));
         cob_stop_run (1);
     }
     if (!cob_jmp_primed) {
         cob_runtime_error (_("Call to 'cob_longjmp' with no prior 'cob_setjmp'"));
         cob_stop_run (1);
     }
     cob_jmp_primed = 0;
     longjmp (jbuf->cbj_jmp_buf, 1);
 }

COB_EXPIMP void* cob_malloc ( const size_t )

 {
     void    *mptr;
 
     mptr = calloc ((size_t)1, size);
     if (unlikely(!mptr)) {
         cob_fatal_error (COB_FERROR_MEMORY);
     }
     return mptr;
 }

COB_EXPIMP void cob_module_enter	(	cob_module **	,
		cob_global **	,
		const int
	)

 {
     /* Check initialized */
     if (unlikely(!cob_initialized)) {
         if (auto_init) {
             cob_init (0, NULL);
         } else {
             cob_fatal_error (COB_FERROR_INITIALIZED);
         }
     }
 
     /* Set global pointer */
     *mglobal = cobglobptr;
 
     /* Check module pointer */
     if (!*module) {
         *module = cob_cache_malloc (sizeof(cob_module));
     }
 
 #if 0   /* RXWRXW - Params */
     /* Save parameter count */
     (*module)->module_num_params = cobglobptr->cob_call_params;
 #endif
 
     /* Push module pointer */
     (*module)->next = COB_MODULE_PTR;
     COB_MODULE_PTR = *module;
 }

COB_EXPIMP void cob_module_leave ( cob_module * )

 {
     COB_UNUSED (module);
     /* Pop module pointer */
     COB_MODULE_PTR = COB_MODULE_PTR->next;
 }

COB_EXPIMP void cob_move	(	cob_field *	,
		cob_field *
	)

 {
     int     opt;
     cob_field   temp;
     unsigned char   data[4];
 
     if (src == dst) {
         return;
     }
     if (dst->size == 0) {
         return;
     }
     if (unlikely(src->size == 0)) {
         temp.size = 1;
         temp.data = data;
         temp.attr = &const_alpha_attr;
         data[0] = ' ';
         data[1] = 0;
         src = &temp;
     }
     if (COB_FIELD_TYPE (src) == COB_TYPE_ALPHANUMERIC_ALL) {
         cob_move_all (src, dst);
         return;
     }
 
     /* Non-elementary move */
     if (COB_FIELD_TYPE (src) == COB_TYPE_GROUP ||
         COB_FIELD_TYPE (dst) == COB_TYPE_GROUP) {
         cob_move_alphanum_to_alphanum (src, dst);
         return;
     }
 
     opt = 0;
     if (COB_FIELD_TYPE (dst) == COB_TYPE_NUMERIC_BINARY) {
         if (COB_FIELD_BINARY_TRUNC (dst) &&
             !COB_FIELD_REAL_BINARY(dst)) {
             opt = COB_STORE_TRUNC_ON_OVERFLOW;
         }
     }
 
     /* Elementary move */
     switch (COB_FIELD_TYPE (src)) {
     case COB_TYPE_NUMERIC_DISPLAY:
         switch (COB_FIELD_TYPE (dst)) {
         case COB_TYPE_NUMERIC_FLOAT:
         case COB_TYPE_NUMERIC_DOUBLE:
         case COB_TYPE_NUMERIC_L_DOUBLE:
         case COB_TYPE_NUMERIC_FP_BIN32:
         case COB_TYPE_NUMERIC_FP_BIN64:
         case COB_TYPE_NUMERIC_FP_BIN128:
         case COB_TYPE_NUMERIC_FP_DEC64:
         case COB_TYPE_NUMERIC_FP_DEC128:
             cob_decimal_setget_fld (src, dst, 0);
             return;
         case COB_TYPE_NUMERIC_DISPLAY:
             cob_move_display_to_display (src, dst);
             return;
         case COB_TYPE_NUMERIC_PACKED:
             cob_move_display_to_packed (src, dst);
             return;
         case COB_TYPE_NUMERIC_BINARY:
             cob_move_display_to_binary (src, dst);
             return;
         case COB_TYPE_NUMERIC_EDITED:
             cob_move_display_to_edited (src, dst);
             return;
         case COB_TYPE_ALPHANUMERIC_EDITED:
             if (COB_FIELD_SCALE(src) < 0 ||
                 COB_FIELD_SCALE(src) > COB_FIELD_DIGITS(src)) {
                 /* Expand P's */
                 indirect_move (cob_move_display_to_display, src, dst,
                           (size_t)cob_max_int ((int)COB_FIELD_DIGITS(src), (int)COB_FIELD_SCALE(src)),
                           cob_max_int (0, (int)COB_FIELD_SCALE(src)));
                 return;
             } else {
                 cob_move_alphanum_to_edited (src, dst);
                 return;
             }
         default:
             cob_move_display_to_alphanum (src, dst);
             return;
         }
 
     case COB_TYPE_NUMERIC_PACKED:
         switch (COB_FIELD_TYPE (dst)) {
         case COB_TYPE_NUMERIC_DISPLAY:
             cob_move_packed_to_display (src, dst);
             return;
         case COB_TYPE_NUMERIC_BINARY:
             cob_decimal_setget_fld (src, dst, opt);
             return;
         case COB_TYPE_NUMERIC_PACKED:
         case COB_TYPE_NUMERIC_DOUBLE:
         case COB_TYPE_NUMERIC_FLOAT:
         case COB_TYPE_NUMERIC_L_DOUBLE:
         case COB_TYPE_NUMERIC_FP_BIN32:
         case COB_TYPE_NUMERIC_FP_BIN64:
         case COB_TYPE_NUMERIC_FP_BIN128:
         case COB_TYPE_NUMERIC_FP_DEC64:
         case COB_TYPE_NUMERIC_FP_DEC128:
             cob_decimal_setget_fld (src, dst, 0);
             return;
         default:
             indirect_move (cob_move_packed_to_display, src, dst,
                     (size_t)(COB_FIELD_DIGITS(src)),
                     COB_FIELD_SCALE(src));
             return;
         }
 
     case COB_TYPE_NUMERIC_BINARY:
         switch (COB_FIELD_TYPE (dst)) {
         case COB_TYPE_NUMERIC_BINARY:
             if (COB_FIELD_SCALE(src) == COB_FIELD_SCALE(dst)) {
                 cob_move_binary_to_binary (src, dst);
                 return;
             }
             cob_decimal_setget_fld (src, dst, opt);
             return;
         case COB_TYPE_NUMERIC_DISPLAY:
             cob_move_binary_to_display (src, dst);
             return;
         case COB_TYPE_NUMERIC_PACKED:
         case COB_TYPE_NUMERIC_DOUBLE:
         case COB_TYPE_NUMERIC_FLOAT:
         case COB_TYPE_NUMERIC_L_DOUBLE:
         case COB_TYPE_NUMERIC_FP_BIN32:
         case COB_TYPE_NUMERIC_FP_BIN64:
         case COB_TYPE_NUMERIC_FP_BIN128:
         case COB_TYPE_NUMERIC_FP_DEC64:
         case COB_TYPE_NUMERIC_FP_DEC128:
             cob_decimal_setget_fld (src, dst, 0);
             return;
         case COB_TYPE_NUMERIC_EDITED:
             indirect_move (cob_move_binary_to_display, src, dst,
                        (size_t)COB_MAX_DIGITS,
                        COB_FIELD_SCALE(src));
             return;
         default:
             indirect_move (cob_move_binary_to_display, src, dst,
                        (size_t)(COB_FIELD_DIGITS(src)),
                        COB_FIELD_SCALE(src));
             return;
         }
 
     case COB_TYPE_NUMERIC_EDITED:
         switch (COB_FIELD_TYPE (dst)) {
         case COB_TYPE_NUMERIC_DISPLAY:
             cob_move_edited_to_display (src, dst);
             return;
         case COB_TYPE_NUMERIC_PACKED:
         case COB_TYPE_NUMERIC_BINARY:
         case COB_TYPE_NUMERIC_EDITED:
         case COB_TYPE_NUMERIC_FLOAT:
         case COB_TYPE_NUMERIC_DOUBLE:
         case COB_TYPE_NUMERIC_L_DOUBLE:
         case COB_TYPE_NUMERIC_FP_BIN32:
         case COB_TYPE_NUMERIC_FP_BIN64:
         case COB_TYPE_NUMERIC_FP_BIN128:
         case COB_TYPE_NUMERIC_FP_DEC64:
         case COB_TYPE_NUMERIC_FP_DEC128:
             indirect_move (cob_move_edited_to_display, src, dst,
                     (size_t)(2 * COB_MAX_DIGITS),
                     COB_MAX_DIGITS);
             return;
         case COB_TYPE_ALPHANUMERIC_EDITED:
             cob_move_alphanum_to_edited (src, dst);
             return;
         default:
             cob_move_alphanum_to_alphanum (src, dst);
             return;
         }
 
     case COB_TYPE_NUMERIC_DOUBLE:
         switch (COB_FIELD_TYPE (dst)) {
         case COB_TYPE_NUMERIC_DOUBLE:
             memmove (dst->data, src->data, sizeof(double));
             return;
         case COB_TYPE_NUMERIC_FLOAT:
             cob_move_fp_to_fp (src, dst);
             return;
         case COB_TYPE_NUMERIC_BINARY:
             cob_decimal_setget_fld (src, dst, opt);
             return;
         case COB_TYPE_NUMERIC_PACKED:
         case COB_TYPE_NUMERIC_DISPLAY:
         case COB_TYPE_NUMERIC_L_DOUBLE:
         case COB_TYPE_NUMERIC_FP_BIN32:
         case COB_TYPE_NUMERIC_FP_BIN64:
         case COB_TYPE_NUMERIC_FP_BIN128:
         case COB_TYPE_NUMERIC_FP_DEC64:
         case COB_TYPE_NUMERIC_FP_DEC128:
             cob_decimal_setget_fld (src, dst, 0);
             return;
         default:
             cob_decimal_move_temp (src, dst);
             return;
         }
 
     case COB_TYPE_NUMERIC_FLOAT:
         switch (COB_FIELD_TYPE (dst)) {
         case COB_TYPE_NUMERIC_FLOAT:
             memmove (dst->data, src->data, sizeof(float));
             return;
         case COB_TYPE_NUMERIC_DOUBLE:
             cob_move_fp_to_fp (src, dst);
             return;
         case COB_TYPE_NUMERIC_BINARY:
             cob_decimal_setget_fld (src, dst, opt);
             return;
         case COB_TYPE_NUMERIC_PACKED:
         case COB_TYPE_NUMERIC_DISPLAY:
         case COB_TYPE_NUMERIC_L_DOUBLE:
         case COB_TYPE_NUMERIC_FP_BIN32:
         case COB_TYPE_NUMERIC_FP_BIN64:
         case COB_TYPE_NUMERIC_FP_BIN128:
         case COB_TYPE_NUMERIC_FP_DEC64:
         case COB_TYPE_NUMERIC_FP_DEC128:
             cob_decimal_setget_fld (src, dst, 0);
             return;
         default:
             cob_decimal_move_temp (src, dst);
             return;
         }
 
     case COB_TYPE_NUMERIC_FP_DEC64:
         switch (COB_FIELD_TYPE (dst)) {
         case COB_TYPE_NUMERIC_BINARY:
             cob_decimal_setget_fld (src, dst, opt);
             return;
         case COB_TYPE_NUMERIC_FP_DEC64:
             memmove (dst->data, src->data, (size_t)8);
             return;
         case COB_TYPE_NUMERIC_FLOAT:
         case COB_TYPE_NUMERIC_DOUBLE:
         case COB_TYPE_NUMERIC_PACKED:
         case COB_TYPE_NUMERIC_DISPLAY:
         case COB_TYPE_NUMERIC_L_DOUBLE:
         case COB_TYPE_NUMERIC_FP_BIN32:
         case COB_TYPE_NUMERIC_FP_BIN128:
         case COB_TYPE_NUMERIC_FP_DEC128:
             cob_decimal_setget_fld (src, dst, 0);
             return;
         default:
             cob_decimal_move_temp (src, dst);
             return;
         }
     case COB_TYPE_NUMERIC_FP_DEC128:
         switch (COB_FIELD_TYPE (dst)) {
         case COB_TYPE_NUMERIC_BINARY:
             cob_decimal_setget_fld (src, dst, opt);
             return;
         case COB_TYPE_NUMERIC_FP_DEC128:
             memmove (dst->data, src->data, (size_t)16);
             return;
         case COB_TYPE_NUMERIC_FLOAT:
         case COB_TYPE_NUMERIC_DOUBLE:
         case COB_TYPE_NUMERIC_PACKED:
         case COB_TYPE_NUMERIC_DISPLAY:
         case COB_TYPE_NUMERIC_L_DOUBLE:
         case COB_TYPE_NUMERIC_FP_BIN32:
         case COB_TYPE_NUMERIC_FP_BIN64:
         case COB_TYPE_NUMERIC_FP_BIN128:
         case COB_TYPE_NUMERIC_FP_DEC64:
             cob_decimal_setget_fld (src, dst, 0);
             return;
         default:
             cob_decimal_move_temp (src, dst);
             return;
         }
     default:
         switch (COB_FIELD_TYPE (dst)) {
         case COB_TYPE_NUMERIC_DISPLAY:
             cob_move_alphanum_to_display (src, dst);
             return;
         case COB_TYPE_NUMERIC_PACKED:
         case COB_TYPE_NUMERIC_BINARY:
         case COB_TYPE_NUMERIC_EDITED:
         case COB_TYPE_NUMERIC_FLOAT:
         case COB_TYPE_NUMERIC_DOUBLE:
         case COB_TYPE_NUMERIC_L_DOUBLE:
         case COB_TYPE_NUMERIC_FP_BIN32:
         case COB_TYPE_NUMERIC_FP_BIN64:
         case COB_TYPE_NUMERIC_FP_BIN128:
         case COB_TYPE_NUMERIC_FP_DEC64:
         case COB_TYPE_NUMERIC_FP_DEC128:
             indirect_move (cob_move_alphanum_to_display, src, dst,
                     (size_t)(2* COB_MAX_DIGITS),
                     COB_MAX_DIGITS);
             return;
         case COB_TYPE_ALPHANUMERIC_EDITED:
             cob_move_alphanum_to_edited (src, dst);
             return;
         default:
             cob_move_alphanum_to_alphanum (src, dst);
             return;
         }
     }
 }

COB_EXPIMP void cob_mul	(	cob_field *	,
		cob_field *	,
		const int
	)

 {
     cob_decimal_set_field (&cob_d1, f1);
     cob_decimal_set_field (&cob_d2, f2);
     cob_decimal_mul (&cob_d1, &cob_d2);
     (void)cob_decimal_get_field (&cob_d1, f1, opt);
 }

COB_EXPIMP int cob_numeric_cmp	(	cob_field *	,
		cob_field *
	)

 {
     if(COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_FLOAT
     || COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_DOUBLE
     || COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_FLOAT
     || COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_DOUBLE) {
         return cob_cmp_float(f1,f2);
     }
     cob_decimal_set_field (&cob_d1, f1);
     cob_decimal_set_field (&cob_d2, f2);
     return cob_decimal_cmp (&cob_d1, &cob_d2);
 }

COB_EXPIMP void cob_open	(	cob_file *	,
		const int	,
		const int	,
		cob_field *
	)

 {
     f->flag_read_done = 0;
 
     /* File was previously closed with lock */
     if (f->open_mode == COB_OPEN_LOCKED) {
         save_status (f, fnstatus, COB_STATUS_38_CLOSED_WITH_LOCK);
         return;
     }
 
     /* File is already open */
     if (f->open_mode != COB_OPEN_CLOSED) {
         save_status (f, fnstatus, COB_STATUS_41_ALREADY_OPEN);
         return;
     }
 
     f->last_open_mode = mode;
     f->flag_nonexistent = 0;
     f->flag_end_of_file = 0;
     f->flag_begin_of_file = 0;
     f->flag_first_read = 2;
     f->flag_operation = 0;
     f->lock_mode &= ~COB_LOCK_OPEN_EXCLUSIVE;
     f->lock_mode |= sharing;
 
     if (unlikely(COB_FILE_STDIN (f))) {
         if (mode != COB_OPEN_INPUT) {
             save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR);
             return;
         }
         f->file = stdin;
         f->fd = fileno (stdin);
         f->open_mode = mode;
         save_status (f, fnstatus, COB_STATUS_00_SUCCESS);
         return;
     }
     if (unlikely(COB_FILE_STDOUT (f))) {
         if (mode != COB_OPEN_OUTPUT) {
             save_status (f, fnstatus, COB_STATUS_30_PERMANENT_ERROR);
             return;
         }
         f->file = stdout;
         f->fd = fileno (stdout);
         f->open_mode = mode;
         save_status (f, fnstatus, COB_STATUS_00_SUCCESS);
         return;
     }
 
     /* Obtain the file name */
     cob_field_to_string (f->assign, file_open_name, (size_t)COB_FILE_MAX);
 
     cob_cache_file (f);
 
     /* Open the file */
     save_status (f, fnstatus,
              fileio_funcs[(int)f->organization]->open (f, file_open_name,
                                 mode, sharing));
 }

COB_EXPIMP void cob_put_indirect_field ( cob_field * )

 {
     make_field_entry (f);
     memcpy (curr_field->data, f->data, f->size);
     move_field = curr_field;
 }

COB_EXPIMP int cob_putenv ( char * )

 {
     int ret;
 
     if (name && strchr (name, '=')) {
         ret = putenv (cob_strdup(name));
         if (!ret) {
             cob_rescan_env_vals ();
         }
         return ret;
     }
     return -1;
 }

COB_EXPIMP void cob_read	(	cob_file *	,
		cob_field *	,
		cob_field *	,
		const int
	)

 {
     int ret;
 
     f->flag_read_done = 0;
 
     if (unlikely(f->open_mode != COB_OPEN_INPUT &&
              f->open_mode != COB_OPEN_I_O)) {
         save_status (f, fnstatus, COB_STATUS_47_INPUT_DENIED);
         return;
     }
 
     if (unlikely(f->flag_nonexistent)) {
         if (f->flag_first_read == 0) {
             save_status (f, fnstatus, COB_STATUS_23_KEY_NOT_EXISTS);
             return;
         }
         f->flag_first_read = 0;
         save_status (f, fnstatus, COB_STATUS_10_END_OF_FILE);
         return;
     }
 
     /* Sequential read at the end of file is an error */
     if (key == NULL) {
         if (unlikely(f->flag_end_of_file &&
                  !(read_opts & COB_READ_PREVIOUS))) {
             save_status (f, fnstatus, COB_STATUS_46_READ_ERROR);
             return;
         }
         if (unlikely(f->flag_begin_of_file &&
                  (read_opts & COB_READ_PREVIOUS))) {
             save_status (f, fnstatus, COB_STATUS_46_READ_ERROR);
             return;
         }
         ret = fileio_funcs[(int)f->organization]->read_next (f, read_opts);
     } else {
         ret = fileio_funcs[(int)f->organization]->read (f, key, read_opts);
     }
 
     switch (ret) {
     case COB_STATUS_00_SUCCESS:
     case COB_STATUS_02_SUCCESS_DUPLICATE:
         f->flag_first_read = 0;
         f->flag_read_done = 1;
         f->flag_end_of_file = 0;
         f->flag_begin_of_file = 0;
         if (f->variable_record) {
             cob_set_int (f->variable_record, (int) f->record->size);
         }
         break;
     case COB_STATUS_10_END_OF_FILE:
         if (read_opts & COB_READ_PREVIOUS) {
             f->flag_begin_of_file = 1;
         } else {
             f->flag_end_of_file = 1;
         }
         break;
     }
 
     save_status (f, fnstatus, ret);
 }

COB_EXPIMP void cob_read_next	(	cob_file *	,
		cob_field *	,
		const int
	)

 {
     int ret;
 
     f->flag_read_done = 0;
 
     if (unlikely(f->open_mode != COB_OPEN_INPUT &&
              f->open_mode != COB_OPEN_I_O)) {
         save_status (f, fnstatus, COB_STATUS_47_INPUT_DENIED);
         return;
     }
 
     if (unlikely(f->flag_nonexistent)) {
         if (f->flag_first_read == 0) {
             save_status (f, fnstatus, COB_STATUS_23_KEY_NOT_EXISTS);
             return;
         }
         f->flag_first_read = 0;
         save_status (f, fnstatus, COB_STATUS_10_END_OF_FILE);
         return;
     }
 
     /* Sequential read at the end of file is an error */
     if (unlikely(f->flag_end_of_file && !(read_opts & COB_READ_PREVIOUS))) {
         save_status (f, fnstatus, COB_STATUS_46_READ_ERROR);
         return;
     }
     if (unlikely(f->flag_begin_of_file && (read_opts & COB_READ_PREVIOUS))) {
         save_status (f, fnstatus, COB_STATUS_46_READ_ERROR);
         return;
     }
 
     ret = fileio_funcs[(int)f->organization]->read_next (f, read_opts);
 
     switch (ret) {
     case COB_STATUS_00_SUCCESS:
     case COB_STATUS_02_SUCCESS_DUPLICATE:
         f->flag_first_read = 0;
         f->flag_read_done = 1;
         f->flag_end_of_file = 0;
         f->flag_begin_of_file = 0;
         if (f->variable_record) {
             cob_set_int (f->variable_record, (int) f->record->size);
         }
         break;
     case COB_STATUS_10_END_OF_FILE:
         if (read_opts & COB_READ_PREVIOUS) {
             f->flag_begin_of_file = 1;
         } else {
             f->flag_end_of_file = 1;
         }
         break;
     }
 
     save_status (f, fnstatus, ret);
 }

COB_EXPIMP void cob_ready_trace ( void )

 {
     cob_line_trace = 1;
 }

COB_EXPIMP void cob_reg_sighnd ( void(*)(int) sighnd )

 {
     cob_ext_sighdl = sighnd;
 }

COB_EXPIMP void cob_reset_trace ( void )

 {
     cob_line_trace = 0;
 }

COB_EXPIMP void* cob_resolve ( const char * )

 {
     void    *p;
     char    *entry;
     char    *dirent;
 
     entry = cob_chk_call_path (name, &dirent);
     p = cob_resolve_internal (entry, dirent, 0);
     if (dirent) {
         cob_free (dirent);
     }
     return p;
 }

COB_EXPIMP void* cob_resolve_cobol	(	const char *	,
		const int	,
		const int
	)

 {
     void    *p;
     char    *entry;
     char    *dirent;
 
     entry = cob_chk_call_path (name, &dirent);
     p = cob_resolve_internal (entry, dirent, fold_case);
     if (dirent) {
         cob_free (dirent);
     }
     if (unlikely(!p)) {
         if (errind) {
             cob_call_error ();
         }
         cob_set_exception (COB_EC_PROGRAM_NOT_FOUND);
     }
     return p;
 }

COB_EXPIMP const char* cob_resolve_error ( void )

 {
     const char  *p;
 
     if (!resolve_error) {
         p = _("Indeterminable error");
     } else {
         p = resolve_error;
         resolve_error = NULL;
     }
     return p;
 }

COB_EXPIMP void* cob_resolve_func ( const char * )

 {
     void    *p;
 
     p = cob_resolve_internal (name, NULL, 0);
     if (unlikely(!p)) {
         cob_runtime_error (_("User function '%s' not found"), name);
         cob_stop_run (1);
     }
     return p;
 }

COB_EXPIMP void cob_restore_func ( struct cob_func_loc * )

 {
     /* Restore calling environment */
     cobglobptr->cob_call_params = fl->save_call_params;
 #if 0   /* RXWRXW - MODNEXT */
     COB_MODULE_PTR->next = fl->save_module;
 #endif
     COB_MODULE_PTR->cob_procedure_params = fl->save_proc_parms;
     COB_MODULE_PTR->module_num_params = fl->save_num_params;
     cob_free (fl->data);
     cob_free (fl->func_params);
     cob_free (fl);
 }

COB_EXPIMP void cob_rewrite	(	cob_file *	,
		cob_field *	,
		const int	,
		cob_field *
	)

 {
     int read_done;
 
     read_done = f->flag_read_done;
     f->flag_read_done = 0;
 
     if (unlikely(f->open_mode != COB_OPEN_I_O)) {
         save_status (f, fnstatus, COB_STATUS_49_I_O_DENIED);
         return;
     }
 
     if (f->access_mode == COB_ACCESS_SEQUENTIAL && !read_done) {
         save_status (f, fnstatus, COB_STATUS_43_READ_NOT_DONE);
         return;
     }
 
     if (unlikely(f->organization == COB_ORG_SEQUENTIAL)) {
         if (f->record->size != rec->size) {
             save_status (f, fnstatus, COB_STATUS_44_RECORD_OVERFLOW);
             return;
         }
 
         if (f->variable_record) {
             if (f->record->size != (size_t)cob_get_int (f->variable_record)) {
                 save_status (f, fnstatus, COB_STATUS_44_RECORD_OVERFLOW);
                 return;
             }
         }
     }
 
     save_status (f, fnstatus,
              fileio_funcs[(int)f->organization]->rewrite (f, opt));
 }

COB_EXPIMP void cob_rollback ( void )

 {
     struct file_list    *l;
 
     for (l = file_cache; l; l = l->next) {
         if (l->file) {
             cob_file_unlock (l->file);
         }
     }
 }

COB_EXPIMP void* cob_save_func	(	cob_field **	,
		const int	,
		const int	,
			...
	)

 {
     struct cob_func_loc *fl;
     va_list         args;
     int         numparams;
     int         n;
 
     if (unlikely(params > eparams)) {
         numparams = eparams;
     } else {
         numparams = params;
     }
 
     /* Allocate return field */
     *savefld = cob_malloc (sizeof (cob_field));
     /* Allocate save area */
     fl = cob_malloc (sizeof(struct cob_func_loc));
     fl->func_params = cob_malloc (sizeof(void *) * ((size_t)numparams + 1U));
     fl->data = cob_malloc (sizeof(void *) * ((size_t)numparams + 1U));
 
     /* Save values */
     fl->save_module = COB_MODULE_PTR->next;
     fl->save_call_params = cobglobptr->cob_call_params;
     fl->save_proc_parms = COB_MODULE_PTR->cob_procedure_params;
     fl->save_num_params = COB_MODULE_PTR->module_num_params;
 
     /* Set current values */
     COB_MODULE_PTR->cob_procedure_params = fl->func_params;
     cobglobptr->cob_call_params = numparams;
     if (numparams) {
         va_start (args, eparams);
         for (n = 0; n < numparams; ++n) {
             fl->func_params[n] = va_arg (args, cob_field *);
             if (fl->func_params[n]) {
                 fl->data[n] = fl->func_params[n]->data;
             }
         }
         va_end (args);
     }
     return fl;
 }

COB_EXPIMP void* cob_savenv ( struct cobjmp_buf * )

 {
     if (unlikely(!cobglobptr)) {
         cob_fatal_error (COB_FERROR_INITIALIZED);
     }
     if (unlikely(!jbuf)) {
         cob_runtime_error (_("NULL parameter passed to 'cob_savenv'"));
         cob_stop_run (1);
     }
     if (cob_jmp_primed) {
         cob_runtime_error (_("Multiple call to 'cob_setjmp'"));
         cob_stop_run (1);
     }
     cob_jmp_primed = 1;
     return jbuf->cbj_jmp_buf;
 }

COB_EXPIMP void* cob_savenv2	(	struct cobjmp_buf *	,
		const int
	)

 {
     COB_UNUSED (jsize);
 
     return cob_savenv (jbuf);
 }

COB_EXPIMP void cob_screen_accept	(	cob_screen *	,
		cob_field *	,
		cob_field *	,
		cob_field *
	)

 {
     COB_UNUSED (s);
     COB_UNUSED (line);
     COB_UNUSED (column);
     COB_UNUSED (ftimeout);
 }

COB_EXPIMP void cob_screen_display	(	cob_screen *	,
		cob_field *	,
		cob_field *
	)

 {
     COB_UNUSED (s);
     COB_UNUSED (line);
     COB_UNUSED (column);
 }

COB_EXPIMP void cob_screen_line_col	(	cob_field *	,
		const int
	)

 {
     if (!l_or_c) {
         cob_set_int (f, 24);
     } else {
         cob_set_int (f, 80);
     }
 }

COB_EXPIMP void cob_set_cancel ( cob_module * )

 {
     struct call_hash    *p;
 
 #ifdef  COB_ALT_HASH
     p = call_table;
 #else
     p = call_table[hash ((const unsigned char *)(m->module_name))];
 #endif
     for (; p; p = p->next) {
         if (strcmp (m->module_name, p->name) == 0) {
             p->module = m;
             /* Set path in program module structure */
             if (p->path && m->module_path && !*(m->module_path)) {
                 *(m->module_path) = p->path;
             }
             return;
         }
     }
     insert (m->module_name, m->module_entry.funcvoid, NULL, m, NULL, 1);
 }

COB_EXPIMP void cob_set_environment	(	const cob_field *	,
		const cob_field *
	)

 {
     cob_display_environment (f1);
     cob_display_env_value (f2);
 }

COB_EXPIMP void cob_set_int	(	cob_field *	,
		const int
	)

 {
     cob_field   temp;
     cob_field_attr  attr;
 
     COB_ATTR_INIT  (COB_TYPE_NUMERIC_BINARY, 9, 0,
             COB_FLAG_HAVE_SIGN | COB_FLAG_REAL_BINARY, NULL);
     temp.size = 4;
     temp.data = (unsigned char *)&n;
     temp.attr = &attr;
     cob_move (&temp, f);
 }

COB_EXPIMP void cob_set_locale	(	cob_field *	,
		const int
	)

 {
 #ifdef  HAVE_SETLOCALE
     char    *p;
     char    *buff;
 
     p = NULL;
     if (locale) {
         if (locale->size == 0) {
             return;
         }
         buff = cob_malloc (locale->size + 1U);
         cob_field_to_string (locale, buff, locale->size);
     } else {
         buff = NULL;
     }
 
     switch (category) {
     case COB_LC_COLLATE:
         p = setlocale (LC_COLLATE, buff);
         break;
     case COB_LC_CTYPE:
         p = setlocale (LC_CTYPE, buff);
         break;
 #ifdef  LC_MESSAGES
     case COB_LC_MESSAGES:
         p = setlocale (LC_MESSAGES, buff);
         break;
 #endif
     case COB_LC_MONETARY:
         p = setlocale (LC_MONETARY, buff);
         break;
     case COB_LC_NUMERIC:
         p = setlocale (LC_NUMERIC, buff);
         break;
     case COB_LC_TIME:
         p = setlocale (LC_TIME, buff);
         break;
     case COB_LC_ALL:
         p = setlocale (LC_ALL, buff);
         break;
     case COB_LC_USER:
         if (cobglobptr->cob_locale_orig) {
             p = setlocale (LC_ALL, cobglobptr->cob_locale_orig);
             (void)setlocale (LC_NUMERIC, "C");
         }
         break;
     case COB_LC_CLASS:
         if (cobglobptr->cob_locale_ctype) {
             p = setlocale (LC_CTYPE, cobglobptr->cob_locale_ctype);
         }
         break;
     }
     if (buff) {
         cob_free (buff);
     }
     if (!p) {
         cob_set_exception (COB_EC_LOCALE_MISSING);
         return;
     }
     p = setlocale (LC_ALL, NULL);
     if (p) {
         if (cobglobptr->cob_locale) {
             cob_free (cobglobptr->cob_locale);
         }
         cobglobptr->cob_locale = cob_strdup (p);
     }
 #else
     cob_set_exception (COB_EC_LOCALE_MISSING);
 #endif
 }

COB_EXPIMP void cob_set_location	(	const char *	,
		const unsigned	int,
		const char *	,
		const char *	,
		const char *
	)

 {
     const char  *s;
 
     cob_current_program_id = COB_MODULE_PTR->module_name;
     cob_source_file = sfile;
     cob_source_line = sline;
     cob_current_section = csect;
     cob_current_paragraph = cpara;
     if (cstatement) {
         cob_source_statement = cstatement;
     }
     if (cob_line_trace) {
         if (!cob_trace_file) {
             cob_check_trace_file ();
         }
         if (!cob_last_sfile || strcmp (cob_last_sfile, sfile)) {
             cob_last_sfile = sfile;
             fprintf (cob_trace_file, "Source :    '%s'\n", sfile);
         }
         if (COB_MODULE_PTR->module_name) {
             s = COB_MODULE_PTR->module_name;
         } else {
             s = "Unknown";
         }
         fprintf (cob_trace_file,
              "Program-Id: %-16s Statement: %-21.21s  Line: %u\n",
              s, cstatement ? (char *)cstatement : "Unknown",
              sline);
         fflush (cob_trace_file);
     }
 }

COB_EXPIMP void cob_set_packed_int	(	cob_field *	,
		const int
	)

 {
     unsigned char   *p;
     size_t      sign = 0;
     cob_u32_t   n;
 
     if (!val) {
         cob_set_packed_zero (f);
         return;
     }
     if (val < 0) {
         n = (cob_u32_t)-val;
         sign = 1;
     } else {
         n = (cob_u32_t)val;
     }
     memset (f->data, 0, f->size);
     p = f->data + f->size - 1;
     if (!COB_FIELD_NO_SIGN_NIBBLE (f)) {
         *p = (n % 10) << 4;
         if (!COB_FIELD_HAVE_SIGN (f)) {
             *p |= 0x0FU;
         } else if (sign) {
             *p |= 0x0DU;
         } else {
             *p |= 0x0CU;
         }
         n /= 10;
         p--;
     }
     for (; n && p >= f->data; n /= 100, p--) {
         *p = packed_bytes[n % 100];
     }
     if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
         if ((COB_FIELD_DIGITS(f) % 2) == 1) {
             *(f->data) &= 0x0FU;
         }
         return;
     }
     if ((COB_FIELD_DIGITS(f) % 2) == 0) {
         *(f->data) &= 0x0FU;
     }
 }

COB_EXPIMP void cob_set_packed_zero ( cob_field * )

 {
     memset (f->data, 0, f->size);
     if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
         return;
     }
     if (!COB_FIELD_HAVE_SIGN (f)) {
         *(f->data + f->size - 1) = 0x0F;
     } else {
         *(f->data + f->size - 1) = 0x0C;
     }
 }

COB_EXPIMP void cob_set_switch	(	const int	,
		const int
	)

 {
     if (n < 0 || n > (COB_SWITCH_MAX - 1)) {
         return;
     }
     if (flag == 0) {
         cob_switch[n] = 0;
     } else if (flag == 1) {
         cob_switch[n] = 1;
     }
 }

COB_EXPIMP void cob_start	(	cob_file *	,
		const int	,
		cob_field *	,
		cob_field *	,
		cob_field *
	)

 {
     int     ret;
     int     size;
     cob_field   tempkey;
 
     f->flag_read_done = 0;
     f->flag_first_read = 0;
 
     if (unlikely(f->open_mode != COB_OPEN_I_O &&
              f->open_mode != COB_OPEN_INPUT)) {
         save_status (f, fnstatus, COB_STATUS_47_INPUT_DENIED);
         return;
     }
 
     if (unlikely(f->access_mode == COB_ACCESS_RANDOM)) {
         save_status (f, fnstatus, COB_STATUS_47_INPUT_DENIED);
         return;
     }
 
     if (f->flag_nonexistent) {
         save_status (f, fnstatus, COB_STATUS_23_KEY_NOT_EXISTS);
         return;
     }
 
     size = 0;
     if (unlikely(keysize)) {
         size = cob_get_int (keysize);
         if (size < 1 || size > (int)key->size) {
             save_status (f, fnstatus, COB_STATUS_23_KEY_NOT_EXISTS);
             return;
         }
         tempkey = *key;
         tempkey.size = (size_t)size;
         ret = fileio_funcs[(int)f->organization]->start (f, cond, &tempkey);
     } else {
         ret = fileio_funcs[(int)f->organization]->start (f, cond, key);
     }
     if (ret == COB_STATUS_00_SUCCESS) {
         f->flag_end_of_file = 0;
         f->flag_begin_of_file = 0;
         f->flag_first_read = 1;
     }
 
     save_status (f, fnstatus, ret);
 }

DECLNORET COB_EXPIMP void cob_stop_run ( const int )

 {
     struct exit_handlerlist *h;
 
     if (!cob_initialized) {
         exit (1);
     }
     if (exit_hdlrs != NULL) {
         h = exit_hdlrs;
         while (h != NULL) {
             h->proc ();
             h = h->next;
         }
     }
     cob_terminate_routines ();
     exit (status);
 }

char* cob_strcat	(	char *	,
		char *
	)

                                    {
     size_t l;
     char *temp1, *temp2;
 
     l = strlen(str1) + strlen(str2) + 1;
 
     /*
      * If one of the parameter is the buffer itself,
      * we copy the buffer before continuing.
      */
     if (str1 == strbuff) {
         temp1 = cob_strdup(str1);
     } else {
         temp1 = str1;
     }
     if (str2 == strbuff) {
         temp2 = cob_strdup(str2);
     } else {
         temp2 = str2;
     }
 
     cob_free(strbuff);
     strbuff = (char*) cob_fast_malloc(l);
 
     sprintf(strbuff, "%s%s", temp1, temp2);
     return strbuff;
 }

COB_EXPIMP void cob_string_append ( cob_field * )

 {
     size_t  src_size;
     int i;
     int size;
 
     if (cob_get_exception_code ()) {
         return;
     }
 
     src_size = src->size;
     if (!src_size) {
         return;
     }
     if (string_dlm) {
         size = (int)(src_size - string_dlm->size + 1);
         for (i = 0; i < size; ++i) {
             if (memcmp (src->data + i, string_dlm->data,
                     string_dlm->size) == 0) {
                 src_size = i;
                 break;
             }
         }
     }
 
     if (src_size <= string_dst->size - string_offset) {
         memcpy (string_dst->data + string_offset, src->data, src_size);
         string_offset += (int) src_size;
     } else {
         size = (int)(string_dst->size - string_offset);
         memcpy (string_dst->data + string_offset, src->data, (size_t)size);
         string_offset += size;
         cob_set_exception (COB_EC_OVERFLOW_STRING);
     }
 }

COB_EXPIMP void cob_string_delimited ( cob_field * )

 {
     string_dlm = NULL;
     if (dlm) {
         string_dlm_copy = *dlm;
         string_dlm = &string_dlm_copy;
     }
 }

COB_EXPIMP void cob_string_finish ( void )

 {
     if (string_ptr) {
         cob_set_int (string_ptr, string_offset + 1);
     }
 }

COB_EXPIMP void cob_string_init	(	cob_field *	,
		cob_field *
	)

 {
     string_dst_copy = *dst;
     string_dst = &string_dst_copy;
     string_ptr = NULL;
     if (ptr) {
         string_ptr_copy = *ptr;
         string_ptr = &string_ptr_copy;
     }
     string_offset = 0;
     cob_set_exception (0);
 
     if (string_ptr) {
         string_offset = cob_get_int (string_ptr) - 1;
         if (string_offset < 0 ||
             string_offset >= (int)string_dst->size) {
             cob_set_exception (COB_EC_OVERFLOW_STRING);
         }
     }
 }

char* cob_strjoin	(	char **	,
		int	,
		char *
	)

                                                         {
 
     char* result;
     int i;
 
     if(!strarray || size <= 0 || !separator) return NULL;
 
     result = strarray[0];
     for (i = 1; i < size; i++) {
         result = cob_strcat(result, separator);
         result = cob_strcat(result, strarray[i]);
     }
 
     return result;
 }

COB_EXPIMP void cob_sub	(	cob_field *	,
		cob_field *	,
		const int
	)

 {
     cob_decimal_set_field (&cob_d1, f1);
     cob_decimal_set_field (&cob_d2, f2);
     cob_decimal_sub (&cob_d1, &cob_d2);
     (void)cob_decimal_get_field (&cob_d1, f1, opt);
 }

COB_EXPIMP int cob_sub_int	(	cob_field *	,
		const int	,
		const int
	)

 {
     return cob_add_int (f, -n, opt);
 }

COB_EXPIMP cob_field* cob_switch_value ( const int )

 {
     cob_alloc_set_field_int (cob_get_switch (id));
     return curr_field;
 }

COB_EXPIMP int cob_sys_and	(	const void *	,
		void *	,
		const int
	)

 {
     const cob_u8_ptr    data_1 = p1;
     cob_u8_ptr      data_2 = p2;
     size_t          n;
 
     COB_CHK_PARMS (CBL_AND, 3);
 
     if (length <= 0) {
         return 0;
     }
     for (n = 0; n < (size_t)length; ++n) {
         data_2[n] &= data_1[n];
     }
     return 0;
 }

COB_EXPIMP int cob_sys_calledby ( void * )

 {
     size_t      size;
     size_t      msize;
 
     COB_CHK_PARMS (C$CALLEDBY, 1);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return -1;
     }
     size = COB_MODULE_PTR->cob_procedure_params[0]->size;
     memset (data, ' ', size);
     if (!COB_MODULE_PTR->next) {
         return 0;
     }
     msize = strlen (COB_MODULE_PTR->next->module_name);
     if (msize > size) {
         msize = size;
     }
     memcpy (data, COB_MODULE_PTR->next->module_name, msize);
     return 1;
 }

COB_EXPIMP int cob_sys_change_dir ( unsigned char * )

 {
     char    *fn;
     int ret;
 
     COB_UNUSED (dir);
 
     COB_CHK_PARMS (CBL_CHANGE_DIR, 1);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return -1;
     }
     fn = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[0]);
     ret = chdir (fn);
     cob_free (fn);
     if (ret) {
         return 128;
     }
     return 0;
 }

COB_EXPIMP int cob_sys_chdir	(	unsigned char *	,
		unsigned char *
	)

 {
     int     ret;
 
     COB_UNUSED (status);
 
     COB_CHK_PARMS (C$CHDIR, 2);
 
     ret = cob_sys_change_dir (dir);
     if (ret < 0) {
         ret = 128;
     }
     cob_set_int (COB_MODULE_PTR->cob_procedure_params[1], ret);
     return ret;
 }

COB_EXPIMP int cob_sys_check_file_exist	(	unsigned char *	,
		unsigned char *
	)

 {
     char        *fn;
     struct tm   *tm;
     cob_s64_t   sz;
     struct stat st;
     short       y;
     short       d, m, hh, mm, ss;
 
     COB_UNUSED (file_name);
 
     COB_CHK_PARMS (CBL_CHECK_FILE_EXIST, 2);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return -1;
     }
     if (!COB_MODULE_PTR->cob_procedure_params[1]) {
         return -1;
     }
     if (COB_MODULE_PTR->cob_procedure_params[1]->size < 16U) {
         cob_runtime_error (_("'CBL_CHECK_FILE_EXIST' - File detail area is too short"));
         cob_stop_run (1);
     }
 
     fn = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[0]);
     if (stat (fn, &st) < 0) {
         cob_free (fn);
         return 35;
     }
     cob_free (fn);
     sz = (cob_s64_t)st.st_size;
     tm = localtime (&st.st_mtime);
     d = (short)tm->tm_mday;
     m = (short)(tm->tm_mon + 1);
     y = (short)(tm->tm_year + 1900);
     hh = (short)tm->tm_hour;
     mm = (short)tm->tm_min;
     /* Leap seconds ? */
     if (tm->tm_sec >= 60) {
         ss = 59;
     } else {
         ss = (short)tm->tm_sec;
     }
 
 #ifndef WORDS_BIGENDIAN
     sz = COB_BSWAP_64 (sz);
     y = COB_BSWAP_16 (y);
 #endif
     memcpy (file_info, &sz, (size_t)8);
     file_info[8] = (unsigned char)d;
     file_info[9] = (unsigned char)m;
     memcpy (file_info+10, &y, (size_t)2);
     file_info[12] = (unsigned char)hh;
     file_info[13] = (unsigned char)mm;
     file_info[14] = (unsigned char)ss;
     file_info[15] = 0;
     return 0;
 }

COB_EXPIMP int cob_sys_clear_screen ( void )

 {
     return 0;
 }

COB_EXPIMP int cob_sys_close_file ( unsigned char * )

 {
     int fd;
 
     COB_CHK_PARMS (CBL_CLOSE_FILE, 1);
 
     memcpy (&fd, file_handle, (size_t)4);
     return close (fd);
 }

COB_EXPIMP int cob_sys_copy_file	(	unsigned char *	,
		unsigned char *
	)

 {
     char    *fn1;
     char    *fn2;
     int flag = O_BINARY;
     int ret;
     int i;
     int fd1, fd2;
 
     COB_UNUSED (fname1);
     COB_UNUSED (fname2);
 
     COB_CHK_PARMS (CBL_COPY_FILE, 2);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return -1;
     }
     if (!COB_MODULE_PTR->cob_procedure_params[1]) {
         return -1;
     }
     fn1 = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[0]);
     flag |= O_RDONLY;
     fd1 = open (fn1, flag, 0);
     if (fd1 < 0) {
         cob_free (fn1);
         return -1;
     }
     cob_free (fn1);
     fn2 = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[1]);
     flag &= ~O_RDONLY;
     flag |= O_CREAT | O_TRUNC | O_WRONLY;
     fd2 = open (fn2, flag, 0660);
     if (fd2 < 0) {
         close (fd1);
         cob_free (fn2);
         return -1;
     }
     cob_free (fn2);
 
     ret = 0;
     while ((i = read (fd1, file_open_buff, COB_FILE_BUFF)) > 0) {
         if (write (fd2, file_open_buff, (size_t)i) < 0) {
             ret = -1;
             break;
         }
     }
     close (fd1);
     close (fd2);
     return ret;
 }

COB_EXPIMP int cob_sys_copyfile	(	unsigned char *	,
		unsigned char *	,
		unsigned char *
	)

 {
     int     ret;
 
     /* RXW - Type is not yet evaluated */
     COB_UNUSED (file_type);
 
     COB_CHK_PARMS (C$COPY, 3);
 
     if (cobglobptr->cob_call_params < 3) {
         return 128;
     }
     ret = cob_sys_copy_file (fname1, fname2);
     if (ret < 0) {
         ret = 128;
     }
     return ret;
 }

COB_EXPIMP int cob_sys_create_dir ( unsigned char * )

 {
     char    *fn;
     int ret;
 
     COB_UNUSED (dir);
 
     COB_CHK_PARMS (CBL_CREATE_DIR, 1);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return -1;
     }
     fn = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[0]);
 #ifdef  _WIN32
     ret = mkdir (fn);
 #else
     ret = mkdir (fn, 0770);
 #endif
     cob_free (fn);
     if (ret) {
         return 128;
     }
     return 0;
 }

COB_EXPIMP int cob_sys_create_file	(	unsigned char *	,
		unsigned char *	,
		unsigned char *	,
		unsigned char *	,
		unsigned char *
	)

 {
     /*
      * @param: file_access : 1 (read-only), 2 (write-only), 3 (both)
      * @param: file_lock : not implemented, set 0
      * @param: file_dev : not implemented, set 0
      */
 
     if (*file_lock != 0 && cobglobptr->cob_display_warn) {
         fprintf (stderr, _("WARNING - Call to CBL_CREATE_FILE with wrong file_lock: %d"), *file_lock);
         putc ('\n', stderr);
         fflush (stderr);
     }
     if (*file_dev != 0 && cobglobptr->cob_display_warn) {
         fprintf (stderr, _("WARNING - Call to CBL_CREATE_FILE with wrong file_dev: %d"), *file_dev);
         putc ('\n', stderr);
         fflush (stderr);
     }
 
     COB_CHK_PARMS (CBL_CREATE_FILE, 5);
 
     return open_cbl_file (file_name, file_access, file_handle, O_CREAT | O_TRUNC);
 }

COB_EXPIMP int cob_sys_delete_dir ( unsigned char * )

 {
     char    *fn;
     int ret;
 
     COB_UNUSED (dir);
 
     COB_CHK_PARMS (CBL_DELETE_DIR, 1);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return -1;
     }
     fn = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[0]);
     ret = rmdir (fn);
     cob_free (fn);
     if (ret) {
         return 128;
     }
     return 0;
 }

COB_EXPIMP int cob_sys_delete_file ( unsigned char * )

 {
     char    *fn;
     int ret;
 
     COB_UNUSED (file_name);
 
     COB_CHK_PARMS (CBL_DELETE_FILE, 1);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return -1;
     }
     fn = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[0]);
     ret = unlink (fn);
     cob_free (fn);
     if (ret) {
         return 128;
     }
     return 0;
 }

COB_EXPIMP int cob_sys_eq	(	const void *	,
		void *	,
		const int
	)

 {
     const cob_u8_ptr    data_1 = p1;
     cob_u8_ptr      data_2 = p2;
     size_t          n;
 
     COB_CHK_PARMS (CBL_EQ, 3);
 
     if (length <= 0) {
         return 0;
     }
     for (n = 0; n < (size_t)length; ++n) {
         data_2[n] = ~(data_1[n] ^ data_2[n]);
     }
     return 0;
 }

COB_EXPIMP int cob_sys_error_proc	(	const void *	,
		const void *
	)

 {
     struct handlerlist  *hp = NULL;
     struct handlerlist  *h = hdlrs;
     const unsigned char *x;
     int         (**p)(char *s);
 
     COB_CHK_PARMS (CBL_ERROR_PROC, 2);
 
     memcpy (&p, &pptr, sizeof (void *));
     if (!p || !*p) {
         return -1;
     }
 
     hp = NULL;
     h = hdlrs;
     /* Remove handler anyway */
     while (h != NULL) {
         if (h->proc == *p) {
             if (hp != NULL) {
                 hp->next = h->next;
             } else {
                 hdlrs = h->next;
             }
             if (hp) {
                 cob_free (hp);
             }
             break;
         }
         hp = h;
         h = h->next;
     }
     x = dispo;
     if (*x != 0) {
         /* Remove handler */
         return 0;
     }
     h = cob_malloc (sizeof(struct handlerlist));
     h->next = hdlrs;
     h->proc = *p;
     hdlrs = h;
     return 0;
 }

COB_EXPIMP int cob_sys_exit_proc	(	const void *	,
		const void *
	)

 {
     struct exit_handlerlist *hp;
     struct exit_handlerlist *h;
     const unsigned char *x;
     int         (**p)(void);
 
     COB_CHK_PARMS (CBL_EXIT_PROC, 2);
 
     memcpy (&p, &pptr, sizeof (void *));
     if (!p || !*p) {
         return -1;
     }
 
     hp = NULL;
     h = exit_hdlrs;
     /* Remove handler anyway */
     while (h != NULL) {
         if (h->proc == *p) {
             if (hp != NULL) {
                 hp->next = h->next;
             } else {
                 exit_hdlrs = h->next;
             }
             if (hp) {
                 cob_free (hp);
             }
             break;
         }
         hp = h;
         h = h->next;
     }
     x = dispo;
     if   (*x != 0 && *x != 2 && *x != 3) {
         /* Remove handler */
         return 0;
     }
     h = cob_malloc (sizeof(struct exit_handlerlist));
     h->next = exit_hdlrs;
     h->proc = *p;
     exit_hdlrs = h;
     return 0;
 }

COB_EXPIMP int cob_sys_file_delete	(	unsigned char *	,
		unsigned char *
	)

 {
     int ret;
 
     /* RXW - Type is not yet evaluated */
     COB_UNUSED (file_type);
 
     COB_CHK_PARMS (C$DELETE, 2);
 
     if (cobglobptr->cob_call_params < 2 ||
         !COB_MODULE_PTR->cob_procedure_params[0]) {
         return 128;
     }
     ret = cob_sys_delete_file (file_name);
     if (ret < 0) {
         ret = 128;
     }
     return ret;
 }

COB_EXPIMP int cob_sys_file_info	(	unsigned char *	,
		unsigned char *
	)

 {
     char            *fn;
     struct tm       *tm;
     cob_u64_t       sz;
     unsigned int        dt;
     short           y;
     short           d, m, hh, mm, ss;
     struct stat     st;
 
     COB_UNUSED (file_name);
 
     COB_CHK_PARMS (C$FILEINFO, 2);
 
     if (cobglobptr->cob_call_params < 2 ||
         !COB_MODULE_PTR->cob_procedure_params[0]) {
         return 128;
     }
     if (!COB_MODULE_PTR->cob_procedure_params[1]) {
         return 128;
     }
     if (COB_MODULE_PTR->cob_procedure_params[1]->size < 16U) {
         cob_runtime_error (_("'C$FILEINFO' - File detail area is too short"));
         cob_stop_run (1);
     }
 
     fn = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[0]);
     if (stat (fn, &st) < 0) {
         cob_free (fn);
         return 35;
     }
     cob_free (fn);
     sz = (cob_u64_t)st.st_size;
     tm = localtime (&st.st_mtime);
     d = (short)tm->tm_mday;
     m = (short)(tm->tm_mon + 1);
     y = (short)(tm->tm_year + 1900);
     hh = (short)tm->tm_hour;
     mm = (short)tm->tm_min;
     /* Leap seconds ? */
     if (tm->tm_sec >= 60) {
         ss = 59;
     } else {
         ss = (short)tm->tm_sec;
     }
 
 #ifndef WORDS_BIGENDIAN
     sz = COB_BSWAP_64 (sz);
 #endif
     memcpy (file_info, &sz, (size_t)8);
     dt = (y * 10000) + (m * 100) + d;
 #ifndef WORDS_BIGENDIAN
     dt = COB_BSWAP_32 (dt);
 #endif
     memcpy (file_info + 8, &dt, (size_t)4);
     dt = (hh * 1000000) + (mm * 10000) + (ss * 100);
 #ifndef WORDS_BIGENDIAN
     dt = COB_BSWAP_32 (dt);
 #endif
     memcpy (file_info + 12, &dt, (size_t)4);
     return 0;
 }

COB_EXPIMP int cob_sys_flush_file ( unsigned char * )

 {
     COB_UNUSED (file_handle);
 
     COB_CHK_PARMS (CBL_FLUSH_FILE, 1);
 
     return 0;
 }

COB_EXPIMP int cob_sys_get_csr_pos ( unsigned char * )

 {
 #ifdef  COB_GEN_SCREENIO
     int cline;
     int ccol;
 #endif
 
     COB_CHK_PARMS (CBL_GET_CSR_POS, 1);
 
 #ifdef  COB_GEN_SCREENIO
     getyx (stdscr, cline, ccol);
     fld[0] = (unsigned char)cline;
     fld[1] = (unsigned char)ccol;
     
 #else
     fld[0] = 1U;
     fld[1] = 1U;
 #endif
     return 0;
 }

COB_EXPIMP int cob_sys_get_current_dir	(	const int	,
		const int	,
		unsigned char *
	)

 {
     char    *dirname;
     int dir_size;
     int has_space;
 
     COB_CHK_PARMS (CBL_GET_CURRENT_DIR, 3);
 
     if (dir_length < 1) {
         return 128;
     }
     if (flags) {
         return 129;
     }
     memset (dir, ' ', (size_t)dir_length);
     dirname = getcwd (NULL, (size_t)0);
     if (dirname == NULL) {
         return 128;
     }
     dir_size = (int) strlen (dirname);
     has_space = 0;
     if (strchr (dirname, ' ')) {
         has_space = 2;
     }
     if (dir_size + has_space > dir_length) {
         cob_free (dirname);
         return 128;
     }
     if (has_space) {
         *dir = '"';
         memcpy (&dir[1], dirname, (size_t)dir_size);
         dir[dir_size + 1] = '"';
     } else {
         memcpy (dir, dirname, (size_t)dir_size);
     }
     cob_free (dirname);
     return 0;
 }

COB_EXPIMP int cob_sys_get_scr_size	(	unsigned char *	,
		unsigned char *
	)

 {
     COB_CHK_PARMS (CBL_GET_SCR_SIZE, 2);
 
 #ifdef  COB_GEN_SCREENIO
     *line = (unsigned char)LINES;
     *col = (unsigned char)COLS;
 #else
     *line = 24U;
     *col = 80U;
 #endif
     return 0;
 }

COB_EXPIMP int cob_sys_getopt_long_long	(	void *	,
		void *	,
		void *	,
		const int	,
		void *	,
		void *
	)

                                                                                                                 {
     /*
      * cob_argc is a static int containing argc from runtime
      * cob_argv is a static char** containing argv from runtime
      */
 
     size_t opt_val_size = 0;
     size_t so_size = 0;
     size_t lo_size = 0;
     
     unsigned int lo_amount;
 
     int exit_status;
 
     char* shortoptions;
     char* temp;
 
     struct option* longoptions;
     longoption_def* l = NULL;
 
     int longind = 0;
     unsigned int i;
     int j;
 
     unsigned int optlen;
     int return_value;
 
     COB_UNUSED (idx);
     COB_UNUSED (lo);
     COB_UNUSED (so);
 
     COB_CHK_PARMS (CBL_OC_GETOPT, 6);
 
     /*
      * Read in sizes of some parameters
      */
     if (COB_MODULE_PTR->cob_procedure_params[1]) {
         lo_size = COB_MODULE_PTR->cob_procedure_params[1]->size;
     }
     if (COB_MODULE_PTR->cob_procedure_params[0]) {
         so_size = COB_MODULE_PTR->cob_procedure_params[0]->size;
     }
     if (COB_MODULE_PTR->cob_procedure_params[5]) {
         opt_val_size = COB_MODULE_PTR->cob_procedure_params[5]->size;
     }
 
     /*
      * Buffering longoptions (cobol), target format (struct option)
      */
     if (lo_size % sizeof(longoption_def) == 0) {
         lo_amount = (int)lo_size / sizeof(longoption_def);
         longoptions = (struct option*) cob_malloc(sizeof(struct option) * (lo_amount + 1U));
     }
     else {
         cob_runtime_error (_("Call to CBL_OC_GETOPT with wrong longoption size."));
         cob_stop_run (1);
     }
 
     if (!COB_MODULE_PTR->cob_procedure_params[2]) {
         cob_runtime_error (_("Call to CBL_OC_GETOPT with missing longind."));
         cob_stop_run (1);
     }
     longind = cob_get_int (COB_MODULE_PTR->cob_procedure_params[2]);
 
     /*
      * Add 0-termination to strings.
      */
     shortoptions = cob_malloc(so_size + 1U);
     if (COB_MODULE_PTR->cob_procedure_params[0]) {
         cob_field_to_string (COB_MODULE_PTR->cob_procedure_params[0], shortoptions, so_size);
     }
 
     if (COB_MODULE_PTR->cob_procedure_params[1]) {
         l = (struct longoption_def*) (COB_MODULE_PTR->cob_procedure_params[1]->data);
     }
 
     for (i = 0; i < lo_amount; i++) {
         j = sizeof(l->name) - 1;
         while (j >= 0 && l->name[j] == 0x20) {
             l->name[j] = 0x00;
             j--;
         }
         longoptions->name = l->name;
         longoptions->has_arg = (int) l->has_option - '0';
         memcpy (&longoptions->flag, l->return_value_pointer, sizeof(l->return_value_pointer));
         memcpy(&longoptions->val, &l->return_value, 4);
 
         l = l + 1; /* +1 means pointer + 1*sizeof(longoption_def) */
         longoptions = longoptions + 1;
     }
 
     /*
      * Appending final record, so getopt can spot the end of longoptions
      */
     longoptions->name = NULL;
     longoptions->has_arg = 0;
     longoptions->flag = NULL;
     longoptions->val = 0;
 
 
     l -= lo_amount; /* Set pointer back to begin of longoptions */
     longoptions -= lo_amount;
 
     return_value = cob_getopt_long_long(cob_argc, cob_argv, shortoptions, longoptions, &longind, long_only);
     temp = (char*) &return_value;
     
     /*
      * Write data back to Cobol
      */
     if (temp[0] == '?' || temp[0] == ':' || temp[0] == 'W' 
         || temp[0] == -1 || temp[0] == 0) exit_status = return_value;
     else exit_status = 3;
 
     for(i = 3; i > 0; i--) {
         if(temp[i] == 0x00) temp[i] = 0x20;
         else break;
     }
 
     cob_set_int (COB_MODULE_PTR->cob_procedure_params[2], longind);
     memcpy (return_char, &return_value, 4);
 
     if(cob_optarg != NULL) {
         memset (opt_val, 0x00, opt_val_size);
         
         optlen = strlen (cob_optarg);
         if (optlen > opt_val_size) {
             /* Returncode 2 for "Optionvalue too long => cut" */
             optlen = opt_val_size;
             exit_status = 2;
         }
         memcpy (opt_val, cob_optarg, optlen);
     }
 
 
     cob_free (shortoptions);
     cob_free (longoptions);
 
     return exit_status;
 
 }

COB_EXPIMP int cob_sys_getpid ( void )

 {
     if (!cob_process_id) {
         cob_process_id = (int)getpid ();
     }
     return cob_process_id;
 }

COB_EXPIMP int cob_sys_imp	(	const void *	,
		void *	,
		const int
	)

 {
     const cob_u8_ptr    data_1 = p1;
     cob_u8_ptr      data_2 = p2;
     size_t          n;
 
     COB_CHK_PARMS (CBL_IMP, 3);
 
     if (length <= 0) {
         return 0;
     }
     for (n = 0; n < (size_t)length; ++n) {
         data_2[n] = (~data_1[n]) | data_2[n];
     }
     return 0;
 }

COB_EXPIMP int cob_sys_justify	(	void *	,
			...
	)

 {
     cob_u8_ptr  data;
     unsigned char   *direction;
     size_t      datalen;
     size_t      left;
     size_t      right;
     size_t      movelen;
     size_t      centrelen;
     size_t      n;
     size_t      shifting;
     va_list     args;
 
     COB_CHK_PARMS (C$JUSTIFY, 1);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return 0;
     }
     data = p1;
     datalen = COB_MODULE_PTR->cob_procedure_params[0]->size;
     if (datalen < 2) {
         return 0;
     }
     if (data[0] != ' ' && data[datalen - 1] != ' ') {
         return 0;
     }
     for (left = 0; left < datalen; ++left) {
         if (data[left] != ' ') {
             break;
         }
     }
     if (left == datalen) {
         return 0;
     }
     right = 0;
     for (n = datalen - 1; ; --n, ++right) {
         if (data[n] != ' ') {
             break;
         }
         if (n == 0) {
             break;
         }
     }
     movelen = datalen - left - right;
     shifting = 0;
     if (cobglobptr->cob_call_params > 1) {
         va_start (args, p1);
         direction = va_arg (args, unsigned char *);
         va_end (args);
         if (*direction == 'L') {
             shifting = 1;
         } else if (*direction == 'C') {
             shifting = 2;
         }
     }
     switch (shifting) {
     case 1:
         memmove (data, &data[left], movelen);
         memset (&data[movelen], ' ', datalen - movelen);
         break;
     case 2:
         centrelen = (left + right) / 2;
         memmove (&data[centrelen], &data[left], movelen);
         memset (data, ' ', centrelen);
         if ((left + right) % 2) {
             memset (&data[centrelen + movelen], ' ', centrelen + 1);
         } else {
             memset (&data[centrelen + movelen], ' ', centrelen);
         }
         break;
     default:
         memmove (&data[left + right], &data[left], movelen);
         memset (data, ' ', datalen - movelen);
         break;
     }
     return 0;
 }

COB_EXPIMP int cob_sys_mkdir ( unsigned char * )

 {
     int     ret;
 
     COB_CHK_PARMS (C$MAKEDIR, 1);
 
     ret = cob_sys_create_dir (dir);
     if (ret < 0) {
         ret = 128;
     }
     return ret;
 }

COB_EXPIMP int cob_sys_nimp	(	const void *	,
		void *	,
		const int
	)

 {
     const cob_u8_ptr    data_1 = p1;
     cob_u8_ptr      data_2 = p2;
     size_t          n;
 
     COB_CHK_PARMS (CBL_NIMP, 3);
 
     if (length <= 0) {
         return 0;
     }
     for (n = 0; n < (size_t)length; ++n) {
         data_2[n] = data_1[n] & (~data_2[n]);
     }
     return 0;
 }

COB_EXPIMP int cob_sys_nor	(	const void *	,
		void *	,
		const int
	)

 {
     const cob_u8_ptr    data_1 = p1;
     cob_u8_ptr      data_2 = p2;
     size_t          n;
 
     COB_CHK_PARMS (CBL_NOR, 3);
 
     if (length <= 0) {
         return 0;
     }
     for (n = 0; n < (size_t)length; ++n) {
         data_2[n] = ~(data_1[n] | data_2[n]);
     }
     return 0;
 }

COB_EXPIMP int cob_sys_not	(	void *	,
		const int
	)

 {
     cob_u8_ptr  data_1 = p1;
     size_t      n;
 
     COB_CHK_PARMS (CBL_NOT, 2);
 
     if (length <= 0) {
         return 0;
     }
     for (n = 0; n < (size_t)length; ++n) {
         data_1[n] = ~data_1[n];
     }
     return 0;
 }

COB_EXPIMP int cob_sys_oc_nanosleep ( const void * )

 {
     cob_s64_t   nsecs;
 #if defined(_WIN32) || defined(__370__) || defined(__OS400__)
     unsigned int    msecs;
 #elif   defined(HAVE_NANO_SLEEP)
     struct timespec tsec;
 #else
     unsigned int    msecs;
 #endif
 
     COB_UNUSED (data);
 
     COB_CHK_PARMS (CBL_OC_NANOSLEEP, 1);
 
     if (COB_MODULE_PTR->cob_procedure_params[0]) {
         nsecs = cob_get_llint (COB_MODULE_PTR->cob_procedure_params[0]);
         if (nsecs > 0) {
 #ifdef  _WIN32
             msecs = (unsigned int)(nsecs / 1000000);
             if (msecs > 0) {
                 Sleep (msecs);
             }
 #elif   defined(__370__) || defined(__OS400__)
             msecs = (unsigned int)(nsecs / 1000000000);
             if (msecs > 0) {
                 sleep (msecs);
             }
 #elif   defined(HAVE_NANO_SLEEP)
             tsec.tv_sec = nsecs / 1000000000;
             tsec.tv_nsec = nsecs % 1000000000;
             nanosleep (&tsec, NULL);
 #else
             msecs = (unsigned int)(nsecs / 1000000000);
             if (msecs > 0) {
                 sleep (msecs);
             }
 #endif
         }
     }
     return 0;
 }

COB_EXPIMP int cob_sys_open_file	(	unsigned char *	,
		unsigned char *	,
		unsigned char *	,
		unsigned char *	,
		unsigned char *
	)

 {
     COB_UNUSED (file_lock);
     COB_UNUSED (file_dev);
 
     COB_CHK_PARMS (CBL_OPEN_FILE, 5);
 
     return open_cbl_file (file_name, file_access, file_handle, 0);
 }

COB_EXPIMP int cob_sys_or	(	const void *	,
		void *	,
		const int
	)

 {
     const cob_u8_ptr    data_1 = p1;
     cob_u8_ptr      data_2 = p2;
     size_t          n;
 
     COB_CHK_PARMS (CBL_OR, 3);
 
     if (length <= 0) {
         return 0;
     }
     for (n = 0; n < (size_t)length; ++n) {
         data_2[n] |= data_1[n];
     }
     return 0;
 }

COB_EXPIMP int cob_sys_parameter_size ( void * )

 {
     int n;
 
     COB_UNUSED (data);
 
     COB_CHK_PARMS (C$PARAMSIZE, 1);
 
     if (COB_MODULE_PTR->cob_procedure_params[0]) {
         n = cob_get_int (COB_MODULE_PTR->cob_procedure_params[0]);
         if (n > 0 && n <= COB_MODULE_PTR->module_num_params) {
             n--;
             if (COB_MODULE_PTR->next &&
                 COB_MODULE_PTR->next->cob_procedure_params[n]) {
                 return (int)COB_MODULE_PTR->next->cob_procedure_params[n]->size;
             }
         }
     }
     return 0;
 }

COB_EXPIMP int cob_sys_printable	(	void *	,
			...
	)

 {
     cob_u8_ptr      data;
     unsigned char       *dotptr;
     size_t          datalen;
     size_t          n;
     unsigned char       dotrep;
     va_list         args;
 
     COB_CHK_PARMS (C$PRINTABLE, 1);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return 0;
     }
     data = p1;
     datalen = COB_MODULE_PTR->cob_procedure_params[0]->size;
     if (cobglobptr->cob_call_params > 1) {
         va_start (args, p1);
         dotptr = va_arg (args, unsigned char *);
         va_end (args);
         dotrep = *dotptr;
     } else {
         dotrep = (unsigned char)'.';
     }
     for (n = 0; n < datalen; ++n) {
         if (!isprint (data[n])) {
             data[n] = dotrep;
         }
     }
     return 0;
 }

COB_EXPIMP int cob_sys_read_file	(	unsigned char *	,
		unsigned char *	,
		unsigned char *	,
		unsigned char *	,
		unsigned char *
	)

 {
     cob_s64_t   off;
     int     fd;
     int     len;
     int     rc;
     struct stat st;
 
     COB_CHK_PARMS (CBL_READ_FILE, 5);
 
     rc = 0;
     memcpy (&fd, file_handle, (size_t)4);
     memcpy (&off, file_offset, (size_t)8);
     memcpy (&len, file_len, (size_t)4);
 #ifndef WORDS_BIGENDIAN
     off = COB_BSWAP_64 (off);
     len = COB_BSWAP_32 (len);
 #endif
     if (lseek (fd, (off_t)off, SEEK_SET) == (off_t)-1) {
         return -1;
     }
     if (len > 0) {
         rc = read (fd, buf, (size_t)len);
         if (rc < 0) {
             rc = -1;
         } else if (rc == 0) {
             rc = 10;
         } else {
             rc = 0;
         }
     }
     if ((*flags & 0x80) != 0) {
         if (fstat (fd, &st) < 0) {
             return -1;
         }
         off = st.st_size;
 #ifndef WORDS_BIGENDIAN
         off = COB_BSWAP_64 (off);
 #endif
         memcpy (file_offset, &off, (size_t)8);
     }
     return rc;
 }

COB_EXPIMP int cob_sys_rename_file	(	unsigned char *	,
		unsigned char *
	)

 {
     char    *fn1;
     char    *fn2;
     int ret;
 
     COB_UNUSED (fname1);
     COB_UNUSED (fname2);
 
     COB_CHK_PARMS (CBL_RENAME_FILE, 2);
 
     if (!COB_MODULE_PTR->cob_procedure_params[0]) {
         return -1;
     }
     if (!COB_MODULE_PTR->cob_procedure_params[1]) {
         return -1;
     }
     fn1 = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[0]);
     fn2 = cob_str_from_fld (COB_MODULE_PTR->cob_procedure_params[1]);
     ret = rename (fn1, fn2);
     cob_free (fn1);
     cob_free (fn2);
     if (ret) {
         return 128;
     }
     return 0;
 }

COB_EXPIMP int cob_sys_return_args ( void * )

 {
     COB_UNUSED (data);
 
     COB_CHK_PARMS (C$NARG, 1);
 
     if (COB_MODULE_PTR->cob_procedure_params[0]) {
         cob_set_int (COB_MODULE_PTR->cob_procedure_params[0],
                  COB_MODULE_PTR->module_num_params);
     }
     return 0;
 }

COB_EXPIMP int cob_sys_sleep ( const void * )

 {
     int n;
 
     COB_UNUSED (data);
 
     COB_CHK_PARMS (C$SLEEP, 1);
 
     if (COB_MODULE_PTR->cob_procedure_params[0]) {
         n = cob_get_int (COB_MODULE_PTR->cob_procedure_params[0]);
         if (n > 0 && n < 3600*24*7) {
 #ifdef  _WIN32
             Sleep (n*1000);
 #else
             sleep ((unsigned int)n);
 #endif
         }
     }
     return 0;
 }

COB_EXPIMP int cob_sys_sound_bell ( void )

 {
     if (COB_BEEP_VALUE == 9) {
         return 0;
     }
 #ifdef  COB_GEN_SCREENIO
     if (!cobglobptr->cob_screen_initialized &&
         COB_BEEP_VALUE != 2) {
         cob_screen_init ();
     }
     cob_beep ();
 #else
     cob_speaker_beep ();
 #endif
     return 0;
 }

COB_EXPIMP int cob_sys_system ( const void * )

 {
     const char  *cmd;
     char        *buff;
     int     i;
 
     COB_CHK_PARMS (SYSTEM, 1);
 
     if (COB_MODULE_PTR->cob_procedure_params[0]) {
         cmd = cmdline;
         i = (int)COB_MODULE_PTR->cob_procedure_params[0]->size;
         if (unlikely(i > COB_MEDIUM_MAX)) {
             cob_runtime_error (_("Parameter to SYSTEM call is larger than 8192 characters"));
             cob_stop_run (1);
         }
         i--;
         for (; i >= 0; --i) {
             if (cmd[i] != ' ' && cmd[i] != 0) {
                 break;
             }
         }
         if (i >= 0) {
             buff = cob_malloc ((size_t)(i + 2));
             memcpy (buff, cmd, (size_t)(i + 1));
             if (cobglobptr->cob_screen_initialized) {
                 cob_screen_set_mode (0);
             }
             i = system (buff);
             cob_free (buff);
             if (cobglobptr->cob_screen_initialized) {
                 cob_screen_set_mode (1U);
             }
             return i;
         }
     }
     return 1;
 }

COB_EXPIMP int cob_sys_tolower	(	void *	,
		const int
	)

 {
     cob_u8_ptr  data = p1;
     size_t      n;
 
     COB_CHK_PARMS (CBL_TOLOWER, 2);
 
     if (length > 0) {
         for (n = 0; n < (size_t)length; ++n) {
             if (isupper (data[n])) {
                 data[n] = (cob_u8_t)tolower (data[n]);
             }
         }
     }
     return 0;
 }

COB_EXPIMP int cob_sys_toupper	(	void *	,
		const int
	)

 {
     cob_u8_ptr  data = p1;
     size_t      n;
 
     COB_CHK_PARMS (CBL_TOUPPER, 2);
 
     if (length > 0) {
         for (n = 0; n < (size_t)length; ++n) {
             if (islower (data[n])) {
                 data[n] = (cob_u8_t)toupper (data[n]);
             }
         }
     }
     return 0;
 }

COB_EXPIMP int cob_sys_write_file	(	unsigned char *	,
		unsigned char *	,
		unsigned char *	,
		unsigned char *	,
		unsigned char *
	)

 {
     cob_s64_t   off;
     int     fd;
     int     len;
     int     rc;
 
     COB_UNUSED (flags);
 
     COB_CHK_PARMS (CBL_WRITE_FILE, 5);
 
     memcpy (&fd, file_handle, (size_t)4);
     memcpy (&off, file_offset, (size_t)8);
     memcpy (&len, file_len, (size_t)4);
 #ifndef WORDS_BIGENDIAN
     off = COB_BSWAP_64 (off);
     len = COB_BSWAP_32 (len);
 #endif
     if (lseek (fd, (off_t)off, SEEK_SET) == (off_t)-1) {
         return -1;
     }
     rc = write (fd, buf, (size_t)len);
     if (rc < 0) {
         return 30;
     }
     return 0;
 }

COB_EXPIMP int cob_sys_x91	(	void *	,
		const void *	,
		void *
	)

 {
     cob_u8_ptr      result = p1;
     const cob_u8_ptr    func = p2;
     cob_u8_ptr      parm = p3;
     unsigned char       *p;
     size_t          i;
 
     switch (*func) {
     case 11:
         /* Set switches */
         p = parm;
         for (i = 0; i < 8; ++i, ++p) {
             if (*p == 0) {
                 cob_switch[i] = 0;
             } else if (*p == 1) {
                 cob_switch[i] = 1;
             }
         }
         *result = 0;
         break;
     case 12:
         /* Get switches */
         p = parm;
         for (i = 0; i < 8; ++i, ++p) {
             *p = (unsigned char)cob_switch[i];
         }
         *result = 0;
         break;
     case 16:
         /* Return number of call parameters */
         *parm = (unsigned char)COB_MODULE_PTR->module_num_params;
         *result = 0;
         break;
     default:
         *result = 1;
         break;
     }
     return 0;
 }

COB_EXPIMP int cob_sys_xf4	(	void *	,
		const void *
	)

 {
     cob_u8_ptr      data_1 = p1;
     const cob_u8_ptr    data_2 = p2;
     size_t          n;
 
     COB_CHK_PARMS (CBL_XF4, 2);
 
     *data_1 = 0;
     for (n = 0; n < 8; ++n) {
         *data_1 |= (data_2[n] & 1) << (7 - n);
     }
     return 0;
 }

COB_EXPIMP int cob_sys_xf5	(	const void *	,
		void *
	)

 {
     const cob_u8_ptr    data_1 = p1;
     cob_u8_ptr      data_2 = p2;
     size_t          n;
 
     COB_CHK_PARMS (CBL_XF5, 2);
 
     for (n = 0; n < 8; ++n) {
         data_2[n] = (*data_1 & (1 << (7 - n))) ? 1 : 0;
     }
     return 0;
 }

COB_EXPIMP int cob_sys_xor	(	const void *	,
		void *	,
		const int
	)

 {
     const cob_u8_ptr    data_1 = p1;
     cob_u8_ptr      data_2 = p2;
     size_t          n;
 
     COB_CHK_PARMS (CBL_XOR, 3);
 
     if (length <= 0) {
         return 0;
     }
     for (n = 0; n < (size_t)length; ++n) {
         data_2[n] ^= data_1[n];
     }
     return 0;
 }

COB_EXPIMP void cob_table_sort	(	cob_field *	,
		const int
	)

 {
     qsort (f->data, (size_t) n, f->size, sort_compare);
     cob_free (sort_keys);
 }

COB_EXPIMP void cob_table_sort_init	(	const size_t	,
		const unsigned char *
	)

 {
     sort_nkeys = 0;
     sort_keys = cob_malloc (nkeys * sizeof (cob_file_key));
     if (collating_sequence) {
         sort_collate = collating_sequence;
     } else {
         sort_collate = COB_MODULE_PTR->collating_sequence;
     }
 }

COB_EXPIMP void cob_table_sort_init_key	(	cob_field *	,
		const int	,
		const unsigned	int
	)

 {
     sort_keys[sort_nkeys].field = field;
     sort_keys[sort_nkeys].flag = flag;
     sort_keys[sort_nkeys].offset = offset;
     sort_nkeys++;
 }

COB_EXPIMP void cob_temp_name	(	char *	,
		const char *
	)

 {
     /* Set temporary file name */
     if (ext) {
         snprintf (filename, (size_t)COB_FILE_MAX, "%s%ccob%d_%d%s",
             cob_gettmpdir(), SLASH_INT, cob_sys_getpid(), cob_temp_iteration, ext);
     } else {
         snprintf (filename, (size_t)COB_FILE_MAX, "%s%ccobsort%d_%d",
             cob_gettmpdir(), SLASH_INT, cob_sys_getpid(), cob_temp_iteration);
     }
 }

COB_EXPIMP int cob_tidy ( void )

 {
     struct exit_handlerlist *h;
 
     if (!cob_initialized) {
         exit (1);
     }
     if (exit_hdlrs != NULL) {
         h = exit_hdlrs;
         while (h != NULL) {
             h->proc ();
             h = h->next;
         }
     }
     cob_terminate_routines ();
     return 0;
 }

COB_EXPIMP void cob_trace_section	(	const char *	,
		const char *	,
		const int
	)

 {
     const char  *s;
 
     if (cob_line_trace) {
         if (!cob_trace_file) {
             cob_check_trace_file ();
         }
         if (source &&
             (!cob_last_sfile || strcmp (cob_last_sfile, source))) {
             cob_last_sfile = source;
             fprintf (cob_trace_file, "Source:     '%s'\n", source);
         }
         if (COB_MODULE_PTR->module_name) {
             s = COB_MODULE_PTR->module_name;
         } else {
             s = "Unknown";
         }
         fprintf (cob_trace_file, "Program-Id: %-16s ", s);
         if (line) {
             fprintf (cob_trace_file, "%-34.34sLine: %d\n", para, line);
         } else {
             fprintf (cob_trace_file, "%s\n", para);
         }
         fflush (cob_trace_file);
     }
 }

COB_EXPIMP void cob_unlock_file	(	cob_file *	,
		cob_field *
	)

 {
     cob_file_unlock (f);
     save_status (f, fnstatus, COB_STATUS_00_SUCCESS);
 }

COB_EXPIMP void cob_unstring_delimited	(	cob_field *	,
		const cob_u32_t
	)

 {
     dlm_list[unstring_ndlms].uns_dlm = *dlm;
     dlm_list[unstring_ndlms].uns_all = all;
     unstring_ndlms++;
 }

COB_EXPIMP void cob_unstring_finish ( void )

 {
     if (unstring_offset < (int)unstring_src->size) {
         cob_set_exception (COB_EC_OVERFLOW_UNSTRING);
     }
 
     if (unstring_ptr) {
         cob_set_int (unstring_ptr, unstring_offset + 1);
     }
 }

COB_EXPIMP void cob_unstring_init	(	cob_field *	,
		cob_field *	,
		const size_t
	)

 {
     unstring_src_copy = *src;
     unstring_src = &unstring_src_copy;
     unstring_ptr = NULL;
     if (ptr) {
         unstring_ptr_copy = *ptr;
         unstring_ptr = &unstring_ptr_copy;
     }
 
     unstring_offset = 0;
     unstring_count = 0;
     unstring_ndlms = 0;
     cob_set_exception (0);
     if (num_dlm > dlm_list_size) {
         cob_free (dlm_list);
         dlm_list = cob_malloc (num_dlm * sizeof(struct dlm_struct));
         dlm_list_size = num_dlm;
     }
 
     if (unstring_ptr) {
         unstring_offset = cob_get_int (unstring_ptr) - 1;
         if (unstring_offset < 0 || unstring_offset >= (int)unstring_src->size) {
             cob_set_exception (COB_EC_OVERFLOW_UNSTRING);
         }
     }
 }

COB_EXPIMP void cob_unstring_into	(	cob_field *	,
		cob_field *	,
		cob_field *
	)

 {
     unsigned char   *p;
     unsigned char   *dp;
     unsigned char   *s;
     unsigned char   *dlm_data;
     unsigned char   *start;
     size_t      dlm_size = 0;
     int     i;
     int     srsize;
     int     dlsize;
     int     match_size = 0;
     int     brkpt = 0;
 
     if (cob_get_exception_code ()) {
         return;
     }
 
     if (unstring_offset >= (int)unstring_src->size) {
         return;
     }
 
     start = unstring_src->data + unstring_offset;
     dlm_data = NULL;
     if (unstring_ndlms == 0) {
         match_size = cob_min_int ((int)COB_FIELD_SIZE (dst),
                       (int)unstring_src->size - unstring_offset);
         cob_str_memcpy (dst, start, match_size);
         unstring_offset += match_size;
     } else {
         srsize = (int) unstring_src->size;
         s = unstring_src->data + srsize;
         for (p = start; p < s; ++p) {
             for (i = 0; i < unstring_ndlms; ++i) {
                 dlsize = (int) dlm_list[i].uns_dlm.size;
                 dp = dlm_list[i].uns_dlm.data;
                 if (p + dlsize > s) {
                     continue;
                 }
                 if (!memcmp (p, dp, (size_t)dlsize)) {             /* delimiter equal */         
                     match_size = (int)(p - start);             /* count in */
                     cob_str_memcpy (dst, start, match_size);   /* into */
                     unstring_offset += match_size + dlsize;    /* with pointer */
                     dlm_data = dp;
                     dlm_size = dlsize;
                     if (dlm_list[i].uns_all) {                 /* delimited by all */
                         for (p += dlsize ; p < s; p += dlsize) { 
                             if (p + dlsize > s) {
                                 break;
                             }
                             if (memcmp (p, dp, (size_t)dlsize)) {
                                 break;
                             }
                             unstring_offset += dlsize;
                         }
                     }
                     brkpt = 1;
                     break;
                 }
             }
             if (brkpt) {
                 break;
             }
         }
         if (!brkpt) {
             /* No match */
             match_size = (int)(unstring_src->size - unstring_offset);
             cob_str_memcpy (dst, start, match_size);
             unstring_offset = (int) unstring_src->size;
             dlm_data = NULL;
         }
     }
     unstring_count++;
 
     if (dlm) {
         if (dlm_data) {
             cob_str_memcpy (dlm, dlm_data, (int) dlm_size);
         } else if (COB_FIELD_IS_NUMERIC (dlm)) {
             cob_set_int (dlm, 0);
         } else {
             memset (dlm->data, ' ', dlm->size);
         }
     }
 
     if (cnt) {
         cob_set_int (cnt, match_size);
     }
 }

COB_EXPIMP void cob_unstring_tallying ( cob_field * )

 {
     cob_add_int (f, unstring_count, 0);
 }

COB_EXPIMP int cob_valid_date_format ( const char * )

 {
     return !strcmp (format, "YYYYMMDD")
         || !strcmp (format, "YYYY-MM-DD")
         || !strcmp (format, "YYYYDDD")
         || !strcmp (format, "YYYY-DDD")
         || !strcmp (format, "YYYYWwwD")
         || !strcmp (format, "YYYY-Www-D");
 }

COB_EXPIMP int cob_valid_datetime_format ( const char * )

 {
         char    date_format_str[MAX_DATETIME_STR_LENGTH] = { '\0' };
     char    time_format_str[MAX_DATETIME_STR_LENGTH] = { '\0' };
     struct date_format  date_format;
     struct time_format  time_format;
 
     split_around_t (format, date_format_str, time_format_str);
 
     if (!cob_valid_date_format (date_format_str)
         || !cob_valid_time_format (time_format_str)) {
         return 0;
     }
 
     /* Check time and date formats match */
     date_format = parse_date_format_string (date_format_str);
     time_format = parse_time_format_string (time_format_str);
     if (date_format.with_hyphens != time_format.with_colons) {
         return 0;
     }
 
     return 1;
 }

COB_EXPIMP int cob_valid_time_format ( const char * )

 {
     int with_colons;
         ptrdiff_t format_offset;
     int decimal_places = 0;
 
     if (!strncmp (format, "hhmmss", 6)) {
         with_colons = 0;
         format_offset = 6;
     } else if (!strncmp (format, "hh:mm:ss", 8)) {
         with_colons = 1;
         format_offset = 8;
     } else {
         return 0;
     }
 
     if (format[format_offset] == '.') {
         decimal_places = decimal_places_for_seconds (format, format_offset);
         format_offset += decimal_places + 1;
         if (!(1 <= decimal_places && decimal_places <= max_time_decimal_places)) {
             return 0;
         }
     }
 
     if (strlen (format) > format_offset
         && !rest_is_z (format + format_offset)
         && !rest_is_offset_format (format + format_offset, with_colons)) {
         return 0;
     }
 
     return 1;
 }

COB_EXPIMP void cob_write	(	cob_file *	,
		cob_field *	,
		const int	,
		cob_field *	,
		const unsigned	int
	)

 {
     f->flag_read_done = 0;
 
     if (f->access_mode == COB_ACCESS_SEQUENTIAL) {
         if (unlikely(f->open_mode != COB_OPEN_OUTPUT &&
                  f->open_mode != COB_OPEN_EXTEND)) {
             save_status (f, fnstatus, COB_STATUS_48_OUTPUT_DENIED);
             return;
         }
     } else {
         if (unlikely(f->open_mode != COB_OPEN_OUTPUT &&
                  f->open_mode != COB_OPEN_I_O)) {
             save_status (f, fnstatus, COB_STATUS_48_OUTPUT_DENIED);
             return;
         }
     }
 
     if (f->variable_record) {
         f->record->size = (size_t)cob_get_int (f->variable_record);
         if (unlikely(f->record->size > rec->size)) {
             f->record->size = rec->size;
         }
     } else {
         f->record->size = rec->size;
     }
 
     if (f->record->size < f->record_min || f->record_max < f->record->size) {
         save_status (f, fnstatus, COB_STATUS_44_RECORD_OVERFLOW);
         return;
     }
 
     check_eop_status = check_eop;
     save_status (f, fnstatus,
              fileio_funcs[(int)f->organization]->write (f, opt));
 }

DECLNORET void cobc_abort	(	const char *	,
		const int
	)

References _, cobc_abort_pr(), and cobc_abort_terminate().

Referenced by cobc_dumb_abort().

 {
     cobc_abort_pr (_("%s:%d Internal compiler error"), filename, linenum);
     cobc_abort_terminate ();
 }

void cobc_abort_pr	(	const char *	,
			...
	)

Referenced by cb_build_binary_op(), cb_define_list_add(), cb_field_size(), cb_get_int(), cb_get_long_long(), cb_get_u_long_long(), cb_tree_category(), cb_tree_type(), cob_gen_optim(), cobc_abort(), cobc_abort_terminate(), cobc_check_action(), cobc_check_string(), cobc_error_name(), cobc_free(), cobc_main_malloc(), cobc_main_realloc(), cobc_main_strdup(), cobc_malloc(), cobc_parse_malloc(), cobc_parse_realloc(), cobc_parse_strdup(), cobc_plex_malloc(), cobc_plex_strdup(), cobc_realloc(), cobc_set_value(), cobc_stradd_dup(), cobc_strdup(), cobc_too_many_errors(), cobc_tree_cast_error(), compute_size(), decimal_alloc(), decimal_compute(), decimal_expand(), initialize_type(), output_attr(), output_base(), output_call_by_value_args(), output_cond(), output_data(), output_funcall(), output_initialize_one(), output_integer(), output_internal_function(), output_long_integer(), output_param(), output_size(), output_stmt(), plex_action_directive(), process_command_line(), process_filename(), and validate_move().

 {
     va_list     ap;
 
     va_start (ap, fmt);
     vfprintf (stderr, fmt, ap);
     va_end (ap);
     putc ('\n', stderr);
     fflush (stderr);
 }

void* cobc_check_string ( const char * )

References _, base_string, cobc_abort_pr(), cobc_abort_terminate(), cobc_main_malloc(), cobc_main_strdup(), strcache::next, unlikely, and strcache::val.

Referenced by cb_build_binary_picture(), cb_build_picture(), cb_build_program_id(), cb_define_list_add(), and cb_encode_program_id().

 {
     struct strcache *s;
 
 #ifdef  COB_TREE_DEBUG
     if (unlikely(!dupstr)) {
         cobc_abort_pr (_("Call to cobc_check_string with NULL pointer"));
         cobc_abort_terminate ();
     }
 #endif
     for (s = base_string; s; s = s->next) {
         if (!strcmp (dupstr, (const char *)s->val)) {
             return s->val;
         }
     }
     s = cobc_main_malloc (sizeof(struct strcache));
     s->next = base_string;
     s->val = cobc_main_strdup (dupstr);
     base_string = s;
     return s->val;
 }

size_t cobc_check_valid_name	(	const char *	,
		const unsigned	int
	)

References cob_csyns, COB_NUM_CSYNS, cobc_bcompare(), cobc_error_name(), and p.

Referenced by cb_build_program_id(), and process_filename().

 {
     const char  *p;
     size_t      len;
 
     for (p = name, len = 0; *p; p++, len++) {
         if (*p == '/' || *p == '\\') {
             cobc_error_name (name, prechk, 5U);
             return 1;
         }
     }
     if (len < 1) {
         cobc_error_name (name, prechk, 1U);
         return 1;
     }
     if (!cb_relaxed_syntax_check && len > 31) {
         cobc_error_name (name, prechk, 1U);
         return 1;
     }
     if (*name == '_' || *name == ' ') {
         cobc_error_name (name, prechk, 2U);
         return 1;
     }
     if (prechk && len > 3 &&
         (!memcmp (name, "cob_", (size_t)4) ||
          !memcmp (name, "COB_", (size_t)4))) {
         cobc_error_name (name, prechk, 3U);
         return 1;
     }
     if (bsearch (name, cob_csyns, COB_NUM_CSYNS,
              sizeof (char *), cobc_bcompare)) {
         cobc_error_name (name, prechk, 4U);
         return 1;
     }
     return 0;
 }

DECLNORET void cobc_dumb_abort	(	const char *	,
		const int
	)

References cobc_abort().

 {
     cobc_abort (filename, linenum);
 }

void cobc_free ( void * )

deallocation of compile time memory

References _, cobc_abort_pr(), cobc_abort_terminate(), and unlikely.

Referenced by cb_define_list_add(), cb_reset_78(), cb_reset_global_78(), clear_initial_values(), cobc_cmd_print(), cobc_deciph_funcs(), cobc_free_mem(), cobc_main_free(), cobc_main_realloc(), cobc_parse_free(), cobc_parse_realloc(), cobc_var_print(), main(), plex_clear_all(), ppecho(), preprocess(), process(), process_env_copy_path(), scan_define_options(), while(), and ylex_clear_all().

 {
 #ifdef  COB_TREE_DEBUG
     if (unlikely(!mptr)) {
         cobc_abort_pr (_("Call to cobc_free with NULL pointer"));
         cobc_abort_terminate ();
     }
 #endif
     free(mptr);
 }

cobc_free ( var )

void cobc_main_free ( void * )

References cobc_free(), cobc_mem_struct::memptr, cobc_mem_struct::next, and NULL.

 {
     struct cobc_mem_struct  *curr;
     struct cobc_mem_struct  *prev;
 
     prev = NULL;
     for (curr = cobc_mainmem_base; curr; curr = curr->next) {
         if (curr->memptr == prevptr) {
             break;
         }
         prev = curr;
     }
     if (!curr) {
         return;
     }
     if (prev) {
         prev->next = curr->next;
     } else {
         /* At mainmem_base */
         cobc_mainmem_base = curr->next;
     }
     cobc_free (curr);
 }

void* cobc_main_malloc ( const size_t )

References _, cobc_abort_pr(), cobc_abort_terminate(), cobc_mainmem_base, cobc_mem_struct::memlen, cobc_mem_struct::memptr, cobc_mem_struct::next, and unlikely.

Referenced by ambiguous_error(), cb_build_class_name(), cb_build_picture(), cb_config_entry(), cb_define_list_add(), cb_expr_init(), cb_int(), cb_text_list_add(), cobc_check_string(), cobc_main_strdup(), cobc_set_value(), cobc_stradd_dup(), codegen(), finalize_file(), main(), output_initialize_one(), process_assemble(), process_command_line(), process_filename(), process_module_direct(), process_translate(), and undefined_error().

 {
     struct cobc_mem_struct  *m;
 
     m = calloc ((size_t)1, sizeof(struct cobc_mem_struct) + size);
     if (unlikely(!m)) {
         cobc_abort_pr (_("Cannot allocate %d bytes of memory - Aborting"),
                 (int)size);
         cobc_abort_terminate ();
     }
     m->next = cobc_mainmem_base;
     m->memptr = (char *)m + sizeof(struct cobc_mem_struct);
     m->memlen = size;
     cobc_mainmem_base = m;
     return m->memptr;
 }

void* cobc_main_realloc	(	void *	,
		const size_t
	)

References _, cobc_abort_pr(), cobc_abort_terminate(), cobc_free(), cobc_mem_struct::memlen, cobc_mem_struct::memptr, cobc_mem_struct::next, NULL, and unlikely.

Referenced by cb_expr_shift(), cobc_add_str(), cobc_chk_buff_size(), file_basename(), and output_initialize_one().

 {
     struct cobc_mem_struct  *m;
     struct cobc_mem_struct  *curr;
     struct cobc_mem_struct  *prev;
 
     m = calloc ((size_t)1, sizeof(struct cobc_mem_struct) + size);
     if (unlikely(!m)) {
         cobc_abort_pr (_("Cannot allocate %d bytes of memory - Aborting"),
                 (int)size);
         cobc_abort_terminate ();
     }
     m->memptr = (char *)m + sizeof(struct cobc_mem_struct);
     m->memlen = size;
 
     prev = NULL;
     for (curr = cobc_mainmem_base; curr; curr = curr->next) {
         if (curr->memptr == prevptr) {
             break;
         }
         prev = curr;
     }
     if (unlikely(!curr)) {
         cobc_abort_pr (_("Attempt to reallocate non-allocated memory - Aborting"));
         cobc_abort_terminate ();
     }
     m->next = curr->next;
     if (prev) {
         prev->next = m;
     } else {
         /* At mainmem_base */
         cobc_mainmem_base = m;
     }
     memcpy (m->memptr, curr->memptr, curr->memlen);
     cobc_free (curr);
     
     return m->memptr;
 }

void* cobc_main_strdup ( const char * )

References _, cobc_abort_pr(), cobc_abort_terminate(), cobc_main_malloc(), p, and unlikely.

Referenced by cb_text_list_add(), cobc_check_string(), cobc_getenv(), cobc_set_value(), main(), process_command_line(), process_filename(), process_link(), and read_string().

 {
     void    *p;
     size_t  n;
 
 #ifdef  COB_TREE_DEBUG
     if (unlikely(!dupstr)) {
         cobc_abort_pr (_("Call to cobc_main_strdup with NULL pointer"));
         cobc_abort_terminate ();
     }
 #endif
     n = strlen (dupstr);
     p = cobc_main_malloc (n + 1);
     memcpy (p, dupstr, n);
     return p;
 }

void* cobc_malloc ( const size_t )

memory allocation for use when compiling

Allocate size bytes of memory, cleared to zeros. Aborts compile if memory unavailable.

References _, cobc_abort_pr(), cobc_abort_terminate(), and unlikely.

Referenced by cb_add_78(), cb_add_const_var(), cobc_strdup(), ppopen(), and process().

 {
     void    *mptr;
 
     mptr = calloc ((size_t)1, size);
     if (unlikely(!mptr)) {
         cobc_abort_pr (_("Cannot allocate %d bytes of memory - Aborting"),
                 (int)size);
         cobc_abort_terminate ();
     }
     return mptr;
 }

void cobc_parse_free ( void * )

References cobc_free(), cobc_mem_struct::memptr, cobc_mem_struct::next, and NULL.

Referenced by cb_build_move_literal(), terminator_clear(), terminator_error(), and terminator_warning().

 {
     struct cobc_mem_struct  *curr;
     struct cobc_mem_struct  *prev;
 
     prev = NULL;
     for (curr = cobc_parsemem_base; curr; curr = curr->next) {
         if (curr->memptr == prevptr) {
             break;
         }
         prev = curr;
     }
     if (!curr) {
         return;
     }
     if (prev) {
         prev->next = curr->next;
     } else {
         /* At parsemem_base */
         cobc_parsemem_base = curr->next;
     }
     cobc_free (curr);
 }

void* cobc_parse_malloc ( const size_t )

References _, cobc_abort_pr(), cobc_abort_terminate(), cobc_parsemem_base, cobc_mem_struct::memlen, cobc_mem_struct::memptr, cobc_mem_struct::next, and unlikely.

Referenced by add_contained_prog(), build_literal(), cb_build_label(), cb_build_move(), cb_build_move_literal(), cb_build_picture(), cb_build_program(), cb_concat_literals(), cb_name(), cb_validate_program_body(), check_attribs(), cobc_parse_strdup(), lookup_attr(), lookup_call(), lookup_func_call(), lookup_literal(), lookup_string(), lookup_word(), make_tree(), output_base(), output_internal_function(), output_param(), output_perform_call(), setup_use_file(), and validate_field_1().

 {
     struct cobc_mem_struct  *m;
 
     m = calloc ((size_t)1, sizeof(struct cobc_mem_struct) + size);
     if (unlikely(!m)) {
         cobc_abort_pr (_("Cannot allocate %d bytes of memory - Aborting"),
                 (int)size);
         cobc_abort_terminate ();
     }
     m->next = cobc_parsemem_base;
     m->memptr = (char *)m + sizeof(struct cobc_mem_struct);
     m->memlen = size;
     cobc_parsemem_base = m;
     return m->memptr;
 }

void* cobc_parse_realloc	(	void *	,
		const size_t
	)

References _, cobc_abort_pr(), cobc_abort_terminate(), cobc_free(), cobc_mem_struct::memlen, cobc_mem_struct::memptr, cobc_mem_struct::next, NULL, and unlikely.

 {
     struct cobc_mem_struct  *m;
     struct cobc_mem_struct  *curr;
     struct cobc_mem_struct  *prev;
 
     m = calloc ((size_t)1, sizeof(struct cobc_mem_struct) + size);
     if (unlikely(!m)) {
         cobc_abort_pr (_("Cannot allocate %d bytes of memory - Aborting"),
                 (int)size);
         cobc_abort_terminate ();
     }
     m->memptr = (char *)m + sizeof(struct cobc_mem_struct);
     m->memlen = size;
 
     prev = NULL;
     for (curr = cobc_parsemem_base; curr; curr = curr->next) {
         if (curr->memptr == prevptr) {
             break;
         }
         prev = curr;
     }
     if (unlikely(!curr)) {
         cobc_abort_pr (_("Attempt to reallocate non-allocated memory - Aborting"));
         cobc_abort_terminate ();
     }
     m->next = curr->next;
     if (prev) {
         prev->next = m;
     } else {
         /* At parsemem_base */
         cobc_parsemem_base = m;
     }
     memcpy (m->memptr, curr->memptr, curr->memlen);
     cobc_free (curr);
     
     return m->memptr;
 }

void* cobc_parse_strdup ( const char * )

References _, cobc_abort_pr(), cobc_abort_terminate(), cobc_parse_malloc(), p, and unlikely.

Referenced by cb_build_class_name(), cb_build_debug(), cb_emit_evaluate(), cb_to_cname(), lookup_string(), lookup_word(), and while().

 {
     void    *p;
     size_t  n;
 
 #ifdef  COB_TREE_DEBUG
     if (unlikely(!dupstr)) {
         cobc_abort_pr (_("Call to cobc_parse_strdup with NULL pointer"));
         cobc_abort_terminate ();
     }
 #endif
     n = strlen (dupstr);
     p = cobc_parse_malloc (n + 1);
     memcpy (p, dupstr, n);
     return p;
 }

void* cobc_plex_malloc ( const size_t )

References _, cobc_abort_pr(), cobc_abort_terminate(), cobc_plexmem_base, cobc_mem_struct::memptr, cobc_mem_struct::next, and unlikely.

Referenced by cobc_plex_strdup(), pp_text_list_add(), ppp_define_add(), ppp_list_add(), and ppp_replace_list_add().

 {
     struct cobc_mem_struct  *m;
 
     m = calloc ((size_t)1, sizeof(struct cobc_mem_struct) + size);
     if (unlikely(!m)) {
         cobc_abort_pr (_("Cannot allocate %d bytes of memory - Aborting"),
                 (int)size);
         cobc_abort_terminate ();
     }
     m->memptr = (char *)m + sizeof(struct cobc_mem_struct);
     m->next = cobc_plexmem_base;
     cobc_plexmem_base = m;
     return m->memptr;
 }

void* cobc_plex_strdup ( const char * )

References _, cobc_abort_pr(), cobc_abort_terminate(), cobc_plex_malloc(), p, and unlikely.

Referenced by ppp_define_add(), ppp_list_add(), ppp_set_value(), switch_to_buffer(), and while().

 {
     void    *p;
     size_t  n;
 
 #ifdef  COB_TREE_DEBUG
     if (unlikely(!dupstr)) {
         cobc_abort_pr (_("Call to cobc_plex_strdup with NULL pointer"));
         cobc_abort_terminate ();
     }
 #endif
     n = strlen (dupstr);
     p = cobc_plex_malloc (n + 1);
     memcpy (p, dupstr, n);
     return p;
 }

void* cobc_realloc	(	void *	,
		const size_t
	)

References _, cobc_abort_pr(), cobc_abort_terminate(), and unlikely.

Referenced by read_literal(), scan_x(), and scan_z().

 {
     void    *mptr;
 
     mptr = realloc (prevptr, size);
     if (unlikely(!mptr)) {
         cobc_abort_pr (_("Cannot reallocate %d bytes of memory - Aborting"),
                 (int)size);
         cobc_abort_terminate ();
     }
     return mptr;
 }

void* cobc_strdup ( const char * )

safely duplicate a character array

References _, cobc_abort_pr(), cobc_abort_terminate(), cobc_malloc(), p, and unlikely.

Referenced by cb_define_list_add(), cobc_cmd_print(), cobc_deciph_funcs(), cobc_var_print(), ppecho(), ppopen(), process_command_line(), process_env_copy_path(), scan_define_options(), and while().

 {
     void    *p;
     size_t  n;
 
 #ifdef  COB_TREE_DEBUG
     if (unlikely(!dupstr)) {
         cobc_abort_pr (_("Call to cobc_strdup with NULL pointer"));
         cobc_abort_terminate ();
     }
 #endif
     n = strlen (dupstr);
     p = cobc_malloc (n + 1);
     memcpy (p, dupstr, n);
     return p;
 }

DECLNORET void cobc_too_many_errors ( void )

References _, cobc_abort_pr(), and cobc_abort_terminate().

Referenced by cb_error(), cb_error_x(), and cb_plex_error().

 {
     cobc_abort_pr (_("Too many errors - Aborting compilation"));
     cobc_abort_terminate ();
 }

DECLNORET void cobc_tree_cast_error	(	const cb_tree	,
		const char *	,
		const int	,
		const enum	cb_tag
	)

 {
     cobc_abort_pr (_("%s:%d Invalid cast from '%s' type %s to type %s"),
         filename, linenum,
         x ? cb_name (x) : "NULL", 
         x ? cobc_enum_explain (CB_TREE_TAG(x)) : "None",
         cobc_enum_explain (tagnum));
     cobc_abort_terminate ();
 }

void codegen	(	struct cb_program *	,
		const int
	)

 {
     cb_tree         l;
     struct attr_list    *j;
     struct literal_list *m;
     struct field_list   *k;
     struct string_list  *stp;
     struct call_list    *clp;
     struct base_list    *blp;
     unsigned char       *s;
     struct nested_list  *nlp;
     struct cb_program   *cp;
 #if 0   /* RXWRXW - Const */
     struct cb_literal   *lp;
 #endif
     cb_tree         l1;
     cb_tree         l2;
     const char      *prevprog;
     struct tm       *loctime;
     cob_u32_t       inc;
 #if 0   /* RXWRXW - Sticky */
     int         save_sticky;
 #endif
     int         i;
     int         found;
     enum cb_optim       optidx;
     time_t          sectime;
 
     /* Clear local program stuff */
     current_prog = prog;
     param_id = 0;
     stack_id = 0;
     num_cob_fields = 0;
     progid = 0;
     loop_counter = 0;
     output_indent_level = 0;
     last_line = 0;
     needs_exit_prog = 0;
     gen_custom = 0;
     gen_nested_tab = 0;
     gen_dynamic = 0;
     gen_if_level = 0;
     local_mem = 0;
     local_working_mem = 0;
     need_save_exception = 0;
     last_segment = 0;
     last_section = NULL;
     call_cache = NULL;
     func_call_cache = NULL;
     label_cache = NULL;
     local_base_cache = NULL;
     local_field_cache = NULL;
     inside_check = 0;
     for (i = 0; i < COB_INSIDE_SIZE; ++i) {
         inside_stack[i] = 0;
     }
     excp_current_program_id = prog->orig_program_id;
     excp_current_section = NULL;
     excp_current_paragraph = NULL;
     memset ((void *)i_counters, 0, sizeof (i_counters));
 #if 0   /* RXWRXW - Sticky */
     save_sticky = cb_sticky_linkage;
 #endif
 
     output_target = yyout;
     cb_local_file = current_prog->local_include->local_fp;
 
     if (!nested) {
         /* First iteration */
         gen_alt_ebcdic = 0;
         gen_ebcdic_ascii = 0;
         gen_full_ebcdic = 0;
         gen_native = 0;
         gen_figurative = 0;
         non_nested_count = 0;
         working_mem = 0;
         attr_cache = NULL;
         base_cache = NULL;
         globext_cache = NULL;
         literal_cache = NULL;
         field_cache = NULL;
         string_cache = NULL;
         string_id = 1;
         if (!string_buffer) {
             string_buffer = cobc_main_malloc ((size_t)COB_MINI_BUFF);
         }
 
         sectime = time (NULL);
         loctime = localtime (&sectime);
         /* Leap seconds ? */
         if (loctime->tm_sec >= 60) {
             loctime->tm_sec = 59;
         }
         if (loctime) {
             strftime (string_buffer, (size_t)COB_MINI_MAX,
                   "%b %d %Y %H:%M:%S", loctime);
         } else {
             strcpy (string_buffer, _("Unknown"));
         }
         output_header (output_target, string_buffer, NULL);
         output_header (cb_storage_file, string_buffer, NULL);
         for (cp = prog; cp; cp = cp->next_program) {
             output_header (cp->local_include->local_fp,
                     string_buffer, cp);
         }
 
 #ifndef _GNU_SOURCE
 #ifdef  _XOPEN_SOURCE_EXTENDED
         output ("#ifndef\t_XOPEN_SOURCE_EXTENDED\n");
         output ("#define\t_XOPEN_SOURCE_EXTENDED 1\n");
         output ("#endif\n");
 #endif
 #endif
         output ("#include <stdio.h>\n");
         output ("#include <stdlib.h>\n");
         output ("#include <stddef.h>\n");
         output ("#include <string.h>\n");
         output ("#include <math.h>\n");
 #ifdef  WORDS_BIGENDIAN
         output ("#define  WORDS_BIGENDIAN 1\n");
 #endif
 #ifdef  COB_KEYWORD_INLINE
         output ("#define  COB_KEYWORD_INLINE %s\n",
             CB_XSTRINGIFY(COB_KEYWORD_INLINE));
 #endif
         output ("#include <libcob.h>\n\n");
 
         output ("#define  COB_SOURCE_FILE\t\t\"%s\"\n",
             cb_source_file);
         output ("#define  COB_PACKAGE_VERSION\t\t\"%s\"\n",
             PACKAGE_VERSION);
         output ("#define  COB_PATCH_LEVEL\t\t%d\n",
             PATCH_LEVEL);
         /* string_buffer has formatted date from above */
         output ("#define  COB_MODULE_FORMATTED_DATE\t\"%s\"\n",
             string_buffer);
         if (loctime) {
             i = ((loctime->tm_year + 1900) * 10000) +
                 ((loctime->tm_mon + 1) * 100) +
                 loctime->tm_mday;
             output ("#define  COB_MODULE_DATE\t\t%d\n", i);
             i = (loctime->tm_hour * 10000) +
                 (loctime->tm_min * 100) +
                 loctime->tm_sec;
             output ("#define  COB_MODULE_TIME\t\t%d\n", i);
         } else {
             output ("#define  COB_MODULE_DATE\t\t0\n");
             output ("#define  COB_MODULE_TIME\t\t0\n");
         }
 
         output_newline ();
         output ("/* Global variables */\n");
         output ("#include \"%s\"\n\n", cb_storage_file_name);
 
         output ("/* Function prototypes */\n\n");
         for (cp = prog; cp; cp = cp->next_program) {
             /* Build parameter list */
             for (l = cp->entry_list; l; l = CB_CHAIN (l)) {
                 for (l1 = CB_VALUE (l); l1; l1 = CB_CHAIN (l1)) {
                     for (l2 = cp->parameter_list; l2; l2 = CB_CHAIN (l2)) {
                         if (strcasecmp (cb_code_field (CB_VALUE (l1))->name,
                                 cb_code_field (CB_VALUE (l2))->name) == 0) {
                             break;
                         }
                     }
                     if (l2 == NULL) {
                         cp->parameter_list = cb_list_add (cp->parameter_list, CB_VALUE (l1));
                     }
                 }
             }
             if (cp->flag_main) {
                 if (!cp->flag_recursive) {
                     output ("static int\t\t%s ();\n",
                         cp->program_id);
                 } else {
                     output ("int\t\t\t%s ();\n",
                         cp->program_id);
                 }
             } else {
                 for (l = cp->entry_list; l; l = CB_CHAIN (l)) {
                     output_entry_function (cp, l, cp->parameter_list, 0);
                 }
             }
             if (cp->prog_type == CB_FUNCTION_TYPE) {
                 non_nested_count++;
 #if 0   /* RXWRXW USERFUNC */
                 output ("static cob_field\t*%s_ (const int, cob_field **",
 #else
                 output ("static cob_field\t*%s_ (const int",
 #endif
                     cp->program_id);
             } else if (!cp->nested_level) {
                 non_nested_count++;
                 output ("static int\t\t%s_ (const int",
                     cp->program_id);
             } else {
                 output ("static int\t\t%s_%d_ (const int",
                     cp->program_id, cp->toplev_count);
             }
 #if 0   /* RXWRXW USERFUNC */
             if (!cp->flag_chained && cp->prog_type != CB_FUNCTION_TYPE) {
 #else
             if (!cp->flag_chained) {
 #endif
                 for (l = cp->parameter_list; l; l = CB_CHAIN (l)) {
                     output (", cob_u8_t *");
                     if (cb_sticky_linkage) {
                         output_storage ("static cob_u8_t\t\t\t*cob_parm_%d = NULL;\n",
                                 cb_code_field (CB_VALUE (l))->id);
                     }
                 }
             }
 #if 0   /* RXWRXW - NOINLINE */
             if (cb_flag_stack_check) {
                 output (") COB_NOINLINE;\n");
             } else {
 #endif
                 output (");\n");
 #if 0   /* RXWRXW - NOINLINE */
             }
 #endif
         }
         output ("\n");
     }
 
     /* Class-names */
     if (!prog->nested_level && prog->class_name_list) {
         output ("/* Class names */\n");
         for (l = prog->class_name_list; l; l = CB_CHAIN (l)) {
             output_class_name_definition (CB_CLASS_NAME (CB_VALUE (l)));
         }
     }
 
     /* Main function */
     if (prog->flag_main) {
         output_main_function (prog);
     }
 
     /* Functions */
     if (!nested) {
         output ("/* Functions */\n\n");
     }
 
     if (prog->prog_type == CB_FUNCTION_TYPE) {
         output ("/* FUNCTION-ID '%s' */\n\n", prog->orig_program_id);
     } else {
         output ("/* PROGRAM-ID '%s' */\n\n", prog->orig_program_id);
     }
 
     for (l = prog->entry_list; l; l = CB_CHAIN (l)) {
         output_entry_function (prog, l, prog->parameter_list, 1);
     }
 
     output_internal_function (prog, prog->parameter_list);
 
     if (!prog->next_program) {
         output ("/* End functions */\n\n");
     }
 
     if (gen_native || gen_full_ebcdic ||
         gen_ebcdic_ascii || prog->alphabet_name_list) {
         (void)lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
     }
 
     output_target = cb_storage_file;
 
     /* Program local stuff */
 
     /* CALL cache */
     if (needs_unifunc || call_cache || func_call_cache) {
         output_local ("\n/* Call pointers */\n");
     }
     if (needs_unifunc) {
         output_local ("cob_call_union\t\tcob_unifunc;\n");
     }
     for (clp = call_cache; clp; clp = clp->next) {
         output_local ("static cob_call_union\tcall_%s;\n",
                   clp->callname);
     }
     for (clp = func_call_cache; clp; clp = clp->next) {
         output_local ("static cob_call_union\tfunc_%s;\n",
                   clp->callname);
     }
     needs_unifunc = 0;
 
     /* Nested / contained list */
     if (prog->nested_prog_list && gen_nested_tab) {
         /* Generate contained program list */
         output_local ("\n/* Nested call table */\n");
         output_local ("static struct cob_call_struct\tcob_nest_tab[] = {\n");
         nlp = prog->nested_prog_list;
         for (; nlp; nlp = nlp->next) {
             if (nlp->nested_prog == prog) {
 #if 0   /* RXWRXW Fix recursive */
                 if (!prog->flag_recursive) {
                     continue;
                 }
 #endif
                 output_local ("\t{ \"%s\", { (void *(*)())%s_%d__ }, { NULL } },\n",
                     nlp->nested_prog->orig_program_id,
                     nlp->nested_prog->program_id,
                     nlp->nested_prog->toplev_count);
             } else {
                 output_local ("\t{ \"%s\", { (void *(*)())%s_%d__ }, { (void *(*)())%s_%d_ } },\n",
                     nlp->nested_prog->orig_program_id,
                     nlp->nested_prog->program_id,
                     nlp->nested_prog->toplev_count,
                     nlp->nested_prog->program_id,
                     nlp->nested_prog->toplev_count);
             }
         }
         output_local ("\t{ NULL, { NULL }, { NULL } }\n");
         output_local ("};\n");
     }
 
     /* Local indexes */
     found = 0;
     for (i = 0; i < COB_MAX_SUBSCRIPTS; i++) {
         if (i_counters[i]) {
             if (!found) {
                 found = 1;
                 output_local ("\n/* Subscripts */\n");
             }
             output_local ("int\t\ti%d;\n", i);
         }
     }
 
     /* PERFORM TIMES counters */
     if (loop_counter) {
         output_local ("\n/* Loop counters */\n");
         for (i = 0; i < loop_counter; i++) {
             output_local ("cob_s64_t\tn%d = 0;\n", i);
         }
         output_local ("\n");
     }
 
     /* Local implicit fields */
     if (num_cob_fields) {
         output_local ("\n/* Local cob_field items */\n");
         for (i = 0; i < num_cob_fields; i++) {
             output_local ("cob_field\t\tf%d;\n", i);
         }
         output_local ("\n");
     }
 
     /* Debugging fields */
     if (prog->flag_debugging) {
         output_local ("\n/* DEBUG runtime switch */\n");
         output_local ("static int\tcob_debugging_mode = 0;\n");
     }
     if (need_save_exception) {
         output_local ("\n/* DEBUG exception code save */\n");
         output_local ("int\t\tsave_exception_code = 0;\n");
     }
 
     /* LOCAL storage pointer */
     if (prog->local_storage && local_mem) {
         output_local ("\n/* LOCAL storage pointer */\n");
         output_local ("unsigned char\t\t*cob_local_ptr = NULL;\n");
         if (current_prog->flag_global_use) {
             output_local ("static unsigned char\t*cob_local_save = NULL;\n");
         }
     }
 
     /* Call parameter stack */
     output_local ("\n/* Call parameters */\n");
     if (cb_flag_stack_on_heap || prog->flag_recursive) {
         output_local ("cob_field\t\t**cob_procedure_params;\n");
     } else {
         if (prog->max_call_param) {
             i = prog->max_call_param;
         } else {
             i = 1;
         }
         output_local ("cob_field\t\t*cob_procedure_params[%d];\n", i);
     }
 
     /* Frame stack */
     output_local ("\n/* Perform frame stack */\n");
     if (cb_perform_osvs && current_prog->prog_type == CB_PROGRAM_TYPE) {
         output_local ("struct cob_frame\t*temp_index;\n");
     }
     if (cb_flag_stack_check) {
         output_local ("struct cob_frame\t*frame_overflow;\n");
     }
     output_local ("struct cob_frame\t*frame_ptr;\n");
     if (cb_flag_stack_on_heap || prog->flag_recursive) {
         output_local ("struct cob_frame\t*frame_stack;\n\n");
     } else {
         output_local ("struct cob_frame\tframe_stack[%d];\n\n",
                   cb_stack_size);
     }
 
     if (gen_dynamic) {
         output_local ("\n/* Dynamic field FUNCTION-ID pointers */\n");
         for (inc = 0; inc < gen_dynamic; inc++) {
             output_local ("cob_field\t*cob_dyn_%u = NULL;\n",
                       inc);
         }
     }
 
     if (local_base_cache) {
         output_local ("\n/* Data storage */\n");
         local_base_cache = list_cache_sort (local_base_cache,
                             &base_cache_cmp);
         for (blp = local_base_cache; blp; blp = blp->next) {
             if (blp->f->special_index > 1) {
                 output_local ("int              %s%d;",
                         CB_PREFIX_BASE, blp->f->id);
             } else if (blp->f->special_index) {
                 output_local ("static int       %s%d;",
                         CB_PREFIX_BASE, blp->f->id);
             } else {
                 output_local ("static cob_u8_t  %s%d[%d]%s;",
                         CB_PREFIX_BASE, blp->f->id,
                         blp->f->memory_size, COB_ALIGN);
             }
             output_local ("\t/* %s */\n", blp->f->name);
         }
         output_local ("\n/* End of data storage */\n\n");
     }
 
     if (local_field_cache) {
         /* Switch to local storage file */
         output_target = current_prog->local_include->local_fp;
         output_local ("\n/* Fields */\n");
         local_field_cache = list_cache_sort (local_field_cache,
                              &field_cache_cmp);
         for (k = local_field_cache; k; k = k->next) {
             output ("static cob_field %s%d\t= ", CB_PREFIX_FIELD,
                 k->f->id);
             if (!k->f->flag_local) {
                 output_field (k->x);
             } else {
                 output ("{");
                 output_size (k->x);
                 output (", NULL, ");
                 output_attr (k->x);
                 output ("}");
             }
             if (k->f->flag_filler) {
                 output (";\t/* Implicit FILLER */\n");
             } else {
                 output (";\t/* %s */\n", k->f->name);
             }
         }
         output_local ("\n/* End of fields */\n\n");
         /* Switch to main storage file */
         output_target = cb_storage_file;
     }
 
     /* Skip to next nested program */
 
     if (prog->next_program) {
         codegen (prog->next_program, 1);
         return;
     }
 
     /* Finalize the main include file */
 
 #if 0   /* RXWRXW - GLOBPTR */
     output_storage ("\n/* Global variable pointer */\n");
     output_storage ("static cob_global\t\t*cob_glob_ptr = NULL;\n");
 #endif
 
     if (!cobc_flag_main && non_nested_count > 1) {
         output_storage ("\n/* Module reference count */\n");
         output_storage ("static unsigned int\t\tcob_reference_count = 0;\n");
     }
 
     output_storage ("\n/* Module path */\n");
     output_storage ("static const char\t\t*cob_module_path = NULL;\n");
 
     if (globext_cache) {
         output_storage ("\n/* GLOBAL EXTERNAL pointers */\n");
         globext_cache = list_cache_sort (globext_cache, &base_cache_cmp);
         for (blp = globext_cache; blp; blp = blp->next) {
             output_storage ("static unsigned char\t\t*%s%d = NULL;",
                     CB_PREFIX_BASE, blp->f->id);
             output_storage ("\t/* %s */\n", blp->f->name);
         }
     }
 
     if (base_cache) {
         output_storage ("\n/* Data storage */\n");
         base_cache = list_cache_sort (base_cache, &base_cache_cmp);
         prevprog = NULL;
         for (blp = base_cache; blp; blp = blp->next) {
             if (blp->curr_prog != prevprog) {
                 prevprog = blp->curr_prog;
                 output_storage ("\n/* PROGRAM-ID : %s */\n",
                         prevprog);
             }
             if (blp->f->special_index) {
                 output_storage ("static int       %s%d;",
                         CB_PREFIX_BASE, blp->f->id);
             } else {
                 output_storage ("static cob_u8_t  %s%d[%d]%s;",
                         CB_PREFIX_BASE, blp->f->id,
                         blp->f->memory_size, COB_ALIGN);
             }
             output_storage ("\t/* %s */\n", blp->f->name);
         }
         output_storage ("\n/* End of data storage */\n\n");
     }
 
     /* Attributes */
     if (attr_cache || gen_figurative) {
         output_storage ("\n/* Attributes */\n\n");
         attr_cache = attr_list_reverse (attr_cache);
         for (j = attr_cache; j; j = j->next) {
             output_storage ("static const cob_field_attr %s%d =\t",
                     CB_PREFIX_ATTR, j->id);
             output_storage ("{0x%02x, %3u, %3d, 0x%04x, ",
                     j->type, j->digits,
                     j->scale, j->flags);
             if (j->pic) {
                 output_storage ("\"");
                 for (s = j->pic; *s; s += 5) {
                     output_storage ("%c\\%03o\\%03o\\%03o\\%03o",
                         s[0], s[1], s[2], s[3], s[4]);
                 }
                 output_storage ("\"");
             } else {
                 output_storage ("NULL");
             }
             output_storage ("};\n");
         }
         if (gen_figurative) {
             output_storage ("\nstatic const cob_field_attr cob_all_attr = ");
             output_storage ("{0x%02x, 0, 0, 0, NULL};\n",
                     COB_TYPE_ALPHANUMERIC_ALL);
         }
         output_storage ("\n");
     }
 
     if (field_cache) {
         output_storage ("\n/* Fields */\n");
         field_cache = list_cache_sort (field_cache, &field_cache_cmp);
         prevprog = NULL;
         for (k = field_cache; k; k = k->next) {
             if (k->curr_prog != prevprog) {
                 prevprog = k->curr_prog;
                 output_storage ("\n/* PROGRAM-ID : %s */\n",
                         prevprog);
             }
             output ("static cob_field %s%d\t= ", CB_PREFIX_FIELD,
                 k->f->id);
             if (!k->f->flag_local) {
                 output_field (k->x);
             } else {
                 output ("{");
                 output_size (k->x);
                 output (", NULL, ");
                 output_attr (k->x);
                 output ("}");
             }
             if (k->f->flag_filler) {
                 output (";\t/* Implicit FILLER */\n");
             } else {
                 output (";\t/* %s */\n", k->f->name);
             }
         }
         output_storage ("\n/* End of fields */\n\n");
     }
 
     /* Literals, figuratives, constants */
     if (literal_cache || gen_figurative) {
         output_storage ("\n/* Constants */\n");
         literal_cache = literal_list_reverse (literal_cache);
         for (m = literal_cache; m; m = m->next) {
 #if 0   /* RXWRXW - Const */
             output ("static const cob_fld_union %s%d\t= ",
                 CB_PREFIX_CONST, m->id);
             output ("{");
             output_size (m->x);
             output (", ");
             lp = CB_LITERAL (m->x);
             if (CB_TREE_CLASS (m->x) == CB_CLASS_NUMERIC) {
                 output ("\"%s%s\"", (char *)lp->data,
                     (lp->sign < 0) ? "-" : (lp->sign > 0) ? "+" : "");
             } else {
                 output_string (lp->data, (int) lp->size, lp->llit);
             }
             output (", ");
             output_attr (m->x);
             output ("}");
 #else
             output ("static const cob_field %s%d\t= ",
                 CB_PREFIX_CONST, m->id);
             output_field (m->x);
 #endif
             output (";\n");
         }
         if (gen_figurative) {
             output ("\n");
             if (gen_figurative & CB_NEED_LOW) {
                 output ("static cob_field cob_all_low\t= ");
                 output ("{1, ");
                 output ("(cob_u8_ptr)\"\\0\", ");
                 output ("&cob_all_attr};\n");
             }
             if (gen_figurative & CB_NEED_HIGH) {
                 output ("static cob_field cob_all_high\t= ");
                 output ("{1, ");
                 output ("(cob_u8_ptr)\"\\xff\", ");
                 output ("&cob_all_attr};\n");
             }
             if (gen_figurative & CB_NEED_QUOTE) {
                 output ("static cob_field cob_all_quote\t= ");
                 output ("{1, ");
                 if (cb_flag_apostrophe) {
                     output ("(cob_u8_ptr)\"'\", ");
                 } else {
                     output ("(cob_u8_ptr)\"\\\"\", ");
                 }
                 output ("&cob_all_attr};\n");
             }
             if (gen_figurative & CB_NEED_SPACE) {
                 output ("static cob_field cob_all_space\t= ");
                 output ("{1, ");
                 output ("(cob_u8_ptr)\" \", ");
                 output ("&cob_all_attr};\n");
             }
             if (gen_figurative & CB_NEED_ZERO) {
                 output ("static cob_field cob_all_zero\t= ");
                 output ("{1, ");
                 output ("(cob_u8_ptr)\"0\", ");
                 output ("&cob_all_attr};\n");
             }
         }
         output ("\n");
     }
 
     /* Collating tables */
     if (gen_alt_ebcdic) {
         output_storage ("\n/* ASCII to EBCDIC translate table (restricted) */\n");
         output ("static const unsigned char\tcob_a2e[256] = {\n");
         /* Restricted table */
         output ("\t0x00, 0x01, 0x02, 0x03, 0x1D, 0x19, 0x1A, 0x1B,\n");
         output ("\t0x0F, 0x04, 0x16, 0x06, 0x07, 0x08, 0x09, 0x0A,\n");
         output ("\t0x0B, 0x0C, 0x0D, 0x0E, 0x1E, 0x1F, 0x1C, 0x17,\n");
         output ("\t0x10, 0x11, 0x20, 0x18, 0x12, 0x13, 0x14, 0x15,\n");
         output ("\t0x21, 0x27, 0x3A, 0x36, 0x28, 0x30, 0x26, 0x38,\n");
         output ("\t0x24, 0x2A, 0x29, 0x25, 0x2F, 0x2C, 0x22, 0x2D,\n");
         output ("\t0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A,\n");
         output ("\t0x7B, 0x7C, 0x35, 0x2B, 0x23, 0x39, 0x32, 0x33,\n");
         output ("\t0x37, 0x57, 0x58, 0x59, 0x5A, 0x5B, 0x5C, 0x5D,\n");
         output ("\t0x5E, 0x5F, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66,\n");
         output ("\t0x67, 0x68, 0x69, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F,\n");
         output ("\t0x70, 0x71, 0x72, 0x7D, 0x6A, 0x7E, 0x7F, 0x31,\n");
         output ("\t0x34, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F, 0x40, 0x41,\n");
         output ("\t0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,\n");
         output ("\t0x4A, 0x4B, 0x4C, 0x4E, 0x4F, 0x50, 0x51, 0x52,\n");
         output ("\t0x53, 0x54, 0x55, 0x56, 0x2E, 0x60, 0x4D, 0x05,\n");
         output ("\t0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
         output ("\t0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x8D, 0x8E, 0x8F,\n");
         output ("\t0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97,\n");
         output ("\t0x98, 0x99, 0x9A, 0x9B, 0x9C, 0x9D, 0x9E, 0x9F,\n");
         output ("\t0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7,\n");
         output ("\t0xA8, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF,\n");
         output ("\t0xB0, 0xB1, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7,\n");
         output ("\t0xB8, 0xB9, 0xBA, 0xBB, 0xBC, 0xBD, 0xBE, 0xBF,\n");
         output ("\t0xC0, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
         output ("\t0xC8, 0xC9, 0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF,\n");
         output ("\t0xD0, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7,\n");
         output ("\t0xD8, 0xD9, 0xDA, 0xDB, 0xDC, 0xDD, 0xDE, 0xDF,\n");
         output ("\t0xE0, 0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7,\n");
         output ("\t0xE8, 0xE9, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF,\n");
         output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
         output ("\t0xF8, 0xF9, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE, 0xFF\n");
         output ("};\n");
         output_storage ("\n");
     }
     if (gen_full_ebcdic) {
         output_storage ("\n/* ASCII to EBCDIC table */\n");
         output ("static const unsigned char\tcob_ascii_ebcdic[256] = {\n");
         output ("\t0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F,\n");
         output ("\t0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
         output ("\t0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26,\n");
         output ("\t0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,\n");
         output ("\t0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D,\n");
         output ("\t0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,\n");
         output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
         output ("\t0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,\n");
         output ("\t0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
         output ("\t0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,\n");
         output ("\t0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6,\n");
         output ("\t0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,\n");
         output ("\t0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
         output ("\t0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,\n");
         output ("\t0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6,\n");
         output ("\t0xA7, 0xA8, 0xA9, 0xC0, 0x6A, 0xD0, 0xA1, 0x07,\n");
         output ("\t0x68, 0xDC, 0x51, 0x42, 0x43, 0x44, 0x47, 0x48,\n");
         output ("\t0x52, 0x53, 0x54, 0x57, 0x56, 0x58, 0x63, 0x67,\n");
         output ("\t0x71, 0x9C, 0x9E, 0xCB, 0xCC, 0xCD, 0xDB, 0xDD,\n");
         output ("\t0xDF, 0xEC, 0xFC, 0xB0, 0xB1, 0xB2, 0x3E, 0xB4,\n");
         output ("\t0x45, 0x55, 0xCE, 0xDE, 0x49, 0x69, 0x9A, 0x9B,\n");
         output ("\t0xAB, 0x9F, 0xBA, 0xB8, 0xB7, 0xAA, 0x8A, 0x8B,\n");
         output ("\t0xB6, 0xB5, 0x62, 0x4F, 0x64, 0x65, 0x66, 0x20,\n");
         output ("\t0x21, 0x22, 0x70, 0x23, 0x72, 0x73, 0x74, 0xBE,\n");
         output ("\t0x76, 0x77, 0x78, 0x80, 0x24, 0x15, 0x8C, 0x8D,\n");
         output ("\t0x8E, 0x41, 0x06, 0x17, 0x28, 0x29, 0x9D, 0x2A,\n");
         output ("\t0x2B, 0x2C, 0x09, 0x0A, 0xAC, 0x4A, 0xAE, 0xAF,\n");
         output ("\t0x1B, 0x30, 0x31, 0xFA, 0x1A, 0x33, 0x34, 0x35,\n");
         output ("\t0x36, 0x59, 0x08, 0x38, 0xBC, 0x39, 0xA0, 0xBF,\n");
         output ("\t0xCA, 0x3A, 0xFE, 0x3B, 0x04, 0xCF, 0xDA, 0x14,\n");
         output ("\t0xE1, 0x8F, 0x46, 0x75, 0xFD, 0xEB, 0xEE, 0xED,\n");
         output ("\t0x90, 0xEF, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF\n");
         output ("};\n");
         if (gen_full_ebcdic > 1) {
             i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
             output
                 ("static cob_field f_ascii_ebcdic = { 256, (cob_u8_ptr)cob_ascii_ebcdic, &%s%d };\n",
                  CB_PREFIX_ATTR, i);
         }
         output_storage ("\n");
     }
     if (gen_ebcdic_ascii) {
         output_storage ("\n/* EBCDIC to ASCII table */\n");
         output ("static const unsigned char\tcob_ebcdic_ascii[256] = {\n");
         output ("\t0x00, 0x01, 0x02, 0x03, 0xEC, 0x09, 0xCA, 0x7F,\n");
         output ("\t0xE2, 0xD2, 0xD3, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
         output ("\t0x10, 0x11, 0x12, 0x13, 0xEF, 0xC5, 0x08, 0xCB,\n");
         output ("\t0x18, 0x19, 0xDC, 0xD8, 0x1C, 0x1D, 0x1E, 0x1F,\n");
         output ("\t0xB7, 0xB8, 0xB9, 0xBB, 0xC4, 0x0A, 0x17, 0x1B,\n");
         output ("\t0xCC, 0xCD, 0xCF, 0xD0, 0xD1, 0x05, 0x06, 0x07,\n");
         output ("\t0xD9, 0xDA, 0x16, 0xDD, 0xDE, 0xDF, 0xE0, 0x04,\n");
         output ("\t0xE3, 0xE5, 0xE9, 0xEB, 0x14, 0x15, 0x9E, 0x1A,\n");
         output ("\t0x20, 0xC9, 0x83, 0x84, 0x85, 0xA0, 0xF2, 0x86,\n");
         output ("\t0x87, 0xA4, 0xD5, 0x2E, 0x3C, 0x28, 0x2B, 0xB3,\n");
         output ("\t0x26, 0x82, 0x88, 0x89, 0x8A, 0xA1, 0x8C, 0x8B,\n");
         output ("\t0x8D, 0xE1, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x5E,\n");
         output ("\t0x2D, 0x2F, 0xB2, 0x8E, 0xB4, 0xB5, 0xB6, 0x8F,\n");
         output ("\t0x80, 0xA5, 0x7C, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,\n");
         output ("\t0xBA, 0x90, 0xBC, 0xBD, 0xBE, 0xF3, 0xC0, 0xC1,\n");
         output ("\t0xC2, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,\n");
         output ("\t0xC3, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,\n");
         output ("\t0x68, 0x69, 0xAE, 0xAF, 0xC6, 0xC7, 0xC8, 0xF1,\n");
         output ("\t0xF8, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70,\n");
         output ("\t0x71, 0x72, 0xA6, 0xA7, 0x91, 0xCE, 0x92, 0xA9,\n");
         output ("\t0xE6, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78,\n");
         output ("\t0x79, 0x7A, 0xAD, 0xA8, 0xD4, 0x5B, 0xD6, 0xD7,\n");
         output ("\t0x9B, 0x9C, 0x9D, 0xFA, 0x9F, 0xB1, 0xB0, 0xAC,\n");
         output ("\t0xAB, 0xFC, 0xAA, 0xFE, 0xE4, 0x5D, 0xBF, 0xE7,\n");
         output ("\t0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47,\n");
         output ("\t0x48, 0x49, 0xE8, 0x93, 0x94, 0x95, 0xA2, 0xED,\n");
         output ("\t0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50,\n");
         output ("\t0x51, 0x52, 0xEE, 0x96, 0x81, 0x97, 0xA3, 0x98,\n");
         output ("\t0x5C, 0xF0, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,\n");
         output ("\t0x59, 0x5A, 0xFD, 0xF5, 0x99, 0xF7, 0xF6, 0xF9,\n");
         output ("\t0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,\n");
         output ("\t0x38, 0x39, 0xDB, 0xFB, 0x9A, 0xF4, 0xEA, 0xFF\n");
         output ("};\n");
         if (gen_ebcdic_ascii > 1) {
             i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
             output
                 ("static cob_field f_ebcdic_ascii = { 256, (cob_u8_ptr)cob_ebcdic_ascii, &%s%d };\n",
                  CB_PREFIX_ATTR, i);
         }
         output_storage ("\n");
     }
     if (gen_native) {
         output_storage ("\n/* NATIVE table */\n");
         output ("static const unsigned char\tcob_native[256] = {\n");
         output ("\t0, 1, 2, 3, 4, 5, 6, 7,\n");
         output ("\t8, 9, 10, 11, 12, 13, 14, 15,\n");
         output ("\t16, 17, 18, 19, 20, 21, 22, 23,\n");
         output ("\t24, 25, 26, 27, 28, 29, 30, 31,\n");
         output ("\t32, 33, 34, 35, 36, 37, 38, 39,\n");
         output ("\t40, 41, 42, 43, 44, 45, 46, 47,\n");
         output ("\t48, 49, 50, 51, 52, 53, 54, 55,\n");
         output ("\t56, 57, 58, 59, 60, 61, 62, 63,\n");
         output ("\t64, 65, 66, 67, 68, 69, 70, 71,\n");
         output ("\t72, 73, 74, 75, 76, 77, 78, 79,\n");
         output ("\t80, 81, 82, 83, 84, 85, 86, 87,\n");
         output ("\t88, 89, 90, 91, 92, 93, 94, 95,\n");
         output ("\t96, 97, 98, 99, 100, 101, 102, 103,\n");
         output ("\t104, 105, 106, 107, 108, 109, 110, 111,\n");
         output ("\t112, 113, 114, 115, 116, 117, 118, 119,\n");
         output ("\t120, 121, 122, 123, 124, 125, 126, 127,\n");
         output ("\t128, 129, 130, 131, 132, 133, 134, 135,\n");
         output ("\t136, 137, 138, 139, 140, 141, 142, 143,\n");
         output ("\t144, 145, 146, 147, 148, 149, 150, 151,\n");
         output ("\t152, 153, 154, 155, 156, 157, 158, 159,\n");
         output ("\t160, 161, 162, 163, 164, 165, 166, 167,\n");
         output ("\t168, 169, 170, 171, 172, 173, 174, 175,\n");
         output ("\t176, 177, 178, 179, 180, 181, 182, 183,\n");
         output ("\t184, 185, 186, 187, 188, 189, 190, 191,\n");
         output ("\t192, 193, 194, 195, 196, 197, 198, 199,\n");
         output ("\t200, 201, 202, 203, 204, 205, 206, 207,\n");
         output ("\t208, 209, 210, 211, 212, 213, 214, 215,\n");
         output ("\t216, 217, 218, 219, 220, 221, 222, 223,\n");
         output ("\t224, 225, 226, 227, 228, 229, 230, 231,\n");
         output ("\t232, 233, 234, 235, 236, 237, 238, 239,\n");
         output ("\t240, 241, 242, 243, 244, 245, 246, 247,\n");
         output ("\t248, 249, 250, 251, 252, 253, 254, 255\n");
         output ("};\n");
         if (gen_native > 1) {
             i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
             output
                 ("static cob_field f_native = { 256, (cob_u8_ptr)cob_native, &%s%d };\n",
                  CB_PREFIX_ATTR, i);
         }
         output_storage ("\n");
     }
 
     /* Strings */
     if (string_cache) {
         output_storage ("\n/* Strings */\n");
         string_cache = string_list_reverse (string_cache);
         for (stp = string_cache; stp; stp = stp->next) {
             output ("static const char %s%d[]\t= \"%s\";\n",
                 CB_PREFIX_STRING, stp->id, stp->text);
         }
         output_storage ("\n");
     }
 
     /* Optimizer output */
     for (optidx = COB_OPTIM_MIN; optidx < COB_OPTIM_MAX; ++optidx) {
         if (optimize_defs[optidx]) {
             cob_gen_optim (optidx);
             output_storage ("\n");
         }
     }
 }

void configuration_error	(	const char *	,
		const int	,
		const char *	,
			...
	)

References _, and conf_error_displayed.

Referenced by cb_config_entry(), cb_load_conf(), invalid_value(), process_command_line(), and unsupported_value().

 {
     va_list args;
 
     if (!conf_error_displayed) {
         conf_error_displayed = 1;
         fputs (_("Configuration Error"), stderr);
         putc ('\n', stderr);
     }
 
     if (fname) {
         if (line) {
             fprintf (stderr, "%s:%d: ", fname, line);
         } else {
             fprintf (stderr, "%s: ", fname);
         }
     } else {
         fputs ("cb_conf: ", stderr);
     }
 
     va_start(args, fmt);
     vfprintf (stderr, fmt, args);
     va_end(args);
 
     putc ('\n', stderr);
     fflush (stderr);
 }

static void count_lines ( const char * )

static

static const char* dcnpgettext_expr	(	const char *	domain,
		const char *	msgctxt,
		const char *	msgid,
		const char *	msgid_plural,
		unsigned long int	n,
		int	category
	)

static

                            {
         integer_is_label = 1;
         last_token_is_dot = 0;
     } else {
         integer_is_label = 0;
     }
 %}
 
 
 <*>^[ ]?"#DEFLIT".*\n {
     scan_define_options (yytext);
 }
 
 <*>^[ ]?"#OPTION".*\n {
     scan_options (yytext, 1);
 }
 
 <*>^[ ]?"#DEFOFF".*\n {
     scan_options (yytext, 2);
 }
 
 <*>^[ ]?"#DEFENV".*\n {
     scan_options (yytext, 3);
 }
 
 <*>\n {
     cb_source_line++;
 }

static const char* dcpgettext_expr	(	const char *	domain,
		const char *	msgctxt,
		const char *	msgid,
		int	category
	)

static

231 {

void finalize_file	(	struct cb_file *	,
		struct cb_field *
	)

 {
     struct cb_field     *p;
     struct cb_field     *v;
     struct cb_alt_key   *cbak;
     cb_tree         l;
     cb_tree         x;
 
     /* stdin/stderr and LINE ADVANCING are L/S */
     if (f->special || f->flag_line_adv) {
         f->organization = COB_ORG_LINE_SEQUENTIAL;
     }
     if (f->flag_fileid && !f->assign) {
         f->assign = cb_build_alphanumeric_literal (f->name,
                                strlen (f->name));
     }
 
     if (f->key && f->organization == COB_ORG_INDEXED &&
         (l = cb_ref (f->key)) != cb_error_node) {
         v = cb_field_founder (CB_FIELD_PTR (l));
         for (p = records; p; p = p->sister) {
             if (p == v) {
                 break;
             }
         }
         if (!p) {
             cb_error (_("Invalid KEY item '%s'"),
                   CB_FIELD_PTR (l)->name);
         }
     }
     if (f->alt_key_list) {
         for (cbak = f->alt_key_list; cbak; cbak = cbak->next) {
             l = cb_ref (cbak->key);
             if (l == cb_error_node) {
                 continue;
             }
             v = cb_field_founder (CB_FIELD_PTR (l));
             for (p = records; p; p = p->sister) {
                 if (p == v) {
                     break;
                 }
             }
             if (!p) {
                 cb_error (_("Invalid KEY item '%s'"),
                         CB_FIELD_PTR (l)->name);
             }
         }
     }
 
     /* Check the record size if it is limited */
     for (p = records; p; p = p->sister) {
         if (f->record_min > 0) {
             if (p->size < f->record_min) {
                 cb_error (_("Record size too small '%s'"),
                       p->name);
             }
         }
         if (f->record_max > 0) {
             if (p->size > f->record_max) {
                 cb_error (_("Record size too large '%s' (%d)"),
                          p->name, p->size);
             }
         }
     }
 
     /* Compute the record size */
     if (f->record_min == 0) {
         if (records) {
             f->record_min = records->size;
         } else {
             f->record_min = 0;
         }
     }
     for (p = records; p; p = p->sister) {
         v = cb_field_variable_size (p);
         if (v && v->offset + v->size * v->occurs_min < f->record_min) {
             f->record_min = v->offset + v->size * v->occurs_min;
         }
         if (p->size < f->record_min) {
             f->record_min = p->size;
         }
         if (p->size > f->record_max) {
             f->record_max = p->size;
         }
     }
 
     if (f->record_max > MAX_FD_RECORD) {
         cb_error (_("Record size exceeds maximum allowed (%d) - File '%s'"),
               MAX_FD_RECORD, f->name);
     }
 
     if (f->same_clause) {
         for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
             if (CB_FILE (CB_VALUE (l))->same_clause == f->same_clause) {
                 if (CB_FILE (CB_VALUE (l))->flag_finalized) {
                     if (f->record_max > CB_FILE (CB_VALUE (l))->record->memory_size) {
                         CB_FILE (CB_VALUE (l))->record->memory_size =
                             f->record_max;
                     }
                     f->record = CB_FILE (CB_VALUE (l))->record;
                     for (p = records; p; p = p->sister) {
                         p->file = f;
                         p->redefines = f->record;
                     }
                     for (p = f->record->sister; p; p = p->sister) {
                         if (!p->sister) {
                             p->sister = records;
                             break;
                         }
                     }
                     f->flag_finalized = 1;
                     return;
                 }
             }
         }
     }
     /* Create record */
     if (f->record_max == 0) {
         f->record_max = 32;
         f->record_min = 32;
     }
     if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
         f->record_min = 0;
     }
     if (!scratch_buff) {
         scratch_buff = cobc_main_malloc ((size_t)COB_MINI_BUFF);
     }
     snprintf (scratch_buff, (size_t)COB_MINI_MAX, "%s Record", f->name);
     f->record = CB_FIELD (cb_build_implicit_field (cb_build_reference (scratch_buff),
                 f->record_max));
     f->record->sister = records;
     f->record->count++;
     if (f->flag_external) {
         current_program->flag_has_external = 1;
         f->record->flag_external = 1;
     }
 
     for (p = records; p; p = p->sister) {
         p->file = f;
         p->redefines = f->record;
 #if 1   /* RXWRXW - Global/External */
         if (p->flag_is_global) {
             f->record->flag_is_global = 1;
         }
 #endif
     }
     f->flag_finalized = 1;
     if (f->linage) {
         snprintf (scratch_buff, (size_t)COB_MINI_MAX,
               "LINAGE-COUNTER %s", f->name);
         x = cb_build_field (cb_build_reference (scratch_buff));
         CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
         CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
         CB_FIELD (x)->count++;
         cb_validate_field (CB_FIELD (x));
         f->linage_ctr = cb_build_field_reference (CB_FIELD (x), NULL);
         CB_FIELD_ADD (current_program->working_storage, CB_FIELD (x));
     }
 }

void group_error	(	cb_tree	,
		const char *
	)

 {
     cb_error_x (x, _("Group item '%s' cannot have %s clause"),
             cb_name (x), clause);
 }

void level_except_error	(	cb_tree	,
		const char *
	)

 {
     const char      *s;
     const struct cb_field   *f;
 
     s = cb_name (x);
     f = CB_FIELD_PTR (x);
     if (f->flag_item_78) {
         cb_error_x (x, _("Constant item '%s' can only have a %s clause"),
                 s, clause);
     } else {
         cb_error_x (x, _("Level %02d item '%s' can only have a %s clause"),
                 f->level,
                 s, clause);
     }
 }

void level_redundant_error	(	cb_tree	,
		const char *
	)

 {
     const char      *s;
     const struct cb_field   *f;
 
     s = cb_name (x);
     f = CB_FIELD_PTR (x);
     if (f->flag_item_78) {
         cb_error_x (x, _("Constant item '%s' cannot have a %s clause"),
                 s, clause);
     } else {
         cb_error_x (x, _("Level %02d item '%s' cannot have a %s clause"),
                 f->level,
                 s, clause);
     }
 }

void level_require_error	(	cb_tree	,
		const char *
	)

 {
     const char      *s;
     const struct cb_field   *f;
 
     s = cb_name (x);
     f = CB_FIELD_PTR (x);
     if (f->flag_item_78) {
         cb_error_x (x, _("Constant item '%s' requires a %s clause"),
                 s, clause);
     } else {
         cb_error_x (x, _("Level %02d item '%s' requires a %s clause"),
                 f->level,
                 s, clause);
     }
 }

struct cb_intrinsic_table* lookup_intrinsic	(	const char *	,
		const int	,
		const int
	)

read

 {
     struct cb_intrinsic_table   *cbp;
     struct noreserve        *nr;
 
     if (unlikely(cobc_nores_base && checkres)) {
         for (nr = cobc_nores_base; nr; nr = nr->next) {
             if (strcasecmp (name, nr->noresword) == 0) {
                 return NULL;
             }
         }
     }
     cbp = bsearch (name, function_list, NUM_INTRINSICS,
             sizeof (struct cb_intrinsic_table), intrinsic_comp);
     if (cbp && (checkimpl || cbp->implemented)) {
         return cbp;
     }
     return NULL;
 }

struct cobc_reserved* lookup_reserved_word ( const char * )

read

 {
     struct cobc_reserved    *p;
     struct noreserve    *nr;
 
     p = bsearch (name, reserved_words, NUM_RESERVED_WORDS,
              sizeof (struct cobc_reserved), reserve_comp);
     if (!p) {
         return NULL;
     }
 
     /* Allow obsolete/unimplemented 85 keywords as user names */
     if (!p->token && !cb_cobol85_reserved) {
         return NULL;
     }
 
     /* Check if the configuration has unreserved the word */
     for (nr = cobc_nores_base; nr; nr = nr->next) {
         if (strcasecmp (name, nr->noresword) == 0) {
             return NULL;
         }
     }
 
     /* Check word is implemented */
     if (unlikely(p->token <= 0)) {
         /* Not implemented - If context sensitive, no error */
         if (!p->context_sens) {
             cb_error (_("'%s' reserved word, but not supported"), name);
         }
         return NULL;
     }
 
     /* Special actions / Context sensitive */
     if (p->context_set) {
         if (unlikely(p->context_test)) {
             /* Dependent words */
             if (!(cobc_cs_check & p->context_test)) {
                 return p;
             }
         }
         cobc_cs_check |= p->context_set;
         return p;
     }
 
     if (p->context_test) {
 #if 0   /* RXWRXW - CS check */
         if (!(cobc_cs_check & p->context_test)) {
 #endif
         if ((cobc_cs_check & p->context_test) != p->context_test) {
             return NULL;
         }
         if (!cobc_in_procedure) {
             cobc_cs_check = 0;
         }
         return p;
     }
 
     if (p->token == FUNCTION_ID) {
         cobc_cs_check = 0;
         cobc_force_literal = 1;
     } else if (p->token == INTRINSIC) {
         if (!cobc_in_repository) {
             return NULL;
         }
     } else if (p->token == PROGRAM_ID) {
         cobc_cs_check = CB_CS_PROGRAM_ID;
         cobc_force_literal = 1;
     } else if (p->token == REPOSITORY) {
         cobc_in_repository = 1;
     } 
 
     return p;
 }

cb_tree lookup_system_name ( const char * )

 {
     size_t  i;
 
     for (i = 0; i < SYSTEM_TAB_SIZE; ++i) {
         if (cob_strcasecmp (name, system_table[i].name) == 0) {
             return cb_build_system_name (system_table[i].category,
                               system_table[i].token);
         }
     }
     if (cb_flag_syntax_extension) {
         for (i = 0; i < EXT_SYSTEM_TAB_SIZE; ++i) {
             if (cob_strcasecmp (name, ext_system_table[i].name) == 0) {
                 return cb_build_system_name (ext_system_table[i].category,
                                   ext_system_table[i].token);
             }
         }
     }
     return NULL;
 }

static const char* npgettext_aux	(	const char *	domain,
		const char *	msg_ctxt_id,
		const char *	msgid,
		const char *	msgid_plural,
		unsigned long int	n,
		int	category
	)

static

231 {

static const char* pgettext_aux	(	const char *	domain,
		const char *	msg_ctxt_id,
		const char *	msgid,
		int	category
	)

static

                                               {
     ['-'] = 1,
     ['0'] = 1,
     ['1'] = 1,
     ['2'] = 1,

void plex_action_directive	(	const unsigned	int,
		const unsigned	int
	)

References _, cb_plex_error(), cb_source_line, plex_stack::cmd, COBC_ABORT, cobc_abort_pr(), plex_stack::cond, plex_stack::line, PLEX_ACT_ELIF, PLEX_ACT_ELSE, PLEX_ACT_END, PLEX_ACT_IF, PLEX_COND_DEPTH, plex_cond_stack, plex_nest_depth, and plex_stack::skip.

 {
     unsigned int    n;
 
     /* Action IF/ELSE/END-IF/ELIF */
     switch (cmdtype) {
     case PLEX_ACT_IF:
         /* Push stack - First occurrence is dummy */
         if (++plex_nest_depth >= PLEX_COND_DEPTH) {
             cobc_abort_pr (_("Directive nest depth exceeded - %d"),
                     PLEX_COND_DEPTH);
             COBC_ABORT ();
         }
         plex_cond_stack[plex_nest_depth].cmd = 1U;
         /* Intersection with previous - first is always 0 */
         n = plex_cond_stack[plex_nest_depth - 1].skip | !is_true;
         plex_cond_stack[plex_nest_depth].skip = n;
         plex_cond_stack[plex_nest_depth].cond = is_true;
         plex_cond_stack[plex_nest_depth].line = cb_source_line;
         plex_skip_input = n;
         return;
     case PLEX_ACT_ELSE:
         /* Must have an associated IF/ELIF */
         if (!plex_nest_depth ||
             plex_cond_stack[plex_nest_depth].cmd != 1) {
             cb_plex_error (newline_count,
                 _("ELSE directive without matching IF/ELIF"));
             return;
         }
         plex_cond_stack[plex_nest_depth].cmd = 2U;
         /* Reverse any IF/ELIF condition */
         n = plex_cond_stack[plex_nest_depth].cond;
         plex_cond_stack[plex_nest_depth].skip = n;
         plex_cond_stack[plex_nest_depth].line = cb_source_line;
         /* Intersection with previous */
         plex_skip_input = plex_cond_stack[plex_nest_depth - 1].skip | n;
         return;
     case PLEX_ACT_END:
         /* Must have an associated IF/ELIF/ELSE */
         if (!plex_nest_depth ||
             !plex_cond_stack[plex_nest_depth].cmd) {
             cb_plex_error (newline_count,
                 _("END-IF directive without matching IF/ELIF/ELSE"));
             return;
         }
         plex_cond_stack[plex_nest_depth].cmd = 0;
         plex_cond_stack[plex_nest_depth].skip = 0;
         plex_cond_stack[plex_nest_depth].cond = 0;
         plex_cond_stack[plex_nest_depth].line = 0;
         /* Pop stack - set skip to previous */
         plex_nest_depth--;
         plex_skip_input = plex_cond_stack[plex_nest_depth].skip;
         return;
     case PLEX_ACT_ELIF:
         /* Must have an associated IF/ELIF */
         if (!plex_nest_depth ||
             plex_cond_stack[plex_nest_depth].cmd != 1) {
             cb_plex_error (newline_count,
                 _("ELIF directive without matching IF/ELIF"));
             return;
         }
         plex_cond_stack[plex_nest_depth].line = cb_source_line;
         if (plex_cond_stack[plex_nest_depth].cond) {
             /* Previous IF or one of previous ELIF was true */
             /* Set to skip */
             n = 1U;
         } else if (is_true) {
             /* Condition is true */
             plex_cond_stack[plex_nest_depth].cond = 1U;
             n = 0;
         } else {
             /* Set to skip */
             n = 1U;
         }
         plex_cond_stack[plex_nest_depth].skip = n;
         /* Intersection with previous */
         plex_skip_input = plex_cond_stack[plex_nest_depth - 1].skip | n;
         return;
     default:
         cobc_abort_pr (_("Invalid internal case - %u"),
                 cmdtype);
         COBC_ABORT ();
     }
 }

void plex_call_destroy ( void )

References pplex_destroy().

Referenced by preprocess().

 {
     (void)pplex_destroy ();
 }

void plex_clear_all ( void )

References cobc_free(), and NULL.

Referenced by main().

 {
     if (plexbuff1) {
         cobc_free (plexbuff1);
         plexbuff1 = NULL;
     }
     if (plexbuff2) {
         cobc_free (plexbuff2);
         plexbuff2 = NULL;
     }
 }

void plex_clear_vars ( void )

References plex_cond_stack.

Referenced by preprocess().

 {
     /* Reset variables */
     plex_skip_input = 0;
     plex_nest_depth = 0;
     memset (plex_cond_stack, 0, sizeof(plex_cond_stack));
     requires_listing_line = 1;
     comment_allowed = 1;
 }

void pp_set_replace_list	(	struct cb_replace_list *	,
		const cob_u32_t
	)

References base_replace_list, cb_replace_list::last, cb_replace_list::next, NULL, and cb_replace_list::prev.

 {
     /* Handle REPLACE verb */
     if (!list) {
         /* REPLACE [LAST] OFF */
         if (!is_pushpop) {
             base_replace_list = NULL;
             return;
         }
         if (!base_replace_list) {
             return;
         }
         base_replace_list = base_replace_list->prev;
         return;
     }
     /* REPLACE [ALSO] ... */
     if (base_replace_list && is_pushpop) {
         list->last->next = base_replace_list;
         list->prev = base_replace_list;
     } else {
         list->prev = NULL;
     }
     base_replace_list = list;
 }

int ppcopy	(	const char *	,
		const char *	,
		struct cb_replace_list *
	)

References _, cb_error(), cb_extension_list, cb_include_list, COB_SMALL_MAX, cb_text_list::next, plexbuff1, ppopen(), R_OK, and cb_text_list::text.

 {
     struct cb_text_list *il;
     struct cb_text_list *el;
     const char      *s;
 
     /* Locate and open COPY file */
     if (lib) {
         snprintf (plexbuff1, (size_t)COB_SMALL_MAX, "%s/%s", lib, name);
         s = plexbuff1;
     } else {
         s = name;
     }
 
     /* Find the file */
     if (access (s, R_OK) == 0) {
         return ppopen (s, replace_list);
     }
 
     for (el = cb_extension_list; el; el = el->next) {
         snprintf (plexbuff2, (size_t)COB_SMALL_MAX, "%s%s", s, el->text);
         if (access (plexbuff2, R_OK) == 0) {
             return ppopen (plexbuff2, replace_list);
         }
     }
 
     if (*s != '/') {
         for (il = cb_include_list; il; il = il->next) {
             for (el = cb_extension_list; el; el = el->next) {
                 snprintf (plexbuff2, (size_t)COB_SMALL_MAX,
                       "%s/%s%s", il->text, name, el->text);
                 if (access (plexbuff2, R_OK) == 0) {
                     return ppopen (plexbuff2, replace_list);
                 }
             }
         }
     }
     cb_error ("%s: %s", name, _("No such file or directory"));
     return -1;
 }

int ppopen	(	const char *	,
		struct cb_replace_list *
	)

References _, copy_info::buffer, cb_error(), cb_source_file, cb_source_format, cb_source_line, cobc_malloc(), cobc_strdup(), copy_stack, current_replace_list, copy_info::dname, errorcount, copy_info::file, cb_replace_list::last, copy_info::line, cb_replace_list::next, copy_info::next, p, pp_create_buffer(), ppin, copy_info::quotation_mark, quotation_mark, copy_info::replacing, replacing_list, copy_info::source_format, switch_to_buffer(), YY_BUF_SIZE, and YY_CURRENT_BUFFER.

Referenced by ppcopy(), and preprocess().

 {
     struct copy_info    *p;
     char            *s;
     char            *dname;
 
 #ifdef  _WIN32
     unsigned char       bom[4];
 #endif
 
     if (ppin) {
         for (; newline_count > 0; newline_count--) {
             ungetc ('\n', ppin);
         }
     }
 
     /* Open copy/source file */
 #ifdef  __OS400__
     ppin = fopen (name, "r");
 #else
     ppin = fopen (name, "rb");
 #endif
     if (!ppin) {
         if (cb_source_file) {
             cb_error ("%s: %s", name,
                   _("No such file or directory"));
         } else {
             fflush (stderr);
             fprintf (stderr, "%s: %s", name,
                  _("No such file or directory"));
             fflush (stderr);
             errorcount++;
         }
         return -1;
     }
 #ifdef  _WIN32
     /* Check for BOM */
     if (fread (bom, 3, 1, ppin) == 1) {
         if (bom[0] != 0xEF || bom[1] != 0xBB || bom[2] != 0xBF) {
             rewind (ppin);
         }
     } else {
         rewind (ppin);
     }
 #endif
 
     /* Preserve the current buffer */
     p = cobc_malloc (sizeof (struct copy_info));
     p->file = cb_source_file;
     p->buffer = YY_CURRENT_BUFFER;
 
     /* Save variables */
     p->replacing = current_replace_list;
     p->line = cb_source_line;
     p->quotation_mark = quotation_mark;
     p->source_format = cb_source_format;
 
     p->next = copy_stack;
     copy_stack = p;
 
     /* Set replacing list */
     if (replacing_list) {
         if (current_replace_list) {
             replacing_list->last->next = current_replace_list;
             replacing_list->last = current_replace_list->last;
         }
         current_replace_list = replacing_list;
     }
 
     dname = cobc_strdup (name);
     p->dname = dname;
     for (s = dname; *s; ++s) {
         if (*s == '\\') {
             *s = '/';
         }
     }
 
     /* Switch to new buffer */
     switch_to_buffer (1, dname, pp_create_buffer (ppin, YY_BUF_SIZE));
     return 0;
 }

int ppparse ( void )

Referenced by preprocess().

void ppparse_clear_vars ( const struct cb_define_struct * )

References cb_define_struct::name, cb_define_struct::next, NULL, ppp_define_add(), and cb_define_struct::value.

Referenced by preprocess().

 {
     const struct cb_define_struct   *q;
 
     ppp_setvar_list = NULL;
     /* Set standard DEFINE's */
     if (cb_perform_osvs) {
         ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                           "PERFORM-TYPE",
                           "'OSVS'", 0);
     } else {
         ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                           "PERFORM-TYPE",
                           "'MF'", 0);
     }
     if (cb_ebcdic_sign) {
         ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                           "SIGN",
                           "'EBCDIC'", 0);
     } else {
         ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                           "SIGN",
                           "'ASCII'", 0);
     }
 #ifdef  WORDS_BIGENDIAN
     ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                       "ENDIAN",
                       "'BIG'", 0);
 #else
     ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                       "ENDIAN",
                       "'LITTLE'", 0);
 #endif
 #if ' ' == 0x20
     ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                       "CHARSET",
                       "'ASCII'", 0);
 #elif   ' ' == 0x40
     ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                       "CHARSET",
                       "'EBCDIC'", 0);
 #else
     ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                       "CHARSET",
                       "'UNKNOWN'", 0);
 #endif
     /* Set DEFINE's from '-D' option(s) */
     for (q = p; q; q = q->next) {
         ppp_setvar_list = ppp_define_add (ppp_setvar_list,
                           q->name,
                           q->value, 0);
     }
 }

void ppparse_error ( const char * )

References cb_plex_error().

 {
     cb_plex_error (newline_count, msg);
 }

COB_EXPIMP void print_info ( void )

                  {
     char    buff[16];
     char    *s;
 
     print_version ();
     putchar ('\n');
     puts (_("Build information"));
     var_print (_("Build environment"),  COB_BLD_BUILD, "", 0);
     var_print ("CC", COB_BLD_CC, "", 0);
     var_print ("CPPFLAGS", COB_BLD_CPPFLAGS, "", 0);
     var_print ("CFLAGS", COB_BLD_CFLAGS, "", 0);
     var_print ("LD", COB_BLD_LD, "", 0);
     var_print ("LDFLAGS", COB_BLD_LDFLAGS, "", 0);
     putchar ('\n');
     printf (_("C version %s%s"), OC_C_VERSION_PRF, OC_C_VERSION);
     putchar ('\n');
     puts (_("GNU Cobol information"));
 
 //  if ((s = getenv ("COB_LIBRARY_PATH")) != NULL) {
 //      var_print ("COB_LIBRARY_PATH",  s, "", 1);
 //  }
     var_print ("COB_MODULE_EXT", COB_MODULE_EXT, "", 0);
     var_print ("COB_OBJECT_EXT", COB_OBJECT_EXT, "", 0);
     var_print ("COB_EXEEXT", COB_EXEEXT, "", 0);
 
 #if defined(USE_LIBDL) || defined(_WIN32)
     var_print (_("Dynamic loading"),    _("System"), "", 0);
 #else
     var_print (_("Dynamic loading"),    _("Libtool"), "", 0);
 #endif
 
 #ifdef  COB_PARAM_CHECK
     var_print ("\"CBL_\" param check",  _("Enabled"), "", 0);
 #else
     var_print ("\"CBL_\" param check",  _("Disabled"), "", 0);
 #endif
 
     snprintf (buff, sizeof(buff), "%d", WITH_VARSEQ);
     var_print (_("Variable format"), buff, "", 0);
     if ((s = getenv ("COB_VARSEQ_FORMAT")) != NULL) {
         var_print ("COB_VARSEQ_FORMAT", s, "", 1);
     }
 
 #ifdef  COB_LI_IS_LL
     var_print ("BINARY-C-LONG", _("8 bytes"), "", 0);
 #else
     var_print ("BINARY-C-LONG", _("4 bytes"), "", 0);
 #endif
 
 #ifdef  WITH_SEQRA_EXTFH
     var_print (_("Sequential handler"), _("External"), "", 0);
 #else
     var_print (_("Sequential handler"), _("Internal"), "", 0);
 #endif
 #ifdef  WITH_INDEX_EXTFH
     var_print (_("ISAM handler"),       _("External"), "", 0);
 #endif
 #ifdef  WITH_DB
     var_print (_("ISAM handler"),       _("BDB"), "", 0);
 #endif
 #ifdef  WITH_CISAM
     var_print (_("ISAM handler"),       _("C-ISAM (Experimental)"), "", 0);
 #endif
 #ifdef  WITH_DISAM
     var_print (_("ISAM handler"),       _("D-ISAM (Experimental)"), "", 0);
 #endif
 #ifdef  WITH_VBISAM
     var_print (_("ISAM handler"),       _("VBISAM (Experimental)"), "", 0);
 #endif
 }

COB_EXPIMP void print_runtime_env ( void )

                         {
     char* no_default;
     char* not_set;
     char* intstring;
     char* intstring2;
 
     printf("GNU Cobol runtime environment\n\n");
     printf("All values were resolved from current environment. \n\n");
     /* Alles aus common.c --> cob_init und cob_init_... - einigerma�en sinnvoll sortiert (ggf. Zwischen�berschriften ...*/
 
     if(!cob_initialized) {
         cob_init(cob_argc, cob_argv);
     }
 
     no_default = (char*) _("No");
     not_set = (char*) _("not set");
     intstring = (char*) cob_fast_malloc(10);
     intstring2 = (char*) cob_fast_malloc(10);
 
     printf(_("Call environment\n"));
 
     var_print("COB_LIBRARY_PATH", runtimeptr->cob_library_path_env, not_set,
             2);
     var_print("resolve_path",
             cob_strjoin(runtimeptr->resolve_path, *(runtimeptr->resolve_size),
                     (char*) PATHSEPS), not_set, 3);
     var_print("COB_PRE_LOAD", runtimeptr->cob_preload_env, not_set, 2);
     var_print("base_preload_ptr",
             runtimeptr->cob_preload_resolved, not_set, 3);
     var_print("COB_LOAD_CASE", runtimeptr->name_convert_env, not_set, 2);
     var_print("name_convert",
             cob_int_to_string(*(runtimeptr->name_convert), intstring),
             no_default, 3);
     var_print("COB_PHYSICAL_CANCEL", runtimeptr->physical_cancel_env,
             not_set, 2);
     var_print("physical_cancel",
             cob_int_to_string(*(runtimeptr->physical_cancel), intstring),
             no_default, 3);
 
     printf(_("\n\nFile I/O\n"));
     var_print("COB_SYNC", runtimeptr->cob_do_sync_env, not_set, 2);
     var_print("cob_do_sync",
             cob_int_to_string(*(runtimeptr->cob_do_sync), intstring),
             no_default, 3);
     var_print("COB_LS_USES_CR", runtimeptr->cob_ls_uses_cr_env, not_set, 2);
     var_print("cob_ls_uses_cr",
             cob_int_to_string(*(runtimeptr->cob_ls_uses_cr), intstring),
             no_default, 3);
 
     var_print("COB_SORT_MEMORY", runtimeptr->cob_sort_memory_env, not_set,
             2);
     var_print("cob_sort_memory",
             cob_int_to_formatted_bytestring(*(runtimeptr->cob_sort_memory),
                     intstring),
             cob_int_to_formatted_bytestring(COB_SORT_MEMORY, intstring2), 3);
     var_print("COB_SORT_CHUNK", runtimeptr->cob_sort_chunk_env, not_set, 2);
     var_print("cob_sort_chunk",
             cob_int_to_formatted_bytestring(*(runtimeptr->cob_sort_chunk),
                     intstring),
             cob_int_to_formatted_bytestring(COB_SORT_CHUNK, intstring2), 3);
     var_print("COB_FILE_PATH", runtimeptr->cob_file_path_env, not_set, 2);
     var_print("cob_file_path", runtimeptr->cob_file_path, not_set, 3);
     var_print("COB_LS_NULLS", runtimeptr->cob_ls_nulls_env, not_set, 2);
     var_print("cob_ls_nulls",
             cob_int_to_string(*(runtimeptr->cob_ls_nulls), intstring),
             no_default, 3);
     var_print("COB_LS_FIXED", runtimeptr->cob_ls_fixed_env, not_set, 2);
     var_print("cob_ls_fixed",
             cob_int_to_string(*(runtimeptr->cob_ls_fixed), intstring),
             no_default, 3);
     var_print("COB_VARSEQ_FORMAT", runtimeptr->cob_varseq_type_env,
             _("0 (default), [2-byte record-length] [0000] [record-data]"), 2);
     var_print("cob_varseq_type",
             cob_int_to_string(*(runtimeptr->cob_varseq_type), intstring),
             _("0 (default), [2-byte record-length] [0000] [record-data]"), 3);
     var_print("COB_UNIX_LF", runtimeptr->cob_unix_lf_env, not_set,
             2);
     var_print("cob_unix_lf",
             cob_int_to_string(cobglobptr->cob_unix_lf, intstring),
             no_default, 3);
 
     if (runtimeptr->cob_local_edit) {
         printf(_("\n\nLocale Properties\n"));
         var_print("COB_LOCALE_NUMERIC_EDITED", runtimeptr->cob_local_edit_env,
                 not_set, 2);
         var_print("cob_local_edit",
                 cob_int_to_string(*(runtimeptr->cob_local_edit), intstring),
                 no_default, 3);
     }
 
     printf(_("\n\nScreen I/O\n"));
     var_print("COB_REDIRECT_DISPLAY",
             runtimeptr->cob_disp_to_stderr_env, not_set, 2);
     var_print("cob_disp_to_stderr",
             cob_int_to_string(cobglobptr->cob_disp_to_stderr,
                     intstring), no_default, 3);
     var_print("COB_BELL", runtimeptr->cob_beep_str_env, not_set, 2);
     var_print("cob_beep_value", cob_int_to_string(cobglobptr->cob_beep_value, intstring), (char*) "0", 3);
     var_print("COB_TIMEOUT_SCALE", runtimeptr->cob_timeout_scale_env,
             not_set, 2);
     var_print("cob_timeout_scale",
             cob_int_to_string(cobglobptr->cob_timeout_scale,
                     intstring), "1000", 3);
     var_print("COB_SCREEN_EXCEPTIONS",
             runtimeptr->cob_extended_status_env, not_set, 2);
     var_print("cob_extended_status",
             cob_int_to_string(cobglobptr->cob_extended_status,
                     intstring), no_default, 3);
     var_print("COB_SCREEN_ESC", runtimeptr->cob_use_esc_env,
             not_set, 2);
     var_print("cob_screen_esc",
             cob_int_to_string(cobglobptr->cob_use_esc, intstring),
             no_default, 3);
     var_print("COB_LEGACY", runtimeptr->cob_legacy_env,
                 not_set, 2);
     var_print("cob_legacy",
                 cob_int_to_string(*(runtimeptr->cob_legacy), intstring),
                 no_default, 3);
     
     printf(_("\n\nMiscellaneous\n"));
     var_print("COB_SET_TRACE", runtimeptr->cob_line_trace_env, not_set, 2);
     var_print("cob_line_trace", cob_int_to_string(cob_line_trace, intstring), no_default, 3);
     cob_check_trace_file();
     var_print("COB_TRACE_FILE", cob_trace_env, not_set, 2);
     if(cob_trace_file != stderr) {
         var_print("cob_trace_file", cob_trace_env, NULL, 3);
     }
     else {
         var_print("cob_trace_file", _("stderr (default)"), NULL, 3);
     }
     var_print("COB_DISABLE_WARNINGS",
             runtimeptr->cob_display_warn_env, not_set, 2);
     var_print("cob_display_warn",
             cob_int_to_string(cobglobptr->cob_display_warn,
                     intstring), no_default, 3);
     var_print("COB_ENV_MANGLE", runtimeptr->cob_env_mangle_env,
             not_set, 2);
     var_print("cob_env_mangle",
             cob_int_to_string(cobglobptr->cob_env_mangle, intstring),
             no_default, 3);
 }

COB_EXPIMP void print_version ( void )

                     {
     char* cobc_buffer;
     char month[32];
     int day, year;
 
     cobc_buffer = cob_fast_malloc((size_t) COB_MINI_MAX);
 
     /* Set up build time stamp */
     memset (month, 0, sizeof(month));
     day = 0;
     year = 0;
     sscanf (__DATE__, "%s %d %d", month, &day, &year);
 
     if (day && year) {
         snprintf (cobc_buffer, (size_t)COB_MINI_MAX,
               "%s %2.2d %4.4d %s", month, day, year, __TIME__);
     } else {
         snprintf (cobc_buffer, (size_t)COB_MINI_MAX,
               "%s %s", __DATE__, __TIME__);
     }
 
     printf ("libcob (%s) %s.%d\n",
         PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL);
     puts ("Copyright (C) 2001,2002,2003,2004,2005,2006,2007 Keisuke Nishida");
     puts ("Copyright (C) 2006-2012 Roger While");
     puts ("Copyright (C) 2009,2010,2012,2014 Simon Sobisch");
     puts (_("This is free software; see the source for copying conditions.  There is NO\n\
 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."));
     printf (_("Built     %s"), cobc_buffer);
     putchar ('\n');
     printf (_("Packaged  %s"), COB_TAR_DATE);
     putchar ('\n');
 
 }

static void read_literal ( const int )

static

void redefinition_error ( cb_tree )

 {
     struct cb_word  *w;
 
     w = CB_REFERENCE (x)->word;
     cb_error_x (x, _("Redefinition of '%s'"), w->name);
     if (w->items) {
         cb_error_x (CB_VALUE (w->items),
                 _("'%s' previously defined here"), w->name);
     }
 }

void redefinition_warning	(	cb_tree	,
		cb_tree
	)

 {
     struct cb_word  *w;
     cb_tree     z;
 
     w = CB_REFERENCE (x)->word;
     cb_warning_x (x, _("Redefinition of '%s'"), w->name);
     z = NULL;
     if (y) {
         z = y;
     } else if (w->items) {
         z = CB_VALUE (w->items);
     }
 
     if (z) {
         cb_warning_x (z, _("'%s' previously defined here"), w->name);
     }
 }

static void scan_define_options ( const char * )

static

static int scan_floating_numeric ( const char * )

static

static int scan_h	(	char *	,
		const int
	)

static

static int scan_numeric ( char * )

static

static void scan_options	(	const char *	,
		const unsigned	int
	)

static

static void scan_picture ( char * )

static

static int scan_x	(	char *	,
		const int
	)

static

static int scan_z	(	char *	,
		const int	,
		const cob_u32_t
	)

static

void undefined_error ( cb_tree )

 {
     struct cb_reference *r;
     cb_tree         c;
 
     if (!errnamebuff) {
         errnamebuff = cobc_main_malloc ((size_t)COB_NORMAL_BUFF);
     }
     r = CB_REFERENCE (x);
     snprintf (errnamebuff, (size_t)COB_NORMAL_MAX, "'%s'", CB_NAME (x));
     for (c = r->chain; c; c = CB_REFERENCE (c)->chain) {
         strcat (errnamebuff, " in '");
         strcat (errnamebuff, CB_NAME (c));
         strcat (errnamebuff, "'");
     }
     if (r->flag_optional) {
         cb_warning_x (x, _("%s is not defined"), errnamebuff);
     } else {
         cb_error_x (x, _("%s is not defined"), errnamebuff);
     }
 }

void validate_file	(	struct cb_file *	,
		cb_tree
	)

 {
     /* Check ASSIGN clause
         Currently break's GNU COBOL's extension for SORT FILEs having no need
         for an ASSIGN clause (tested in run_extensions "SORT ASSIGN ..."
         According to the Programmer's Guide for 1.1 the ASSIGN is totally
         ignored as the SORT is either done in memory (if there's enough space)
         or in a temporary disk file.
         For supporting this f->organization = COB_ORG_SORT is done when we
         see an SD in FILE SECTION for the file, while validate_file is called
         in INPUT-OUTPUT Section.
     */
     if (!f->assign && f->organization != COB_ORG_SORT && !f->flag_fileid) {
         file_error (name, "ASSIGN", CB_FILE_ERR_REQUIRED);
     }
     /* Check RECORD/RELATIVE KEY clause */
     switch (f->organization) {
     case COB_ORG_INDEXED:
         if (f->key == NULL) {
             file_error (name, "RECORD KEY", CB_FILE_ERR_REQUIRED);
         }
         break;
     case COB_ORG_RELATIVE:
         if (f->key == NULL && f->access_mode != COB_ACCESS_SEQUENTIAL) {
             file_error (name, "RELATIVE KEY", CB_FILE_ERR_REQUIRED);
         }
         if (f->alt_key_list) {
             file_error (name, "ALTERNATE", CB_FILE_ERR_INVALID_FT);
             f->alt_key_list = NULL;
         }
         break;
     default:
         if (f->key) {
             file_error (name, "RECORD", CB_FILE_ERR_INVALID_FT);
             f->key = NULL;
         }
         if (f->alt_key_list) {
             file_error (name, "ALTERNATE", CB_FILE_ERR_INVALID_FT);
             f->alt_key_list = NULL;
         }
         if (f->access_mode == COB_ACCESS_DYNAMIC ||
             f->access_mode == COB_ACCESS_RANDOM) {
             file_error (name, "ORGANIZATION", CB_FILE_ERR_INVALID);
         }
         break;
     }
 }

int validate_move	(	cb_tree	,
		cb_tree	,
		const unsigned	int
	)

 {
     struct cb_field     *fdst;
     struct cb_field     *fsrc;
     struct cb_literal   *l;
     unsigned char       *p;
     cb_tree         loc;
     cob_s64_t       val;
     size_t          i;
     size_t          is_numeric_edited;
     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;
     is_numeric_edited = 0;
     overlapping = 0;
     if (CB_REFERENCE_P (dst)) {
         if (CB_ALPHABET_NAME_P(CB_REFERENCE(dst)->value)) {
             goto invalid;
         }
         if (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;
         }
     }
 
     fdst = CB_FIELD_PTR (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)) {
                 if (!cb_relaxed_syntax_check || is_value) {
                     goto invalid;
                 }
                 cb_warning_x (loc, _("Source is non-numeric - substituting zero"));
             }
         } else if (src == cb_zero) {
             if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHABETIC) {
                 goto invalid;
             }
         } else if (src == cb_low || src == cb_high || src == cb_quote) {
             if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC ||
                 CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED) {
                 if (!cb_relaxed_syntax_check || is_value) {
                     goto invalid;
                 }
                 cb_warning_x (loc, _("Source is non-numeric - substituting zero"));
             }
         }
         break;
     case CB_TAG_LITERAL:
         l = CB_LITERAL (src);
         if (CB_TREE_CLASS (src) == CB_CLASS_NUMERIC) {
             /* Numeric literal */
             if (l->all) {
                 goto invalid;
             }
             if (fdst->usage == CB_USAGE_DOUBLE ||
                 fdst->usage == CB_USAGE_FLOAT ||
                 fdst->usage == CB_USAGE_LONG_DOUBLE ||
                 fdst->usage == CB_USAGE_FP_BIN32 ||
                 fdst->usage == CB_USAGE_FP_BIN64 ||
                 fdst->usage == CB_USAGE_FP_BIN128 ||
                 fdst->usage == CB_USAGE_FP_DEC64 ||
                 fdst->usage == CB_USAGE_FP_DEC128) {
                 break;
             }
             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;
                 }
                 goto non_integer_move;
             case CB_CATEGORY_NUMERIC:
                 if (fdst->pic->scale < 0) {
                     /* Check for PIC 9(n)P(m) */
                     if (least_significant < -fdst->pic->scale) {
                         goto value_mismatch;
                     }
                 } else if (fdst->pic->scale > fdst->pic->size) {
                     /* Check for PIC P(n)9(m) */
                     if (most_significant >= fdst->pic->size - fdst->pic->scale) {
                         goto value_mismatch;
                     }
                 }
                 break;
             case CB_CATEGORY_NUMERIC_EDITED:
                 if (is_value) {
                     goto expect_alphanumeric;
                 }
 
                 /* TODO */
                 break;
             case CB_CATEGORY_ALPHABETIC:
                 if (is_value) {
                     goto expect_alphanumeric;
                 }
                 /* Coming from codegen */
                 if (!suppress_warn) {
                     goto invalid;
                 }
 #if 1   /* RXWRXW - Initialize warn */
                 if (warningopt) {
                     cb_warning_x (loc, _("Numeric move to ALPHABETIC"));
                 }
 #endif
                 break;
             default:
                 if (is_value) {
                     goto expect_alphanumeric;
                 }
                 goto invalid;
             }
 
             /* Sign check */
             if (l->sign != 0 && !fdst->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 sign"));
                 }
             }
 
             /* Size check */
             if (fdst->flag_real_binary ||
                 ((fdst->usage == CB_USAGE_COMP_5 ||
                   fdst->usage == CB_USAGE_COMP_X ||
                   fdst->usage == CB_USAGE_BINARY) &&
                   fdst->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 (fdst->size) {
                 case 1:
                     if (i > 18) {
                         goto numlit_overflow;
                     }
                     val = cb_get_long_long (src);
                     if (fdst->pic->have_sign) {
                         if (val < COB_S64_C(-128) ||
                             val > COB_S64_C(127)) {
                             goto numlit_overflow;
                         }
                     } else {
                         if (val > COB_S64_C(255)) {
                             goto numlit_overflow;
                         }
                     }
                     break;
                 case 2:
                     if (i > 18) {
                         goto numlit_overflow;
                     }
                     val = cb_get_long_long (src);
                     if (fdst->pic->have_sign) {
                         if (val < COB_S64_C(-32768) ||
                             val > COB_S64_C(32767)) {
                             goto numlit_overflow;
                         }
                     } else {
                         if (val > COB_S64_C(65535)) {
                             goto numlit_overflow;
                         }
                     }
                     break;
                 case 3:
                     if (i > 18) {
                         goto numlit_overflow;
                     }
                     val = cb_get_long_long (src);
                     if (fdst->pic->have_sign) {
                         if (val < COB_S64_C(-8388608) ||
                             val > COB_S64_C(8388607)) {
                             goto numlit_overflow;
                         }
                     } else {
                         if (val > COB_S64_C(16777215)) {
                             goto numlit_overflow;
                         }
                     }
                     break;
                 case 4:
                     if (i > 18) {
                         goto numlit_overflow;
                     }
                     val = cb_get_long_long (src);
                     if (fdst->pic->have_sign) {
                         if (val < COB_S64_C(-2147483648) ||
                             val > COB_S64_C(2147483647)) {
                             goto numlit_overflow;
                         }
                     } else {
                         if (val > COB_S64_C(4294967295)) {
                             goto numlit_overflow;
                         }
                     }
                     break;
                 case 5:
                     if (i > 18) {
                         goto numlit_overflow;
                     }
                     val = cb_get_long_long (src);
                     if (fdst->pic->have_sign) {
                         if (val < COB_S64_C(-549755813888) ||
                             val > COB_S64_C(549755813887)) {
                             goto numlit_overflow;
                         }
                     } else {
                         if (val > COB_S64_C(1099511627775)) {
                             goto numlit_overflow;
                         }
                     }
                     break;
                 case 6:
                     if (i > 18) {
                         goto numlit_overflow;
                     }
                     val = cb_get_long_long (src);
                     if (fdst->pic->have_sign) {
                         if (val < COB_S64_C(-140737488355328) ||
                             val > COB_S64_C(140737488355327)) {
                             goto numlit_overflow;
                         }
                     } else {
                         if (val > COB_S64_C(281474976710655)) {
                             goto numlit_overflow;
                         }
                     }
                     break;
                 case 7:
                     if (i > 18) {
                         goto numlit_overflow;
                     }
                     val = cb_get_long_long (src);
                     if (fdst->pic->have_sign) {
                         if (val < COB_S64_C(-36028797018963968) ||
                             val > COB_S64_C(36028797018963967)) {
                             goto numlit_overflow;
                         }
                     } else {
                         if (val > COB_S64_C(72057594037927935)) {
                             goto numlit_overflow;
                         }
                     }
                     break;
                 default:
                     if (fdst->pic->have_sign) {
                         if (i < 19) {
                             break;
                         }
                         if (i > 19) {
                             goto numlit_overflow;
                         }
                         if (memcmp (p, "9223372036854775807", (size_t)19) > 0) {
                             goto numlit_overflow;
                         }
                     } else {
                         if (i < 20) {
                             break;
                         }
                         if (i > 20) {
                             goto numlit_overflow;
                         }
                         if (memcmp (p, "18446744073709551615", (size_t)20) > 0) {
                             goto numlit_overflow;
                         }
                     }
                     break;
                 }
                 return 0;
             }
             if (least_significant < -fdst->pic->scale) {
                 goto size_overflow;
             }
             if (fdst->pic->scale > 0) {
                 size = fdst->pic->digits - fdst->pic->scale;
             } else {
                 size = fdst->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]) &&
                         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;
         }
         fsrc = CB_FIELD_PTR (src);
         size = cb_field_size (src);
         if (size < 0) {
             size = fsrc->size;
         }
 
         /* Check basic overlapping */
         overlapping = cb_check_overlapping (src, dst, fsrc, fdst);
 
         /* Non-elementary move */
         if (fsrc->children || fdst->children) {
             if (size > fdst->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 > (int)fdst->pic->digits) {
                     goto size_overflow_2;
                 }
                 break;
             case CB_CATEGORY_ALPHANUMERIC_EDITED:
                 if (size > count_pic_alphanumeric_edited (fdst)) {
                     goto size_overflow_1;
                 }
                 break;
             default:
                 if (size > fdst->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(fdst)) {
                     goto size_overflow_1;
                 }
                 break;
             default:
                 if (size > fdst->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 (!fsrc->pic) {
                     return -1;
                 }
                 if (is_numeric_edited) {
                     dst_size_mod = count_pic_alphanumeric_edited (fdst);
                 } else {
                     dst_size_mod = fdst->size;
                 }
                 if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC &&
                     fsrc->pic->scale > 0) {
                     goto non_integer_move;
                 }
                 if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC &&
                     (int)fsrc->pic->digits > dst_size_mod) {
                     goto size_overflow_2;
                 }
                 if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC_EDITED &&
                     fsrc->size > dst_size_mod) {
                     goto size_overflow_1;
                 }
                 break;
             default:
                 if (!fsrc->pic) {
                     return -1;
                 }
                 if (!fdst->pic) {
                     return -1;
                 }
                 src_scale_mod = fsrc->pic->scale < 0 ?
                         0 : fsrc->pic->scale;
                 dst_scale_mod = fdst->pic->scale < 0 ?
                         0 : fdst->pic->scale;
                 if (fsrc->pic->digits - src_scale_mod >
                     fdst->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:
     case CB_TAG_FUNCALL:
         /* TODO: check this */
         break;
     default:
         cobc_abort_pr (_("Unexpected tree tag %d"),
                 (int)CB_TREE_TAG (src));
         COBC_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 && !suppress_warn) {
         cb_warning_x (loc, _("Numeric literal exceeds data size"));
     }
     return 0;
 
 non_integer_move:
     if (!suppress_warn) {
         if (cb_move_noninteger_to_alphanumeric == CB_ERROR) {
             goto invalid;
         }
         cb_warning_x (loc, _("Move non-integer to alphanumeric"));
     }
     return 0;
 
 expect_numeric:
     move_warning (src, dst, is_value, cb_warn_strict_typing, 0,
             _("Numeric value is expected"));
     return 0;
 
 expect_alphanumeric:
     move_warning (src, dst, is_value, cb_warn_strict_typing, 0,
             _("Alphanumeric value is expected"));
     return 0;
 
 value_mismatch:
     move_warning (src, dst, is_value, cb_warn_constant, 0,
             _("Value does not fit the picture string"));
     return 0;
 
 size_overflow:
     move_warning (src, dst, is_value, cb_warn_constant, 0,
             _("Value size exceeds data size"));
     return 0;
 
 size_overflow_1:
     move_warning (src, dst, is_value, cb_warn_truncate, 1,
             _("Sending field larger than receiving field"));
     return 0;
 
 size_overflow_2:
     move_warning (src, dst, is_value, cb_warn_truncate, 1,
             _("Some digits may be truncated"));
     return 0;
 }

void ylex_call_destroy ( void )

References NULL, and yylex_destroy().

Referenced by process_translate().

 {
     /* Release flex buffers */
     (void)yylex_destroy ();
     const78ptr = NULL;
 }

void ylex_call_destroy ( void )

Referenced by process_translate().

 {
     /* Release flex buffers */
     (void)yylex_destroy ();
     const78ptr = NULL;
 }

void ylex_clear_all ( void )

References cobc_free(), and NULL.

Referenced by main().

 {
     /* Clear buffers after parsing all source elements */
     if (picbuff2) {
         cobc_free (picbuff2);
         picbuff2 = NULL;
     }
     if (picbuff1) {
         cobc_free (picbuff1);
         picbuff1 = NULL;
     }
     if (plexbuff) {
         cobc_free (plexbuff);
         plexbuff = NULL;
     }
     plexsize = 0;
     pic1size = 0;
     pic2size = 0;
 }

void ylex_clear_all ( void )

Referenced by main().

 {
     /* Clear buffers after parsing all source elements */
     if (picbuff2) {
         cobc_free (picbuff2);
         picbuff2 = NULL;
     }
     if (picbuff1) {
         cobc_free (picbuff1);
         picbuff1 = NULL;
     }
     if (plexbuff) {
         cobc_free (plexbuff);
         plexbuff = NULL;
     }
     plexsize = 0;
     pic1size = 0;
     pic2size = 0;
 }

int yyparse ( void )

int yyparse ( )

Variable Documentation

freevar __pad0__

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional archaic

cb_tree cb_any

cb_tree cb_debug_contents

cb_tree cb_debug_item

cb_tree cb_debug_line

cb_tree cb_debug_name

cb_tree cb_debug_sub_1

cb_tree cb_debug_sub_2

cb_tree cb_debug_sub_3

cb_tree cb_depend_check

cb_tree cb_error_node

cb_tree cb_false

cb_tree cb_high

cb_tree cb_i[COB_MAX_SUBSCRIPTS]

cb_tree cb_int0

cb_tree cb_int1

cb_tree cb_int2

cb_tree cb_int3

cb_tree cb_int4

cb_tree cb_int5

cb_tree cb_intr_whencomp

cb_tree cb_low

size_t cb_needs_01

cb_tree cb_norm_high

cb_tree cb_norm_low

cb_tree cb_null

cb_tree cb_one

cb_tree cb_quote

cb_tree cb_space

cb_tree cb_standard_error_handler

cb_tree cb_true

cb_tree cb_zero

unsigned int cobc_cs_check

unsigned int cobc_force_literal

unsigned int cobc_in_procedure

unsigned int cobc_in_repository

cb_tree cobc_printer_node

struct cb_level_78* const78ptr = NULL

static

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional constant

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit corresponding

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit define

s DECIMAL_IS_PERIOD DECIMAL_IS_COMMA x PICTURE_STATE FUNCTION_STATE

unsigned int gen_screen_ptr

struct cb_level_78* globlev78ptr = NULL

static

unsigned int inside_bracket = 0

static

unsigned int integer_is_label = 0

static

unsigned int last_token_is_dot = 0

static

struct cb_level_78* lev78ptr = NULL

static

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column linkage

int non_const_word

option option case insensitive option never interactive option noyy_scan_buffer option noyy_scan_bytes option noyy_scan_string option noyyget_extra option noyyset_extra option noyyget_leng option noyyget_text option noyyget_lineno option noyyset_lineno option noyyget_in option noyyset_in option noyyget_out option noyyset_out option noyyget_lval option noyyset_lval option noyyget_lloc option noyyset_lloc option noyyget_debug option noyyset_debug

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional obsolete

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column overflow

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional overlap

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call params

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional parentheses

size_t pic1size

static

size_t pic2size

static

char* picbuff1 = NULL

static

char* picbuff2 = NULL

static

unsigned char* plexbuff = NULL

static

size_t plexsize

static

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional redefinition

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column terminator

struct cb_level_78* top78ptr = NULL

static

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column truncate

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict typing

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external call column unreachable

const unsigned char valid_char[256]

static

if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional strict implicit external value

Data Structures

Macros

Typedefs

Enumerations

Functions

Variables

Macro Definition Documentation

Typedef Documentation

Enumeration Type Documentation

Function Documentation

Variable Documentation