GnuCOBOL  2.0
A free COBOL compiler
 All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Macros
Data Structures | Macros | Functions | Variables
typeck.c File Reference
#include "config.h"
#include <stdio.h>
#include <stdlib.h>
#include <stddef.h>
#include <string.h>
#include <ctype.h>
#include <time.h>
#include <limits.h>
#include "cobc.h"
#include "tree.h"
#include "libcob/system.def"
Include dependency graph for typeck.c:

Data Structures

struct  system_table
 
struct  optim_table
 
struct  expr_node
 

Macros

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

Functions

static cb_tree cb_check_needs_break (cb_tree stmt)
 
static size_t cb_validate_one (cb_tree x)
 
static size_t cb_validate_list (cb_tree l)
 
static cb_tree cb_check_group_name (cb_tree x)
 
static cb_tree cb_check_numeric_name (cb_tree x)
 
static cb_tree cb_check_numeric_edited_name (cb_tree x)
 
cb_tree cb_check_numeric_value (cb_tree x)
 
static cb_tree cb_check_integer_value (cb_tree x)
 
static void cb_check_data_incompat (cb_tree x)
 
static void cb_check_lit_subs (struct cb_reference *r, const int numsubs, const int numindex)
 
static int cb_field_size (const cb_tree x)
 
void cb_list_system (void)
 
size_t cb_check_index_p (cb_tree x)
 
void cb_check_field_debug (cb_tree fld)
 
void cb_build_registers (void)
 
char * cb_encode_program_id (const char *name)
 
char * cb_build_program_id (cb_tree name, cb_tree alt_name, const cob_u32_t is_func)
 
cb_tree cb_define_switch_name (cb_tree name, cb_tree sname, const int flag)
 
cb_tree cb_build_section_name (cb_tree name, const int sect_or_para)
 
cb_tree cb_build_assignment_name (struct cb_file *cfile, cb_tree name)
 
cb_tree cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by, struct cb_field *qual)
 
cb_tree cb_build_address (cb_tree x)
 
cb_tree cb_build_identifier (cb_tree x, const int subchk)
 
static cb_tree cb_build_length_1 (cb_tree x)
 
cb_tree cb_build_const_length (cb_tree x)
 
cb_tree cb_build_length (cb_tree x)
 
cb_tree cb_build_ppointer (cb_tree x)
 
static int get_value (cb_tree x)
 
static void cb_validate_collating (struct cb_program *prog)
 
void cb_validate_program_environment (struct cb_program *prog)
 
void cb_build_debug_item (void)
 
void cb_validate_program_data (struct cb_program *prog)
 
void cb_validate_program_body (struct cb_program *prog)
 
static void cb_expr_init (void)
 
static int expr_chk_cond (cb_tree expr_1, cb_tree expr_2)
 
static int expr_reduce (int token)
 
static void cb_expr_shift_sign (const int op)
 
static void cb_expr_shift_class (const char *name)
 
static void cb_expr_shift (int token, cb_tree value)
 
static void expr_expand (cb_tree *x)
 
static cb_tree cb_expr_finish (void)
 
cb_tree cb_build_expr (cb_tree list)
 
static cb_tree build_store_option (cb_tree x, cb_tree round_opt)
 
static cb_tree decimal_alloc (void)
 
static void decimal_free (void)
 
static void decimal_compute (const int op, cb_tree x, cb_tree y)
 
static void decimal_expand (cb_tree d, cb_tree x)
 
static void decimal_assign (cb_tree x, cb_tree d, cb_tree round_opt)
 
static cb_tree cb_build_mul (cb_tree v, cb_tree n, cb_tree round_opt)
 
static cb_tree cb_build_div (cb_tree v, cb_tree n, cb_tree round_opt)
 
static cb_tree build_decimal_assign (cb_tree vars, const int op, cb_tree val)
 
void cb_emit_arithmetic (cb_tree vars, const int op, cb_tree val)
 
static cb_tree build_cond_88 (cb_tree x)
 
static cb_tree cb_build_optim_cond (struct cb_binary_op *p)
 
static int cb_chk_num_cond (cb_tree x, cb_tree y)
 
static int cb_chk_alpha_cond (cb_tree x)
 
cb_tree cb_build_cond (cb_tree x)
 
static cb_tree cb_build_optim_add (cb_tree v, cb_tree n)
 
static cb_tree cb_build_optim_sub (cb_tree v, cb_tree n)
 
cb_tree cb_build_add (cb_tree v, cb_tree n, cb_tree round_opt)
 
cb_tree cb_build_sub (cb_tree v, cb_tree n, cb_tree round_opt)
 
static unsigned int emit_corresponding (cb_tree(*func)(cb_tree f1, cb_tree f2, cb_tree f3), cb_tree x1, cb_tree x2, cb_tree opt)
 
void cb_emit_corresponding (cb_tree(*func)(cb_tree f1, cb_tree f2, cb_tree f3), cb_tree x1, cb_tree x2, cb_tree opt)
 
static unsigned int emit_move_corresponding (cb_tree x1, cb_tree x2)
 
void cb_emit_move_corresponding (cb_tree x1, cb_tree x2)
 
static void output_screen_from (struct cb_field *p, const unsigned int sisters)
 
static void output_screen_to (struct cb_field *p, const unsigned int sisters)
 
static void cb_gen_field_accept (cb_tree var, cb_tree pos, cb_tree fgc, cb_tree bgc, cb_tree scroll, cb_tree timeout, cb_tree prompt, int dispattrs)
 
void cb_emit_accept (cb_tree var, cb_tree pos, struct cb_attr_struct *attr_ptr)
 
void cb_emit_accept_line_or_col (cb_tree var, const int l_or_c)
 
void cb_emit_accept_escape_key (cb_tree var)
 
void cb_emit_accept_exception_status (cb_tree var)
 
void cb_emit_accept_user_name (cb_tree var)
 
void cb_emit_accept_date (cb_tree var)
 
void cb_emit_accept_date_yyyymmdd (cb_tree var)
 
void cb_emit_accept_day (cb_tree var)
 
void cb_emit_accept_day_yyyyddd (cb_tree var)
 
void cb_emit_accept_day_of_week (cb_tree var)
 
void cb_emit_accept_time (cb_tree var)
 
void cb_emit_accept_command_line (cb_tree var)
 
void cb_emit_get_environment (cb_tree envvar, cb_tree envval)
 
void cb_emit_accept_environment (cb_tree var)
 
void cb_emit_accept_arg_number (cb_tree var)
 
void cb_emit_accept_arg_value (cb_tree var)
 
void cb_emit_accept_mnemonic (cb_tree var, cb_tree mnemonic)
 
void cb_emit_accept_name (cb_tree var, cb_tree name)
 
void cb_emit_allocate (cb_tree target1, cb_tree target2, cb_tree size, cb_tree initialize)
 
void cb_emit_alter (cb_tree source, cb_tree target)
 
void cb_emit_call (cb_tree prog, cb_tree par_using, cb_tree returning, cb_tree on_exception, cb_tree not_on_exception, cb_tree convention)
 
void cb_emit_cancel (cb_tree prog)
 
void cb_emit_close (cb_tree file, cb_tree opt)
 
void cb_emit_commit (void)
 
void cb_emit_continue (void)
 
void cb_emit_delete (cb_tree file)
 
void cb_emit_delete_file (cb_tree file)
 
void cb_emit_env_name (cb_tree value)
 
void cb_emit_env_value (cb_tree value)
 
void cb_emit_arg_number (cb_tree value)
 
void cb_emit_command_line (cb_tree value)
 
void cb_emit_display (cb_tree values, cb_tree upon, cb_tree no_adv, cb_tree pos, struct cb_attr_struct *attr_ptr)
 
cb_tree cb_build_display_mnemonic (cb_tree x)
 
cb_tree cb_build_display_name (cb_tree x)
 
void cb_emit_divide (cb_tree dividend, cb_tree divisor, cb_tree quotient, cb_tree remainder)
 
static cb_tree evaluate_test (cb_tree s, cb_tree o)
 
static void build_evaluate (cb_tree subject_list, cb_tree case_list, cb_tree labid)
 
void cb_emit_evaluate (cb_tree subject_list, cb_tree case_list)
 
void cb_emit_free (cb_tree vars)
 
void cb_emit_goto (cb_tree target, cb_tree depending)
 
void cb_emit_exit (const unsigned int goback)
 
void cb_emit_if (cb_tree cond, cb_tree stmt1, cb_tree stmt2)
 
cb_tree cb_build_if_check_break (cb_tree cond, cb_tree stmts)
 
void cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value, cb_tree replacing, cb_tree def)
 
static void validate_inspect (cb_tree x, cb_tree y, const unsigned int replconv)
 
void cb_emit_inspect (cb_tree var, cb_tree body, cb_tree replacing, const unsigned int replconv)
 
void cb_init_tallying (void)
 
cb_tree cb_build_tallying_data (cb_tree x)
 
cb_tree cb_build_tallying_characters (cb_tree l)
 
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 x, cb_tree l)
 
cb_tree cb_build_replacing_characters (cb_tree x, cb_tree l)
 
cb_tree cb_build_replacing_all (cb_tree x, cb_tree y, cb_tree l)
 
cb_tree cb_build_replacing_leading (cb_tree x, cb_tree y, cb_tree l)
 
cb_tree cb_build_replacing_first (cb_tree x, cb_tree y, cb_tree l)
 
cb_tree cb_build_replacing_trailing (cb_tree x, cb_tree y, cb_tree l)
 
cb_tree cb_build_converting (cb_tree x, cb_tree y, cb_tree l)
 
cb_tree cb_build_inspect_region_start (void)
 
static void warning_destination (cb_tree x)
 
static void move_warning (cb_tree src, cb_tree dst, const unsigned int value_flag, const int flag, const int src_flag, const char *msg)
 
static int count_pic_alphanumeric_edited (struct cb_field *field)
 
static size_t cb_check_overlapping (cb_tree src, cb_tree dst, struct cb_field *src_f, struct cb_field *dst_f)
 
int validate_move (cb_tree src, cb_tree dst, const unsigned int is_value)
 
static cb_tree cb_build_memset (cb_tree x, const int c)
 
static cb_tree cb_build_move_copy (cb_tree src, cb_tree dst)
 
static cb_tree cb_build_move_num_zero (cb_tree x)
 
static cb_tree cb_build_move_space (cb_tree x)
 
static cb_tree cb_build_move_zero (cb_tree x)
 
static cb_tree cb_build_move_high (cb_tree x)
 
static cb_tree cb_build_move_low (cb_tree x)
 
static cb_tree cb_build_move_quote (cb_tree x)
 
static void cob_put_sign_ebcdic (unsigned char *p, const int sign)
 
static cb_tree cb_build_move_literal (cb_tree src, cb_tree dst)
 
static cb_tree cb_build_move_field (cb_tree src, cb_tree dst)
 
cb_tree cb_build_move (cb_tree src, cb_tree dst)
 
void cb_emit_move (cb_tree src, cb_tree dsts)
 
void cb_emit_open (cb_tree file, cb_tree mode, cb_tree sharing)
 
void cb_emit_perform (cb_tree perform, cb_tree body)
 
cb_tree cb_build_perform_once (cb_tree body)
 
cb_tree cb_build_perform_times (cb_tree times)
 
cb_tree cb_build_perform_until (cb_tree condition, cb_tree varying)
 
cb_tree cb_build_perform_forever (cb_tree body)
 
cb_tree cb_build_perform_exit (struct cb_label *label)
 
void cb_emit_read (cb_tree ref, cb_tree next, cb_tree into, cb_tree key, cb_tree lock_opts)
 
void cb_emit_ready_trace (void)
 
void cb_emit_reset_trace (void)
 
void cb_emit_rewrite (cb_tree record, cb_tree from, cb_tree lockopt)
 
void cb_emit_release (cb_tree record, cb_tree from)
 
void cb_emit_return (cb_tree ref, cb_tree into)
 
void cb_emit_rollback (void)
 
static unsigned int search_set_keys (struct cb_field *f, cb_tree x)
 
static cb_tree cb_build_search_all (cb_tree table, cb_tree cond)
 
void cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens)
 
void cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts)
 
void cb_emit_setenv (cb_tree x, cb_tree y)
 
void cb_emit_set_to (cb_tree vars, cb_tree x)
 
void cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x)
 
void cb_emit_set_on_off (cb_tree l, cb_tree flag)
 
void cb_emit_set_true (cb_tree l)
 
void cb_emit_set_false (cb_tree l)
 
void cb_emit_set_attribute (cb_tree x, const int val_on, const int val_off)
 
void cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col)
 
void cb_emit_sort_using (cb_tree file, cb_tree l)
 
void cb_emit_sort_input (cb_tree proc)
 
void cb_emit_sort_giving (cb_tree file, cb_tree l)
 
void cb_emit_sort_output (cb_tree proc)
 
void cb_emit_sort_finish (cb_tree file)
 
static unsigned int check_valid_key (const struct cb_file *cbf, const struct cb_field *f)
 
void cb_emit_start (cb_tree file, cb_tree op, cb_tree key, cb_tree keylen)
 
void cb_emit_stop_run (cb_tree x)
 
void cb_emit_string (cb_tree items, cb_tree into, cb_tree pointer)
 
void cb_emit_unlock (cb_tree ref)
 
void cb_emit_unstring (cb_tree name, cb_tree delimited, cb_tree into, cb_tree pointer, cb_tree tallying)
 
cb_tree cb_build_unstring_delimited (cb_tree all, cb_tree value)
 
cb_tree cb_build_unstring_into (cb_tree name, cb_tree delimiter, cb_tree count)
 
void cb_emit_write (cb_tree record, cb_tree from, cb_tree opt, cb_tree lockopt)
 
cb_tree cb_build_write_advancing_lines (cb_tree pos, cb_tree lines)
 
cb_tree cb_build_write_advancing_mnemonic (cb_tree pos, cb_tree mnemonic)
 
cb_tree cb_build_write_advancing_page (cb_tree pos)
 
void cobc_init_typeck (void)
 

Variables

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
 
size_t suppress_warn = 0
 
static cb_tree decimal_stack = NULL
 
static const char * inspect_func
 
static cb_tree inspect_data
 
static int expr_op
 
static cb_tree expr_lh
 
static size_t initialized = 0
 
static size_t overlapping = 0
 
static int expr_index
 
static int expr_stack_size
 
static struct expr_node * expr_stack
 
static const unsigned char hexval [] = "0123456789ABCDEF"
 
static unsigned char expr_prio [256]
 
static unsigned char valid_char [256]
 
static const unsigned char pvalid_char []
 
static const unsigned char cob_refer_ascii [256]
 
static const unsigned char cob_refer_ebcdic [256]
 
static struct system_table system_tab []
 
static struct optim_table bin_set_funcs []
 
static struct optim_table bin_compare_funcs []
 
static struct optim_table bin_add_funcs []
 
static struct optim_table bin_sub_funcs []
 

Macro Definition Documentation

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

Referenced by build_evaluate(), cb_build_length(), cb_check_data_incompat(), cb_emit_accept(), cb_emit_accept_arg_number(), cb_emit_accept_arg_value(), cb_emit_accept_command_line(), cb_emit_accept_date(), cb_emit_accept_date_yyyymmdd(), cb_emit_accept_day(), cb_emit_accept_day_of_week(), cb_emit_accept_day_yyyyddd(), cb_emit_accept_environment(), cb_emit_accept_escape_key(), cb_emit_accept_exception_status(), cb_emit_accept_line_or_col(), cb_emit_accept_mnemonic(), cb_emit_accept_name(), cb_emit_accept_time(), cb_emit_accept_user_name(), cb_emit_allocate(), cb_emit_alter(), cb_emit_arg_number(), cb_emit_call(), cb_emit_cancel(), cb_emit_close(), cb_emit_command_line(), cb_emit_commit(), cb_emit_continue(), cb_emit_delete(), cb_emit_delete_file(), cb_emit_display(), cb_emit_divide(), cb_emit_env_name(), cb_emit_env_value(), cb_emit_evaluate(), cb_emit_exit(), cb_emit_free(), cb_emit_get_environment(), cb_emit_goto(), cb_emit_if(), cb_emit_initialize(), cb_emit_inspect(), cb_emit_move(), cb_emit_open(), cb_emit_perform(), cb_emit_read(), cb_emit_ready_trace(), cb_emit_release(), cb_emit_reset_trace(), cb_emit_return(), cb_emit_rewrite(), cb_emit_rollback(), cb_emit_search(), cb_emit_search_all(), cb_emit_set_attribute(), cb_emit_set_false(), cb_emit_set_on_off(), cb_emit_set_to(), cb_emit_set_true(), cb_emit_set_up_down(), cb_emit_setenv(), cb_emit_sort_finish(), cb_emit_sort_giving(), cb_emit_sort_init(), cb_emit_sort_input(), cb_emit_sort_output(), cb_emit_sort_using(), cb_emit_start(), cb_emit_stop_run(), cb_emit_string(), cb_emit_unlock(), cb_emit_unstring(), cb_emit_write(), cb_gen_field_accept(), decimal_expand(), emit_corresponding(), emit_move_corresponding(), output_screen_from(), and output_screen_to().

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

Referenced by cb_emit_arithmetic(), cb_emit_inspect(), and cb_emit_unstring().

#define COB_SYSTEM_GEN (   x,
  y,
  z 
)    { x, y },
#define dpush (   x)    CB_ADD_TO_CHAIN (x, decimal_stack)

Referenced by cb_build_cond(), decimal_assign(), decimal_compute(), and decimal_expand().

#define START_STACK_SIZE   32

Referenced by cb_expr_init().

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

Referenced by cb_expr_shift(), cb_expr_shift_class(), cb_expr_shift_sign(), expr_reduce(), and while().

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

Referenced by cb_expr_shift(), cb_expr_shift_class(), cb_expr_shift_sign(), and expr_reduce().

Function Documentation

static cb_tree build_cond_88 ( cb_tree  x)
static

References cb_build_binary_op(), cb_build_field_reference(), CB_CHAIN, cb_error_node, CB_FIELD_PTR, CB_PAIR_P, CB_PAIR_X, CB_PAIR_Y, CB_VALUE, cb_field::count, NULL, cb_field::parent, and cb_field::values.

Referenced by cb_build_cond(), and search_set_keys().

3443 {
3444  struct cb_field *f;
3445  cb_tree l;
3446  cb_tree t;
3447  cb_tree c1;
3448  cb_tree c2;
3449 
3450  f = CB_FIELD_PTR (x);
3451  /* Refer to parents data storage */
3452  if (!f->parent) {
3453  /* Field is invalid */
3454  return cb_error_node;
3455  }
3456  x = cb_build_field_reference (f->parent, x);
3457  f->parent->count++;
3458  c1 = NULL;
3459 
3460  /* Build condition */
3461  for (l = f->values; l; l = CB_CHAIN (l)) {
3462  t = CB_VALUE (l);
3463  if (CB_PAIR_P (t)) {
3464  /* VALUE THRU VALUE */
3465  c2 = cb_build_binary_op (cb_build_binary_op (CB_PAIR_X (t), '[', x),
3466  '&', cb_build_binary_op (x, '[', CB_PAIR_Y (t)));
3467  } else {
3468  /* VALUE */
3469  c2 = cb_build_binary_op (x, '=', t);
3470  }
3471  if (c1 == NULL) {
3472  c1 = c2;
3473  } else {
3474  c1 = cb_build_binary_op (c1, '|', c2);
3475  }
3476  }
3477  return c1;
3478 }
static cb_tree build_decimal_assign ( cb_tree  vars,
const int  op,
cb_tree  val 
)
static

References CB_CHAIN, cb_list_append(), cb_list_reverse(), CB_PURPOSE, CB_VALUE, decimal_alloc(), decimal_assign(), decimal_compute(), decimal_expand(), decimal_free(), and NULL.

Referenced by cb_emit_arithmetic().

3336 {
3337  cb_tree l;
3338  cb_tree t;
3339  cb_tree s1;
3340  cb_tree s2;
3341  cb_tree d;
3342 
3343  d = decimal_alloc ();
3344 
3345  /* Set d, VAL */
3346  decimal_expand (d, val);
3347 
3348  s1 = NULL;
3349  if (op == 0) {
3350  for (l = vars; l; l = CB_CHAIN (l)) {
3351  /* Set VAR, d */
3352  decimal_assign (CB_VALUE (l), d, CB_PURPOSE (l));
3353  s2 = cb_list_reverse (decimal_stack);
3354  if (!s1) {
3355  s1 = s2;
3356  } else {
3357  s1 = cb_list_append (s1, s2);
3358  }
3359  decimal_stack = NULL;
3360  }
3361  } else {
3362  t = decimal_alloc ();
3363  for (l = vars; l; l = CB_CHAIN (l)) {
3364  /* Set t, VAR
3365  * OP t, d
3366  * set VAR, t
3367  */
3368  decimal_expand (t, CB_VALUE (l));
3369  decimal_compute (op, t, d);
3370  decimal_assign (CB_VALUE (l), t, CB_PURPOSE (l));
3371  s2 = cb_list_reverse (decimal_stack);
3372  if (!s1) {
3373  s1 = s2;
3374  } else {
3375  s1 = cb_list_append (s1, s2);
3376  }
3377  decimal_stack = NULL;
3378  }
3379  decimal_free ();
3380  }
3381 
3382  decimal_free ();
3383 
3384  return s1;
3385 }
static void build_evaluate ( cb_tree  subject_list,
cb_tree  case_list,
cb_tree  labid 
)
static

References _, cb_build_binary_op(), cb_build_comment(), cb_build_cond(), cb_build_if(), CB_CHAIN, cb_emit, cb_error(), cb_error_node, CB_GOTO_P, cb_list_add(), CB_STATEMENT, CB_STATEMENT_P, CB_VALUE, evaluate_test(), and NULL.

Referenced by cb_emit_evaluate().

5291 {
5292  cb_tree c1;
5293  cb_tree c2;
5294  cb_tree c3;
5295  cb_tree subjs;
5296  cb_tree whens;
5297  cb_tree objs;
5298  cb_tree stmt;
5299 
5300  if (case_list == NULL) {
5301  return;
5302  }
5303 
5304  whens = CB_VALUE (case_list);
5305  stmt = CB_VALUE (whens);
5306  whens = CB_CHAIN (whens);
5307  c1 = NULL;
5308 
5309  /* For each WHEN sequence */
5310  for (; whens; whens = CB_CHAIN (whens)) {
5311  c2 = NULL;
5312  /* Single WHEN test */
5313  for (subjs = subject_list, objs = CB_VALUE (whens);
5314  subjs && objs;
5315  subjs = CB_CHAIN (subjs), objs = CB_CHAIN (objs)) {
5316  c3 = evaluate_test (CB_VALUE (subjs), CB_VALUE (objs));
5317  if (c3 == NULL || c3 == cb_error_node) {
5318  return;
5319  }
5320 
5321  if (c2 == NULL) {
5322  c2 = c3;
5323  } else {
5324  c2 = cb_build_binary_op (c2, '&', c3);
5325  if (c2 == cb_error_node) {
5326  return;
5327  }
5328  }
5329  }
5330  if (subjs || objs) {
5331  cb_error (_("Wrong number of WHEN parameters"));
5332  }
5333  /* Connect multiple WHEN's */
5334  if (c1 == NULL) {
5335  c1 = c2;
5336  } else {
5337  c1 = cb_build_binary_op (c1, '|', c2);
5338  if (c1 == cb_error_node) {
5339  return;
5340  }
5341  }
5342  }
5343 
5344  if (c1 == NULL) {
5345  cb_emit (cb_build_comment ("WHEN OTHER"));
5346  cb_emit (stmt);
5347  } else {
5348  c2 = stmt;
5349  /* Check if last statement is GO TO */
5350  for (c3 = stmt; c3; c3 = CB_CHAIN (c3)) {
5351  if (!CB_CHAIN(c3)) {
5352  break;
5353  }
5354  }
5355  if (c3 && CB_VALUE (c3) && CB_STATEMENT_P (CB_VALUE (c3))) {
5356  c3 = CB_STATEMENT(CB_VALUE(c3))->body;
5357  if (c3 && CB_VALUE (c3) && !CB_GOTO_P (CB_VALUE(c3))) {
5358  /* Append the jump */
5359  c2 = cb_list_add (stmt, labid);
5360  }
5361  }
5362  cb_emit (cb_build_if (cb_build_cond (c1), c2, NULL, 0));
5363  build_evaluate (subject_list, CB_CHAIN (case_list), labid);
5364  }
5365 }
static cb_tree build_store_option ( cb_tree  x,
cb_tree  round_opt 
)
static

References CB_FIELD_PTR, cb_int(), CB_INTEGER, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_X, CB_USAGE_DOUBLE, CB_USAGE_FLOAT, COB_STORE_KEEP_ON_OVERFLOW, COB_STORE_TRUNC_ON_OVERFLOW, current_statement, cb_statement::handler1, cb_statement::handler_id, and cb_field::usage.

Referenced by cb_build_add(), cb_build_div(), cb_build_mul(), cb_build_sub(), cb_emit_divide(), and decimal_assign().

3117 {
3118  struct cb_field *f;
3119  int opt;
3120  enum cb_usage usage;
3121 
3122  f = CB_FIELD_PTR (x);
3123  usage = f->usage;
3124 #if 0 /* RXWRXW - FP */
3125  if (usage == CB_USAGE_DOUBLE || usage == CB_USAGE_FLOAT) {
3126  /* Rounding on FP is useless */
3127  opt = 0;
3128  } else {
3129 #endif
3130  opt = CB_INTEGER (round_opt)->val;
3131 #if 0 /* RXWRXW - FP */
3132  }
3133 #endif
3134 
3135  if (usage == CB_USAGE_COMP_5 || usage == CB_USAGE_COMP_X) {
3136  /* Do not check NOT ERROR case, so that we optimize */
3137  if (current_statement->handler1) {
3138  opt |= COB_STORE_KEEP_ON_OVERFLOW;
3139  }
3140  } else if (current_statement->handler_id) {
3141  /* There is a [NOT] ERROR/OVERFLOW/EXCEPTION - Set in parser */
3142  opt |= COB_STORE_KEEP_ON_OVERFLOW;
3143  } else if (usage == CB_USAGE_BINARY && cb_binary_truncate) {
3144  /* Truncate binary field to digits in picture */
3145  opt |= COB_STORE_TRUNC_ON_OVERFLOW;
3146  }
3147 
3148  return cb_int (opt);
3149 }
cb_tree cb_build_add ( cb_tree  v,
cb_tree  n,
cb_tree  round_opt 
)

References build_store_option(), cb_build_binary_op(), CB_BUILD_FUNCALL_3, cb_build_move(), cb_build_optim_add(), CB_CLASS_POINTER, CB_FIELD_PTR, cb_fits_int(), cb_high, CB_INDEX_P, cb_int0, CB_REF_OR_FIELD_P, CB_TREE_CLASS, cb_field::count, and optimize_defs.

Referenced by cb_build_perform_varying(), cb_emit_arithmetic(), and cb_emit_set_up_down().

3940 {
3941  cb_tree opt;
3942  struct cb_field *f;
3943 
3944 #ifdef COB_NON_ALIGNED
3945  if (CB_INDEX_P (v)) {
3946  return cb_build_move (cb_build_binary_op (v, '+', n), v);
3947  }
3948  if (CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
3949  optimize_defs[COB_POINTER_MANIP] = 1;
3950  return CB_BUILD_FUNCALL_3 ("cob_pointer_manip", v, n, cb_int0);
3951  }
3952 #else
3953  if (CB_INDEX_P (v) || CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
3954  return cb_build_move (cb_build_binary_op (v, '+', n), v);
3955  }
3956 #endif
3957 
3958  if (CB_REF_OR_FIELD_P (v)) {
3959  f = CB_FIELD_PTR (v);
3960  f->count++;
3961  }
3962  if (CB_REF_OR_FIELD_P (n)) {
3963  f = CB_FIELD_PTR (n);
3964  f->count++;
3965  }
3966  if (round_opt == cb_high) {
3967  /* Short circuit from tree.c for perform */
3968  if (cb_fits_int (n)) {
3969  return cb_build_optim_add (v, n);
3970  } else {
3971  return CB_BUILD_FUNCALL_3 ("cob_add", v, n, cb_int0);
3972  }
3973  }
3974  opt = build_store_option (v, round_opt);
3975  if (opt == cb_int0 && cb_fits_int (n)) {
3976  return cb_build_optim_add (v, n);
3977  }
3978  return CB_BUILD_FUNCALL_3 ("cob_add", v, n, opt);
3979 }
cb_tree cb_build_address ( cb_tree  x)

References _, CB_ADD_TO_CHAIN, CB_BUILD_CAST_ADDRESS, cb_error_node, cb_error_x(), CB_FIELD, CB_FIELD_P, cb_list_length(), cb_one, cb_ref(), CB_REFERENCE, CB_REFERENCE_P, cb_warning_x(), cb_word::name, cb_reference::offset, cb_reference::subs, and cb_reference::word.

Referenced by cb_build_identifier().

1329 {
1330  cb_tree v;
1331  struct cb_reference *r;
1332  const char *name;
1333  int numsubs;
1334  int refsubs;
1335 
1336  if (x == cb_error_node) {
1337  return cb_error_node;
1338  }
1339  if (!CB_REFERENCE_P (x)) {
1340  return CB_BUILD_CAST_ADDRESS (x);
1341  }
1342 
1343  r = CB_REFERENCE (x);
1344  name = r->word->name;
1345  v = cb_ref (x);
1346  if (v == cb_error_node) {
1347  return cb_error_node;
1348  }
1349 
1350  refsubs = cb_list_length (r->subs);
1351  if (CB_FIELD_P (v)) {
1352  numsubs = CB_FIELD (v)->indexes;
1353  if (refsubs > numsubs) {
1354  goto subserror;
1355  } else if (refsubs < numsubs) {
1356  if (!cb_relaxed_syntax_check) {
1357  goto subserror;
1358  } else {
1359  cb_warning_x (x,
1360  _("Subscripts missing for '%s' - Defaulting to 1"),
1361  name);
1362  for (; refsubs < numsubs; ++refsubs) {
1363  CB_ADD_TO_CHAIN (cb_one, r->subs);
1364  }
1365  }
1366  }
1367  } else {
1368  numsubs = 0;
1369  if (r->subs) {
1370  goto subserror;
1371  }
1372  if (r->offset) {
1373  cb_error_x (x, _("'%s' cannot be reference modified"), name);
1374  return cb_error_node;
1375  }
1376  }
1377 
1378  return CB_BUILD_CAST_ADDRESS (x);
1379 
1380 subserror:
1381  switch (numsubs) {
1382  case 0:
1383  cb_error_x (x, _("'%s' cannot be subscripted"), name);
1384  break;
1385  case 1:
1386  cb_error_x (x, _("'%s' requires 1 subscript"), name);
1387  break;
1388  default:
1389  cb_error_x (x, _("'%s' requires %d subscripts"),
1390  name, numsubs);
1391  break;
1392  }
1393  return cb_error_node;
1394 }
cb_tree cb_build_assignment_name ( struct cb_file *  cfile,
cb_tree  name 
)

References _, CB_ASSIGN_IBM, CB_ASSIGN_MF, cb_build_alphanumeric_literal(), cb_error_node, cb_list_add(), CB_NAME, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_TAG, cb_warning(), current_program, cb_file::flag_ext_assign, NULL, p, cb_program::reference_list, and warningopt.

1248 {
1249  const char *s;
1250  const char *p;
1251 
1252  if (name == cb_error_node) {
1253  return cb_error_node;
1254  }
1255  /* For special assignment */
1256  if (name == NULL) {
1257  return NULL;
1258  }
1259 
1260  switch (CB_TREE_TAG (name)) {
1261  case CB_TAG_LITERAL:
1262  return name;
1263 
1264  case CB_TAG_REFERENCE:
1265  s = CB_NAME (name);
1266  if (cb_assign_clause == CB_ASSIGN_MF) {
1267  if (cfile->flag_ext_assign) {
1268  p = strrchr (s, '-');
1269  if (p) {
1270  s = p + 1;
1271  }
1272  return cb_build_alphanumeric_literal (s, strlen (s));
1273  }
1274  current_program->reference_list =
1275  cb_list_add (current_program->reference_list, name);
1276  return name;
1277  } else if (cb_assign_clause == CB_ASSIGN_IBM) {
1278  /* Check organization */
1279  if (strncmp (s, "S-", (size_t)2) == 0 ||
1280  strncmp (s, "AS-", (size_t)3) == 0) {
1281  goto org;
1282  }
1283  /* Skip the device label if exists */
1284  if ((p = strchr (s, '-')) != NULL) {
1285  s = p + 1;
1286  }
1287  /* Check organization again */
1288  if (strncmp (s, "S-", (size_t)2) == 0 ||
1289  strncmp (s, "AS-", (size_t)3) == 0) {
1290 org:
1291  /* Skip it for now */
1292  s = strchr (s, '-') + 1;
1293  }
1294  /* Convert the name into literal */
1295  if (warningopt) {
1296  cb_warning (_("ASSIGN interpreted as %s"), s);
1297  }
1298  return cb_build_alphanumeric_literal (s, strlen (s));
1299  }
1300  /* Fall through for CB_ASSIGN_COBOL2002 */
1301  /* To be looked at */
1302  default:
1303  return cb_error_node;
1304  }
1305 }
cb_tree cb_build_cond ( cb_tree  x)

References _, cb_program::alphabet_name_list, build_cond_88(), cb_any, CB_BINARY_OP, CB_BINARY_OP_P, cb_build_binary_op(), CB_BUILD_CAST_ADDRESS, cb_build_cond(), CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_3, CB_BUILD_NEGATION, cb_build_optim_cond(), CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, cb_chk_alpha_cond(), cb_chk_num_cond(), CB_CLASS_NUMERIC, CB_CLASS_POINTER, cb_error_node, cb_error_x(), cb_false, CB_FIELD_P, CB_FIELD_PTR, cb_field_size(), cb_fits_long_long(), cb_high, CB_INDEX_P, cb_int(), cb_list_reverse(), cb_low, cb_ref(), CB_REF_OR_FIELD_P, cb_space, CB_TAG_BINARY_OP, CB_TAG_CONST, CB_TAG_FUNCALL, CB_TAG_REFERENCE, CB_TREE, CB_TREE_CATEGORY, CB_TREE_CLASS, CB_TREE_TAG, cb_true, cb_zero, current_program, current_statement, d1, d2, decimal_alloc(), decimal_expand(), decimal_free(), dpush, cb_program::flag_debugging, cb_field::level, NULL, cb_binary_op::op, p, cb_binary_op::x, and cb_binary_op::y.

Referenced by build_evaluate(), cb_build_cond(), and cb_build_search_all().

3661 {
3662  struct cb_field *f;
3663  struct cb_binary_op *p;
3664  cb_tree d1;
3665  cb_tree d2;
3666  int size1;
3667  int size2;
3668 
3669  if (x == cb_error_node) {
3670  return cb_error_node;
3671  }
3672  switch (CB_TREE_TAG (x)) {
3673  case CB_TAG_CONST:
3674  if (x != cb_any && x != cb_true && x != cb_false) {
3675  cb_error_x (CB_TREE(current_statement),
3676  _("Invalid expression"));
3677  return cb_error_node;
3678  }
3679  return x;
3680  case CB_TAG_FUNCALL:
3681  return x;
3682  case CB_TAG_REFERENCE:
3683  if (!CB_FIELD_P (cb_ref (x))) {
3684  return cb_build_cond (cb_ref (x));
3685  }
3686 
3687  f = CB_FIELD_PTR (x);
3688 
3689  /* Level 88 condition */
3690  if (f->level == 88) {
3691  /* Build an 88 condition at every occurrence */
3692  /* as it may be subscripted */
3693  return cb_build_cond (build_cond_88 (x));
3694  }
3695 
3696  cb_error_x (x, _("Invalid expression"));
3697  return cb_error_node;
3698  case CB_TAG_BINARY_OP:
3699  p = CB_BINARY_OP (x);
3700  if (!p->x || p->x == cb_error_node) {
3701  return cb_error_node;
3702  }
3703  switch (p->op) {
3704  case '!':
3705  return CB_BUILD_NEGATION (cb_build_cond (p->x));
3706  case '&':
3707  case '|':
3708  if (!p->y || p->y == cb_error_node) {
3709  return cb_error_node;
3710  }
3711  return cb_build_binary_op (cb_build_cond (p->x), p->op, cb_build_cond (p->y));
3712  default:
3713  if (!p->y || p->y == cb_error_node) {
3714  return cb_error_node;
3715  }
3716  if (CB_INDEX_P (p->x) || CB_INDEX_P (p->y) ||
3717  CB_TREE_CLASS (p->x) == CB_CLASS_POINTER ||
3718  CB_TREE_CLASS (p->y) == CB_CLASS_POINTER) {
3719  x = cb_build_binary_op (p->x, '-', p->y);
3720  } else if (CB_BINARY_OP_P (p->x) ||
3721  CB_BINARY_OP_P (p->y)) {
3722  /* Decimal comparison */
3723  d1 = decimal_alloc ();
3724  d2 = decimal_alloc ();
3725 
3726  decimal_expand (d1, p->x);
3727  decimal_expand (d2, p->y);
3728  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_cmp", d1, d2));
3729  decimal_free ();
3730  decimal_free ();
3731  x = cb_list_reverse (decimal_stack);
3732  decimal_stack = NULL;
3733  } else {
3734  /* DEBUG Bypass optimization for PERFORM */
3735  if (current_program->flag_debugging) {
3736  x = CB_BUILD_FUNCALL_2 ("cob_cmp", p->x, p->y);
3737  break;
3738  }
3739  if (cb_chk_num_cond (p->x, p->y)) {
3740  size1 = cb_field_size (p->x);
3741  x = CB_BUILD_FUNCALL_3 ("memcmp",
3742  CB_BUILD_CAST_ADDRESS (p->x),
3743  CB_BUILD_CAST_ADDRESS (p->y),
3744  cb_int (size1));
3745  break;
3746  }
3747  if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC &&
3748  CB_TREE_CLASS (p->y) == CB_CLASS_NUMERIC &&
3749  cb_fits_long_long (p->y)) {
3750  x = cb_build_optim_cond (p);
3751  break;
3752  }
3753 
3754  /* Field comparison */
3755  if ((CB_REF_OR_FIELD_P (p->x)) &&
3756  (CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHANUMERIC ||
3757  CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHABETIC) &&
3758  cb_field_size (p->x) == 1 &&
3759  !current_program->alphabet_name_list &&
3760  (p->y == cb_space || p->y == cb_low ||
3761  p->y == cb_high || p->y == cb_zero)) {
3762  x = CB_BUILD_FUNCALL_2 ("$G", p->x, p->y);
3763  break;
3764  }
3765  if (cb_chk_alpha_cond (p->x) &&
3766  cb_chk_alpha_cond (p->y)) {
3767  size1 = cb_field_size (p->x);
3768  size2 = cb_field_size (p->y);
3769  } else {
3770  size1 = 0;
3771  size2 = 0;
3772  }
3773  if (size1 == 1 && size2 == 1) {
3774  x = CB_BUILD_FUNCALL_2 ("$G", p->x, p->y);
3775  } else if (size1 != 0 && size1 == size2) {
3776  x = CB_BUILD_FUNCALL_3 ("memcmp",
3777  CB_BUILD_CAST_ADDRESS (p->x),
3778  CB_BUILD_CAST_ADDRESS (p->y),
3779  cb_int (size1));
3780  } else {
3781  if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC && p->y == cb_zero) {
3782  x = cb_build_optim_cond (p);
3783  } else {
3784  x = CB_BUILD_FUNCALL_2 ("cob_cmp", p->x, p->y);
3785  }
3786  }
3787  }
3788  }
3789  return cb_build_binary_op (x, p->op, p->y);
3790  default:
3791  break;
3792  }
3793  cb_error_x (x, _("Invalid expression"));
3794  return cb_error_node;
3795 }
cb_tree cb_build_const_length ( cb_tree  x)

References _, cb_build_numeric_literal(), cb_error(), cb_error_node, CB_FIELD, cb_field_variable_size(), CB_INTEGER, CB_INTEGER_P, cb_ref(), CB_REFERENCE, CB_REFERENCE_P, cb_validate_field(), cb_field::flag_any_length, cb_field::level, cb_field::memory_size, cb_field::offset, cb_field::redefines, cb_field::rename_thru, and cb_field::size.

1670 {
1671  struct cb_field *f;
1672  char buff[32];
1673 
1674  if (x == cb_error_node) {
1675  return cb_error_node;
1676  }
1677  if (CB_INTEGER_P (x)) {
1678  sprintf (buff, "%d", CB_INTEGER(x)->val);
1679  return cb_build_numeric_literal (0, buff, 0);
1680  }
1681  if (CB_REFERENCE_P (x)) {
1682  if (cb_ref (x) == cb_error_node) {
1683  return cb_error_node;
1684  }
1685  if (CB_REFERENCE (x)->offset) {
1686  cb_error (_("Reference modification not allowed here"));
1687  return cb_error_node;
1688  }
1689  }
1690 
1691  memset (buff, 0, sizeof (buff));
1692  f = CB_FIELD (cb_ref (x));
1693  if (f->flag_any_length) {
1694  cb_error (_("ANY LENGTH item not allowed here"));
1695  return cb_error_node;
1696  }
1697  if (f->level == 88) {
1698  cb_error (_("88 level item not allowed here"));
1699  return cb_error_node;
1700  }
1701  if (cb_field_variable_size (f)) {
1702  cb_error (_("Variable length item not allowed here"));
1703  return cb_error_node;
1704  }
1705  if (f->redefines) {
1706  cb_validate_field (f->redefines);
1707  if (f->rename_thru) {
1708  cb_validate_field (f->rename_thru);
1709  }
1710  cb_validate_field (f);
1711  sprintf (buff, "%d", f->size);
1712  } else {
1713  cb_validate_field (f);
1714  sprintf (buff, "%d", f->memory_size);
1715  }
1716  return cb_build_numeric_literal (0, buff, 0);
1717 }
cb_tree cb_build_converting ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

References CB_BUILD_FUNCALL_2, cb_list_add(), and validate_inspect().

5744 {
5745  validate_inspect (x, y, 2);
5746  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_converting", x, y));
5747 }
void cb_build_debug_item ( void  )

References cb_build_field_tree(), cb_build_filler(), cb_build_picture(), cb_build_reference(), CB_FIELD, CB_FIELD_ADD, CB_LIST_INIT, CB_PICTURE, cb_space, CB_STORAGE_WORKING, cb_validate_field(), current_program, NULL, and cb_program::working_storage.

2183 {
2184  cb_tree l;
2185  cb_tree x;
2186  cb_tree assign;
2187 
2188  /* Set up DEBUG-ITEM */
2189  l = cb_build_reference ("DEBUG-ITEM");
2190  assign = cb_build_field_tree (NULL, l, NULL, CB_STORAGE_WORKING,
2191  NULL, 1);
2192  CB_FIELD (assign)->values = CB_LIST_INIT (cb_space);
2193  cb_debug_item = l;
2194 
2195  l = cb_build_reference ("DEBUG-LINE");
2196  x = cb_build_field_tree (NULL, l, CB_FIELD(assign),
2197  CB_STORAGE_WORKING, NULL, 3);
2198  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("9(6)"));
2199  cb_validate_field (CB_FIELD (x));
2200  cb_debug_line = l;
2201 
2202  l = cb_build_filler ();
2203  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2204  CB_STORAGE_WORKING, NULL, 3);
2205  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2206  CB_FIELD (x)->flag_filler = 1;
2207  cb_validate_field (CB_FIELD (x));
2208 
2209  l = cb_build_reference ("DEBUG-NAME");
2210  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2211  CB_STORAGE_WORKING, NULL, 3);
2212  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X(31)"));
2213  cb_validate_field (CB_FIELD (x));
2214  cb_debug_name = l;
2215 
2216  l = cb_build_filler ();
2217  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2218  CB_STORAGE_WORKING, NULL, 3);
2219  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2220  CB_FIELD (x)->flag_filler = 1;
2221  cb_validate_field (CB_FIELD (x));
2222 
2223  l = cb_build_reference ("DEBUG-SUB-1");
2224  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2225  CB_STORAGE_WORKING, NULL, 3);
2226  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
2227  CB_FIELD (x)->flag_sign_leading = 1;
2228  CB_FIELD (x)->flag_sign_separate = 1;
2229  cb_validate_field (CB_FIELD (x));
2230  cb_debug_sub_1 = l;
2231 
2232  l = cb_build_filler ();
2233  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2234  CB_STORAGE_WORKING, NULL, 3);
2235  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2236  CB_FIELD (x)->flag_filler = 1;
2237  cb_validate_field (CB_FIELD (x));
2238 
2239  l = cb_build_reference ("DEBUG-SUB-2");
2240  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2241  CB_STORAGE_WORKING, NULL, 3);
2242  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
2243  CB_FIELD (x)->flag_sign_leading = 1;
2244  CB_FIELD (x)->flag_sign_separate = 1;
2245  cb_validate_field (CB_FIELD (x));
2246  cb_debug_sub_2 = l;
2247 
2248  l = cb_build_filler ();
2249  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2250  CB_STORAGE_WORKING, NULL, 3);
2251  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2252  CB_FIELD (x)->flag_filler = 1;
2253  cb_validate_field (CB_FIELD (x));
2254 
2255  l = cb_build_reference ("DEBUG-SUB-3");
2256  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2257  CB_STORAGE_WORKING, NULL, 3);
2258  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
2259  CB_FIELD (x)->flag_sign_leading = 1;
2260  CB_FIELD (x)->flag_sign_separate = 1;
2261  cb_validate_field (CB_FIELD (x));
2262  cb_debug_sub_3 = l;
2263 
2264  l = cb_build_filler ();
2265  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2266  CB_STORAGE_WORKING, NULL, 3);
2267  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2268  CB_FIELD (x)->flag_filler = 1;
2269  cb_validate_field (CB_FIELD (x));
2270 
2271  l = cb_build_reference ("DEBUG-CONTENTS");
2272  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2273  CB_STORAGE_WORKING, NULL, 3);
2274  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X(31)"));
2275  cb_validate_field (CB_FIELD (x));
2276  cb_debug_contents = l;
2277 
2278  cb_validate_field (CB_FIELD (assign));
2279  CB_FIELD_ADD (current_program->working_storage, CB_FIELD (assign));
2280 }
cb_tree cb_build_display_mnemonic ( cb_tree  x)

References _, CB_DEVICE_CONSOLE, CB_DEVICE_SYSERR, CB_DEVICE_SYSOUT, cb_error_node, cb_error_x(), cb_int0, cb_int1, cb_ref(), and CB_SYSTEM_NAME.

5138 {
5139  if (x == cb_error_node) {
5140  return cb_int0;
5141  }
5142  if (cb_ref (x) == cb_error_node) {
5143  return cb_int0;
5144  }
5145 
5146  switch (CB_SYSTEM_NAME (cb_ref (x))->token) {
5147  case CB_DEVICE_CONSOLE:
5148  case CB_DEVICE_SYSOUT:
5149  return cb_int0;
5150  case CB_DEVICE_SYSERR:
5151  return cb_int1;
5152  default:
5153  cb_error_x (x, _("Invalid output device"));
5154  return cb_int0;
5155  }
5156 }
cb_tree cb_build_display_name ( cb_tree  x)

References _, CB_DEVICE_CONSOLE, CB_DEVICE_SYSERR, CB_DEVICE_SYSOUT, cb_error_node, cb_error_x(), cb_int0, cb_int1, CB_NAME, CB_SYSTEM_NAME, cb_warning_x(), lookup_system_name(), and cb_file::name.

5160 {
5161  const char *name;
5162  cb_tree sys;
5163 
5164  if (x == cb_error_node) {
5165  return cb_error_node;
5166  }
5167  name = CB_NAME (x);
5168  /* Allow direct reference to a device name */
5169  sys = lookup_system_name (name);
5170  if (sys) {
5171  switch (CB_SYSTEM_NAME (sys)->token) {
5172  case CB_DEVICE_CONSOLE:
5173  case CB_DEVICE_SYSOUT:
5174  if (!cb_relaxed_syntax_check) {
5175  cb_warning_x (x, _("'%s' is not defined in SPECIAL-NAMES"), name);
5176  }
5177  return cb_int0;
5178  case CB_DEVICE_SYSERR:
5179  if (!cb_relaxed_syntax_check) {
5180  cb_warning_x (x, _("'%s' is not defined in SPECIAL-NAMES"), name);
5181  }
5182  return cb_int1;
5183  default:
5184  cb_error_x (x, _("'%s' is not an output device"), name);
5185  return cb_error_node;
5186  }
5187  }
5188 
5189  cb_error_x (x, _("'%s' is not defined in SPECIAL-NAMES"), name);
5190  return cb_error_node;
5191 }
static cb_tree cb_build_div ( cb_tree  v,
cb_tree  n,
cb_tree  round_opt 
)
static

References build_store_option(), cb_build_binary_op(), CB_BUILD_FUNCALL_3, cb_build_move(), CB_FIELD_PTR, CB_INDEX_P, CB_REF_OR_FIELD_P, and cb_field::count.

Referenced by cb_emit_arithmetic().

3314 {
3315  cb_tree opt;
3316  struct cb_field *f;
3317 
3318  if (CB_INDEX_P (v)) {
3319  return cb_build_move (cb_build_binary_op (v, '/', n), v);
3320  }
3321 
3322  if (CB_REF_OR_FIELD_P (v)) {
3323  f = CB_FIELD_PTR (v);
3324  f->count++;
3325  }
3326  if (CB_REF_OR_FIELD_P (n)) {
3327  f = CB_FIELD_PTR (n);
3328  f->count++;
3329  }
3330  opt = build_store_option (v, round_opt);
3331  return CB_BUILD_FUNCALL_3 ("cob_div", v, n, opt);
3332 }
cb_tree cb_build_expr ( cb_tree  list)

References CB_CHAIN, CB_CLASS_NAME, cb_expr_finish(), cb_expr_init(), cb_expr_shift(), cb_expr_shift_class(), cb_expr_shift_sign(), CB_PURPOSE_INT, cb_ref(), CB_VALUE, current_statement, NULL, cb_statement::null_check, and cb_binary_op::op.

3060 {
3061  cb_tree l;
3062  int op;
3063 
3064  cb_expr_init ();
3065 
3066  for (l = list; l; l = CB_CHAIN (l)) {
3067  op = CB_PURPOSE_INT (l);
3068  switch (op) {
3069  case '9':
3070  /* NUMERIC */
3071  cb_expr_shift_class ("cob_is_numeric");
3072  break;
3073  case 'A':
3074  /* ALPHABETIC */
3075  cb_expr_shift_class ("cob_is_alpha");
3076  break;
3077  case 'L':
3078  /* ALPHABETIC_LOWER */
3079  cb_expr_shift_class ("cob_is_lower");
3080  break;
3081  case 'U':
3082  /* ALPHABETIC_UPPER */
3083  cb_expr_shift_class ("cob_is_upper");
3084  break;
3085  case 'P':
3086  /* POSITIVE */
3087  cb_expr_shift_sign ('>');
3088  break;
3089  case 'N':
3090  /* NEGATIVE */
3091  cb_expr_shift_sign ('<');
3092  break;
3093  case 'O':
3094  /* OMITTED */
3095  if (current_statement) {
3096  current_statement->null_check = NULL;
3097  }
3098  cb_expr_shift_class ("cob_is_omitted");
3099  break;
3100  case 'C':
3101  /* CLASS */
3102  cb_expr_shift_class (CB_CLASS_NAME (cb_ref (CB_VALUE (l)))->cname);
3103  break;
3104  default:
3105  cb_expr_shift (op, CB_VALUE (l));
3106  break;
3107  }
3108  }
3109 
3110  return cb_expr_finish ();
3111 }
cb_tree cb_build_identifier ( cb_tree  x,
const int  subchk 
)

References _, CB_ADD_TO_CHAIN, CB_BINARY_OP, CB_BINARY_OP_P, cb_build_address(), cb_build_cast_int(), CB_BUILD_CAST_LENGTH, cb_build_field_reference(), CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_4, CB_BUILD_STRING0, CB_CHAIN, cb_check_integer_value(), cb_check_lit_subs(), cb_error_node, cb_error_x(), CB_EXCEPTION_ENABLE, CB_FIELD, cb_field_founder(), CB_FIELD_P, CB_FIELD_PTR, cb_get_int(), cb_int(), cb_int1, cb_list_add(), cb_list_length(), cb_list_reverse(), CB_LITERAL_P, cb_one, cb_ref(), CB_REFERENCE, CB_STORAGE_CONSTANT, CB_STORAGE_LINKAGE, CB_USAGE_NATIONAL, CB_VALUE, cb_warning_x(), cb_reference::check, COB_EC_DATA_PTR_NULL, current_statement, cb_field::depending, cb_reference::flag_all, cb_field::flag_any_length, cb_field::flag_is_pdiv_parm, cb_field::flag_item_based, cb_statement::flag_no_based, cb_field::flag_occurs, cb_field::indexes, cb_reference::length, cb_field::name, cb_word::name, NULL, cb_statement::null_check, cb_field::occurs_max, cb_field::occurs_min, cb_field::offset, cb_reference::offset, p, cb_field::parent, cb_field::redefines, cb_field::size, cb_field::storage, cb_reference::subs, cb_field::usage, cb_field::values, and cb_reference::word.

1398 {
1399  struct cb_reference *r;
1400  struct cb_field *f;
1401  struct cb_field *p;
1402  const char *name;
1403  cb_tree v;
1404  cb_tree e1;
1405  cb_tree e2;
1406  cb_tree l;
1407  cb_tree sub;
1408  int offset;
1409  int length;
1410  int n;
1411  int numsubs;
1412  int refsubs;
1413  int pseudosize;
1414 
1415  if (x == cb_error_node) {
1416  return cb_error_node;
1417  }
1418 
1419  r = CB_REFERENCE (x);
1420  name = r->word->name;
1421 
1422  /* Resolve reference */
1423  v = cb_ref (x);
1424  if (v == cb_error_node) {
1425  return cb_error_node;
1426  }
1427 
1428  /* Check if it is a data name */
1429  if (!CB_FIELD_P (v)) {
1430  if (r->subs) {
1431  cb_error_x (x, _("'%s' cannot be subscripted"), name);
1432  return cb_error_node;
1433  }
1434  if (r->offset) {
1435  cb_error_x (x, _("'%s' cannot be reference modified"), name);
1436  return cb_error_node;
1437  }
1438  return x;
1439  }
1440  f = CB_FIELD (v);
1441 
1442  /* BASED check */
1443  if (current_statement && CB_EXCEPTION_ENABLE (COB_EC_DATA_PTR_NULL)) {
1444  p = cb_field_founder (f);
1445  if (p->redefines) {
1446  p = p->redefines;
1447  }
1448  if (!current_statement->flag_no_based) {
1449  if (p->flag_item_based ||
1450  (f->storage == CB_STORAGE_LINKAGE &&
1451  !p->flag_is_pdiv_parm)) {
1452  current_statement->null_check = CB_BUILD_FUNCALL_2 (
1453  "cob_check_based",
1454  cb_build_address (cb_build_field_reference (p, NULL)),
1455  CB_BUILD_STRING0 (name));
1456  }
1457  }
1458  }
1459 
1460  for (l = r->subs; l; l = CB_CHAIN (l)) {
1461  if (CB_BINARY_OP_P (CB_VALUE (l))) {
1462  /* Set special flag for codegen */
1463  CB_BINARY_OP(CB_VALUE(l))->flag = 1;
1464  }
1465  }
1466 
1467  /* Check the number of subscripts */
1468  numsubs = cb_list_length (r->subs);
1469  cb_check_lit_subs (r, numsubs, f->indexes);
1470  if (subchk) {
1471  if (!f->indexes) {
1472  cb_error_x (x, _("'%s' has no OCCURS clause"), name);
1473  return cb_error_node;
1474  }
1475  numsubs = f->indexes - 1;
1476  } else {
1477  numsubs = f->indexes;
1478  }
1479  refsubs = cb_list_length (r->subs);
1480  if (!r->flag_all && refsubs != numsubs) {
1481  if (refsubs > numsubs) {
1482  goto refsubserr;
1483  } else if (refsubs < numsubs) {
1484  if (!cb_relaxed_syntax_check) {
1485  goto refsubserr;
1486  } else {
1487  cb_warning_x (x,
1488  _("Subscripts missing for '%s' - Defaulting to 1"),
1489  name);
1490  for (; refsubs < numsubs; ++refsubs) {
1491  CB_ADD_TO_CHAIN (cb_one, r->subs);
1492  }
1493  }
1494  }
1495  }
1496 
1497  /* Subscript check */
1498  if (!r->flag_all && r->subs) {
1499  l = r->subs;
1500  for (p = f; p; p = p->parent) {
1501  if (!p->flag_occurs) {
1502  continue;
1503  }
1504 
1505 #if 1 /* RXWRXW - Sub check */
1506  if (!l) {
1507  break;
1508  }
1509 #endif
1510  sub = cb_check_integer_value (CB_VALUE (l));
1511  l = CB_CHAIN (l);
1512  if (sub == cb_error_node) {
1513  continue;
1514  }
1515 
1516  /* Compile-time check */
1517  if (CB_LITERAL_P (sub)) {
1518  n = cb_get_int (sub);
1519  if (n < 1 || n > p->occurs_max) {
1520  cb_error_x (x, _("Subscript of '%s' out of bounds: %d"),
1521  name, n);
1522  }
1523  }
1524 
1525  /* Run-time check */
1526  if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
1527  if (p->depending) {
1528  e1 = CB_BUILD_FUNCALL_4 ("cob_check_odo",
1529  cb_build_cast_int (p->depending),
1530  cb_int (p->occurs_min),
1531  cb_int (p->occurs_max),
1532  CB_BUILD_STRING0
1533  ((CB_FIELD_PTR (p->depending)->name)));
1534  e2 = CB_BUILD_FUNCALL_4 ("cob_check_subscript",
1535  cb_build_cast_int (sub),
1536  cb_int1,
1537  cb_build_cast_int (p->depending),
1538  CB_BUILD_STRING0 (name));
1539  r->check = cb_list_add (r->check, e1);
1540  r->check = cb_list_add (r->check, e2);
1541  } else {
1542  if (!CB_LITERAL_P (sub)) {
1543  e1 = CB_BUILD_FUNCALL_4 ("cob_check_subscript",
1544  cb_build_cast_int (sub),
1545  cb_int1,
1546  cb_int (p->occurs_max),
1547  CB_BUILD_STRING0 (name));
1548  r->check = cb_list_add (r->check, e1);
1549  }
1550  }
1551  }
1552  }
1553  }
1554 
1555  if (subchk) {
1556  r->subs = cb_list_reverse (r->subs);
1557  r->subs = cb_list_add (r->subs, cb_int1);
1558  r->subs = cb_list_reverse (r->subs);
1559  }
1560 
1561  /* Reference modification check */
1562  if ( f->usage == CB_USAGE_NATIONAL ) {
1563  pseudosize = f->size / 2;
1564  } else {
1565  pseudosize = f->size;
1566  }
1567  if (r->offset) {
1568  /* Compile-time check */
1569  if (CB_LITERAL_P (r->offset)) {
1570  offset = cb_get_int (r->offset);
1571  if (f->flag_any_length) {
1572  if (offset < 1) {
1573  cb_error_x (x, _("Offset of '%s' out of bounds: %d"), name, offset);
1574  } else if (r->length && CB_LITERAL_P (r->length)) {
1575  length = cb_get_int (r->length);
1576  if (length < 1) {
1577  cb_error_x (x, _("Length of '%s' out of bounds: %d"),
1578  name, length);
1579  }
1580  }
1581  } else {
1582  if (offset < 1 || offset > pseudosize) {
1583  cb_error_x (x, _("Offset of '%s' out of bounds: %d"), name, offset);
1584  } else if (r->length && CB_LITERAL_P (r->length)) {
1585  length = cb_get_int (r->length);
1586  if (length < 1 || length > pseudosize - offset + 1) {
1587  cb_error_x (x, _("Length of '%s' out of bounds: %d"),
1588  name, length);
1589  }
1590  }
1591  }
1592  }
1593 
1594  /* Run-time check */
1595  if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_REF_MOD)) {
1596  if (f->flag_any_length || !CB_LITERAL_P (r->offset) ||
1597  (r->length && !CB_LITERAL_P (r->length))) {
1598  e1 = CB_BUILD_FUNCALL_4 ("cob_check_ref_mod",
1599  cb_build_cast_int (r->offset),
1600  r->length ?
1601  cb_build_cast_int (r->length) :
1602  cb_int1,
1603  f->flag_any_length ?
1604  CB_BUILD_CAST_LENGTH (v) :
1605  cb_int (pseudosize),
1606  CB_BUILD_STRING0 (f->name));
1607  r->check = cb_list_add (r->check, e1);
1608  }
1609  }
1610  }
1611 
1612  if (f->storage == CB_STORAGE_CONSTANT) {
1613  return CB_VALUE (f->values);
1614  }
1615 
1616  return x;
1617 
1618 refsubserr:
1619  switch (numsubs) {
1620  case 0:
1621  cb_error_x (x, _("'%s' cannot be subscripted"), name);
1622  break;
1623  case 1:
1624  cb_error_x (x, _("'%s' requires 1 subscript"), name);
1625  break;
1626  default:
1627  cb_error_x (x, _("'%s' requires %d subscripts"),
1628  name, f->indexes);
1629  break;
1630  }
1631  return cb_error_node;
1632 }
cb_tree cb_build_if_check_break ( cb_tree  cond,
cb_tree  stmts 
)

References cb_build_if(), cb_check_needs_break(), and NULL.

5469 {
5470  cb_tree stmt_lis;
5471 
5472  stmt_lis = cb_check_needs_break (stmts);
5473  return cb_build_if (cond, stmt_lis, NULL, 0);
5474 }
cb_tree cb_build_index ( cb_tree  x,
cb_tree  values,
const unsigned int  indexed_by,
struct cb_field *  qual 
)

References cb_build_field(), CB_FIELD, CB_FIELD_ADD, CB_LIST_INIT, CB_USAGE_INDEX, cb_validate_field(), current_program, cb_field::flag_indexed_by, cb_field::index_qual, cb_field::usage, cb_field::values, and cb_program::working_storage.

Referenced by cb_build_length(), and cb_build_registers().

1310 {
1311  struct cb_field *f;
1312 
1313  f = CB_FIELD (cb_build_field (x));
1314  f->usage = CB_USAGE_INDEX;
1315  cb_validate_field (f);
1316  if (values) {
1317  f->values = CB_LIST_INIT (values);
1318  }
1319  if (qual) {
1320  f->index_qual = qual;
1321  }
1322  f->flag_indexed_by = !!indexed_by;
1323  CB_FIELD_ADD (current_program->working_storage, f);
1324  return x;
1325 }
cb_tree cb_build_inspect_region_start ( void  )

References CB_BUILD_FUNCALL_0, and CB_LIST_INIT.

5751 {
5752  return CB_LIST_INIT (CB_BUILD_FUNCALL_0 ("cob_inspect_start"));
5753 }
cb_tree cb_build_length ( cb_tree  x)

References cb_build_any_intrinsic(), cb_build_assign(), cb_build_filler(), cb_build_index(), cb_build_length_1(), cb_build_numeric_literal(), cb_emit, cb_error_node, CB_FIELD, cb_field_size(), cb_field_variable_size(), CB_INTRINSIC_P, CB_LIST_INIT, CB_LITERAL, CB_LITERAL_P, cb_ref(), CB_REF_OR_FIELD_P, CB_REFERENCE, CB_REFERENCE_P, CB_USAGE_LENGTH, cb_field::flag_any_length, NULL, and cb_literal::size.

Referenced by cb_build_intrinsic().

1721 {
1722  struct cb_field *f;
1723  struct cb_literal *l;
1724  cb_tree temp;
1725  char buff[32];
1726 
1727  if (x == cb_error_node) {
1728  return cb_error_node;
1729  }
1730  if (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node) {
1731  return cb_error_node;
1732  }
1733 
1734  if (CB_LITERAL_P (x)) {
1735  l = CB_LITERAL (x);
1736  sprintf (buff, "%d", (int)l->size);
1737  return cb_build_numeric_literal (0, buff, 0);
1738  }
1739  if (CB_INTRINSIC_P (x)) {
1740  return cb_build_any_intrinsic (CB_LIST_INIT (x));
1741  }
1742  if (CB_REF_OR_FIELD_P (x)) {
1743  if (CB_REFERENCE_P (x) && CB_REFERENCE (x)->offset) {
1744  return cb_build_any_intrinsic (CB_LIST_INIT (x));
1745  }
1746  f = CB_FIELD (cb_ref (x));
1747  if (f->flag_any_length) {
1748  return cb_build_any_intrinsic (CB_LIST_INIT (x));
1749  }
1750  if (cb_field_variable_size (f) == NULL) {
1751  sprintf (buff, "%d", cb_field_size (x));
1752  return cb_build_numeric_literal (0, buff, 0);
1753  }
1754  }
1755  temp = cb_build_index (cb_build_filler (), NULL, 0, NULL);
1756  CB_FIELD (cb_ref (temp))->usage = CB_USAGE_LENGTH;
1757  CB_FIELD (cb_ref (temp))->count++;
1758  cb_emit (cb_build_assign (temp, cb_build_length_1 (x)));
1759  return temp;
1760 }
static cb_tree cb_build_length_1 ( cb_tree  x)
static

References cb_build_binary_op(), cb_build_field_reference(), CB_FIELD, cb_field_size(), cb_field_variable_size(), cb_int(), cb_ref(), cb_field::children, cb_field::depending, cb_field::flag_odo_item, NULL, cb_field::occurs_max, cb_field::sister, and cb_field::size.

Referenced by cb_build_length().

1636 {
1637  struct cb_field *f;
1638  cb_tree e;
1639  cb_tree size;
1640 
1641  f = CB_FIELD (cb_ref (x));
1642 
1643  if (cb_field_variable_size (f) == NULL) {
1644  /* Constant size */
1645  return cb_int (cb_field_size (x));
1646  }
1647  /* Variable size */
1648  e = NULL;
1649  for (f = f->children; f; f = f->sister) {
1650  size = cb_build_length_1 (cb_build_field_reference (f, x));
1651  if (f->depending) {
1652  if (!cb_flag_odoslide && f->flag_odo_item) {
1653  size = cb_build_binary_op (size, '*',
1654  cb_int (f->occurs_max));
1655  } else {
1656  size = cb_build_binary_op (size, '*',
1657  f->depending);
1658  }
1659  } else if (f->occurs_max > 1) {
1660  size = cb_build_binary_op (size, '*',
1661  cb_int (f->occurs_max));
1662  }
1663  e = e ? cb_build_binary_op (e, '+', size) : size;
1664  }
1665  return e;
1666 }
static cb_tree cb_build_memset ( cb_tree  x,
const int  c 
)
static

References CB_BUILD_CAST_ADDRESS, CB_BUILD_CAST_LENGTH, CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_3, cb_field_size(), cb_int(), and cb_literal::size.

Referenced by cb_build_move_high(), cb_build_move_low(), cb_build_move_num_zero(), cb_build_move_quote(), cb_build_move_space(), and cb_build_move_zero().

6498 {
6499  int size = cb_field_size (x);
6500 
6501  if (size == 1) {
6502  return CB_BUILD_FUNCALL_2 ("$E", x, cb_int (c));
6503  }
6504  return CB_BUILD_FUNCALL_3 ("memset",
6505  CB_BUILD_CAST_ADDRESS (x),
6506  cb_int (c), CB_BUILD_CAST_LENGTH (x));
6507 }
cb_tree cb_build_move ( cb_tree  src,
cb_tree  dst 
)

References CB_ALPHABET_NAME_P, cb_build_assign(), cb_build_cast_int(), CB_BUILD_FUNCALL_2, cb_build_move_field(), cb_build_move_high(), cb_build_move_literal(), cb_build_move_low(), cb_build_move_quote(), cb_build_move_space(), cb_build_move_zero(), CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, CB_CLASS_POINTER, cb_error_node, cb_high, CB_INDEX_P, CB_INTRINSIC_P, CB_LITERAL_P, cb_low, cb_null, cb_quote, CB_REFERENCE, CB_REFERENCE_P, cb_space, CB_TREE, CB_TREE_CATEGORY, CB_TREE_CLASS, cb_zero, check, cobc_parse_malloc(), cb_reference::flag_receiving, validate_move(), and value.

Referenced by cb_build_add(), cb_build_div(), cb_build_mul(), cb_build_sub(), cb_check_field_debug(), cb_emit_close(), cb_emit_move(), cb_emit_open(), cb_emit_read(), cb_emit_release(), cb_emit_return(), cb_emit_rewrite(), cb_emit_set_false(), cb_emit_set_to(), cb_emit_set_true(), cb_emit_write(), emit_move_corresponding(), and output_move().

7103 {
7104  struct cb_reference *x;
7105 
7106  if (src == cb_error_node || dst == cb_error_node) {
7107  return cb_error_node;
7108  }
7109 
7110  if (validate_move (src, dst, 0) < 0) {
7111  return cb_error_node;
7112  }
7113 
7114 #if 0 /* Flag receiving */
7115  if (CB_REFERENCE_P (src)) {
7116  CB_REFERENCE (src)->flag_receiving = 0;
7117  }
7118 #endif
7119 
7120  if (CB_REFERENCE_P (dst)) {
7121  /* Clone reference */
7122  x = cobc_parse_malloc (sizeof(struct cb_reference));
7123  *x = *CB_REFERENCE (dst);
7124  x->flag_receiving = 1;
7125  dst = CB_TREE (x);
7126  }
7127 
7128  if ((src == cb_space || src == cb_low ||
7129  src == cb_high || src == cb_quote) &&
7130  (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC ||
7131  CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED)) {
7132  src = cb_zero;
7133  }
7134 
7135  if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER ||
7136  CB_TREE_CLASS (src) == CB_CLASS_POINTER) {
7137  return cb_build_assign (dst, src);
7138  }
7139 
7140  if (CB_REFERENCE_P (src) &&
7141  CB_ALPHABET_NAME_P(CB_REFERENCE(src)->value)) {
7142  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7143  }
7144  if (CB_INDEX_P (dst)) {
7145  if (src == cb_null) {
7146  return cb_build_assign (dst, cb_zero);
7147  }
7148  return cb_build_assign (dst, src);
7149  }
7150 
7151  if (CB_INDEX_P (src)) {
7152  return CB_BUILD_FUNCALL_2 ("cob_set_int", dst,
7153  cb_build_cast_int (src));
7154  }
7155 
7156  if (CB_INTRINSIC_P (src) || CB_INTRINSIC_P (dst)) {
7157  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7158  }
7159 
7160  if (CB_REFERENCE_P (src) && CB_REFERENCE (src)->check) {
7161  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7162  }
7163  if (CB_REFERENCE_P (dst) && CB_REFERENCE (dst)->check) {
7164  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7165  }
7166 
7167  /* Output optimal code */
7168  if (src == cb_zero) {
7169  return cb_build_move_zero (dst);
7170  } else if (src == cb_space) {
7171  return cb_build_move_space (dst);
7172  } else if (src == cb_high) {
7173  return cb_build_move_high (dst);
7174  } else if (src == cb_low) {
7175  return cb_build_move_low (dst);
7176  } else if (src == cb_quote) {
7177  return cb_build_move_quote (dst);
7178  } else if (CB_LITERAL_P (src)) {
7179  return cb_build_move_literal (src, dst);
7180  }
7181  return cb_build_move_field (src, dst);
7182 }
static cb_tree cb_build_move_copy ( cb_tree  src,
cb_tree  dst 
)
static

References CB_BUILD_CAST_ADDRESS, CB_BUILD_CAST_LENGTH, CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_3, CB_FIELD_PTR, cb_field_size(), CB_STORAGE_LINKAGE, overlapping, and cb_literal::size.

Referenced by cb_build_move_field().

6511 {
6512  int size;
6513 
6514  size = cb_field_size (dst);
6515  if (size == 1) {
6516  return CB_BUILD_FUNCALL_2 ("$F", dst, src);
6517  }
6518  if (overlapping
6519  || CB_FIELD_PTR (src)->storage == CB_STORAGE_LINKAGE
6520  || CB_FIELD_PTR (dst)->storage == CB_STORAGE_LINKAGE) {
6521  overlapping = 0;
6522  return CB_BUILD_FUNCALL_3 ("memmove",
6523  CB_BUILD_CAST_ADDRESS (dst),
6524  CB_BUILD_CAST_ADDRESS (src),
6525  CB_BUILD_CAST_LENGTH (dst));
6526  } else {
6527  return CB_BUILD_FUNCALL_3 ("memcpy",
6528  CB_BUILD_CAST_ADDRESS (dst),
6529  CB_BUILD_CAST_ADDRESS (src),
6530  CB_BUILD_CAST_LENGTH (dst));
6531  }
6532 }
static cb_tree cb_build_move_field ( cb_tree  src,
cb_tree  dst 
)
static

References CB_BUILD_FUNCALL_2, cb_build_move_copy(), CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NUMERIC, CB_FIELD_PTR, cb_field_size(), cb_field_variable_size(), CB_TREE_CATEGORY, CB_USAGE_DISPLAY, cb_picture::digits, cb_field::flag_any_length, cb_field::flag_binary_swap, cb_field::flag_justified, cb_field::flag_sign_leading, cb_field::flag_sign_separate, cb_picture::have_sign, cb_field::pic, cb_picture::scale, cb_picture::size, and cb_field::usage.

Referenced by cb_build_move().

7041 {
7042  struct cb_field *src_f;
7043  struct cb_field *dst_f;
7044  int src_size;
7045  int dst_size;
7046 
7047  src_f = CB_FIELD_PTR (src);
7048  src_size = cb_field_size (src);
7049  dst_f = CB_FIELD_PTR (dst);
7050  dst_size = cb_field_size (dst);
7051 
7052  if (dst_f->flag_any_length || src_f->flag_any_length) {
7053  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7054  }
7055  if (src_size > 0 && dst_size > 0 && src_size >= dst_size &&
7056  !cb_field_variable_size (src_f) &&
7057  !cb_field_variable_size (dst_f)) {
7058  switch (CB_TREE_CATEGORY (src)) {
7059  case CB_CATEGORY_ALPHABETIC:
7060  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHABETIC ||
7061  CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC) {
7062  if (dst_f->flag_justified == 0) {
7063  return cb_build_move_copy (src, dst);
7064  }
7065  }
7066  break;
7067  case CB_CATEGORY_ALPHANUMERIC:
7068  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC) {
7069  if (dst_f->flag_justified == 0) {
7070  return cb_build_move_copy (src, dst);
7071  }
7072  }
7073  break;
7074  case CB_CATEGORY_NUMERIC:
7075  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC &&
7076  src_f->usage == dst_f->usage &&
7077  src_f->pic->size == dst_f->pic->size &&
7078  src_f->pic->digits == dst_f->pic->digits &&
7079  src_f->pic->scale == dst_f->pic->scale &&
7080  src_f->pic->have_sign == dst_f->pic->have_sign &&
7081  src_f->flag_binary_swap == dst_f->flag_binary_swap &&
7082  src_f->flag_sign_leading == dst_f->flag_sign_leading &&
7083  src_f->flag_sign_separate == dst_f->flag_sign_separate) {
7084  return cb_build_move_copy (src, dst);
7085  } else if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC
7086  && src_f->usage == CB_USAGE_DISPLAY
7087  && src_f->pic->have_sign == 0
7088  && !src_f->flag_sign_leading
7089  && !src_f->flag_sign_separate) {
7090  return cb_build_move_copy (src, dst);
7091  }
7092  break;
7093  default:
7094  break;
7095  }
7096  }
7097 
7098  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7099 }
static cb_tree cb_build_move_high ( cb_tree  x)
static

References CB_BUILD_FUNCALL_2, cb_build_memset(), CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NUMERIC, CB_FIELD_PTR, cb_high, cb_norm_high, CB_TREE_CATEGORY, and cb_field::flag_any_length.

Referenced by cb_build_move().

6636 {
6637  switch (CB_TREE_CATEGORY (x)) {
6638  case CB_CATEGORY_NUMERIC:
6639  case CB_CATEGORY_ALPHABETIC:
6640  case CB_CATEGORY_ALPHANUMERIC:
6641  if (CB_FIELD_PTR (x)->flag_any_length) {
6642  return CB_BUILD_FUNCALL_2 ("cob_move", cb_high, x);
6643  }
6644  if (cb_high == cb_norm_high) {
6645  return cb_build_memset (x, 255);
6646  }
6647  /* Fall through */
6648  default:
6649  return CB_BUILD_FUNCALL_2 ("cob_move", cb_high, x);
6650  }
6651 }
static cb_tree cb_build_move_literal ( cb_tree  src,
cb_tree  dst 
)
static

References cb_literal::all, cb_build_assign(), CB_BUILD_CAST_ADDRESS, CB_BUILD_CAST_LENGTH, cb_build_cast_llint(), CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_3, cb_build_move_num_zero(), cb_build_string(), CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, CB_FIELD_PTR, cb_field_variable_size(), cb_fits_int(), cb_get_int(), cb_int(), CB_LITERAL, CB_STORAGE_LINKAGE, CB_TREE_CATEGORY, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_6, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_PACKED, cob_put_sign_ascii(), cob_put_sign_ebcdic(), cobc_parse_free(), cobc_parse_malloc(), cb_literal::data, cb_field::flag_binary_swap, cb_field::flag_blank_zero, cb_field::flag_justified, cb_field::flag_sign_leading, cb_field::flag_sign_separate, cb_picture::have_sign, cb_field::indexes, cb_field::offset, optim_table::optim_val, optimize_defs, p, cb_field::pic, cb_literal::scale, cb_picture::scale, cb_literal::sign, cb_literal::size, cb_field::size, cb_field::storage, and cb_field::usage.

Referenced by cb_build_move().

6808 {
6809  struct cb_literal *l;
6810  struct cb_field *f;
6811  unsigned char *buff;
6812  unsigned char *p;
6813  enum cb_category cat;
6814  int i;
6815  int diff;
6816  int val;
6817  int n;
6818  unsigned char bbyte;
6819 
6820  l = CB_LITERAL (src);
6821  f = CB_FIELD_PTR (dst);
6822  cat = CB_TREE_CATEGORY (dst);
6823 
6824  if (l->all) {
6825  if (cat == CB_CATEGORY_NUMERIC ||
6826  cat == CB_CATEGORY_NUMERIC_EDITED) {
6827  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
6828  }
6829  if (l->size == 1) {
6830  return CB_BUILD_FUNCALL_3 ("memset",
6831  CB_BUILD_CAST_ADDRESS (dst),
6832  cb_int (l->data[0]),
6833  CB_BUILD_CAST_LENGTH (dst));
6834  }
6835  bbyte = l->data[0];
6836  for (i = 0; i < (int)l->size; i++) {
6837  if (bbyte != l->data[i]) {
6838  break;
6839  }
6840  bbyte = l->data[i];
6841  }
6842  if (i == (int)l->size) {
6843  return CB_BUILD_FUNCALL_3 ("memset",
6844  CB_BUILD_CAST_ADDRESS (dst),
6845  cb_int (l->data[0]),
6846  CB_BUILD_CAST_LENGTH (dst));
6847  }
6848  if (f->size > 128) {
6849  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
6850  }
6851  buff = cobc_parse_malloc ((size_t)f->size);
6852  for (i = 0; i < f->size; i++) {
6853  buff[i] = l->data[i % l->size];
6854  }
6855  return CB_BUILD_FUNCALL_3 ("memcpy",
6856  CB_BUILD_CAST_ADDRESS (dst),
6857  cb_build_string (buff, (size_t)f->size),
6858  CB_BUILD_CAST_LENGTH (dst));
6859  }
6860 
6861  if (cat == CB_CATEGORY_NUMERIC_EDITED) {
6862  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
6863  }
6864 
6865  if ((cat == CB_CATEGORY_NUMERIC &&
6866  f->usage == CB_USAGE_DISPLAY &&
6867  f->pic->scale == l->scale &&
6868  !f->flag_sign_leading && !f->flag_sign_separate &&
6869  !f->flag_blank_zero) ||
6870  ((cat == CB_CATEGORY_ALPHABETIC ||
6871  cat == CB_CATEGORY_ALPHANUMERIC) &&
6872  f->size < (int) (l->size + 16) &&
6873  !cb_field_variable_size (f))) {
6874  buff = cobc_parse_malloc ((size_t)f->size);
6875  diff = (int) (f->size - l->size);
6876  if (cat == CB_CATEGORY_NUMERIC) {
6877  if (diff <= 0) {
6878  memcpy (buff, l->data - diff, (size_t)f->size);
6879  } else {
6880  memset (buff, '0', (size_t)diff);
6881  memcpy (buff + diff, l->data, (size_t)l->size);
6882  }
6883  /* Check all zeros */
6884  n = 0;
6885  for (p = buff; p < buff + f->size; p++) {
6886  if (*p != '0') {
6887  n = 1;
6888  break;
6889  }
6890  }
6891  if (f->pic->have_sign) {
6892  p = &buff[f->size - 1];
6893  if (!n) {
6894  /* Zeros */
6895  /* EBCDIC - store sign otherwise nothing */
6896  if (cb_ebcdic_sign) {
6897  cob_put_sign_ebcdic (p, 1);
6898  }
6899  } else if (cb_ebcdic_sign) {
6900  cob_put_sign_ebcdic (p, l->sign);
6901  } else if (l->sign < 0) {
6902 #ifdef COB_EBCDIC_MACHINE
6903  cob_put_sign_ascii (p);
6904 #else
6905  *p += 0x40;
6906 #endif
6907  }
6908  }
6909  } else {
6910  if (f->flag_justified) {
6911  if (diff <= 0) {
6912  memcpy (buff, l->data - diff, (size_t)f->size);
6913  } else {
6914  memset (buff, ' ', (size_t)diff);
6915  memcpy (buff + diff, l->data, (size_t)l->size);
6916  }
6917  } else {
6918  if (diff <= 0) {
6919  memcpy (buff, l->data, (size_t)f->size);
6920  } else {
6921  memcpy (buff, l->data, (size_t)l->size);
6922  memset (buff + l->size, ' ', (size_t)diff);
6923  }
6924  }
6925  }
6926  bbyte = *buff;
6927  if (f->size == 1) {
6928  cobc_parse_free (buff);
6929  return CB_BUILD_FUNCALL_2 ("$E", dst, cb_int (bbyte));
6930  }
6931  for (i = 0; i < f->size; i++) {
6932  if (bbyte != buff[i]) {
6933  break;
6934  }
6935  }
6936  if (i == f->size) {
6937  cobc_parse_free (buff);
6938  return CB_BUILD_FUNCALL_3 ("memset",
6939  CB_BUILD_CAST_ADDRESS (dst),
6940  cb_int (bbyte),
6941  CB_BUILD_CAST_LENGTH (dst));
6942  }
6943  return CB_BUILD_FUNCALL_3 ("memcpy",
6944  CB_BUILD_CAST_ADDRESS (dst),
6945  cb_build_string (buff, (size_t)f->size),
6946  CB_BUILD_CAST_LENGTH (dst));
6947  }
6948 
6949  if ((f->usage == CB_USAGE_BINARY ||
6950  f->usage == CB_USAGE_COMP_5 ||
6951  f->usage == CB_USAGE_COMP_X) &&
6952  cb_fits_int (src) && f->size <= 8) {
6953  val = cb_get_int (src);
6954  n = f->pic->scale - l->scale;
6955  if ((l->size + n) > 9) {
6956  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
6957  }
6958  for (; n > 0; n--) {
6959  val *= 10;
6960  }
6961  for (; n < 0; n++) {
6962  val /= 10;
6963  }
6964  if (val == 0) {
6965  return cb_build_move_num_zero (dst);
6966  }
6967  if (val < 0 && !f->pic->have_sign) {
6968  val = -val;
6969  }
6970  if (f->size == 1) {
6971  return cb_build_assign (dst, cb_int (val));
6972  }
6973  if (f->flag_binary_swap) {
6974  i = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0));
6975  optimize_defs[bin_set_funcs[i].optim_val] = 1;
6976  return CB_BUILD_FUNCALL_2 (bin_set_funcs[i].optim_name,
6977  CB_BUILD_CAST_ADDRESS (dst),
6978  cb_int (val));
6979  }
6980  switch (f->size) {
6981  case 2:
6982 #ifdef COB_SHORT_BORK
6983  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
6984  (f->offset % 4 == 0)) {
6985  return cb_build_assign (dst, cb_int (val));
6986  }
6987  break;
6988 #endif
6989  case 4:
6990  case 8:
6991 #ifdef COB_NON_ALIGNED
6992  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
6993  (f->offset % f->size == 0)) {
6994  return cb_build_assign (dst, cb_int (val));
6995  }
6996  break;
6997 #else
6998  return cb_build_assign (dst, cb_int (val));
6999 #endif
7000  default:
7001  break;
7002  }
7003  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7004  }
7005 
7006  if ((f->usage == CB_USAGE_PACKED || f->usage == CB_USAGE_COMP_6) &&
7007  cb_fits_int (src)) {
7008  if (f->pic->scale < 0) {
7009  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7010  }
7011  val = cb_get_int (src);
7012  n = f->pic->scale - l->scale;
7013  if ((l->size + n) > 9) {
7014  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7015  }
7016  for (; n > 0; n--) {
7017  val *= 10;
7018  }
7019  for (; n < 0; n++) {
7020  val /= 10;
7021  }
7022  if (val == 0) {
7023  return cb_build_move_num_zero (dst);
7024  }
7025  if (val < 0 && !f->pic->have_sign) {
7026  val = -val;
7027  }
7028 #if 1 /* RXWRXW - Set packed */
7029  return CB_BUILD_FUNCALL_2 ("cob_set_packed_int", dst,
7030  cb_int (val));
7031 #else
7032  return CB_BUILD_FUNCALL_2 ("cob_set_packed_int", dst,
7033  cb_build_cast_llint (src));
7034 #endif
7035  }
7036  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7037 }
static cb_tree cb_build_move_low ( cb_tree  x)
static

References CB_BUILD_FUNCALL_2, cb_build_memset(), CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NUMERIC, CB_FIELD_PTR, cb_low, cb_norm_low, CB_TREE_CATEGORY, and cb_field::flag_any_length.

Referenced by cb_build_move().

6655 {
6656  switch (CB_TREE_CATEGORY (x)) {
6657  case CB_CATEGORY_NUMERIC:
6658  case CB_CATEGORY_ALPHABETIC:
6659  case CB_CATEGORY_ALPHANUMERIC:
6660  if (CB_FIELD_PTR (x)->flag_any_length) {
6661  return CB_BUILD_FUNCALL_2 ("cob_move", cb_low, x);
6662  }
6663  if (cb_low == cb_norm_low) {
6664  return cb_build_memset (x, 0);
6665  }
6666  /* Fall through */
6667  default:
6668  return CB_BUILD_FUNCALL_2 ("cob_move", cb_low, x);
6669  }
6670 }
static cb_tree cb_build_move_num_zero ( cb_tree  x)
static

References cb_build_assign(), CB_BUILD_FUNCALL_1, CB_BUILD_FUNCALL_2, cb_build_memset(), CB_FIELD_PTR, cb_int0, CB_STORAGE_LINKAGE, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_6, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_PACKED, cb_zero, cb_field::flag_binary_swap, cb_picture::have_sign, cb_field::indexes, cb_field::offset, cb_field::pic, cb_field::size, cb_field::storage, and cb_field::usage.

Referenced by cb_build_move_literal(), and cb_build_move_zero().

6536 {
6537  struct cb_field *f;
6538 
6539  f = CB_FIELD_PTR (x);
6540  switch (f->usage) {
6541  case CB_USAGE_BINARY:
6542  case CB_USAGE_COMP_5:
6543  case CB_USAGE_COMP_X:
6544  if (f->flag_binary_swap) {
6545  return cb_build_memset (x, 0);
6546  }
6547  switch (f->size) {
6548 #ifdef COB_NON_ALIGNED
6549  case 1:
6550  return cb_build_assign (x, cb_int0);
6551  case 2:
6552 #ifdef COB_SHORT_BORK
6553  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
6554  (f->offset % 4 == 0)) {
6555  return cb_build_assign (x, cb_int0);
6556  }
6557  break;
6558 #endif
6559  case 4:
6560  case 8:
6561  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
6562  (f->offset % f->size == 0)) {
6563  return cb_build_assign (x, cb_int0);
6564  }
6565  break;
6566 #else
6567  case 1:
6568  case 2:
6569  case 4:
6570  case 8:
6571  return cb_build_assign (x, cb_int0);
6572 #endif
6573  default:
6574  break;
6575  }
6576  return cb_build_memset (x, 0);
6577  case CB_USAGE_DISPLAY:
6578  if (!cb_ebcdic_sign) {
6579  return cb_build_memset (x, '0');
6580  }
6581  if (f->pic && !f->pic->have_sign) {
6582  return cb_build_memset (x, '0');
6583  }
6584  break;
6585  case CB_USAGE_PACKED:
6586  return CB_BUILD_FUNCALL_1 ("cob_set_packed_zero", x);
6587  case CB_USAGE_COMP_6:
6588  return cb_build_memset (x, 0);
6589  default:
6590  break;
6591  }
6592  return CB_BUILD_FUNCALL_2 ("cob_move", cb_zero, x);
6593 }
static cb_tree cb_build_move_quote ( cb_tree  x)
static

References CB_BUILD_FUNCALL_2, cb_build_memset(), CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NUMERIC, CB_FIELD_PTR, cb_quote, CB_TREE_CATEGORY, and cb_field::flag_any_length.

Referenced by cb_build_move().

6674 {
6675  switch (CB_TREE_CATEGORY (x)) {
6676  case CB_CATEGORY_NUMERIC:
6677  case CB_CATEGORY_ALPHABETIC:
6678  case CB_CATEGORY_ALPHANUMERIC:
6679  if (!CB_FIELD_PTR (x)->flag_any_length) {
6680  return cb_build_memset (x, cb_flag_apostrophe ? '\'' : '"');
6681  }
6682  /* Fall through */
6683  default:
6684  return CB_BUILD_FUNCALL_2 ("cob_move", cb_quote, x);
6685  }
6686 }
static cb_tree cb_build_move_space ( cb_tree  x)
static

References CB_BUILD_FUNCALL_2, cb_build_memset(), CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NUMERIC, CB_FIELD_PTR, cb_space, CB_TREE_CATEGORY, and cb_field::flag_any_length.

Referenced by cb_build_move(), and cb_build_move_zero().

6597 {
6598  switch (CB_TREE_CATEGORY (x)) {
6599  case CB_CATEGORY_NUMERIC:
6600  case CB_CATEGORY_ALPHABETIC:
6601  case CB_CATEGORY_ALPHANUMERIC:
6602  if (!CB_FIELD_PTR (x)->flag_any_length) {
6603  return cb_build_memset (x, ' ');
6604  }
6605  /* Fall through */
6606  default:
6607  return CB_BUILD_FUNCALL_2 ("cob_move", cb_space, x);
6608  }
6609 }
static cb_tree cb_build_move_zero ( cb_tree  x)
static

References CB_BUILD_FUNCALL_2, cb_build_memset(), cb_build_move_num_zero(), cb_build_move_space(), CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NUMERIC, CB_FIELD_PTR, CB_TREE_CATEGORY, cb_zero, cb_field::flag_any_length, cb_field::flag_blank_zero, and cb_field::flag_sign_separate.

Referenced by cb_build_move().

6613 {
6614  switch (CB_TREE_CATEGORY (x)) {
6615  case CB_CATEGORY_NUMERIC:
6616  if (CB_FIELD_PTR (x)->flag_blank_zero) {
6617  return cb_build_move_space (x);
6618  } else if (CB_FIELD_PTR (x)->flag_sign_separate) {
6619  return CB_BUILD_FUNCALL_2 ("cob_move", cb_zero, x);
6620  } else {
6621  return cb_build_move_num_zero (x);
6622  }
6623  case CB_CATEGORY_ALPHABETIC:
6624  case CB_CATEGORY_ALPHANUMERIC:
6625  if (!CB_FIELD_PTR (x)->flag_any_length) {
6626  return cb_build_memset (x, '0');
6627  }
6628  /* Fall through */
6629  default:
6630  return CB_BUILD_FUNCALL_2 ("cob_move", cb_zero, x);
6631  }
6632 }
static cb_tree cb_build_mul ( cb_tree  v,
cb_tree  n,
cb_tree  round_opt 
)
static

References build_store_option(), cb_build_binary_op(), CB_BUILD_FUNCALL_3, cb_build_move(), CB_FIELD_PTR, CB_INDEX_P, CB_REF_OR_FIELD_P, and cb_field::count.

Referenced by cb_emit_arithmetic().

3292 {
3293  cb_tree opt;
3294  struct cb_field *f;
3295 
3296  if (CB_INDEX_P (v)) {
3297  return cb_build_move (cb_build_binary_op (v, '*', n), v);
3298  }
3299 
3300  if (CB_REF_OR_FIELD_P (v)) {
3301  f = CB_FIELD_PTR (v);
3302  f->count++;
3303  }
3304  if (CB_REF_OR_FIELD_P (n)) {
3305  f = CB_FIELD_PTR (n);
3306  f->count++;
3307  }
3308  opt = build_store_option (v, round_opt);
3309  return CB_BUILD_FUNCALL_3 ("cob_mul", v, n, opt);
3310 }
static cb_tree cb_build_optim_add ( cb_tree  v,
cb_tree  n 
)
static

References cb_build_assign(), cb_build_binary_op(), CB_BUILD_CAST_ADDRESS, cb_build_cast_int(), CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_3, CB_FIELD_PTR, cb_int0, CB_REF_OR_FIELD_P, CB_STORAGE_LINKAGE, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_X, CB_USAGE_PACKED, cb_picture::digits, cb_field::flag_binary_swap, cb_picture::have_sign, cb_field::indexes, cb_field::offset, optim_table::optim_val, optimize_defs, cb_field::pic, cb_picture::scale, cb_field::size, cb_field::storage, and cb_field::usage.

Referenced by cb_build_add().

3801 {
3802  size_t z;
3803  const char *s;
3804  struct cb_field *f;
3805 
3806  if (CB_REF_OR_FIELD_P (v)) {
3807  f = CB_FIELD_PTR (v);
3808  if (!f->pic) {
3809  return CB_BUILD_FUNCALL_3 ("cob_add_int", v,
3810  cb_build_cast_int (n),
3811  cb_int0);
3812  }
3813  if (!f->pic->scale && (f->usage == CB_USAGE_BINARY ||
3814  f->usage == CB_USAGE_COMP_5 ||
3815  f->usage == CB_USAGE_COMP_X)) {
3816  z = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0)) +
3817  (16 * (f->flag_binary_swap ? 1 : 0));
3818 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
3819  switch (f->size) {
3820  case 2:
3821 #ifdef COB_SHORT_BORK
3822  optimize_defs[bin_add_funcs[z].optim_val] = 1;
3823  s = bin_add_funcs[z].optim_name;
3824  break;
3825 #endif
3826  case 4:
3827  case 8:
3828  if (f->storage != CB_STORAGE_LINKAGE &&
3829  f->indexes == 0 &&
3830  (f->offset % f->size) == 0) {
3831  optimize_defs[align_bin_add_funcs[z].optim_val] = 1;
3832  s = align_bin_add_funcs[z].optim_name;
3833  } else {
3834  optimize_defs[bin_add_funcs[z].optim_val] = 1;
3835  s = bin_add_funcs[z].optim_name;
3836  }
3837  break;
3838  default:
3839  optimize_defs[bin_add_funcs[z].optim_val] = 1;
3840  s = bin_add_funcs[z].optim_name;
3841  break;
3842  }
3843 #else
3844  if (f->usage == CB_USAGE_COMP_5) {
3845  switch (f->size) {
3846  case 1:
3847  case 2:
3848  case 4:
3849  case 8:
3850  return cb_build_assign (v, cb_build_binary_op (v, '+', n));
3851  default:
3852  break;
3853  }
3854  }
3855  optimize_defs[bin_add_funcs[z].optim_val] = 1;
3856  s = bin_add_funcs[z].optim_name;
3857 #endif
3858  if (s) {
3859  return CB_BUILD_FUNCALL_2 (s,
3860  CB_BUILD_CAST_ADDRESS (v),
3861  cb_build_cast_int (n));
3862  }
3863  } else if (!f->pic->scale && f->usage == CB_USAGE_PACKED &&
3864  f->pic->digits < 10) {
3865  optimize_defs[COB_ADD_PACKED_INT] = 1;
3866  return CB_BUILD_FUNCALL_2 ("cob_add_packed_int",
3867  v, cb_build_cast_int (n));
3868  }
3869  }
3870  return CB_BUILD_FUNCALL_3 ("cob_add_int", v,
3871  cb_build_cast_int (n), cb_int0);
3872 }
static cb_tree cb_build_optim_cond ( struct cb_binary_op *  p)
static

References CB_BUILD_CAST_ADDRESS, cb_build_cast_int(), cb_build_cast_llint(), CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_4, CB_FIELD_PTR, cb_fits_long_long(), cb_int(), CB_REF_OR_FIELD_P, CB_STORAGE_LINKAGE, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_6, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_INDEX, CB_USAGE_PACKED, cb_picture::digits, cb_field::flag_any_numeric, cb_field::flag_binary_swap, cb_field::flag_sign_leading, cb_field::flag_sign_separate, cb_picture::have_sign, cb_field::indexes, cb_field::offset, optim_table::optim_val, optimize_defs, cb_field::pic, cb_picture::scale, cb_field::size, cb_field::special_index, cb_field::storage, cb_field::usage, cb_binary_op::x, and cb_binary_op::y.

Referenced by cb_build_cond().

3482 {
3483  struct cb_field *f;
3484  const char *s;
3485  size_t n;
3486 
3487 #if 0 /* RXWRXW - US */
3488  struct cb_field *fy;
3489  if (CB_REF_OR_FIELD_P (p->y)) {
3490  fy = CB_FIELD_PTR (p->y);
3491  if (!fy->pic->have_sign && (fy->usage == CB_USAGE_BINARY ||
3492  fy->usage == CB_USAGE_COMP_5 ||
3493  fy->usage == CB_USAGE_COMP_X)) {
3494  return CB_BUILD_FUNCALL_2 ("cob_cmp_uint", p->x,
3495  cb_build_cast_int (p->y));
3496  }
3497  }
3498 #endif
3499 
3500  if (!CB_REF_OR_FIELD_P (p->x)) {
3501  return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
3502  cb_build_cast_llint (p->y));
3503  }
3504 
3505  f = CB_FIELD_PTR (p->x);
3506 #if 0 /* RXWRXW - SI */
3507  if (f->special_index) {
3508  return CB_BUILD_FUNCALL_2 ("cob_cmp_special",
3509  cb_build_cast_int (p->x),
3510  cb_build_cast_int (p->y));
3511  }
3512 #endif
3513  if (f->pic->scale || f->flag_any_numeric) {
3514  return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
3515  cb_build_cast_llint (p->y));
3516  }
3517  if (f->usage == CB_USAGE_PACKED) {
3518  if (f->pic->digits < 19) {
3519  optimize_defs[COB_CMP_PACKED_INT] = 1;
3520  return CB_BUILD_FUNCALL_2 ("cob_cmp_packed_int",
3521  p->x,
3522  cb_build_cast_llint (p->y));
3523  } else {
3524  return CB_BUILD_FUNCALL_2 ("cob_cmp_packed",
3525  p->x,
3526  cb_build_cast_llint (p->y));
3527  }
3528  }
3529  if (f->usage == CB_USAGE_COMP_6) {
3530  return CB_BUILD_FUNCALL_2 ("cob_cmp_packed",
3531  p->x,
3532  cb_build_cast_llint (p->y));
3533  }
3534  if (f->usage == CB_USAGE_DISPLAY &&
3535  !f->flag_sign_leading && !f->flag_sign_separate) {
3536  if (cb_fits_long_long (p->x)) {
3537  return CB_BUILD_FUNCALL_4 ("cob_cmp_numdisp",
3538  CB_BUILD_CAST_ADDRESS (p->x),
3539  cb_int (f->size),
3540  cb_build_cast_llint (p->y),
3541  cb_int (f->pic->have_sign ? 1 : 0));
3542  }
3543  return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
3544  cb_build_cast_llint (p->y));
3545  }
3546  if (f->usage == CB_USAGE_BINARY ||
3547  f->usage == CB_USAGE_COMP_5 ||
3548  f->usage == CB_USAGE_INDEX ||
3549  f->usage == CB_USAGE_COMP_X) {
3550  n = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0)) +
3551  (16 * (f->flag_binary_swap ? 1 : 0));
3552 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
3553  switch (f->size) {
3554  case 2:
3555 #ifdef COB_SHORT_BORK
3556  optimize_defs[bin_compare_funcs[n].optim_val] = 1;
3557  s = bin_compare_funcs[n].optim_name;
3558  break;
3559 #endif
3560  case 4:
3561  case 8:
3562  if (f->storage != CB_STORAGE_LINKAGE &&
3563  f->indexes == 0 && (f->offset % f->size) == 0) {
3564  optimize_defs[align_bin_compare_funcs[n].optim_val] = 1;
3565  s = align_bin_compare_funcs[n].optim_name;
3566  } else {
3567  optimize_defs[bin_compare_funcs[n].optim_val] = 1;
3568  s = bin_compare_funcs[n].optim_name;
3569  }
3570  break;
3571  default:
3572  optimize_defs[bin_compare_funcs[n].optim_val] = 1;
3573  s = bin_compare_funcs[n].optim_name;
3574  break;
3575  }
3576 #else
3577  optimize_defs[bin_compare_funcs[n].optim_val] = 1;
3578  s = bin_compare_funcs[n].optim_name;
3579 #endif
3580  if (s) {
3581  return CB_BUILD_FUNCALL_2 (s,
3582  CB_BUILD_CAST_ADDRESS (p->x),
3583  cb_build_cast_llint (p->y));
3584  }
3585  }
3586  return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
3587  cb_build_cast_llint (p->y));
3588 }
static cb_tree cb_build_optim_sub ( cb_tree  v,
cb_tree  n 
)
static

References cb_build_assign(), cb_build_binary_op(), CB_BUILD_CAST_ADDRESS, cb_build_cast_int(), CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_3, CB_FIELD_PTR, cb_int0, CB_REF_OR_FIELD_P, CB_STORAGE_LINKAGE, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_X, cb_field::flag_binary_swap, cb_picture::have_sign, cb_field::indexes, cb_field::offset, optim_table::optim_val, optimize_defs, cb_field::pic, cb_picture::scale, cb_field::size, cb_field::storage, and cb_field::usage.

Referenced by cb_build_sub().

3876 {
3877  size_t z;
3878  const char *s;
3879  struct cb_field *f;
3880 
3881  if (CB_REF_OR_FIELD_P (v)) {
3882  f = CB_FIELD_PTR (v);
3883  if (!f->pic->scale && (f->usage == CB_USAGE_BINARY ||
3884  f->usage == CB_USAGE_COMP_5 ||
3885  f->usage == CB_USAGE_COMP_X)) {
3886  z = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0)) +
3887  (16 * (f->flag_binary_swap ? 1 : 0));
3888 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
3889  switch (f->size) {
3890  case 2:
3891 #ifdef COB_SHORT_BORK
3892  optimize_defs[bin_sub_funcs[z].optim_val] = 1;
3893  s = bin_sub_funcs[z].optim_name;
3894  break;
3895 #endif
3896  case 4:
3897  case 8:
3898  if (f->storage != CB_STORAGE_LINKAGE &&
3899  f->indexes == 0 && (f->offset % f->size) == 0) {
3900  optimize_defs[align_bin_sub_funcs[z].optim_val] = 1;
3901  s = align_bin_sub_funcs[z].optim_name;
3902  } else {
3903  optimize_defs[bin_sub_funcs[z].optim_val] = 1;
3904  s = bin_sub_funcs[z].optim_name;
3905  }
3906  break;
3907  default:
3908  optimize_defs[bin_sub_funcs[z].optim_val] = 1;
3909  s = bin_sub_funcs[z].optim_name;
3910  break;
3911  }
3912 #else
3913  if (f->usage == CB_USAGE_COMP_5) {
3914  switch (f->size) {
3915  case 1:
3916  case 2:
3917  case 4:
3918  case 8:
3919  return cb_build_assign (v, cb_build_binary_op (v, '-', n));
3920  default:
3921  break;
3922  }
3923  }
3924  optimize_defs[bin_sub_funcs[z].optim_val] = 1;
3925  s = bin_sub_funcs[z].optim_name;
3926 #endif
3927  if (s) {
3928  return CB_BUILD_FUNCALL_2 (s,
3929  CB_BUILD_CAST_ADDRESS (v),
3930  cb_build_cast_int (n));
3931  }
3932  }
3933  }
3934  return CB_BUILD_FUNCALL_3 ("cob_sub_int", v,
3935  cb_build_cast_int (n), cb_int0);
3936 }
cb_tree cb_build_perform_exit ( struct cb_label *  label)

References cb_build_perform(), CB_PERFORM, CB_PERFORM_EXIT, and CB_TREE.

7344 {
7345  cb_tree x;
7346 
7347  x = cb_build_perform (CB_PERFORM_EXIT);
7348  CB_PERFORM (x)->data = CB_TREE (label);
7349  return x;
7350 }
cb_tree cb_build_perform_forever ( cb_tree  body)

References cb_build_perform(), cb_error_node, CB_PERFORM, and CB_PERFORM_FOREVER.

7331 {
7332  cb_tree x;
7333 
7334  if (body == cb_error_node) {
7335  return cb_error_node;
7336  }
7337  x = cb_build_perform (CB_PERFORM_FOREVER);
7338  CB_PERFORM (x)->body = body;
7339  return x;
7340 }
cb_tree cb_build_perform_once ( cb_tree  body)

References cb_build_perform(), cb_error_node, CB_PERFORM, and CB_PERFORM_ONCE.

Referenced by cb_emit_sort_input(), and cb_emit_sort_output().

7293 {
7294  cb_tree x;
7295 
7296  if (body == cb_error_node) {
7297  return cb_error_node;
7298  }
7299  x = cb_build_perform (CB_PERFORM_ONCE);
7300  CB_PERFORM (x)->body = body;
7301  return x;
7302 }
cb_tree cb_build_perform_times ( cb_tree  times)

References cb_build_perform(), cb_check_integer_value(), cb_error_node, CB_PERFORM, and CB_PERFORM_TIMES.

7306 {
7307  cb_tree x;
7308 
7309  if (cb_check_integer_value (times) == cb_error_node) {
7310  return cb_error_node;
7311  }
7312 
7313  x = cb_build_perform (CB_PERFORM_TIMES);
7314  CB_PERFORM (x)->data = times;
7315  return x;
7316 }
cb_tree cb_build_perform_until ( cb_tree  condition,
cb_tree  varying 
)

References cb_build_perform(), CB_PERFORM, and CB_PERFORM_UNTIL.

7320 {
7321  cb_tree x;
7322 
7323  x = cb_build_perform (CB_PERFORM_UNTIL);
7324  CB_PERFORM (x)->test = condition;
7325  CB_PERFORM (x)->varying = varying;
7326  return x;
7327 }
cb_tree cb_build_ppointer ( cb_tree  x)

References CB_BUILD_CAST_PPOINTER, cb_error_node, CB_FIELD_PTR, cb_ref(), CB_REFERENCE_P, and cb_field::count.

1764 {
1765  struct cb_field *f;
1766 
1767  if (x == cb_error_node ||
1768  (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node)) {
1769  return cb_error_node;
1770  }
1771 
1772  if (CB_REFERENCE_P (x)) {
1773  f = CB_FIELD_PTR (cb_ref(x));
1774  f->count++;
1775  }
1776  return CB_BUILD_CAST_PPOINTER (x);
1777 }
char* cb_build_program_id ( cb_tree  name,
cb_tree  alt_name,
const cob_u32_t  is_func 
)

References cb_encode_program_id(), CB_LITERAL, CB_LITERAL_P, CB_NAME, cob_u8_t, cobc_check_string(), cobc_check_valid_name(), current_program, cb_program::orig_program_id, and p.

1170 {
1171  char *s;
1172  unsigned char *p;
1173 
1174  if (alt_name) {
1175  current_program->orig_program_id =
1176  cobc_check_string ((char *)CB_LITERAL (alt_name)->data);
1177  s = cb_encode_program_id ((char *)CB_LITERAL (alt_name)->data);
1178  } else if (CB_LITERAL_P (name)) {
1179  current_program->orig_program_id =
1180  cobc_check_string ((char *)CB_LITERAL (name)->data);
1181  s = cb_encode_program_id ((char *)CB_LITERAL (name)->data);
1182  } else {
1183  current_program->orig_program_id =
1184  cobc_check_string (CB_NAME (name));
1185  s = cb_encode_program_id (CB_NAME (name));
1186  }
1187  (void)cobc_check_valid_name (current_program->orig_program_id, 2U);
1188  if (is_func) {
1189  for (p = (unsigned char *)s; *p; ++p) {
1190  if (islower ((int)*p)) {
1191  *p = (cob_u8_t)toupper ((int)*p);
1192  }
1193  }
1194  }
1195  return s;
1196 }
void cb_build_registers ( void  )

References cb_build_alphanumeric_literal(), cb_build_constant(), cb_build_index(), cb_build_reference(), cb_program::cb_call_params, CB_FIELD_PTR, cb_intr_whencomp, cb_program::cb_return_code, cb_program::cb_sort_return, cb_zero, current_program, cb_program::nested_level, and NULL.

1045 {
1046 #if !defined(__linux__) && !defined(__CYGWIN__) && defined(HAVE_TIMEZONE)
1047  long contz;
1048 #endif
1049  cb_tree x;
1050  struct tm *tlt;
1051  time_t t;
1052  char buff[48];
1053 
1054  /* RETURN-CODE */
1055  if (!current_program->nested_level) {
1056  x = cb_build_index (cb_build_reference ("RETURN-CODE"),
1057  cb_zero, 0, NULL);
1058  CB_FIELD_PTR (x)->special_index = 1;
1059  current_program->cb_return_code = x;
1060  }
1061 
1062  /* SORT-RETURN */
1063  x = cb_build_index (cb_build_reference ("SORT-RETURN"),
1064  cb_zero, 0, NULL);
1065  CB_FIELD_PTR (x)->flag_no_init = 1;
1066  current_program->cb_sort_return = x;
1067 
1068  /* NUMBER-OF-CALL-PARAMETERS */
1069  x = cb_build_index (cb_build_reference ("NUMBER-OF-CALL-PARAMETERS"),
1070  cb_zero, 0, NULL);
1071  CB_FIELD_PTR (x)->flag_no_init = 1;
1072  CB_FIELD_PTR (x)->flag_local = 1;
1073  CB_FIELD_PTR (x)->special_index = 2;
1074  current_program->cb_call_params = x;
1075 
1076  t = time (NULL);
1077  tlt = localtime (&t);
1078  /* Leap seconds ? */
1079  if (tlt->tm_sec >= 60) {
1080  tlt->tm_sec = 59;
1081  }
1082 
1083  /* WHEN-COMPILED */
1084  memset (buff, 0, sizeof (buff));
1085  strftime (buff, (size_t)17, "%m/%d/%y%H.%M.%S", tlt);
1086  cb_build_constant (cb_build_reference ("WHEN-COMPILED"),
1087  cb_build_alphanumeric_literal (buff, (size_t)16));
1088 
1089  /* FUNCTION WHEN-COMPILED */
1090  memset (buff, 0, sizeof (buff));
1091 #if defined(__linux__) || defined(__CYGWIN__)
1092  strftime (buff, (size_t)22, "%Y%m%d%H%M%S00%z", tlt);
1093 #elif defined(HAVE_TIMEZONE)
1094  strftime (buff, (size_t)17, "%Y%m%d%H%M%S00", tlt);
1095  if (timezone <= 0) {
1096  contz = -timezone;
1097  buff[16] = '+';
1098  } else {
1099  contz = timezone;
1100  buff[16] = '-';
1101  }
1102  sprintf (&buff[17], "%2.2ld%2.2ld", contz / 3600, contz % 60);
1103 #else
1104  strftime (buff, (size_t)22, "%Y%m%d%H%M%S0000000", tlt);
1105 #endif
1106  cb_intr_whencomp = cb_build_alphanumeric_literal (buff, (size_t)21);
1107 
1108 }
cb_tree cb_build_replacing_all ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

References CB_BUILD_FUNCALL_2, cb_list_add(), and validate_inspect().

5716 {
5717  validate_inspect (x, y, 1);
5718  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_all", y, x));
5719 }
cb_tree cb_build_replacing_characters ( cb_tree  x,
cb_tree  l 
)

References _, CB_BUILD_FUNCALL_1, cb_error_x(), cb_list_add(), CB_LITERAL, CB_LITERAL_P, CB_TREE, and current_statement.

5706 {
5707  if (CB_LITERAL_P (x) && CB_LITERAL(x)->size != 1) {
5708  cb_error_x (CB_TREE (current_statement),
5709  _("Operand has wrong size"));
5710  }
5711  return cb_list_add (l, CB_BUILD_FUNCALL_1 ("cob_inspect_characters", x));
5712 }
cb_tree cb_build_replacing_first ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

References CB_BUILD_FUNCALL_2, cb_list_add(), and validate_inspect().

5730 {
5731  validate_inspect (x, y, 1);
5732  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_first", y, x));
5733 }
cb_tree cb_build_replacing_leading ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

References CB_BUILD_FUNCALL_2, cb_list_add(), and validate_inspect().

5723 {
5724  validate_inspect (x, y, 1);
5725  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_leading", y, x));
5726 }
cb_tree cb_build_replacing_trailing ( cb_tree  x,
cb_tree  y,
cb_tree  l 
)

References CB_BUILD_FUNCALL_2, cb_list_add(), and validate_inspect().

5737 {
5738  validate_inspect (x, y, 1);
5739  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_trailing", y, x));
5740 }
static cb_tree cb_build_search_all ( cb_tree  table,
cb_tree  cond 
)
static

References cb_build_binary_op(), cb_build_cond(), CB_FIELD_PTR, COB_ASCENDING, cb_key::dir, cb_field::keys, cb_field::nkeys, NULL, cb_key::ref, search_set_keys(), and cb_key::val.

Referenced by cb_emit_search_all().

7693 {
7694  cb_tree c1;
7695  cb_tree c2;
7696  struct cb_field *f;
7697  int i;
7698 
7699  f = CB_FIELD_PTR (table);
7700  /* Set keys */
7701  for (i = 0; i < f->nkeys; i++) {
7702  f->keys[i].ref = NULL;
7703  }
7704  if (search_set_keys (f, cond)) {
7705  return NULL;
7706  }
7707  c1 = NULL;
7708 
7709  /* Build condition */
7710  for (i = 0; i < f->nkeys; i++) {
7711  if (f->keys[i].ref) {
7712  if (f->keys[i].dir == COB_ASCENDING) {
7713  c2 = cb_build_binary_op (f->keys[i].ref, '=',
7714  f->keys[i].val);
7715  } else {
7716  c2 = cb_build_binary_op (f->keys[i].val, '=',
7717  f->keys[i].ref);
7718  }
7719  if (c1 == NULL) {
7720  c1 = c2;
7721  } else {
7722  c1 = cb_build_binary_op (c1, '&', c2);
7723  }
7724  }
7725  }
7726 
7727  if (!c1) {
7728  return NULL;
7729  }
7730  return cb_build_cond (c1);
7731 }
cb_tree cb_build_section_name ( cb_tree  name,
const int  sect_or_para 
)

References cb_error_node, CB_LABEL, CB_LABEL_P, CB_VALUE, CB_WORD_COUNT, CB_WORD_ITEMS, and redefinition_error().

1223 {
1224  cb_tree x;
1225 
1226  if (name == cb_error_node) {
1227  return cb_error_node;
1228  }
1229 
1230  if (CB_WORD_COUNT (name) > 0) {
1231  x = CB_VALUE (CB_WORD_ITEMS (name));
1232  /* Used as a non-label name or used as a section name.
1233  Duplicate paragraphs are allowed if not referenced;
1234  Checked in typeck.c */
1235  if (!CB_LABEL_P (x) || sect_or_para == 0 ||
1236  (sect_or_para && CB_LABEL_P (x) &&
1237  CB_LABEL (x)->flag_section)) {
1238  redefinition_error (name);
1239  return cb_error_node;
1240  }
1241  }
1242 
1243  return name;
1244 }
cb_tree cb_build_sub ( cb_tree  v,
cb_tree  n,
cb_tree  round_opt 
)

References build_store_option(), cb_build_binary_op(), CB_BUILD_FUNCALL_3, cb_build_move(), cb_build_optim_sub(), CB_CLASS_POINTER, CB_FIELD_PTR, cb_fits_int(), CB_INDEX_P, cb_int0, cb_int1, CB_REF_OR_FIELD_P, CB_TREE_CLASS, cb_field::count, and optimize_defs.

Referenced by cb_emit_arithmetic(), and cb_emit_set_up_down().

3983 {
3984  cb_tree opt;
3985  struct cb_field *f;
3986 
3987 #ifdef COB_NON_ALIGNED
3988  if (CB_INDEX_P (v)) {
3989  return cb_build_move (cb_build_binary_op (v, '-', n), v);
3990  }
3991  if (CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
3992  optimize_defs[COB_POINTER_MANIP] = 1;
3993  return CB_BUILD_FUNCALL_3 ("cob_pointer_manip", v, n, cb_int1);
3994  }
3995 #else
3996  if (CB_INDEX_P (v) || CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
3997  return cb_build_move (cb_build_binary_op (v, '-', n), v);
3998  }
3999 #endif
4000 
4001  if (CB_REF_OR_FIELD_P (v)) {
4002  f = CB_FIELD_PTR (v);
4003  f->count++;
4004  }
4005  if (CB_REF_OR_FIELD_P (n)) {
4006  f = CB_FIELD_PTR (n);
4007  f->count++;
4008  }
4009  opt = build_store_option (v, round_opt);
4010  if (opt == cb_int0 && cb_fits_int (n)) {
4011  return cb_build_optim_sub (v, n);
4012  }
4013  return CB_BUILD_FUNCALL_3 ("cob_sub", v, n, opt);
4014 }
cb_tree cb_build_tallying_all ( void  )

References _, cb_error_x(), CB_TREE, current_statement, inspect_func, and NULL.

5664 {
5665  if (inspect_data == NULL) {
5666  cb_error_x (CB_TREE (current_statement),
5667  _("Data name expected before ALL"));
5668  }
5669  inspect_func = "cob_inspect_all";
5670  return NULL;
5671 }
cb_tree cb_build_tallying_characters ( cb_tree  l)

References _, CB_BUILD_FUNCALL_1, cb_error_x(), cb_list_add(), CB_TREE, current_statement, inspect_func, and NULL.

5653 {
5654  if (inspect_data == NULL) {
5655  cb_error_x (CB_TREE (current_statement),
5656  _("Data name expected before CHARACTERS"));
5657  }
5658  inspect_func = NULL;
5659  return cb_list_add (l, CB_BUILD_FUNCALL_1 ("cob_inspect_characters", inspect_data));
5660 }
cb_tree cb_build_tallying_data ( cb_tree  x)

References NULL.

5646 {
5647  inspect_data = x;
5648  return NULL;
5649 }
cb_tree cb_build_tallying_leading ( void  )

References _, cb_error_x(), CB_TREE, current_statement, inspect_func, and NULL.

5675 {
5676  if (inspect_data == NULL) {
5677  cb_error_x (CB_TREE (current_statement),
5678  _("Data name expected before LEADING"));
5679  }
5680  inspect_func = "cob_inspect_leading";
5681  return NULL;
5682 }
cb_tree cb_build_tallying_trailing ( void  )

References _, cb_error_x(), CB_TREE, current_statement, inspect_func, and NULL.

5686 {
5687  if (inspect_data == NULL) {
5688  cb_error_x (CB_TREE (current_statement),
5689  _("Data name expected before TRAILING"));
5690  }
5691  inspect_func = "cob_inspect_trailing";
5692  return NULL;
5693 }
cb_tree cb_build_tallying_value ( cb_tree  x,
cb_tree  l 
)

References _, CB_BUILD_FUNCALL_2, cb_error_x(), cb_list_add(), cb_name(), inspect_func, and NULL.

5697 {
5698  if (inspect_func == NULL) {
5699  cb_error_x (x, _("ALL, LEADING or TRAILING expected before '%s'"), cb_name (x));
5700  }
5701  return cb_list_add (l, CB_BUILD_FUNCALL_2 (inspect_func, inspect_data, x));
5702 }
cb_tree cb_build_unstring_delimited ( cb_tree  all,
cb_tree  value 
)

References CB_BUILD_FUNCALL_2, cb_error_node, and cb_validate_one().

8342 {
8343  if (cb_validate_one (value)) {
8344  return cb_error_node;
8345  }
8346  return CB_BUILD_FUNCALL_2 ("cob_unstring_delimited", value, all);
8347 }
cb_tree cb_build_unstring_into ( cb_tree  name,
cb_tree  delimiter,
cb_tree  count 
)

References CB_BUILD_FUNCALL_3, cb_error_node, cb_int0, cb_validate_one(), and NULL.

8351 {
8352  if (cb_validate_one (name)) {
8353  return cb_error_node;
8354  }
8355  if (delimiter == NULL) {
8356  delimiter = cb_int0;
8357  }
8358  if (count == NULL) {
8359  count = cb_int0;
8360  }
8361  return CB_BUILD_FUNCALL_3 ("cob_unstring_into", name, delimiter, count);
8362 }
cb_tree cb_build_write_advancing_lines ( cb_tree  pos,
cb_tree  lines 
)

References CB_BEFORE, cb_build_binary_op(), cb_build_cast_int(), cb_get_int(), cb_int(), cb_int_hex(), CB_LITERAL_P, COB_WRITE_AFTER, COB_WRITE_BEFORE, and COB_WRITE_LINES.

8449 {
8450  cb_tree e;
8451  int opt;
8452 
8453  opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
8454  opt |= COB_WRITE_LINES;
8455  if (CB_LITERAL_P (lines)) {
8456  opt |= cb_get_int (lines);
8457  return cb_int_hex (opt);
8458  }
8459  e = cb_build_binary_op (cb_int (opt), '+', lines);
8460  return cb_build_cast_int (e);
8461 }
cb_tree cb_build_write_advancing_mnemonic ( cb_tree  pos,
cb_tree  mnemonic 
)

References _, CB_BEFORE, cb_error_node, cb_error_x(), CB_FEATURE_C01, CB_FEATURE_C02, CB_FEATURE_C03, CB_FEATURE_C04, CB_FEATURE_C05, CB_FEATURE_C06, CB_FEATURE_C07, CB_FEATURE_C08, CB_FEATURE_C09, CB_FEATURE_C10, CB_FEATURE_C11, CB_FEATURE_C12, CB_FEATURE_FORMFEED, cb_int0, cb_int_hex(), cb_ref(), CB_SYSTEM_NAME, COB_WRITE_AFTER, COB_WRITE_BEFORE, COB_WRITE_CHANNEL, and COB_WRITE_PAGE.

8465 {
8466  int opt;
8467  int token;
8468 
8469  if (mnemonic == cb_error_node) {
8470  return cb_int0;
8471  }
8472  if (cb_ref (mnemonic) == cb_error_node) {
8473  return cb_int0;
8474  }
8475  token = CB_SYSTEM_NAME (cb_ref (mnemonic))->token;
8476  switch (token) {
8477  case CB_FEATURE_FORMFEED:
8478  opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
8479  return cb_int_hex (opt | COB_WRITE_PAGE);
8480  case CB_FEATURE_C01:
8481  case CB_FEATURE_C02:
8482  case CB_FEATURE_C03:
8483  case CB_FEATURE_C04:
8484  case CB_FEATURE_C05:
8485  case CB_FEATURE_C06:
8486  case CB_FEATURE_C07:
8487  case CB_FEATURE_C08:
8488  case CB_FEATURE_C09:
8489  case CB_FEATURE_C10:
8490  case CB_FEATURE_C11:
8491  case CB_FEATURE_C12:
8492  opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
8493  return cb_int_hex (opt | COB_WRITE_CHANNEL | COB_WRITE_PAGE | token);
8494  default:
8495  cb_error_x (mnemonic, _("Invalid mnemonic name"));
8496  return cb_int0;
8497  }
8498 }
cb_tree cb_build_write_advancing_page ( cb_tree  pos)

References CB_BEFORE, cb_int_hex(), COB_WRITE_AFTER, COB_WRITE_BEFORE, and COB_WRITE_PAGE.

8502 {
8503  int opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
8504 
8505  return cb_int_hex (opt | COB_WRITE_PAGE);
8506 }
static void cb_check_data_incompat ( cb_tree  x)
static

References CB_BUILD_FUNCALL_1, CB_BUILD_FUNCALL_2, CB_BUILD_STRING0, CB_CATEGORY_NUMERIC, cb_emit, cb_error_node, CB_EXCEPTION_ENABLE, CB_FIELD_PTR, CB_REF_OR_FIELD_P, CB_TREE_CATEGORY, CB_USAGE_COMP_6, CB_USAGE_DISPLAY, CB_USAGE_PACKED, COB_EC_DATA_INCOMPATIBLE, cb_field::name, and cb_field::usage.

Referenced by cb_emit_arithmetic(), cb_emit_goto(), cb_emit_move(), and cb_emit_set_to().

713 {
714  struct cb_field *f;
715 
716  if (!x || x == cb_error_node) {
717  return;
718  }
719  if (!CB_REF_OR_FIELD_P (x) ||
720  CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
721  return;
722  }
723  f = CB_FIELD_PTR (x);
724  if (cb_flag_correct_numeric && f->usage == CB_USAGE_DISPLAY) {
725  cb_emit (CB_BUILD_FUNCALL_1 ("cob_correct_numeric", x));
726  }
727  if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE)) {
728  if (f->usage == CB_USAGE_DISPLAY ||
729  f->usage == CB_USAGE_PACKED ||
730  f->usage == CB_USAGE_COMP_6) {
731  cb_emit (CB_BUILD_FUNCALL_2 ("cob_check_numeric",
732  x,
733  CB_BUILD_STRING0 (f->name)));
734  }
735  }
736 }
void cb_check_field_debug ( cb_tree  fld)

References CB_BUILD_CAST_ADDRESS, CB_BUILD_CAST_LENGTH, cb_build_debug(), cb_build_debug_call(), CB_BUILD_FUNCALL_3, cb_build_move(), CB_CHAIN, cb_error_node, CB_FIELD, CB_FIELD_P, cb_int(), cb_list_add(), cb_list_reverse(), CB_PURPOSE, cb_ref(), CB_REFERENCE, CB_VALUE, CB_WORD_COUNT, CB_WORD_ITEMS, COB_MINI_BUFF, current_program, current_statement, cb_statement::debug_check, cb_program::debug_list, cb_statement::debug_nodups, cb_field::debug_section, cb_field::flag_all_debug, found, cb_field::name, NULL, and cb_field::size.

898 {
899  cb_tree l;
900  cb_tree x;
901  cb_tree z;
902  size_t size;
903  size_t found;
904  char buff[COB_MINI_BUFF];
905 
906  /* Basic reference check */
907  if (CB_WORD_COUNT (fld) > 0) {
908  if (!CB_WORD_ITEMS (fld)) {
909  return;
910  }
911  z = CB_VALUE(CB_WORD_ITEMS (fld));
912  if (!CB_FIELD_P (z)) {
913  return;
914  }
915  x = cb_ref (fld);
916  if (x == cb_error_node) {
917  return;
918  }
919  } else {
920  return;
921  }
922 
923  found = 0;
924  /* Check if reference is being debugged */
925  for (l = current_program->debug_list; l; l = CB_CHAIN (l)) {
926  if (!CB_PURPOSE (l)) {
927  continue;
928  }
929  if (x == CB_PURPOSE (l)) {
930  if (CB_REFERENCE (fld)->flag_target ||
931  CB_REFERENCE (CB_VALUE (l))->flag_all_debug) {
932  found = 1;
933  }
934  break;
935  }
936  }
937  if (!found) {
938  return;
939  }
940 
941  found = 0;
942  /* Found it - check if it is already in the statement list */
943  for (l = current_statement->debug_nodups; l; l = CB_CHAIN (l)) {
944  if (CB_VALUE (l) == x) {
945  found = 1;
946  break;
947  }
948  }
949  if (found) {
950  return;
951  }
952 
953  /* Set up debug info */
954  strcpy (buff, CB_FIELD(x)->name);
955  size = strlen (buff);
956  for (l = CB_REFERENCE (fld)->chain; l; l = CB_REFERENCE (l)->chain) {
957  z = cb_ref (l);
958  if (z != cb_error_node) {
959  size += strlen (CB_FIELD (z)->name);
960  size += 4;
961  if (size >= sizeof(buff)) {
962  break;
963  }
964  strcat (buff, " OF ");
965  strcat (buff, CB_FIELD (z)->name);
966  }
967  }
968  current_statement->debug_nodups =
969  cb_list_add (current_statement->debug_nodups, x);
970  current_statement->debug_check =
971  cb_list_add (current_statement->debug_check,
972  cb_build_debug (cb_debug_name, buff, NULL));
973  current_statement->debug_check =
974  cb_list_add (current_statement->debug_check,
975  cb_build_debug (cb_debug_contents, NULL, fld));
976  found = 0;
977  CB_REFERENCE (fld)->subs = cb_list_reverse (CB_REFERENCE (fld)->subs);
978  l = CB_REFERENCE (fld)->subs;
979  for (; l && found < 3; l = CB_CHAIN (l), ++found) {
980  switch (found) {
981  case 0:
982  current_statement->debug_check =
983  cb_list_add (current_statement->debug_check,
984  cb_build_move (CB_VALUE (l),
985  cb_debug_sub_1));
986  break;
987  case 1:
988  current_statement->debug_check =
989  cb_list_add (current_statement->debug_check,
990  cb_build_move (CB_VALUE (l),
991  cb_debug_sub_2));
992  break;
993  case 2:
994  current_statement->debug_check =
995  cb_list_add (current_statement->debug_check,
996  cb_build_move (CB_VALUE (l),
997  cb_debug_sub_3));
998  break;
999  default:
1000  break;
1001  }
1002  }
1003  CB_REFERENCE (fld)->subs = cb_list_reverse (CB_REFERENCE (fld)->subs);
1004 
1005  for (; found < 3; ++found) {
1006  switch (found) {
1007  case 0:
1008  current_statement->debug_check =
1009  cb_list_add (current_statement->debug_check,
1010  CB_BUILD_FUNCALL_3 ("memset",
1011  CB_BUILD_CAST_ADDRESS (cb_debug_sub_1),
1012  cb_int (' '),
1013  CB_BUILD_CAST_LENGTH (cb_debug_sub_1)));
1014  break;
1015  case 1:
1016  current_statement->debug_check =
1017  cb_list_add (current_statement->debug_check,
1018  CB_BUILD_FUNCALL_3 ("memset",
1019  CB_BUILD_CAST_ADDRESS (cb_debug_sub_2),
1020  cb_int (' '),
1021  CB_BUILD_CAST_LENGTH (cb_debug_sub_2)));
1022  break;
1023  case 2:
1024  current_statement->debug_check =
1025  cb_list_add (current_statement->debug_check,
1026  CB_BUILD_FUNCALL_3 ("memset",
1027  CB_BUILD_CAST_ADDRESS (cb_debug_sub_3),
1028  cb_int (' '),
1029  CB_BUILD_CAST_LENGTH (cb_debug_sub_3)));
1030  break;
1031  default:
1032  break;
1033  }
1034  }
1035 
1036  current_statement->debug_check =
1037  cb_list_add (current_statement->debug_check,
1038  cb_build_debug_call (CB_FIELD(x)->debug_section));
1039 }
static cb_tree cb_check_group_name ( cb_tree  x)
static

References _, cb_error_node, cb_error_x(), CB_FIELD, CB_FIELD_P, cb_name(), cb_ref(), CB_REFERENCE, CB_REFERENCE_P, and NULL.

Referenced by cb_emit_corresponding(), and cb_emit_move_corresponding().

586 {
587  cb_tree y;
588 
589  if (x == cb_error_node) {
590  return cb_error_node;
591  }
592 
593  if (CB_REFERENCE_P (x)) {
594  y = cb_ref (x);
595  if (y == cb_error_node) {
596  return cb_error_node;
597  }
598  if (CB_FIELD_P (y) && CB_FIELD (y)->children != NULL &&
599  CB_REFERENCE (x)->offset == NULL) {
600  return x;
601  }
602  }
603 
604  cb_error_x (x, _("'%s' is not group name"), cb_name (x));
605  return cb_error_node;
606 }
size_t cb_check_index_p ( cb_tree  x)

References CB_FIELD_PTR, CB_REF_OR_FIELD_P, CB_USAGE_INDEX, cb_field::children, and cb_field::usage.

881 {
882  struct cb_field *f;
883 
884  if (!CB_REF_OR_FIELD_P (x)) {
885  return 0;
886  }
887  f = CB_FIELD_PTR (x);
888  if (f->usage == CB_USAGE_INDEX && !f->children) {
889  return 1;
890  }
891  return 0;
892 }
static cb_tree cb_check_integer_value ( cb_tree  x)
static

References _, CB_CATEGORY_NUMERIC, cb_error_node, cb_error_x(), CB_FIELD, CB_LITERAL, cb_name(), cb_ref(), CB_TAG_BINARY_OP, CB_TAG_CONST, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_CATEGORY, CB_TREE_TAG, cb_zero, cb_field::pic, cb_literal::scale, cb_picture::scale, and cb_literal::sign.

Referenced by cb_build_identifier(), and cb_build_perform_times().

660 {
661  struct cb_literal *l;
662  struct cb_field *f;
663  cb_tree y;
664 
665  if (x == cb_error_node) {
666  return cb_error_node;
667  }
668 
669  if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
670  goto invalid;
671  }
672 
673  switch (CB_TREE_TAG (x)) {
674  case CB_TAG_CONST:
675  if (x != cb_zero) {
676  goto invalid;
677  }
678  return x;
679  case CB_TAG_LITERAL:
680  l = CB_LITERAL (x);
681  if (l->sign < 0 || l->scale > 0) {
682  goto invliteral;
683  }
684  return x;
685  case CB_TAG_REFERENCE:
686  y = cb_ref (x);
687  if (y == cb_error_node) {
688  return cb_error_node;
689  }
690  f = CB_FIELD (y);
691  if (f->pic->scale > 0) {
692  goto invalid;
693  }
694  return x;
695  case CB_TAG_BINARY_OP:
696  /* TODO: need to check */
697  return x;
698  case CB_TAG_INTRINSIC:
699  /* TODO: need to check */
700  return x;
701  default:
702 invalid:
703  cb_error_x (x, _("'%s' is not an integer value"), cb_name (x));
704  return cb_error_node;
705  }
706 invliteral:
707  cb_error_x (x, _("A positive numeric integer is required here"));
708  return cb_error_node;
709 }
static void cb_check_lit_subs ( struct cb_reference *  r,
const int  numsubs,
const int  numindex 
)
static

References CB_BUILD_CHAIN, cb_build_numsize_literal(), CB_CHAIN, cb_error_node, CB_LITERAL, CB_LITERAL_P, CB_VALUE, current_program, cb_literal::data, cb_program::decimal_point, cb_literal::scale, cb_literal::sign, cb_literal::size, and cb_reference::subs.

Referenced by cb_build_identifier().

741 {
742  cb_tree l;
743  cb_tree v;
744  struct cb_literal *lt;
745  int size;
746 
747  /* Check for DPC and non-standard separator usage */
748  if (!cb_relaxed_syntax_check ||
749  current_program->decimal_point != ',') {
750  return;
751  }
752  if (numsubs > numindex) {
753  return;
754  }
755 
756  for (l = r->subs; l; l = CB_CHAIN (l)) {
757  v = CB_VALUE (l);
758  if (v == cb_error_node) {
759  continue;
760  }
761  if (!CB_LITERAL_P (v)) {
762  continue;
763  }
764  lt = CB_LITERAL (v);
765  if (!lt->scale) {
766  continue;
767  }
768  if (lt->scale == (int)lt->size) {
769  lt->scale = 0;
770  continue;
771  }
772  size = lt->size - lt->scale;
773  v = cb_build_numsize_literal (&lt->data[size],
774  (size_t)lt->scale, lt->sign);
775  CB_VALUE (l) = v;
776  v = cb_build_numsize_literal (lt->data, (size_t)size, 0);
777  CB_CHAIN (l) = CB_BUILD_CHAIN (v, CB_CHAIN (l));
778  }
779  return;
780 }
static cb_tree cb_check_needs_break ( cb_tree  stmt)
static

References cb_build_direct(), CB_CHAIN, CB_GOTO_P, cb_list_add(), CB_STATEMENT, CB_STATEMENT_P, and CB_VALUE.

Referenced by cb_build_if_check_break(), cb_emit_search(), and cb_emit_search_all().

524 {
525  cb_tree l;
526 
527  /* Check if last statement is GO TO */
528  for (l = stmt; l; l = CB_CHAIN (l)) {
529  if (!CB_CHAIN(l)) {
530  break;
531  }
532  }
533  if (l && CB_VALUE (l) && CB_STATEMENT_P (CB_VALUE (l))) {
534  l = CB_STATEMENT(CB_VALUE(l))->body;
535  if (l && CB_VALUE (l) && !CB_GOTO_P (CB_VALUE(l))) {
536  /* Append a break */
537  l = cb_build_direct ("break;", 0);
538  return cb_list_add (stmt, l);
539  }
540  }
541  return stmt;
542 }
static cb_tree cb_check_numeric_edited_name ( cb_tree  x)
static

References _, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, cb_error_node, cb_error_x(), CB_FIELD_P, cb_name(), cb_ref(), CB_REFERENCE_P, and CB_TREE_CATEGORY.

Referenced by cb_emit_arithmetic(), and cb_emit_divide().

627 {
628  if (x == cb_error_node) {
629  return cb_error_node;
630  }
631 
632  if (CB_REFERENCE_P (x) &&
633  CB_FIELD_P (cb_ref (x)) &&
634  (CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC ||
635  CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC_EDITED)) {
636  return x;
637  }
638 
639  cb_error_x (x, _("'%s' is not numeric or numeric-edited name"), cb_name (x));
640  return cb_error_node;
641 }
static cb_tree cb_check_numeric_name ( cb_tree  x)
static

References _, CB_CATEGORY_NUMERIC, cb_error_node, cb_error_x(), CB_FIELD_P, cb_name(), cb_ref(), CB_REFERENCE_P, and CB_TREE_CATEGORY.

Referenced by cb_emit_arithmetic().

610 {
611  if (x == cb_error_node) {
612  return cb_error_node;
613  }
614 
615  if (CB_REFERENCE_P (x) &&
616  CB_FIELD_P (cb_ref (x)) &&
617  CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
618  return x;
619  }
620 
621  cb_error_x (x, _("'%s' is not a numeric name"), cb_name (x));
622  return cb_error_node;
623 }
cb_tree cb_check_numeric_value ( cb_tree  x)

References _, CB_CATEGORY_NUMERIC, cb_error_node, cb_error_x(), cb_name(), and CB_TREE_CATEGORY.

Referenced by cb_build_binary_op(), cb_emit_arithmetic(), and cb_emit_goto().

645 {
646  if (x == cb_error_node) {
647  return cb_error_node;
648  }
649 
650  if (CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
651  return x;
652  }
653 
654  cb_error_x (x, _("'%s' is not a numeric value"), cb_name (x));
655  return cb_error_node;
656 }
static size_t cb_check_overlapping ( cb_tree  src,
cb_tree  dst,
struct cb_field *  src_f,
struct cb_field *  dst_f 
)
static

References _, cb_field_founder(), cb_field_size(), cb_field_variable_size(), CB_REFERENCE, CB_REFERENCE_P, cb_warning_x(), cb_field::children, cb_field::indexes, cb_field::offset, cb_field::redefines, cb_field::sister, cb_tree_common::source_line, and suppress_warn.

Referenced by validate_move().

5869 {
5870  struct cb_field *f1;
5871  struct cb_field *ff1;
5872  struct cb_field *ff2;
5873  cb_tree loc;
5874  int src_size;
5875  int dst_size;
5876  int src_off;
5877  int dst_off;
5878 
5879  src_size = cb_field_size (src);
5880  dst_size = cb_field_size (dst);
5881 
5882  if (src_size <= 0 || dst_size <= 0 ||
5883  cb_field_variable_size (src_f) ||
5884  cb_field_variable_size (dst_f)) {
5885  return 0;
5886  }
5887  /* Check basic overlapping */
5888  for (f1 = src_f->children; f1; f1 = f1->sister) {
5889  if (f1 == dst_f) {
5890  goto overlapret;
5891  }
5892  }
5893  for (f1 = dst_f->children; f1; f1 = f1->sister) {
5894  if (f1 == src_f) {
5895  goto overlapret;
5896  }
5897  }
5898  ff1 = cb_field_founder (src_f);
5899  ff2 = cb_field_founder (dst_f);
5900  if (ff1->redefines) {
5901  ff1 = ff1->redefines;
5902  }
5903  if (ff2->redefines) {
5904  ff2 = ff2->redefines;
5905  }
5906  if (ff1 != ff2) {
5907  return 0;
5908  }
5909  /* Check literal occurs? */
5910  if (src_f->indexes || dst_f->indexes) {
5911  return 0;
5912  }
5913  /* Check reference modification ? */
5914  if (CB_REFERENCE_P (src) && CB_REFERENCE(src)->offset) {
5915  return 0;
5916  }
5917  if (CB_REFERENCE_P (dst) && CB_REFERENCE(dst)->offset) {
5918  return 0;
5919  }
5920  src_off = src_f->offset;
5921  dst_off = dst_f->offset;
5922  if (src_off >= dst_off && src_off < (dst_off + dst_size)) {
5923  goto overlapret;
5924  }
5925  if (src_off < dst_off && (src_off + src_size) > dst_off) {
5926  goto overlapret;
5927  }
5928  return 0;
5929 overlapret:
5930  loc = src->source_line ? src : dst;
5931  if (cb_warn_overlap && !suppress_warn) {
5932  cb_warning_x (loc, _("Overlapping MOVE may produce unpredictable results"));
5933  }
5934  return 1;
5935 }
static int cb_chk_alpha_cond ( cb_tree  x)
static

References cb_program::alphabet_name_list, CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_FIELD_PTR, cb_field_size(), cb_field_variable_size(), CB_LITERAL_P, CB_REF_OR_FIELD_P, CB_TREE_CATEGORY, and current_program.

Referenced by cb_build_cond().

3636 {
3637  if (current_program->alphabet_name_list) {
3638  return 0;
3639  }
3640  if (CB_LITERAL_P (x)) {
3641  return 1;
3642  }
3643  if (!CB_REF_OR_FIELD_P (x)) {
3644  return 0;
3645  }
3646  if (CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHANUMERIC &&
3647  CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHABETIC) {
3648  return 0;
3649  }
3650  if (cb_field_variable_size (CB_FIELD_PTR (x))) {
3651  return 0;
3652  }
3653  if (cb_field_size (x) < 0) {
3654  return 0;
3655  }
3656  return 1;
3657 }
static int cb_chk_num_cond ( cb_tree  x,
cb_tree  y 
)
static

References CB_CATEGORY_NUMERIC, CB_CLASS_NUMERIC, CB_FIELD_PTR, CB_REF_OR_FIELD_P, CB_TREE_CATEGORY, CB_TREE_CLASS, CB_USAGE_DISPLAY, cb_picture::have_sign, cb_field::pic, cb_picture::scale, cb_field::size, and cb_field::usage.

Referenced by cb_build_cond().

3592 {
3593  struct cb_field *fx;
3594  struct cb_field *fy;
3595 
3596  if (!CB_REF_OR_FIELD_P (x)) {
3597  return 0;
3598  }
3599  if (!CB_REF_OR_FIELD_P (y)) {
3600  return 0;
3601  }
3602  if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
3603  return 0;
3604  }
3605  if (CB_TREE_CATEGORY (y) != CB_CATEGORY_NUMERIC) {
3606  return 0;
3607  }
3608  if (CB_TREE_CLASS (x) != CB_CLASS_NUMERIC) {
3609  return 0;
3610  }
3611  if (CB_TREE_CLASS (y) != CB_CLASS_NUMERIC) {
3612  return 0;
3613  }
3614  fx = CB_FIELD_PTR (x);
3615  fy = CB_FIELD_PTR (y);
3616  if (fx->usage != CB_USAGE_DISPLAY) {
3617  return 0;
3618  }
3619  if (fy->usage != CB_USAGE_DISPLAY) {
3620  return 0;
3621  }
3622  if (fx->pic->have_sign || fy->pic->have_sign) {
3623  return 0;
3624  }
3625  if (fx->size != fy->size) {
3626  return 0;
3627  }
3628  if (fx->pic->scale != fy->pic->scale) {
3629  return 0;
3630  }
3631  return 1;
3632 }
cb_tree cb_define_switch_name ( cb_tree  name,
cb_tree  sname,
const int  flag 
)

References _, cb_build_constant(), CB_BUILD_FUNCALL_1, CB_BUILD_NEGATION, cb_error_node, cb_error_x(), cb_int(), CB_SWITCH_NAME, CB_SYSTEM_NAME, NULL, and value.

1200 {
1201  cb_tree switch_id;
1202  cb_tree value;
1203 
1204  if (!name || name == cb_error_node) {
1205  return NULL;
1206  }
1207  if (!sname || sname == cb_error_node ||
1208  CB_SYSTEM_NAME (sname)->category != CB_SWITCH_NAME) {
1209  cb_error_x (name, _("ON/OFF usage requires a SWITCH name"));
1210  return NULL;
1211  }
1212  switch_id = cb_int (CB_SYSTEM_NAME (sname)->token);
1213  value = CB_BUILD_FUNCALL_1 ("cob_get_switch", switch_id);
1214  if (flag == 0) {
1215  value = CB_BUILD_NEGATION (value);
1216  }
1217  cb_build_constant (name, value);
1218  return value;
1219 }
void cb_emit_accept ( cb_tree  var,
cb_tree  pos,
struct cb_attr_struct *  attr_ptr 
)

References _, cb_attr_struct::bgc, CB_BUILD_FUNCALL_1, CB_BUILD_FUNCALL_4, CB_BUILD_FUNCALL_9, cb_emit, cb_error_x(), CB_FIELD, CB_FIELD_PTR, cb_gen_field_accept(), cb_int(), CB_LIST_P, CB_LITERAL, CB_LITERAL_P, cb_null, CB_PAIR_X, CB_PAIR_Y, cb_ref(), CB_REF_OR_FIELD_P, CB_STORAGE_SCREEN, cb_validate_one(), cb_program::crt_status, current_program, cb_attr_struct::dispattrs, cb_attr_struct::fgc, cb_program::flag_screen, gen_screen_ptr, line, NULL, output_screen_from(), output_screen_to(), cb_attr_struct::prompt, cb_attr_struct::scroll, cb_field::size, cb_field::storage, and cb_attr_struct::timeout.

4196 {
4197  cb_tree line;
4198  cb_tree column;
4199  cb_tree fgc;
4200  cb_tree bgc;
4201  cb_tree scroll;
4202  cb_tree timeout;
4203  cb_tree prompt;
4204  int dispattrs;
4205 
4206  if (attr_ptr) {
4207  fgc = attr_ptr->fgc;
4208  bgc = attr_ptr->bgc;
4209  scroll = attr_ptr->scroll;
4210  timeout = attr_ptr->timeout;
4211  prompt = attr_ptr->prompt;
4212  dispattrs = attr_ptr->dispattrs;
4213  } else {
4214  fgc = NULL;
4215  bgc = NULL;
4216  scroll = NULL;
4217  timeout = NULL;
4218  prompt = NULL;
4219  dispattrs = 0;
4220  }
4221 
4222  if (cb_validate_one (var)) {
4223  return;
4224  }
4225  if (cb_validate_one (pos)) {
4226  return;
4227  }
4228  if (cb_validate_one (fgc)) {
4229  return;
4230  }
4231  if (cb_validate_one (bgc)) {
4232  return;
4233  }
4234  if (cb_validate_one (scroll)) {
4235  return;
4236  }
4237  if (cb_validate_one (timeout)) {
4238  return;
4239  }
4240  if (cb_validate_one (prompt)) {
4241  return;
4242  }
4243 
4244  if (prompt) {
4245  /* PROMPT character - 1 character identifier or literal */
4246  if (CB_LITERAL_P (prompt)) {
4247  if (CB_LITERAL (prompt)->size != 1) {
4248  cb_error_x (prompt, _("Invalid PROMPT literal"));
4249  return;
4250  }
4251  } else {
4252  if (CB_FIELD_PTR (prompt)->size != 1) {
4253  cb_error_x (prompt, _("Invalid PROMPT identifier"));
4254  return;
4255  }
4256  }
4257  }
4258 
4259 #if 0 /* RXWRXW - Screen */
4260  if ((CB_REF_OR_FIELD_P (var)) &&
4261  CB_FIELD (cb_ref (var))->storage == CB_STORAGE_SCREEN) {
4262  current_program->flag_screen = 1;
4263  }
4264 #endif
4265 
4266  if (current_program->flag_screen) {
4267  /* Bump ref count to force CRT STATUS field generation */
4268  if (current_program->crt_status) {
4269  CB_FIELD_PTR (current_program->crt_status)->count++;
4270  }
4271  if ((CB_REF_OR_FIELD_P (var)) &&
4272  CB_FIELD (cb_ref (var))->storage == CB_STORAGE_SCREEN) {
4273  output_screen_from (CB_FIELD (cb_ref (var)), 0);
4274  gen_screen_ptr = 1;
4275  if (pos) {
4276  if (CB_LIST_P (pos)) {
4277  line = CB_PAIR_X (pos);
4278  column = CB_PAIR_Y (pos);
4279  cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_accept",
4280  var, line, column, timeout));
4281  } else {
4282  cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_accept",
4283  var, pos, NULL, timeout));
4284  }
4285  } else {
4286  cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_accept",
4287  var, NULL, NULL, timeout));
4288  }
4289  gen_screen_ptr = 0;
4290  output_screen_to (CB_FIELD (cb_ref (var)), 0);
4291  } else {
4292  if (var == cb_null) {
4293  var = NULL;
4294  }
4295  if (pos || fgc || bgc || scroll || dispattrs) {
4296  cb_gen_field_accept (var, pos, fgc, bgc, scroll,
4297  timeout, prompt, dispattrs);
4298  } else {
4299  cb_emit (CB_BUILD_FUNCALL_9 ("cob_field_accept",
4300  var, NULL, NULL, fgc, bgc,
4301  scroll, timeout, prompt,
4302  cb_int (dispattrs)));
4303  }
4304  }
4305  } else if (pos || fgc || bgc || scroll || dispattrs) {
4306  /* Bump ref count to force CRT STATUS field generation */
4307  if (current_program->crt_status) {
4308  CB_FIELD_PTR (current_program->crt_status)->count++;
4309  }
4310  if (var == cb_null) {
4311  var = NULL;
4312  }
4313  cb_gen_field_accept (var, pos, fgc, bgc, scroll,
4314  timeout, prompt, dispattrs);
4315  } else {
4316  if (var == cb_null) {
4317  var = NULL;
4318  }
4319  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
4320  }
4321 }
void cb_emit_accept_arg_number ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4445 {
4446  if (cb_validate_one (var)) {
4447  return;
4448  }
4449  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_arg_number", var));
4450 }
void cb_emit_accept_arg_value ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4454 {
4455  if (cb_validate_one (var)) {
4456  return;
4457  }
4458  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_arg_value", var));
4459 }
void cb_emit_accept_command_line ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4415 {
4416  if (cb_validate_one (var)) {
4417  return;
4418  }
4419  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_command_line", var));
4420 }
void cb_emit_accept_date ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4361 {
4362  if (cb_validate_one (var)) {
4363  return;
4364  }
4365  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_date", var));
4366 }
void cb_emit_accept_date_yyyymmdd ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4370 {
4371  if (cb_validate_one (var)) {
4372  return;
4373  }
4374  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_date_yyyymmdd", var));
4375 }
void cb_emit_accept_day ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4379 {
4380  if (cb_validate_one (var)) {
4381  return;
4382  }
4383  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day", var));
4384 }
void cb_emit_accept_day_of_week ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4397 {
4398  if (cb_validate_one (var)) {
4399  return;
4400  }
4401  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day_of_week", var));
4402 }
void cb_emit_accept_day_yyyyddd ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4388 {
4389  if (cb_validate_one (var)) {
4390  return;
4391  }
4392  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day_yyyyddd", var));
4393 }
void cb_emit_accept_environment ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4436 {
4437  if (cb_validate_one (var)) {
4438  return;
4439  }
4440  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_environment", var));
4441 }
void cb_emit_accept_escape_key ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4334 {
4335  if (cb_validate_one (var)) {
4336  return;
4337  }
4338  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_escape_key", var));
4339 }
void cb_emit_accept_exception_status ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4343 {
4344  if (cb_validate_one (var)) {
4345  return;
4346  }
4347  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_exception_status", var));
4348 }
void cb_emit_accept_line_or_col ( cb_tree  var,
const int  l_or_c 
)

References CB_BUILD_FUNCALL_2, cb_emit, cb_int(), and cb_validate_one().

4325 {
4326  if (cb_validate_one (var)) {
4327  return;
4328  }
4329  cb_emit (CB_BUILD_FUNCALL_2 ("cob_screen_line_col", var, cb_int (l_or_c)));
4330 }
void cb_emit_accept_mnemonic ( cb_tree  var,
cb_tree  mnemonic 
)

References _, CB_BUILD_FUNCALL_1, CB_DEVICE_CONSOLE, CB_DEVICE_SYSIN, cb_emit, cb_error_node, cb_error_x(), cb_name(), cb_ref(), CB_SYSTEM_NAME, and cb_validate_one().

4463 {
4464  if (cb_validate_one (var)) {
4465  return;
4466  }
4467  if (cb_ref (mnemonic) == cb_error_node) {
4468  return;
4469  }
4470  switch (CB_SYSTEM_NAME (cb_ref (mnemonic))->token) {
4471  case CB_DEVICE_CONSOLE:
4472  case CB_DEVICE_SYSIN:
4473  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
4474  break;
4475  default:
4476  cb_error_x (mnemonic, _("Invalid input device '%s'"),
4477  cb_name (mnemonic));
4478  break;
4479  }
4480 }
void cb_emit_accept_name ( cb_tree  var,
cb_tree  name 
)

References _, CB_BUILD_FUNCALL_1, CB_DEVICE_CONSOLE, CB_DEVICE_SYSIN, cb_emit, cb_error_x(), CB_NAME, cb_name(), CB_SYSTEM_NAME, cb_validate_one(), cb_warning_x(), and lookup_system_name().

4484 {
4485  cb_tree sys;
4486 
4487  if (cb_validate_one (var)) {
4488  return;
4489  }
4490 
4491  /* Allow direct reference to a device name */
4492  sys = lookup_system_name (CB_NAME (name));
4493  if (sys) {
4494  switch (CB_SYSTEM_NAME (sys)->token) {
4495  case CB_DEVICE_CONSOLE:
4496  case CB_DEVICE_SYSIN:
4497  if (!cb_relaxed_syntax_check) {
4498  cb_warning_x (name, _("'%s' is not defined in SPECIAL-NAMES"), CB_NAME (name));
4499  }
4500  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
4501  return;
4502  default:
4503  cb_error_x (name, _("Invalid input device '%s'"),
4504  cb_name (name));
4505  return;
4506  }
4507  }
4508 
4509  cb_error_x (name, _("'%s' is not defined in SPECIAL-NAMES"),
4510  CB_NAME (name));
4511 }
void cb_emit_accept_time ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4406 {
4407  if (cb_validate_one (var)) {
4408  return;
4409  }
4410  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_time", var));
4411 }
void cb_emit_accept_user_name ( cb_tree  var)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4352 {
4353  if (cb_validate_one (var)) {
4354  return;
4355  }
4356  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_user_name", var));
4357 }
void cb_emit_allocate ( cb_tree  target1,
cb_tree  target2,
cb_tree  size,
cb_tree  initialize 
)

References _, CB_BUILD_CAST_ADDR_OF_ADDR, CB_BUILD_FUNCALL_4, cb_build_initialize(), cb_build_numeric_literal(), cb_category_is_alpha(), CB_CLASS_NUMERIC, CB_CLASS_POINTER, cb_emit, cb_error_x(), CB_FIELD_PTR, CB_REFERENCE_P, CB_TREE, CB_TREE_CLASS, cb_true, cb_validate_one(), current_statement, cb_field::flag_item_based, cb_statement::handler2, cb_field::memory_size, and NULL.

4518 {
4519  cb_tree x;
4520  char buff[32];
4521 
4522  if (cb_validate_one (target1)) {
4523  return;
4524  }
4525  if (cb_validate_one (target2)) {
4526  return;
4527  }
4528  if (cb_validate_one (size)) {
4529  return;
4530  }
4531  if (cb_validate_one (initialize)) {
4532  return;
4533  }
4534  if (target1) {
4535  if (!(CB_REFERENCE_P(target1) &&
4536  CB_FIELD_PTR (target1)->flag_item_based)) {
4537  cb_error_x (CB_TREE(current_statement),
4538  _("Target of ALLOCATE is not a BASED item"));
4539  return;
4540  }
4541  }
4542  if (target2) {
4543  if (!(CB_REFERENCE_P(target2) &&
4544  CB_TREE_CLASS (target2) == CB_CLASS_POINTER)) {
4545  cb_error_x (CB_TREE(current_statement),
4546  _("Target of RETURNING is not a data pointer"));
4547  return;
4548  }
4549  }
4550  if (size) {
4551  if (CB_TREE_CLASS (size) != CB_CLASS_NUMERIC) {
4552  cb_error_x (CB_TREE(current_statement),
4553  _("The CHARACTERS field of ALLOCATE must be numeric"));
4554  return;
4555  }
4556  }
4557  if (target1) {
4558  sprintf (buff, "%d", CB_FIELD_PTR (target1)->memory_size);
4559  x = cb_build_numeric_literal (0, buff, 0);
4560  cb_emit (CB_BUILD_FUNCALL_4 ("cob_allocate",
4561  CB_BUILD_CAST_ADDR_OF_ADDR (target1),
4562  target2, x, NULL));
4563  } else {
4564  if (initialize && !cb_category_is_alpha (initialize)) {
4565  cb_error_x (CB_TREE(current_statement),
4566  _("INITIALIZED TO item is not alphanumeric"));
4567  }
4568  cb_emit (CB_BUILD_FUNCALL_4 ("cob_allocate",
4569  NULL, target2, size, initialize));
4570  }
4571  if (initialize && target1) {
4572  current_statement->handler2 =
4573  cb_build_initialize (target1, cb_true, NULL, 1, 0, 0);
4574  }
4575 }
void cb_emit_alter ( cb_tree  source,
cb_tree  target 
)

References cb_build_alter(), cb_emit, cb_error_node, and CB_REFERENCE.

4582 {
4583  if (source == cb_error_node) {
4584  return;
4585  }
4586  if (target == cb_error_node) {
4587  return;
4588  }
4589  CB_REFERENCE(source)->flag_alter_code = 1;
4590  cb_emit (cb_build_alter (source, target));
4591 }
void cb_emit_arg_number ( cb_tree  value)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4973 {
4974  if (cb_validate_one (value)) {
4975  return;
4976  }
4977  cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_arg_number", value));
4978 }
void cb_emit_arithmetic ( cb_tree  vars,
const int  op,
cb_tree  val 
)

References build_decimal_assign(), CB_BINARY_OP_P, cb_build_add(), cb_build_div(), cb_build_mul(), cb_build_sub(), CB_CHAIN, cb_check_data_incompat(), cb_check_numeric_edited_name(), cb_check_numeric_name(), cb_check_numeric_value(), cb_emit_list, cb_error_node, cb_list_map(), CB_PURPOSE, cb_validate_list(), cb_validate_one(), and CB_VALUE.

3389 {
3390  cb_tree l;
3391  cb_tree x;
3392 
3393  x = cb_check_numeric_value (val);
3394 
3395  if (op) {
3396  cb_list_map (cb_check_numeric_name, vars);
3397  } else {
3398  cb_list_map (cb_check_numeric_edited_name, vars);
3399  }
3400 
3401  if (cb_validate_one (x)) {
3402  return;
3403  }
3404  if (cb_validate_list (vars)) {
3405  return;
3406  }
3407 
3408  if (!CB_BINARY_OP_P (x)) {
3409  if (op == '+' || op == '-' || op == '*' || op == '/') {
3410  cb_check_data_incompat (x);
3411  for (l = vars; l; l = CB_CHAIN (l)) {
3412  cb_check_data_incompat (CB_VALUE (l));
3413  switch (op) {
3414  case '+':
3415  CB_VALUE (l) = cb_build_add (CB_VALUE (l), x, CB_PURPOSE (l));
3416  break;
3417  case '-':
3418  CB_VALUE (l) = cb_build_sub (CB_VALUE (l), x, CB_PURPOSE (l));
3419  break;
3420  case '*':
3421  CB_VALUE (l) = cb_build_mul (CB_VALUE (l), x, CB_PURPOSE (l));
3422  break;
3423  case '/':
3424  CB_VALUE (l) = cb_build_div (CB_VALUE (l), x, CB_PURPOSE (l));
3425  break;
3426  }
3427  }
3428  cb_emit_list (vars);
3429  return;
3430  }
3431  }
3432  if (x == cb_error_node) {
3433  return;
3434  }
3435 
3436  cb_emit_list (build_decimal_assign (vars, op, x));
3437 }
void cb_emit_call ( cb_tree  prog,
cb_tree  par_using,
cb_tree  returning,
cb_tree  on_exception,
cb_tree  not_on_exception,
cb_tree  convention 
)

References _, cb_build_call(), CB_CALL_BY_REFERENCE, CB_CALL_BY_VALUE, CB_CATEGORY_ALPHANUMERIC, CB_CHAIN, CB_CLASS_NUMERIC, CB_CLASS_POINTER, CB_CONST_P, CB_CONV_STATIC_LINK, CB_CONV_STDCALL, cb_emit, cb_error_node, cb_error_x(), CB_FIELD_P, CB_FIELD_PTR, cb_get_int(), cb_get_long_long(), CB_INTEGER, CB_INTEGER_P, CB_INTRINSIC, CB_INTRINSIC_P, cb_list_length(), CB_LITERAL, CB_LITERAL_P, CB_NAME, cb_null, CB_NUMERIC_LITERAL_P, CB_PURPOSE_INT, CB_REFERENCE, CB_REFERENCE_P, CB_SIZE_1, CB_SIZE_2, CB_SIZE_4, CB_SIZE_8, CB_SIZE_AUTO, CB_SIZES_INT, CB_SIZES_INT_UNSIGNED, CB_TREE, CB_TREE_CLASS, CB_VALUE, cb_warning(), cb_warning_x(), cob_s64_t, cob_u32_t, current_program, current_statement, cb_field::flag_any_length, cb_field::level, cb_program::max_call_param, NULL, p, sign, system_table::syst_name, system_table::syst_params, value, and warningopt.

4599 {
4600  cb_tree l;
4601  cb_tree x;
4602  struct cb_field *f;
4603  const struct system_table *psyst;
4604  const char *p;
4605  const char *entry;
4606  cob_s64_t val;
4607  cob_s64_t valmin;
4608  cob_s64_t valmax;
4609  cob_u32_t is_sys_call;
4610  cob_u32_t is_sys_idx;
4611  int error_ind;
4612  int call_conv;
4613  int numargs;
4614 
4615  if (CB_INTRINSIC_P (prog)) {
4616  if (CB_INTRINSIC(prog)->intr_tab->category != CB_CATEGORY_ALPHANUMERIC) {
4617  cb_error_x (CB_TREE (current_statement),
4618  _("Only alphanumeric FUNCTION types are allowed here"));
4619  return;
4620  }
4621  }
4622  if (returning && returning != cb_null) {
4623  if (CB_TREE_CLASS(returning) != CB_CLASS_NUMERIC &&
4624  CB_TREE_CLASS(returning) != CB_CLASS_POINTER) {
4625  cb_error_x (CB_TREE (current_statement),
4626  _("Invalid RETURNING field"));
4627  return;
4628  }
4629  }
4630 
4631  error_ind = 0;
4632  numargs = 0;
4633 
4634  if (convention) {
4635  if (CB_INTEGER_P (convention)) {
4636  call_conv = CB_INTEGER (convention)->val;
4637  } else {
4638  call_conv = cb_get_int (convention);
4639  }
4640  } else {
4641  call_conv = 0;
4642  }
4643 #ifndef _WIN32
4644  if (call_conv & CB_CONV_STDCALL) {
4645  call_conv &= ~CB_CONV_STDCALL;
4646  if (warningopt) {
4647  cb_warning (_("STDCALL not available on this platform"));
4648  }
4649  }
4650 #elif defined(_WIN64)
4651  if (call_conv & CB_CONV_STDCALL) {
4652  if (warningopt) {
4653  cb_warning (_("STDCALL used on 64-bit Windows platform"));
4654  }
4655  }
4656 #endif
4657  if ((call_conv & CB_CONV_STATIC_LINK) && !CB_LITERAL_P (prog)) {
4658  cb_error_x (CB_TREE (current_statement),
4659  _("STATIC CALL convention requires a literal program name"));
4660  error_ind = 1;
4661  }
4662 
4663  for (l = par_using; l; l = CB_CHAIN (l), numargs++) {
4664  x = CB_VALUE (l);
4665  if (x == cb_error_node) {
4666  error_ind = 1;
4667  continue;
4668  }
4669  if (CB_NUMERIC_LITERAL_P (x)) {
4670  if (CB_PURPOSE_INT (l) != CB_CALL_BY_VALUE) {
4671  continue;
4672  }
4673  if (CB_SIZES_INT_UNSIGNED(l) &&
4674  CB_LITERAL (x)->sign < 0) {
4675  cb_error_x (x, _("Numeric literal is negative"));
4676  error_ind = 1;
4677  continue;
4678  }
4679  val = 0;
4680  valmin = 0;
4681  valmax = 0;
4682  switch (CB_SIZES_INT (l)) {
4683  case CB_SIZE_1:
4684  val = cb_get_long_long (x);
4685  if (CB_SIZES_INT_UNSIGNED(l)) {
4686  valmin = 0;
4687  valmax = UCHAR_MAX;
4688  } else {
4689  valmin = CHAR_MIN;
4690  valmax = CHAR_MAX;
4691  }
4692  break;
4693  case CB_SIZE_2:
4694  val = cb_get_long_long (x);
4695  if (CB_SIZES_INT_UNSIGNED(l)) {
4696  valmin = 0;
4697  valmax = USHRT_MAX;
4698  } else {
4699  valmin = SHRT_MIN;
4700  valmax = SHRT_MAX;
4701  }
4702  break;
4703  case CB_SIZE_4:
4704  val = cb_get_long_long (x);
4705  if (CB_SIZES_INT_UNSIGNED(l)) {
4706  valmin = 0;
4707  valmax = UINT_MAX;
4708  } else {
4709  valmin = INT_MIN;
4710  valmax = INT_MAX;
4711  }
4712  break;
4713  case CB_SIZE_8:
4714  case CB_SIZE_AUTO:
4715  if (CB_SIZES_INT_UNSIGNED(l)) {
4716  if (CB_LITERAL (x)->size < 20) {
4717  break;
4718  }
4719  if (CB_LITERAL (x)->size > 20) {
4720  valmin = 1;
4721  break;
4722  }
4723  if (memcmp (CB_LITERAL (x)->data,
4724  "18446744073709551615",
4725  (size_t)20) > 0) {
4726  valmin = 1;
4727  break;
4728  }
4729  } else {
4730  if (CB_LITERAL (x)->size < 19) {
4731  break;
4732  }
4733  if (CB_LITERAL (x)->size > 19) {
4734  valmin = 1;
4735  break;
4736  }
4737  if (memcmp (CB_LITERAL (x)->data,
4738  "9223372036854775807",
4739  (size_t)19) > 0) {
4740  valmin = 1;
4741  break;
4742  }
4743  }
4744  break;
4745  default:
4746  break;
4747  }
4748  if (!valmin && !valmax) {
4749  continue;
4750  }
4751  if (val < valmin || val > valmax) {
4752  cb_error_x (x, _("Numeric literal exceeds size limits"));
4753  error_ind = 1;
4754  }
4755  continue;
4756  }
4757  if (CB_CONST_P (x) && x != cb_null) {
4758  cb_error_x (x, _("Figurative constant invalid here"));
4759  error_ind = 1;
4760  continue;
4761  }
4762  if ((CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value)) ||
4763  CB_FIELD_P (x)) {
4764  f = CB_FIELD_PTR (x);
4765  if (f->level == 88) {
4766  cb_error_x (x, _("'%s' is not a valid data name"), CB_NAME (x));
4767  error_ind = 1;
4768  continue;
4769  }
4770  if (f->flag_any_length &&
4771  CB_PURPOSE_INT (l) != CB_CALL_BY_REFERENCE) {
4772  cb_error_x (x, _("'%s' ANY LENGTH item not passed BY REFERENCE"), CB_NAME (x));
4773  error_ind = 1;
4774  continue;
4775  }
4776  if (cb_warn_call_params &&
4777  CB_PURPOSE_INT (l) == CB_CALL_BY_REFERENCE) {
4778  if (f->level != 01 && f->level != 77) {
4779  cb_warning_x (x, _("'%s' is not a 01 or 77 level item"), CB_NAME (x));
4780  }
4781  }
4782  }
4783  }
4784 
4785  is_sys_call = 0;
4786  if (CB_LITERAL_P(prog)) {
4787  entry = NULL;
4788  p = (const char *)CB_LITERAL(prog)->data;
4789  for (; *p; ++p) {
4790  if (*p == '/' || *p == '\\') {
4791  entry = p + 1;
4792  }
4793  }
4794  if (!entry) {
4795  entry = (const char *)CB_LITERAL(prog)->data;
4796  }
4797  is_sys_idx = 1;
4798  for (psyst = system_tab; psyst->syst_name; psyst++, is_sys_idx++) {
4799  if (!strcmp(entry, (const char *)psyst->syst_name)) {
4800  if (psyst->syst_params > cb_list_length (par_using)) {
4801  cb_error_x (CB_TREE (current_statement),
4802  _("Wrong number of CALL parameters for '%s'"),
4803  (char *)psyst->syst_name);
4804  return;
4805  }
4806  is_sys_call = is_sys_idx;
4807  break;
4808  }
4809  }
4810  }
4811 
4812  if (error_ind) {
4813  return;
4814  }
4815  if (numargs > current_program->max_call_param) {
4816  current_program->max_call_param = numargs;
4817  }
4818  cb_emit (cb_build_call (prog, par_using, on_exception, not_on_exception,
4819  returning, is_sys_call, call_conv));
4820 }
void cb_emit_cancel ( cb_tree  prog)

References cb_build_cancel(), cb_emit, and cb_validate_one().

4826 {
4827  if (cb_validate_one (prog)) {
4828  return;
4829  }
4830  cb_emit (cb_build_cancel (prog));
4831 }
void cb_emit_close ( cb_tree  file,
cb_tree  opt 
)

References _, cb_build_debug(), cb_build_debug_call(), CB_BUILD_FUNCALL_4, cb_build_move(), cb_emit, cb_error_node, cb_error_x(), CB_FILE, cb_int0, cb_ref(), cb_space, CB_TREE, COB_ORG_SORT, current_program, current_statement, cb_file::debug_section, file, cb_statement::file, cb_file::file_status, cb_program::flag_debugging, cb_file::flag_fl_debug, cb_statement::flag_in_debug, cb_file::name, NULL, and cb_file::organization.

4837 {
4838  struct cb_file *f;
4839 
4840  if (file == cb_error_node) {
4841  return;
4842  }
4843  file = cb_ref (file);
4844  if (file == cb_error_node) {
4845  return;
4846  }
4847  current_statement->file = file;
4848  f = CB_FILE (file);
4849 
4850  if (f->organization == COB_ORG_SORT) {
4851  cb_error_x (CB_TREE (current_statement),
4852  _("Operation not allowed on SORT files"));
4853  }
4854 
4855  cb_emit (CB_BUILD_FUNCALL_4 ("cob_close", file,
4856  f->file_status, opt, cb_int0));
4857 
4858  /* Check for file debugging */
4859  if (current_program->flag_debugging &&
4860  !current_statement->flag_in_debug &&
4861  CB_FILE(file)->flag_fl_debug) {
4862  cb_emit (cb_build_debug (cb_debug_name, f->name, NULL));
4863  cb_emit (cb_build_move (cb_space, cb_debug_contents));
4864  cb_emit (cb_build_debug_call (f->debug_section));
4865  }
4866 }
void cb_emit_command_line ( cb_tree  value)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4982 {
4983  if (cb_validate_one (value)) {
4984  return;
4985  }
4986  cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_command_line", value));
4987 }
void cb_emit_commit ( void  )

References CB_BUILD_FUNCALL_0, and cb_emit.

4872 {
4873  cb_emit (CB_BUILD_FUNCALL_0 ("cob_commit"));
4874 }
void cb_emit_continue ( void  )

References cb_build_continue(), and cb_emit.

4880 {
4881  cb_emit (cb_build_continue ());
4882 }
void cb_emit_corresponding ( cb_tree(*)(cb_tree f1, cb_tree f2, cb_tree f3)  func,
cb_tree  x1,
cb_tree  x2,
cb_tree  opt 
)

References _, cb_check_group_name(), cb_validate_one(), cb_warning_x(), and emit_corresponding().

4050 {
4051  x1 = cb_check_group_name (x1);
4052  x2 = cb_check_group_name (x2);
4053 
4054  if (cb_validate_one (x1)) {
4055  return;
4056  }
4057  if (cb_validate_one (x2)) {
4058  return;
4059  }
4060 
4061  if (!emit_corresponding (func, x1, x2, opt)) {
4062  if (cb_warn_corresponding) {
4063  cb_warning_x (x2, _("No CORRESPONDING items found"));
4064  }
4065  }
4066 }
void cb_emit_delete ( cb_tree  file)

References _, CB_BUILD_FUNCALL_2, cb_emit, cb_error_node, cb_error_x(), CB_FILE, cb_ref(), CB_TREE, COB_ORG_LINE_SEQUENTIAL, COB_ORG_SORT, current_program, current_statement, file, cb_statement::file, cb_file::file_status, cb_statement::flag_callback, cb_program::flag_debugging, cb_file::flag_fl_debug, cb_statement::flag_in_debug, and cb_file::organization.

4888 {
4889  struct cb_file *f;
4890 
4891  if (file == cb_error_node) {
4892  return;
4893  }
4894  file = cb_ref (file);
4895  if (file == cb_error_node) {
4896  return;
4897  }
4898  current_statement->file = file;
4899  f = CB_FILE (file);
4900 
4901  if (f->organization == COB_ORG_SORT) {
4902  cb_error_x (CB_TREE (current_statement),
4903  _("Operation not allowed on SORT files"));
4904  return;
4905  } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
4906  cb_error_x (CB_TREE (current_statement),
4907  _("Operation not allowed on LINE SEQUENTIAL files"));
4908  return;
4909  }
4910 
4911  /* Check for file debugging */
4912  if (current_program->flag_debugging &&
4913  !current_statement->flag_in_debug &&
4914  f->flag_fl_debug) {
4915  /* Gen callback after delete but before exception test */
4916  current_statement->flag_callback = 1;
4917  }
4918 
4919  cb_emit (CB_BUILD_FUNCALL_2 ("cob_delete", file,
4920  f->file_status));
4921 }
void cb_emit_delete_file ( cb_tree  file)

References _, CB_BUILD_FUNCALL_2, cb_emit, cb_error_node, cb_error_x(), CB_FILE, cb_ref(), CB_TREE, COB_ORG_SORT, current_program, current_statement, cb_file::file_status, cb_statement::flag_callback, cb_program::flag_debugging, cb_file::flag_fl_debug, cb_statement::flag_in_debug, and cb_file::organization.

4925 {
4926  if (file == cb_error_node) {
4927  return;
4928  }
4929  file = cb_ref (file);
4930  if (file == cb_error_node) {
4931  return;
4932  }
4933  if (CB_FILE (file)->organization == COB_ORG_SORT) {
4934  cb_error_x (CB_TREE (current_statement),
4935  _("Operation not allowed on SORT files"));
4936  return;
4937  }
4938 
4939  /* Check for file debugging */
4940  if (current_program->flag_debugging &&
4941  !current_statement->flag_in_debug &&
4942  CB_FILE(file)->flag_fl_debug) {
4943  /* Gen callback after delete but before exception test */
4944  current_statement->flag_callback = 1;
4945  }
4946 
4947  cb_emit (CB_BUILD_FUNCALL_2 ("cob_delete_file", file,
4948  CB_FILE(file)->file_status));
4949 }
void cb_emit_display ( cb_tree  values,
cb_tree  upon,
cb_tree  no_adv,
cb_tree  pos,
struct cb_attr_struct *  attr_ptr 
)

References _, cb_attr_struct::bgc, CB_BUILD_FUNCALL_0, CB_BUILD_FUNCALL_3, CB_BUILD_FUNCALL_7, CB_CHAIN, cb_emit, cb_error_node, cb_error_x(), CB_FIELD, CB_FIELD_P, CB_FUNCALL, cb_int(), cb_int0, cb_list_length(), CB_LITERAL, CB_LITERAL_P, cb_low, cb_name(), cb_null, CB_PAIR_P, CB_PAIR_X, CB_PAIR_Y, cb_ref(), CB_REF_OR_FIELD_P, CB_REFERENCE, cb_space, CB_STORAGE_SCREEN, CB_TAG_CONST, CB_TAG_INTEGER, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TAG_STRING, CB_TREE_TAG, cb_validate_list(), cb_validate_one(), CB_VALUE, COB_SCREEN_BELL, COB_SCREEN_ERASE_EOL, COB_SCREEN_ERASE_EOS, COB_SCREEN_NO_DISP, cb_attr_struct::dispattrs, cb_attr_struct::fgc, gen_screen_ptr, line, NULL, output_screen_from(), p, cb_attr_struct::scroll, and value.

4992 {
4993  cb_tree l;
4994  cb_tree x;
4995  cb_tree line;
4996  cb_tree column;
4997  cb_tree p;
4998  cb_tree fgc;
4999  cb_tree bgc;
5000  cb_tree scroll;
5001  int dispattrs;
5002 
5003  if (attr_ptr) {
5004  fgc = attr_ptr->fgc;
5005  bgc = attr_ptr->bgc;
5006  scroll = attr_ptr->scroll;
5007  dispattrs = attr_ptr->dispattrs;
5008  } else {
5009  fgc = NULL;
5010  bgc = NULL;
5011  scroll = NULL;
5012  dispattrs = 0;
5013  }
5014 
5015  if (cb_validate_list (values)) {
5016  return;
5017  }
5018  if (cb_validate_one (pos)) {
5019  return;
5020  }
5021  if (cb_validate_one (fgc)) {
5022  return;
5023  }
5024  if (cb_validate_one (bgc)) {
5025  return;
5026  }
5027  if (cb_validate_one (scroll)) {
5028  return;
5029  }
5030  for (l = values; l; l = CB_CHAIN (l)) {
5031  x = CB_VALUE (l);
5032  if (x == cb_error_node) {
5033  return;
5034  }
5035 
5036  switch (CB_TREE_TAG (x)) {
5037  case CB_TAG_LITERAL:
5038  case CB_TAG_INTRINSIC:
5039  case CB_TAG_CONST:
5040  case CB_TAG_STRING:
5041  case CB_TAG_INTEGER:
5042  break;
5043  case CB_TAG_REFERENCE:
5044  if (!CB_FIELD_P(CB_REFERENCE(x)->value)) {
5045  cb_error_x (x, _("'%s' is an invalid type for DISPLAY operand"), cb_name (x));
5046  return;
5047  }
5048  break;
5049  default:
5050  cb_error_x (x, _("Invalid type for DISPLAY operand"));
5051  return;
5052  }
5053  }
5054  if (upon == cb_error_node) {
5055  return;
5056  }
5057 
5058  x = CB_VALUE (values);
5059  if ((CB_REF_OR_FIELD_P (x)) &&
5060  CB_FIELD (cb_ref (x))->storage == CB_STORAGE_SCREEN) {
5061  output_screen_from (CB_FIELD (cb_ref (x)), 0);
5062  gen_screen_ptr = 1;
5063  if (pos) {
5064  if (CB_PAIR_P (pos)) {
5065  line = CB_PAIR_X (pos);
5066  column = CB_PAIR_Y (pos);
5067  if (line == cb_int0) {
5068  line = NULL;
5069  }
5070  cb_emit (CB_BUILD_FUNCALL_3 ("cob_screen_display",
5071  x, line, column));
5072  } else {
5073  cb_emit (CB_BUILD_FUNCALL_3 ("cob_screen_display",
5074  x, pos, NULL));
5075  }
5076  } else {
5077  cb_emit (CB_BUILD_FUNCALL_3 ("cob_screen_display", x,
5078  NULL, NULL));
5079  }
5080  gen_screen_ptr = 0;
5081  } else if (pos || fgc || bgc || scroll || dispattrs || upon == cb_null) {
5082  for (l = values; l; l = CB_CHAIN (l)) {
5083  x = CB_VALUE (l);
5084  if (x == cb_space) {
5085  dispattrs |= COB_SCREEN_ERASE_EOS;
5086  dispattrs |= COB_SCREEN_NO_DISP;
5087  } else if (x == cb_low) {
5088  dispattrs |= COB_SCREEN_NO_DISP;
5089  } else if (CB_LITERAL_P (x) && CB_LITERAL (x)->all &&
5090  CB_LITERAL (x)->size == 1) {
5091  if (CB_LITERAL (x)->data[0] == 1) {
5092  dispattrs |= COB_SCREEN_ERASE_EOL;
5093  dispattrs |= COB_SCREEN_NO_DISP;
5094  } else if (CB_LITERAL (x)->data[0] == 2) {
5095  cb_emit (CB_BUILD_FUNCALL_0 ("cob_sys_clear_screen"));
5096  return;
5097  } else if (CB_LITERAL (x)->data[0] == 7) {
5098  dispattrs |= COB_SCREEN_BELL;
5099  dispattrs |= COB_SCREEN_NO_DISP;
5100  }
5101  }
5102  if (!pos) {
5103  cb_emit (CB_BUILD_FUNCALL_7 ("cob_field_display",
5104  x, NULL, NULL, fgc, bgc,
5105  scroll, cb_int (dispattrs)));
5106  } else if (CB_PAIR_P (pos)) {
5107  line = CB_PAIR_X (pos);
5108  column = CB_PAIR_Y (pos);
5109  if (line == cb_int0) {
5110  line = NULL;
5111  }
5112  cb_emit (CB_BUILD_FUNCALL_7 ("cob_field_display",
5113  x, line, column, fgc, bgc,
5114  scroll, cb_int (dispattrs)));
5115  } else {
5116  cb_emit (CB_BUILD_FUNCALL_7 ("cob_field_display",
5117  x, pos, NULL, fgc, bgc,
5118  scroll, cb_int (dispattrs)));
5119  }
5120  }
5121  } else {
5122  /* DISPLAY x ... [UPON device-name] */
5123  p = CB_BUILD_FUNCALL_3 ("cob_display", upon, no_adv, values);
5124  CB_FUNCALL(p)->varcnt = cb_list_length (values);
5125  CB_FUNCALL(p)->nolitcast = 1;
5126  cb_emit (p);
5127  for (l = values; l; l = CB_CHAIN (l)) {
5128  x = CB_VALUE (l);
5129  if (CB_FIELD_P (x)) {
5130  CB_FIELD (cb_ref (x))->count++;
5131  }
5132  }
5133  }
5134 }
void cb_emit_divide ( cb_tree  dividend,
cb_tree  divisor,
cb_tree  quotient,
cb_tree  remainder 
)

References build_store_option(), CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_4, cb_check_numeric_edited_name(), cb_emit, cb_int0, CB_PURPOSE, cb_validate_one(), and CB_VALUE.

5198 {
5199  if (cb_validate_one (dividend)) {
5200  return;
5201  }
5202  if (cb_validate_one (divisor)) {
5203  return;
5204  }
5205  CB_VALUE (quotient) = cb_check_numeric_edited_name (CB_VALUE (quotient));
5206  CB_VALUE (remainder) = cb_check_numeric_edited_name (CB_VALUE (remainder));
5207 
5208  if (cb_validate_one (CB_VALUE (quotient))) {
5209  return;
5210  }
5211  if (cb_validate_one (CB_VALUE (remainder))) {
5212  return;
5213  }
5214 
5215  cb_emit (CB_BUILD_FUNCALL_4 ("cob_div_quotient", dividend, divisor,
5216  CB_VALUE (quotient),
5217  build_store_option (CB_VALUE (quotient),
5218  CB_PURPOSE (quotient))));
5219  cb_emit (CB_BUILD_FUNCALL_2 ("cob_div_remainder", CB_VALUE (remainder),
5220  build_store_option (CB_VALUE (remainder),
5221  cb_int0)));
5222 }
void cb_emit_env_name ( cb_tree  value)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4955 {
4956  if (cb_validate_one (value)) {
4957  return;
4958  }
4959  cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_environment", value));
4960 }
void cb_emit_env_value ( cb_tree  value)

References CB_BUILD_FUNCALL_1, cb_emit, and cb_validate_one().

4964 {
4965  if (cb_validate_one (value)) {
4966  return;
4967  }
4968  cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_env_value", value));
4969 }
void cb_emit_evaluate ( cb_tree  subject_list,
cb_tree  case_list 
)

References build_evaluate(), cb_build_comment(), cb_build_direct(), cb_emit, cb_id, CB_PREFIX_LABEL, and cobc_parse_strdup().

5369 {
5370  cb_tree x;
5371  char sbuf[16];
5372 
5373  snprintf (sbuf, sizeof(sbuf), "goto %s%d;", CB_PREFIX_LABEL, cb_id);
5374  x = cb_build_direct (cobc_parse_strdup (sbuf), 0);
5375  build_evaluate (subject_list, case_list, x);
5376  snprintf (sbuf, sizeof(sbuf), "%s%d:;", CB_PREFIX_LABEL, cb_id);
5377  cb_emit (cb_build_comment ("End EVALUATE"));
5378  cb_emit (cb_build_direct (cobc_parse_strdup (sbuf), 0));
5379  cb_id++;
5380 }
void cb_emit_exit ( const unsigned int  goback)

References cb_build_goto(), cb_emit, cb_int1, and NULL.

5451 {
5452  if (goback) {
5453  cb_emit (cb_build_goto (cb_int1, NULL));
5454  } else {
5455  cb_emit (cb_build_goto (NULL, NULL));
5456  }
5457 }
void cb_emit_free ( cb_tree  vars)

References _, CB_BUILD_CAST_ADDR_OF_ADDR, CB_BUILD_CAST_ADDRESS, CB_BUILD_FUNCALL_2, CB_CAST, CB_CAST_P, CB_CHAIN, CB_CLASS_POINTER, cb_emit, cb_error_x(), CB_FIELD_PTR, CB_REF_OR_FIELD_P, CB_TREE, CB_TREE_CLASS, cb_validate_list(), CB_VALUE, current_statement, cb_field::flag_item_based, and NULL.

5386 {
5387  cb_tree l;
5388  struct cb_field *f;
5389  int i;
5390 
5391  if (cb_validate_list (vars)) {
5392  return;
5393  }
5394  for (l = vars, i = 1; l; l = CB_CHAIN (l), i++) {
5395  if (CB_TREE_CLASS (CB_VALUE (l)) == CB_CLASS_POINTER) {
5396  if (CB_CAST_P (CB_VALUE (l))) {
5397  f = CB_FIELD_PTR (CB_CAST (CB_VALUE(l))->val);
5398  if (!f->flag_item_based) {
5399  cb_error_x (CB_TREE (current_statement),
5400  _("Target %d of FREE is not a BASED data item"), i);
5401  }
5402  cb_emit (CB_BUILD_FUNCALL_2 ("cob_free_alloc",
5403  CB_BUILD_CAST_ADDRESS (CB_VALUE (l)), NULL));
5404  } else {
5405  cb_emit (CB_BUILD_FUNCALL_2 ("cob_free_alloc",
5406  NULL, CB_BUILD_CAST_ADDRESS (CB_VALUE (l))));
5407  }
5408  } else if (CB_REF_OR_FIELD_P (CB_VALUE (l))) {
5409  f = CB_FIELD_PTR (CB_VALUE (l));
5410  if (!f->flag_item_based) {
5411  cb_error_x (CB_TREE (current_statement),
5412  _("Target %d of FREE is not a BASED data item"), i);
5413  }
5414  cb_emit (CB_BUILD_FUNCALL_2 ("cob_free_alloc",
5415  CB_BUILD_CAST_ADDR_OF_ADDR (CB_VALUE (l)), NULL));
5416  } else {
5417  cb_error_x (CB_TREE (current_statement),
5418  _("Target %d of FREE must be a data pointer"), i);
5419  }
5420  }
5421 }
void cb_emit_get_environment ( cb_tree  envvar,
cb_tree  envval 
)

References CB_BUILD_FUNCALL_2, cb_emit, and cb_validate_one().

4424 {
4425  if (cb_validate_one (envvar)) {
4426  return;
4427  }
4428  if (cb_validate_one (envval)) {
4429  return;
4430  }
4431  cb_emit (CB_BUILD_FUNCALL_2 ("cob_get_environment", envvar, envval));
4432 }
void cb_emit_goto ( cb_tree  target,
cb_tree  depending 
)

References _, cb_build_goto(), CB_CHAIN, cb_check_data_incompat(), cb_check_numeric_value(), cb_emit, cb_error_node, cb_error_x(), CB_TREE, CB_VALUE, cb_verify(), current_statement, and NULL.

5427 {
5428  if (target == cb_error_node) {
5429  return;
5430  }
5431  if (target == NULL) {
5432  cb_verify (cb_goto_statement_without_name, "GO TO without procedure-name");
5433  } else if (depending) {
5434  /* GO TO procedure-name ... DEPENDING ON identifier */
5435  if (cb_check_numeric_value (depending) == cb_error_node) {
5436  return;
5437  }
5438  cb_check_data_incompat (depending);
5439  cb_emit (cb_build_goto (target, depending));
5440  } else if (CB_CHAIN (target)) {
5441  cb_error_x (CB_TREE (current_statement),
5442  _("GO TO with multiple procedure-names"));
5443  } else {
5444  /* GO TO procedure-name */
5445  cb_emit (cb_build_goto (CB_VALUE (target), NULL));
5446  }
5447 }
void cb_emit_if ( cb_tree  cond,
cb_tree  stmt1,
cb_tree  stmt2 
)

References cb_build_if(), and cb_emit.

5463 {
5464  cb_emit (cb_build_if (cond, stmt1, stmt2, 1));
5465 }
void cb_emit_initialize ( cb_tree  vars,
cb_tree  fillinit,
cb_tree  value,
cb_tree  replacing,
cb_tree  def 
)

References cb_build_initialize(), CB_CHAIN, cb_emit, cb_true, cb_validate_list(), CB_VALUE, and NULL.

5481 {
5482  cb_tree l;
5483  unsigned int no_fill_init;
5484  unsigned int def_init;
5485 
5486  if (cb_validate_list (vars)) {
5487  return;
5488  }
5489  if (value == NULL && replacing == NULL) {
5490  def = cb_true;
5491  }
5492  no_fill_init = (fillinit == NULL);
5493  def_init = (def != NULL);
5494  for (l = vars; l; l = CB_CHAIN (l)) {
5495  cb_emit (cb_build_initialize (CB_VALUE (l), value, replacing,
5496  def_init, 1, no_fill_init));
5497  }
5498 }
void cb_emit_inspect ( cb_tree  var,
cb_tree  body,
cb_tree  replacing,
const unsigned int  replconv 
)

References _, CB_BUILD_FUNCALL_0, CB_BUILD_FUNCALL_2, CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_NATIONAL, cb_emit, cb_emit_list, cb_error_x(), CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE, CB_TREE_CATEGORY, CB_TREE_TAG, and current_statement.

5596 {
5597  switch (CB_TREE_TAG(var)) {
5598  case CB_TAG_REFERENCE:
5599  break;
5600  case CB_TAG_INTRINSIC:
5601  if (replconv) {
5602  goto rep_error;
5603  }
5604  switch (CB_TREE_CATEGORY(var)) {
5605  case CB_CATEGORY_ALPHABETIC:
5606  case CB_CATEGORY_ALPHANUMERIC:
5607  case CB_CATEGORY_NATIONAL:
5608  break;
5609  default:
5610  cb_error_x (CB_TREE (current_statement),
5611  _("Invalid target for INSPECT"));
5612  return;
5613  }
5614  break;
5615  case CB_TAG_LITERAL:
5616  if (replconv) {
5617  goto rep_error;
5618  }
5619  break;
5620  default:
5621  goto rep_error;
5622  }
5623  cb_emit (CB_BUILD_FUNCALL_2 ("cob_inspect_init", var, replacing));
5624  cb_emit_list (body);
5625  cb_emit (CB_BUILD_FUNCALL_0 ("cob_inspect_finish"));
5626  return;
5627 rep_error:
5628  if (replconv == 1) {
5629  cb_error_x (CB_TREE (current_statement),
5630  _("Invalid target for %s"), "REPLACING");
5631  } else {
5632  cb_error_x (CB_TREE (current_statement),
5633  _("Invalid target for %s"), "CONVERTING");
5634  }
5635 }
void cb_emit_move ( cb_tree  src,
cb_tree  dsts 
)

References _, CB_BUILD_FUNCALL_1, cb_build_move(), CB_CHAIN, cb_check_data_incompat(), CB_CONST_P, cb_emit, cb_error_x(), CB_INTRINSIC_P, cb_list_length(), CB_LITERAL_P, cb_name(), CB_REFERENCE, CB_REFERENCE_P, CB_TREE, cb_validate_list(), cb_validate_one(), CB_VALUE, current_statement, cb_reference::offset, and cb_reference::subs.

7186 {
7187  cb_tree l;
7188  cb_tree x;
7189  cb_tree m;
7190  unsigned int tempval;
7191 
7192  if (cb_validate_one (src)) {
7193  return;
7194  }
7195  if (cb_validate_list (dsts)) {
7196  return;
7197  }
7198 
7199  cb_check_data_incompat (src);
7200 
7201  tempval = 0;
7202  if (cb_list_length (dsts) > 1) {
7203  if (CB_INTRINSIC_P (src) || (CB_REFERENCE_P (src) &&
7204  (CB_REFERENCE (src)->subs || CB_REFERENCE (src)->offset))) {
7205  tempval = 1;
7206  cb_emit (CB_BUILD_FUNCALL_1 ("cob_put_indirect_field",
7207  src));
7208  }
7209  }
7210 
7211  for (l = dsts; l; l = CB_CHAIN (l)) {
7212  x = CB_VALUE (l);
7213  if (CB_LITERAL_P (x) || CB_CONST_P (x)) {
7214  cb_error_x (CB_TREE (current_statement),
7215  _("Invalid MOVE target - %s"), cb_name (x));
7216  continue;
7217  }
7218  if (!tempval) {
7219  m = cb_build_move (src, x);
7220  } else {
7221  m = CB_BUILD_FUNCALL_1 ("cob_get_indirect_field", x);
7222  }
7223  cb_emit (m);
7224  }
7225 }
void cb_emit_move_corresponding ( cb_tree  x1,
cb_tree  x2 
)

References _, CB_CHAIN, cb_check_group_name(), cb_validate_one(), CB_VALUE, cb_warning_x(), and emit_move_corresponding().

4100 {
4101  cb_tree l;
4102  cb_tree v;
4103 
4104  x1 = cb_check_group_name (x1);
4105  if (cb_validate_one (x1)) {
4106  return;
4107  }
4108  for (l = x2; l; l = CB_CHAIN(l)) {
4109  v = CB_VALUE(l);
4110  v = cb_check_group_name (v);
4111  if (cb_validate_one (v)) {
4112  return;
4113  }
4114  if (!emit_move_corresponding (x1, v)) {
4115  if (cb_warn_corresponding) {
4116  cb_warning_x (v, _("No CORRESPONDING items found"));
4117  }
4118  }
4119  }
4120 }
void cb_emit_open ( cb_tree  file,
cb_tree  mode,
cb_tree  sharing 
)

References _, cb_build_debug(), cb_build_debug_call(), CB_BUILD_FUNCALL_4, cb_build_move(), cb_emit, cb_error_node, cb_error_x(), CB_FILE, cb_int(), cb_int0, cb_ref(), cb_space, CB_TREE, COB_OPEN_I_O, COB_ORG_LINE_SEQUENTIAL, COB_ORG_SORT, current_program, current_statement, cb_file::debug_section, file, cb_statement::file, cb_file::file_status, cb_program::flag_debugging, cb_file::flag_fl_debug, cb_statement::flag_in_debug, cb_file::name, NULL, cb_file::organization, and cb_file::sharing.

7231 {
7232  struct cb_file *f;
7233 
7234  if (file == cb_error_node) {
7235  return;
7236  }
7237  file = cb_ref (file);
7238  if (file == cb_error_node) {
7239  return;
7240  }
7241  current_statement->file = file;
7242  f = CB_FILE (file);
7243 
7244  if (f->organization == COB_ORG_SORT) {
7245  cb_error_x (CB_TREE (current_statement),
7246  _("Operation not allowed on SORT files"));
7247  return;
7248  } else if (f->organization == COB_ORG_LINE_SEQUENTIAL &&
7249  mode == cb_int (COB_OPEN_I_O)) {
7250  cb_error_x (CB_TREE (current_statement),
7251  _("OPEN I-O not allowed on LINE SEQUENTIAL files"));
7252  return;
7253  }
7254  if (sharing == NULL) {
7255  if (f->sharing) {
7256  sharing = f->sharing;
7257  } else {
7258  sharing = cb_int0;
7259  }
7260  }
7261 
7262  cb_emit (CB_BUILD_FUNCALL_4 ("cob_open", file, mode,
7263  sharing, f->file_status));
7264 
7265  /* Check for file debugging */
7266  if (current_program->flag_debugging &&
7267  !current_statement->flag_in_debug &&
7268  f->flag_fl_debug) {
7269  cb_emit (cb_build_debug (cb_debug_name, f->name, NULL));
7270  cb_emit (cb_build_move (cb_space, cb_debug_contents));
7271  cb_emit (cb_build_debug_call (f->debug_section));
7272  }
7273 }
void cb_emit_perform ( cb_tree  perform,
cb_tree  body 
)

References cb_build_debug(), cb_emit, cb_error_node, CB_PAIR_P, CB_PERFORM, current_program, current_statement, cb_program::flag_debugging, cb_statement::flag_in_debug, and NULL.

7279 {
7280  if (perform == cb_error_node) {
7281  return;
7282  }
7283  if (current_program->flag_debugging &&
7284  !current_statement->flag_in_debug && CB_PAIR_P (body)) {
7285  cb_emit (cb_build_debug (cb_debug_contents, "PERFORM LOOP", NULL));
7286  }
7287  CB_PERFORM (perform)->body = body;
7288  cb_emit (perform);
7289 }
void cb_emit_read ( cb_tree  ref,
cb_tree  next,
cb_tree  into,
cb_tree  key,
cb_tree  lock_opts 
)

References _, cb_file::access_mode, cb_build_debug(), cb_build_debug_call(), cb_build_field_reference(), CB_BUILD_FUNCALL_3, CB_BUILD_FUNCALL_4, cb_build_move(), cb_emit, cb_error_node, cb_error_x(), CB_FILE, cb_int(), cb_int1, cb_int2, cb_int3, cb_int4, cb_list_add(), CB_LIST_INIT, cb_ref(), CB_TREE, cb_warning(), COB_ACCESS_DYNAMIC, COB_ACCESS_SEQUENTIAL, COB_ORG_INDEXED, COB_ORG_RELATIVE, COB_ORG_SORT, COB_READ_IGNORE_LOCK, COB_READ_LOCK, COB_READ_NEXT, COB_READ_NO_LOCK, COB_READ_PREVIOUS, COB_READ_WAIT_LOCK, current_program, current_statement, cb_file::debug_section, file, cb_statement::file, cb_file::file_status, cb_program::flag_debugging, cb_file::flag_fl_debug, cb_statement::flag_in_debug, cb_statement::handler3, cb_statement::handler_id, cb_file::key, cb_file::name, NULL, cb_file::organization, and cb_file::record.

7357 {
7358  cb_tree file;
7359  cb_tree rec;
7360  cb_tree x;
7361  struct cb_file *f;
7362  int read_opts;
7363 
7364  read_opts = 0;
7365  if (lock_opts == cb_int1) {
7366  read_opts = COB_READ_LOCK;
7367  } else if (lock_opts == cb_int2) {
7368  read_opts = COB_READ_NO_LOCK;
7369  } else if (lock_opts == cb_int3) {
7370  read_opts = COB_READ_IGNORE_LOCK;
7371  } else if (lock_opts == cb_int4) {
7372  read_opts = COB_READ_WAIT_LOCK;
7373  }
7374  if (ref == cb_error_node) {
7375  return;
7376  }
7377  file = cb_ref (ref);
7378  if (file == cb_error_node) {
7379  return;
7380  }
7381  f = CB_FILE (file);
7382 
7383  rec = cb_build_field_reference (f->record, ref);
7384  if (f->organization == COB_ORG_SORT) {
7385  cb_error_x (CB_TREE (current_statement),
7386  _("Operation not allowed on SORT files"));
7387  return;
7388  }
7389  if (next == cb_int1 || next == cb_int2 ||
7390  f->access_mode == COB_ACCESS_SEQUENTIAL) {
7391  /* READ NEXT/PREVIOUS */
7392  if (next == cb_int2) {
7393  switch (f->organization) {
7394  case COB_ORG_INDEXED:
7395  case COB_ORG_RELATIVE:
7396  break;
7397  default:
7398  cb_error_x (CB_TREE (current_statement),
7399  _("READ PREVIOUS not allowed for this file type"));
7400  return;
7401  }
7402  read_opts |= COB_READ_PREVIOUS;
7403  } else {
7404  read_opts |= COB_READ_NEXT;
7405  }
7406  if (key) {
7407  cb_warning (_("KEY ignored with sequential READ"));
7408  }
7409  cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
7410  f->file_status,
7411  cb_int (read_opts)));
7412  } else {
7413  /* READ */
7414  /* DYNAMIC with [NOT] AT END */
7415  if (f->access_mode == COB_ACCESS_DYNAMIC &&
7416  current_statement->handler_id == COB_EC_I_O_AT_END) {
7417  read_opts |= COB_READ_NEXT;
7418  cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
7419  f->file_status,
7420  cb_int (read_opts)));
7421  } else if (key || f->key) {
7422  cb_emit (CB_BUILD_FUNCALL_4 ("cob_read",
7423  file, key ? key : f->key,
7424  f->file_status, cb_int (read_opts)));
7425  } else {
7426  cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
7427  f->file_status,
7428  cb_int (read_opts)));
7429  }
7430  }
7431  if (into) {
7432  current_statement->handler3 = cb_build_move (rec, into);
7433  }
7434 
7435  /* Check for file debugging */
7436  if (current_program->flag_debugging &&
7437  !current_statement->flag_in_debug &&
7438  f->flag_fl_debug) {
7439  if (into) {
7440  current_statement->handler3 =
7441  CB_LIST_INIT (current_statement->handler3);
7442  }
7443  x = cb_build_debug (cb_debug_name, f->name, NULL);
7444  current_statement->handler3 =
7445  cb_list_add (current_statement->handler3, x);
7446  x = cb_build_move (rec, cb_debug_contents);
7447  current_statement->handler3 =
7448  cb_list_add (current_statement->handler3, x);
7449  x = cb_build_debug_call (f->debug_section);
7450  current_statement->handler3 =
7451  cb_list_add (current_statement->handler3, x);
7452  }
7453  current_statement->file = file;
7454 }
void cb_emit_ready_trace ( void  )

References CB_BUILD_FUNCALL_0, and cb_emit.

7460 {
7461  cb_emit (CB_BUILD_FUNCALL_0 ("cob_ready_trace"));
7462 }
void cb_emit_release ( cb_tree  record,
cb_tree  from 
)

References _, CB_BUILD_FUNCALL_1, cb_build_move(), cb_emit, cb_error_x(), CB_FIELD_PTR, CB_FILE, cb_ref(), CB_REF_OR_FIELD_P, CB_STORAGE_FILE, CB_TREE, cb_validate_one(), COB_ORG_SORT, current_statement, file, cb_field::file, cb_statement::file, and cb_field::storage.

7550 {
7551  struct cb_field *f;
7552  cb_tree file;
7553 
7554  if (cb_validate_one (record)) {
7555  return;
7556  }
7557  if (cb_validate_one (from)) {
7558  return;
7559  }
7560  if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
7561  cb_error_x (CB_TREE (current_statement),
7562  _("RELEASE requires a record name as subject"));
7563  return;
7564  }
7565  f = CB_FIELD_PTR (record);
7566  if (f->storage != CB_STORAGE_FILE) {
7567  cb_error_x (CB_TREE (current_statement),
7568  _("RELEASE subject does not refer to a record name"));
7569  return;
7570  }
7571  file = CB_TREE (f->file);
7572  if (CB_FILE (file)->organization != COB_ORG_SORT) {
7573  cb_error_x (CB_TREE (current_statement),
7574  _("RELEASE not allowed on this record item"));
7575  return;
7576  }
7577  current_statement->file = file;
7578  if (from) {
7579  cb_emit (cb_build_move (from, record));
7580  }
7581  cb_emit (CB_BUILD_FUNCALL_1 ("cob_file_release", file));
7582 }
void cb_emit_reset_trace ( void  )

References CB_BUILD_FUNCALL_0, and cb_emit.

7469 {
7470  cb_emit (CB_BUILD_FUNCALL_0 ("cob_reset_trace"));
7471 }
void cb_emit_return ( cb_tree  ref,
cb_tree  into 
)

References cb_build_field_reference(), CB_BUILD_FUNCALL_1, cb_build_move(), cb_emit, cb_error_node, CB_FILE, cb_ref(), cb_validate_one(), current_statement, file, cb_statement::file, and cb_statement::handler3.

7588 {
7589  cb_tree file;
7590  cb_tree rec;
7591 
7592  if (cb_validate_one (ref)) {
7593  return;
7594  }
7595  if (cb_validate_one (into)) {
7596  return;
7597  }
7598  file = cb_ref (ref);
7599  if (file == cb_error_node) {
7600  return;
7601  }
7602  rec = cb_build_field_reference (CB_FILE (file)->record, ref);
7603  cb_emit (CB_BUILD_FUNCALL_1 ("cob_file_return", file));
7604  if (into) {
7605  current_statement->handler3 = cb_build_move (rec, into);
7606  }
7607  current_statement->file = file;
7608 }
void cb_emit_rewrite ( cb_tree  record,
cb_tree  from,
cb_tree  lockopt 
)

References _, cb_build_debug(), cb_build_debug_call(), CB_BUILD_FUNCALL_4, cb_build_move(), cb_emit, cb_error_node, cb_error_x(), CB_FIELD, CB_FIELD_PTR, CB_FILE, cb_int(), cb_int1, cb_ref(), CB_REF_OR_FIELD_P, CB_STORAGE_FILE, CB_TREE, cb_validate_one(), COB_EC_I_O_INVALID_KEY, COB_LOCK_AUTOMATIC, COB_ORG_INDEXED, COB_ORG_LINE_SEQUENTIAL, COB_ORG_RELATIVE, COB_ORG_SORT, COB_WRITE_LOCK, current_program, current_statement, cb_file::debug_section, file, cb_statement::file, cb_file::file_status, cb_program::flag_debugging, cb_statement::flag_in_debug, cb_statement::handler_id, cb_file::lock_mode, cb_file::name, NULL, and cb_file::organization.

7477 {
7478  cb_tree file;
7479  struct cb_file *f;
7480  int opts;
7481 
7482  if (cb_validate_one (record)) {
7483  return;
7484  }
7485  if (cb_validate_one (from)) {
7486  return;
7487  }
7488  if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
7489  cb_error_x (CB_TREE (current_statement),
7490  _("REWRITE requires a record name as subject"));
7491  return;
7492  }
7493  if (CB_FIELD_PTR (record)->storage != CB_STORAGE_FILE) {
7494  cb_error_x (CB_TREE (current_statement),
7495  _("REWRITE subject does not refer to a record name"));
7496  return;
7497  }
7498 
7499  file = CB_TREE (CB_FIELD (cb_ref (record))->file);
7500  if (!file || file == cb_error_node) {
7501  return;
7502  }
7503  current_statement->file = file;
7504  f = CB_FILE (file);
7505  opts = 0;
7506 
7507  if (f->organization == COB_ORG_SORT) {
7508  cb_error_x (CB_TREE (current_statement),
7509  _("Operation not allowed on SORT files"));
7510  return;
7511  } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
7512  cb_error_x (CB_TREE (current_statement),
7513  _("Operation not allowed on LINE SEQUENTIAL files"));
7514  return;
7515  } else if (current_statement->handler_id == COB_EC_I_O_INVALID_KEY &&
7516  (f->organization != COB_ORG_RELATIVE &&
7517  f->organization != COB_ORG_INDEXED)) {
7518  cb_error_x (CB_TREE(current_statement),
7519  _("INVALID KEY clause invalid with this file type"));
7520  return;
7521  } else if ((f->lock_mode & COB_LOCK_AUTOMATIC) && lockopt) {
7522  cb_error_x (CB_TREE (current_statement),
7523  _("LOCK clause invalid with file LOCK AUTOMATIC"));
7524  return;
7525  } else if (lockopt == cb_int1) {
7526  opts = COB_WRITE_LOCK;
7527  }
7528 
7529  if (from) {
7530  cb_emit (cb_build_move (from, record));
7531  }
7532 
7533  /* Check debugging on record name */
7534  if (current_program->flag_debugging &&
7535  !current_statement->flag_in_debug &&
7536  CB_FIELD_PTR (record)->flag_field_debug) {
7537  cb_emit (cb_build_debug (cb_debug_name,
7538  CB_FIELD_PTR (record)->name, NULL));
7539  cb_emit (cb_build_move (record, cb_debug_contents));
7540  cb_emit (cb_build_debug_call (CB_FIELD_PTR (record)->debug_section));
7541  }
7542  cb_emit (CB_BUILD_FUNCALL_4 ("cob_rewrite", file, record,
7543  cb_int (opts), f->file_status));
7544 }
void cb_emit_rollback ( void  )

References CB_BUILD_FUNCALL_0, and cb_emit.

7614 {
7615  cb_emit (CB_BUILD_FUNCALL_0 ("cob_rollback"));
7616 }
void cb_emit_search ( cb_tree  table,
cb_tree  varying,
cb_tree  at_end,
cb_tree  whens 
)

References cb_build_search(), cb_check_needs_break(), cb_emit, cb_error_node, cb_list_reverse(), and cb_validate_one().

7735 {
7736  if (cb_validate_one (table)) {
7737  return;
7738  }
7739  if (cb_validate_one (varying)) {
7740  return;
7741  }
7742  if (table == cb_error_node) {
7743  return;
7744  }
7745  if (whens == cb_error_node) {
7746  return;
7747  }
7748  whens = cb_list_reverse (whens);
7749  cb_emit (cb_build_search (0, table, varying,
7750  cb_check_needs_break (at_end), whens));
7751 }
void cb_emit_search_all ( cb_tree  table,
cb_tree  at_end,
cb_tree  when,
cb_tree  stmts 
)

References cb_build_if(), cb_build_search(), cb_build_search_all(), cb_check_needs_break(), cb_emit, cb_error_node, cb_validate_one(), and NULL.

7755 {
7756  cb_tree x;
7757  cb_tree stmt_lis;
7758 
7759  if (cb_validate_one (table)) {
7760  return;
7761  }
7762  if (table == cb_error_node) {
7763  return;
7764  }
7765  if (when == cb_error_node) {
7766  return;
7767  }
7768  x = cb_build_search_all (table, when);
7769  if (!x) {
7770  return;
7771  }
7772 
7773  stmt_lis = cb_check_needs_break (stmts);
7774  cb_emit (cb_build_search (1, table, NULL,
7775  cb_check_needs_break (at_end),
7776  cb_build_if (x, stmt_lis, NULL, 0)));
7777 }
void cb_emit_set_attribute ( cb_tree  x,
const int  val_on,
const int  val_off 
)

References _, cb_build_set_attribute(), cb_emit, cb_error_x(), CB_FIELD_PTR, cb_ref(), CB_REF_OR_FIELD_P, CB_STORAGE_SCREEN, CB_TREE, cb_validate_one(), current_statement, and cb_field::storage.

7977 {
7978  struct cb_field *f;
7979 
7980  if (cb_validate_one (x)) {
7981  return;
7982  }
7983  if (!CB_REF_OR_FIELD_P (cb_ref (x))) {
7984  cb_error_x (CB_TREE (current_statement),
7985  _("SET ATTRIBUTE requires a screen item as subject"));
7986  return;
7987  }
7988  f = CB_FIELD_PTR (x);
7989  if (f->storage != CB_STORAGE_SCREEN) {
7990  cb_error_x (CB_TREE (current_statement),
7991  _("SET ATTRIBUTE subject does not refer to a screen item"));
7992  return;
7993  }
7994  cb_emit (cb_build_set_attribute (f, val_on, val_off));
7995 }
void cb_emit_set_false ( cb_tree  l)

References _, cb_build_field_reference(), cb_build_move(), CB_CHAIN, cb_emit, cb_error_node, cb_error_x(), CB_FIELD_P, CB_FIELD_PTR, CB_PAIR_P, CB_PAIR_X, CB_REFERENCE, CB_REFERENCE_P, CB_VALUE, cb_field::false_88, cb_field::level, cb_field::parent, and value.

7941 {
7942  cb_tree x;
7943  struct cb_field *f;
7944  cb_tree ref;
7945  cb_tree val;
7946 
7947  for (; l; l = CB_CHAIN (l)) {
7948  x = CB_VALUE (l);
7949  if (x == cb_error_node) {
7950  return;
7951  }
7952  if (!(CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value)) &&
7953  !CB_FIELD_P (x)) {
7954  cb_error_x (x, _("Invalid SET statement"));
7955  return;
7956  }
7957  f = CB_FIELD_PTR (x);
7958  if (f->level != 88) {
7959  cb_error_x (x, _("Invalid SET statement"));
7960  return;
7961  }
7962  if (!f->false_88) {
7963  cb_error_x (x, _("Field does not have FALSE clause"));
7964  return;
7965  }
7966  ref = cb_build_field_reference (f->parent, x);
7967  val = CB_VALUE (f->false_88);
7968  if (CB_PAIR_P (val)) {
7969  val = CB_PAIR_X (val);
7970  }
7971  cb_emit (cb_build_move (val, ref));
7972  }
7973 }
void cb_emit_set_on_off ( cb_tree  l,
cb_tree  flag 
)

References CB_BUILD_FUNCALL_2, CB_CHAIN, cb_emit, cb_int(), cb_ref(), CB_SYSTEM_NAME, cb_validate_list(), CB_VALUE, and cb_system_name::token.

7894 {
7895  struct cb_system_name *s;
7896 
7897  if (cb_validate_list (l)) {
7898  return;
7899  }
7900  for (; l; l = CB_CHAIN (l)) {
7901  s = CB_SYSTEM_NAME (cb_ref (CB_VALUE (l)));
7902  cb_emit (CB_BUILD_FUNCALL_2 ("cob_set_switch",
7903  cb_int (s->token), flag));
7904  }
7905 }
void cb_emit_set_to ( cb_tree  vars,
cb_tree  x 
)

References _, cb_cast::cast_type, cb_build_move(), CB_CAST, CB_CAST_ADDRESS, CB_CAST_P, CB_CAST_PROGRAM_POINTER, CB_CHAIN, cb_check_data_incompat(), CB_CLASS_INDEX, CB_CLASS_NUMERIC, CB_CLASS_POINTER, CB_CLASS_UNKNOWN, cb_emit, cb_error_node, cb_error_x(), CB_FIELD, cb_name(), cb_ref(), CB_REFERENCE_P, CB_STORAGE_LINKAGE, CB_TREE, CB_TREE_CLASS, cb_tree_class(), CB_USAGE_PROGRAM_POINTER, cb_validate_list(), cb_validate_one(), CB_VALUE, current_statement, p, and cb_cast::val.

7789 {
7790  cb_tree l;
7791  cb_tree v;
7792  struct cb_cast *p;
7793  enum cb_class class;
7794 
7795  if (cb_validate_one (x)) {
7796  return;
7797  }
7798  if (cb_validate_list (vars)) {
7799  return;
7800  }
7801 
7802 #if 0 /* RXWRXW - target check */
7803  /* Determine class of targets */
7804  for (l = vars; l; l = CB_CHAIN (l)) {
7805  if (CB_TREE_CLASS (CB_VALUE (l)) != CB_CLASS_UNKNOWN) {
7806  if (class == CB_CLASS_UNKNOWN) {
7807  class = CB_TREE_CLASS (CB_VALUE (l));
7808  } else if (class != CB_TREE_CLASS (CB_VALUE (l))) {
7809  break;
7810  }
7811  }
7812  }
7813  if (l || (class != CB_CLASS_INDEX && class != CB_CLASS_POINTER)) {
7814  cb_error_x (CB_TREE (current_statement),
7815  _("The targets of SET must be either indexes or pointers"));
7816  return;
7817  }
7818 #endif
7819 
7820  if (CB_CAST_P (x)) {
7821  p = CB_CAST (x);
7822  if (p->cast_type == CB_CAST_PROGRAM_POINTER) {
7823  for (l = vars; l; l = CB_CHAIN (l)) {
7824  v = CB_VALUE (l);
7825  if (!CB_REFERENCE_P (v)) {
7826  cb_error_x (CB_TREE (current_statement),
7827  _("SET targets must be PROGRAM-POINTER"));
7828  CB_VALUE (l) = cb_error_node;
7829  } else if (CB_FIELD(cb_ref(v))->usage != CB_USAGE_PROGRAM_POINTER) {
7830  cb_error_x (CB_TREE (current_statement),
7831  _("SET targets must be PROGRAM-POINTER"));
7832  CB_VALUE (l) = cb_error_node;
7833  }
7834  }
7835  }
7836  }
7837  /* Validate the targets */
7838  for (l = vars; l; l = CB_CHAIN (l)) {
7839  v = CB_VALUE (l);
7840  if (!CB_CAST_P (v)) {
7841  continue;
7842  }
7843  p = CB_CAST (v);
7844  if (p->cast_type == CB_CAST_ADDRESS &&
7845  !CB_FIELD (cb_ref (p->val))->flag_item_based &&
7846  CB_FIELD (cb_ref (p->val))->storage != CB_STORAGE_LINKAGE) {
7847  cb_error_x (p->val, _("The address of '%s' cannot be changed"),
7848  cb_name (p->val));
7849  CB_VALUE (l) = cb_error_node;
7850  }
7851  }
7852  if (cb_validate_list (vars)) {
7853  return;
7854  }
7855 
7856  for (l = vars; l; l = CB_CHAIN (l)) {
7857  class = cb_tree_class (CB_VALUE (l));
7858  switch (class) {
7859  case CB_CLASS_INDEX:
7860  case CB_CLASS_NUMERIC:
7861  case CB_CLASS_POINTER:
7862  cb_check_data_incompat (x);
7863  cb_emit (cb_build_move (x, CB_VALUE (l)));
7864  break;
7865  default:
7866  cb_error_x (CB_TREE (current_statement),
7867  _("SET target is invalid - '%s'"),
7868  cb_name (CB_VALUE(l)));
7869  break;
7870  }
7871  }
7872 }
void cb_emit_set_true ( cb_tree  l)

References _, cb_build_field_reference(), cb_build_move(), CB_CHAIN, cb_emit, cb_error_node, cb_error_x(), CB_FIELD_P, CB_FIELD_PTR, CB_PAIR_P, CB_PAIR_X, CB_REFERENCE, CB_REFERENCE_P, CB_VALUE, cb_field::level, cb_field::parent, value, and cb_field::values.

7909 {
7910  cb_tree x;
7911  struct cb_field *f;
7912  cb_tree ref;
7913  cb_tree val;
7914 
7915  for (; l; l = CB_CHAIN (l)) {
7916  x = CB_VALUE (l);
7917  if (x == cb_error_node) {
7918  return;
7919  }
7920  if (!(CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value)) &&
7921  !CB_FIELD_P (x)) {
7922  cb_error_x (x, _("Invalid SET statement"));
7923  return;
7924  }
7925  f = CB_FIELD_PTR (x);
7926  if (f->level != 88) {
7927  cb_error_x (x, _("Invalid SET statement"));
7928  return;
7929  }
7930  ref = cb_build_field_reference (f->parent, x);
7931  val = CB_VALUE (f->values);
7932  if (CB_PAIR_P (val)) {
7933  val = CB_PAIR_X (val);
7934  }
7935  cb_emit (cb_build_move (val, ref));
7936  }
7937 }
void cb_emit_set_up_down ( cb_tree  l,
cb_tree  flag,
cb_tree  x 
)

References cb_build_add(), cb_build_sub(), CB_CHAIN, cb_emit, cb_int0, cb_validate_list(), cb_validate_one(), and CB_VALUE.

7876 {
7877  if (cb_validate_one (x)) {
7878  return;
7879  }
7880  if (cb_validate_list (l)) {
7881  return;
7882  }
7883  for (; l; l = CB_CHAIN (l)) {
7884  if (flag == cb_int0) {
7885  cb_emit (cb_build_add (CB_VALUE (l), x, cb_int0));
7886  } else {
7887  cb_emit (cb_build_sub (CB_VALUE (l), x, cb_int0));
7888  }
7889  }
7890 }
void cb_emit_setenv ( cb_tree  x,
cb_tree  y 
)

References CB_BUILD_FUNCALL_2, and cb_emit.

7783 {
7784  cb_emit (CB_BUILD_FUNCALL_2 ("cob_set_environment", x, y));
7785 }
void cb_emit_sort_finish ( cb_tree  file)

References CB_BUILD_FUNCALL_1, cb_emit, CB_FILE_P, and cb_ref().

8120 {
8121  if (CB_FILE_P (cb_ref (file))) {
8122  cb_emit (CB_BUILD_FUNCALL_1 ("cob_file_sort_close", cb_ref (file)));
8123  }
8124 }
void cb_emit_sort_giving ( cb_tree  file,
cb_tree  l 
)

References _, CB_BUILD_FUNCALL_2, CB_CHAIN, cb_emit, cb_error_x(), CB_FILE, CB_FUNCALL, cb_list_length(), cb_ref(), CB_TREE, cb_validate_list(), CB_VALUE, COB_ORG_SORT, current_statement, and p.

8083 {
8084  cb_tree p;
8085  int listlen;
8086 
8087  if (cb_validate_list (l)) {
8088  return;
8089  }
8090  for (p = l; p; p = CB_CHAIN (p)) {
8091  if (CB_FILE (cb_ref(CB_VALUE(p)))->organization == COB_ORG_SORT) {
8092  cb_error_x (CB_TREE (current_statement),
8093  _("Invalid SORT GIVING parameter"));
8094  }
8095  }
8096  listlen = cb_list_length (l);
8097  p = CB_BUILD_FUNCALL_2 ("cob_file_sort_giving", cb_ref (file), l);
8098  CB_FUNCALL(p)->varcnt = listlen;
8099  cb_emit (p);
8100 }
void cb_emit_sort_init ( cb_tree  name,
cb_tree  keys,
cb_tree  col 
)

References _, CB_BUILD_CAST_ADDRESS, cb_build_cast_int(), CB_BUILD_FUNCALL_2, CB_BUILD_FUNCALL_3, CB_BUILD_FUNCALL_4, CB_BUILD_FUNCALL_5, CB_CHAIN, cb_emit, cb_error_node, cb_error_x(), CB_FIELD, CB_FIELD_PTR, CB_FILE, CB_FILE_P, cb_int(), cb_list_length(), CB_PURPOSE, cb_ref(), cb_program::cb_sort_return, cb_validate_list(), CB_VALUE, COB_ORG_SORT, current_program, cb_field::depending, cb_field::name, NULL, cb_field::occurs_max, cb_field::offset, and cb_field::parent.

8001 {
8002  cb_tree l;
8003  struct cb_field *f;
8004 
8005  if (cb_validate_list (keys)) {
8006  return;
8007  }
8008  if (cb_ref (name) == cb_error_node) {
8009  return;
8010  }
8011  for (l = keys; l; l = CB_CHAIN (l)) {
8012  if (CB_VALUE (l) == NULL) {
8013  CB_VALUE (l) = name;
8014  }
8015  cb_ref (CB_VALUE (l));
8016  }
8017 
8018  if (CB_FILE_P (cb_ref (name))) {
8019  if (CB_FILE (cb_ref (name))->organization != COB_ORG_SORT) {
8020  cb_error_x (name, _("Invalid SORT filename"));
8021  }
8022  CB_FIELD_PTR (current_program->cb_sort_return)->count++;
8023  cb_emit (CB_BUILD_FUNCALL_5 ("cob_file_sort_init", cb_ref (name),
8024  cb_int (cb_list_length (keys)), col,
8025  CB_BUILD_CAST_ADDRESS (current_program->cb_sort_return),
8026  CB_FILE(cb_ref (name))->file_status));
8027  for (l = keys; l; l = CB_CHAIN (l)) {
8028  cb_emit (CB_BUILD_FUNCALL_4 ("cob_file_sort_init_key",
8029  cb_ref (name),
8030  CB_VALUE (l),
8031  CB_PURPOSE (l),
8032  cb_int (CB_FIELD_PTR (CB_VALUE(l))->offset)));
8033  }
8034  } else {
8035  if (keys == NULL) {
8036  cb_error_x (name, _("Table sort without keys not implemented yet"));
8037  }
8038  cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort_init",
8039  cb_int (cb_list_length (keys)), col));
8040  for (l = keys; l; l = CB_CHAIN (l)) {
8041  cb_emit (CB_BUILD_FUNCALL_3 ("cob_table_sort_init_key",
8042  CB_VALUE (l),
8043  CB_PURPOSE (l),
8044  cb_int(CB_FIELD_PTR (CB_VALUE(l))->offset
8045  - CB_FIELD_PTR (CB_VALUE(l))->parent->offset)));
8046  }
8047  f = CB_FIELD (cb_ref (name));
8048  cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort", name,
8049  (f->depending
8050  ? cb_build_cast_int (f->depending)
8051  : cb_int (f->occurs_max))));
8052  }
8053 }
void cb_emit_sort_input ( cb_tree  proc)

References cb_build_debug(), cb_build_perform_once(), cb_emit, current_program, current_statement, cb_program::flag_debugging, cb_statement::flag_in_debug, and NULL.

8073 {
8074  if (current_program->flag_debugging &&
8075  !current_statement->flag_in_debug) {
8076  cb_emit (cb_build_debug (cb_debug_contents, "SORT INPUT", NULL));
8077  }
8078  cb_emit (cb_build_perform_once (proc));
8079 }
void cb_emit_sort_output ( cb_tree  proc)

References cb_build_debug(), cb_build_perform_once(), cb_emit, current_program, current_statement, cb_program::flag_debugging, cb_statement::flag_in_debug, cb_statement::flag_merge, and NULL.

8104 {
8105  if (current_program->flag_debugging &&
8106  !current_statement->flag_in_debug) {
8107  if (current_statement->flag_merge) {
8108  cb_emit (cb_build_debug (cb_debug_contents,
8109  "MERGE OUTPUT", NULL));
8110  } else {
8111  cb_emit (cb_build_debug (cb_debug_contents,
8112  "SORT OUTPUT", NULL));
8113  }
8114  }
8115  cb_emit (cb_build_perform_once (proc));
8116 }
void cb_emit_sort_using ( cb_tree  file,
cb_tree  l 
)

References _, CB_BUILD_FUNCALL_2, CB_CHAIN, cb_emit, cb_error_x(), CB_FILE, cb_ref(), CB_TREE, cb_validate_list(), CB_VALUE, COB_ORG_SORT, and current_statement.

8057 {
8058  if (cb_validate_list (l)) {
8059  return;
8060  }
8061  for (; l; l = CB_CHAIN (l)) {
8062  if (CB_FILE (cb_ref(CB_VALUE(l)))->organization == COB_ORG_SORT) {
8063  cb_error_x (CB_TREE (current_statement),
8064  _("Invalid SORT USING parameter"));
8065  }
8066  cb_emit (CB_BUILD_FUNCALL_2 ("cob_file_sort_using",
8067  cb_ref (file), cb_ref (CB_VALUE (l))));
8068  }
8069 }
void cb_emit_start ( cb_tree  file,
cb_tree  op,
cb_tree  key,
cb_tree  keylen 
)

References _, cb_file::access_mode, CB_BUILD_FUNCALL_5, cb_emit, cb_error_node, cb_error_x(), CB_FIELD_PTR, CB_FILE, cb_ref(), CB_TREE, cb_validate_one(), check_valid_key(), COB_ACCESS_RANDOM, COB_ORG_INDEXED, COB_ORG_RELATIVE, current_program, current_statement, cb_statement::file, cb_file::file_status, cb_statement::flag_callback, cb_program::flag_debugging, cb_file::flag_fl_debug, cb_statement::flag_in_debug, cb_file::key, and cb_file::organization.

8178 {
8179  cb_tree kfld;
8180  cb_tree fl;
8181  cb_tree cbtkey;
8182  struct cb_file *f;
8183 
8184  if (cb_validate_one (key)) {
8185  return;
8186  }
8187  if (cb_validate_one (keylen)) {
8188  return;
8189  }
8190  if (file == cb_error_node) {
8191  return;
8192  }
8193  fl = cb_ref (file);
8194  if (fl == cb_error_node) {
8195  return;
8196  }
8197  f = CB_FILE (fl);
8198 
8199  if (f->organization != COB_ORG_INDEXED &&
8200  f->organization != COB_ORG_RELATIVE) {
8201  cb_error_x (CB_TREE (current_statement),
8202  _("START not allowed on SEQUENTIAL files"));
8203  return;
8204  }
8205  if (keylen && f->organization != COB_ORG_INDEXED) {
8206  cb_error_x (CB_TREE (current_statement),
8207  _("LENGTH/SIZE clause only allowed on INDEXED files"));
8208  return;
8209  }
8210  if (f->access_mode == COB_ACCESS_RANDOM) {
8211  cb_error_x (CB_TREE (current_statement),
8212  _("START not allowed with ACCESS MODE RANDOM"));
8213  return;
8214  }
8215 
8216  current_statement->file = fl;
8217  if (key) {
8218  kfld = cb_ref (key);
8219  if (kfld == cb_error_node) {
8220  return;
8221  }
8222  if (check_valid_key (f, CB_FIELD_PTR (kfld))) {
8223  return;
8224  }
8225  cbtkey = key;
8226  } else {
8227  cbtkey = f->key;
8228  }
8229 
8230  /* Check for file debugging */
8231  if (current_program->flag_debugging &&
8232  !current_statement->flag_in_debug &&
8233  f->flag_fl_debug) {
8234  /* Gen callback after start but before exception test */
8235  current_statement->flag_callback = 1;
8236  }
8237 
8238  cb_emit (CB_BUILD_FUNCALL_5 ("cob_start", fl, op, cbtkey, keylen,
8239  f->file_status));
8240 }
void cb_emit_stop_run ( cb_tree  x)

References cb_build_cast_int(), CB_BUILD_FUNCALL_1, and cb_emit.

8246 {
8247  cb_emit (CB_BUILD_FUNCALL_1 ("cob_stop_run", cb_build_cast_int (x)));
8248 }
void cb_emit_string ( cb_tree  items,
cb_tree  into,
cb_tree  pointer 
)

References CB_BUILD_FUNCALL_0, CB_BUILD_FUNCALL_1, CB_BUILD_FUNCALL_2, CB_CHAIN, cb_emit, cb_int0, CB_PAIR_P, CB_PAIR_X, cb_validate_one(), CB_VALUE, and NULL.

8254 {
8255  cb_tree start;
8256  cb_tree l;
8257  cb_tree end;
8258  cb_tree dlm;
8259 
8260  if (cb_validate_one (into)) {
8261  return;
8262  }
8263  if (cb_validate_one (pointer)) {
8264  return;
8265  }
8266  start = items;
8267  cb_emit (CB_BUILD_FUNCALL_2 ("cob_string_init", into, pointer));
8268  while (start) {
8269 
8270  /* Find DELIMITED item */
8271  for (end = start; end; end = CB_CHAIN (end)) {
8272  if (CB_PAIR_P (CB_VALUE (end))) {
8273  break;
8274  }
8275  }
8276 
8277  /* cob_string_delimited */
8278  dlm = end ? CB_PAIR_X (CB_VALUE (end)) : NULL;
8279  if (dlm == cb_int0) {
8280  dlm = NULL;
8281  }
8282  cb_emit (CB_BUILD_FUNCALL_1 ("cob_string_delimited", dlm));
8283 
8284  /* cob_string_append */
8285  for (l = start; l != end; l = CB_CHAIN (l)) {
8286  cb_emit (CB_BUILD_FUNCALL_1 ("cob_string_append",
8287  CB_VALUE (l)));
8288  }
8289 
8290  start = end ? CB_CHAIN (end) : NULL;
8291  }
8292  cb_emit (CB_BUILD_FUNCALL_0 ("cob_string_finish"));
8293 }
void cb_emit_unlock ( cb_tree  ref)

References CB_BUILD_FUNCALL_2, cb_emit, cb_error_node, CB_FILE, cb_ref(), current_statement, file, cb_statement::file, and cb_file::file_status.

8299 {
8300  cb_tree file;
8301 
8302  if (ref != cb_error_node) {
8303  file = cb_ref (ref);
8304  if (file != cb_error_node) {
8305  cb_emit (CB_BUILD_FUNCALL_2 ("cob_unlock_file",
8306  file, CB_FILE(file)->file_status));
8307  current_statement->file = file;
8308  }
8309  }
8310 }
void cb_emit_unstring ( cb_tree  name,
cb_tree  delimited,
cb_tree  into,
cb_tree  pointer,
cb_tree  tallying 
)

References CB_BUILD_FUNCALL_0, CB_BUILD_FUNCALL_1, CB_BUILD_FUNCALL_3, cb_emit, cb_emit_list, cb_int(), cb_list_length(), cb_validate_list(), and cb_validate_one().

8317 {
8318  if (cb_validate_one (name)) {
8319  return;
8320  }
8321  if (cb_validate_one (tallying)) {
8322  return;
8323  }
8324  if (cb_validate_list (delimited)) {
8325  return;
8326  }
8327  if (cb_validate_list (into)) {
8328  return;
8329  }
8330  cb_emit (CB_BUILD_FUNCALL_3 ("cob_unstring_init", name, pointer,
8331  cb_int (cb_list_length (delimited))));
8332  cb_emit_list (delimited);
8333  cb_emit_list (into);
8334  if (tallying) {
8335  cb_emit (CB_BUILD_FUNCALL_1 ("cob_unstring_tallying", tallying));
8336  }
8337  cb_emit (CB_BUILD_FUNCALL_0 ("cob_unstring_finish"));
8338 }
void cb_emit_write ( cb_tree  record,
cb_tree  from,
cb_tree  opt,
cb_tree  lockopt 
)

References _, cb_build_debug(), cb_build_debug_call(), CB_BUILD_FUNCALL_5, cb_build_move(), cb_emit, cb_error_node, cb_error_x(), CB_FIELD, CB_FIELD_PTR, CB_FILE, cb_int(), cb_int0, cb_int1, cb_int_hex(), cb_ref(), CB_REF_OR_FIELD_P, CB_STORAGE_FILE, CB_TREE, cb_validate_one(), COB_EC_I_O_EOP, COB_EC_I_O_INVALID_KEY, COB_LOCK_AUTOMATIC, COB_ORG_INDEXED, COB_ORG_LINE_SEQUENTIAL, COB_ORG_RELATIVE, COB_ORG_SORT, COB_WRITE_AFTER, COB_WRITE_BEFORE, COB_WRITE_LINES, COB_WRITE_LOCK, current_program, current_statement, cb_file::debug_section, file, cb_statement::file, cb_file::file_status, cb_program::flag_debugging, cb_statement::flag_in_debug, cb_file::flag_line_adv, cb_statement::handler1, cb_statement::handler_id, cb_file::lock_mode, cb_file::name, NULL, and cb_file::organization.

8368 {
8369  cb_tree file;
8370  cb_tree check_eop;
8371  struct cb_file *f;
8372 
8373  if (cb_validate_one (record)) {
8374  return;
8375  }
8376  if (cb_validate_one (from)) {
8377  return;
8378  }
8379  if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
8380  cb_error_x (CB_TREE (current_statement),
8381  _("WRITE requires a record name as subject"));
8382  return;
8383  }
8384  if (CB_FIELD_PTR (record)->storage != CB_STORAGE_FILE) {
8385  cb_error_x (CB_TREE (current_statement),
8386  _("WRITE subject does not refer to a record name"));
8387  return;
8388  }
8389  file = CB_TREE (CB_FIELD (cb_ref (record))->file);
8390  if (!file || file == cb_error_node) {
8391  return;
8392  }
8393  current_statement->file = file;
8394  f = CB_FILE (file);
8395 
8396  if (f->organization == COB_ORG_SORT) {
8397  cb_error_x (CB_TREE (current_statement),
8398  _("Operation not allowed on SORT files"));
8399  } else if (current_statement->handler_id == COB_EC_I_O_INVALID_KEY &&
8400  (f->organization != COB_ORG_RELATIVE &&
8401  f->organization != COB_ORG_INDEXED)) {
8402  cb_error_x (CB_TREE(current_statement),
8403  _("INVALID KEY clause invalid with this file type"));
8404  } else if (lockopt) {
8405  if (f->lock_mode & COB_LOCK_AUTOMATIC) {
8406  cb_error_x (CB_TREE (current_statement),
8407  _("LOCK clause invalid with file LOCK AUTOMATIC"));
8408  } else if (opt != cb_int0) {
8409  cb_error_x (CB_TREE (current_statement),
8410  _("LOCK clause invalid here"));
8411  } else if (lockopt == cb_int1) {
8412  opt = cb_int (COB_WRITE_LOCK);
8413  }
8414  }
8415 
8416  if (from) {
8417  cb_emit (cb_build_move (from, record));
8418  }
8419 
8420  /* Check debugging on record name */
8421  if (current_program->flag_debugging &&
8422  !current_statement->flag_in_debug &&
8423  CB_FIELD_PTR (record)->flag_field_debug) {
8424  cb_emit (cb_build_debug (cb_debug_name,
8425  CB_FIELD_PTR (record)->name, NULL));
8426  cb_emit (cb_build_move (record, cb_debug_contents));
8427  cb_emit (cb_build_debug_call (CB_FIELD_PTR (record)->debug_section));
8428  }
8429  if (f->organization == COB_ORG_LINE_SEQUENTIAL &&
8430  opt == cb_int0) {
8431  if (cb_flag_write_after || CB_FILE (file)->flag_line_adv) {
8432  opt = cb_int_hex (COB_WRITE_AFTER | COB_WRITE_LINES | 1);
8433  } else {
8434  opt = cb_int_hex (COB_WRITE_BEFORE | COB_WRITE_LINES | 1);
8435  }
8436  }
8437  if (current_statement->handler_id == COB_EC_I_O_EOP &&
8438  current_statement->handler1) {
8439  check_eop = cb_int1;
8440  } else {
8441  check_eop = cb_int0;
8442  }
8443  cb_emit (CB_BUILD_FUNCALL_5 ("cob_write", file, record, opt,
8444  f->file_status, check_eop));
8445 }
char* cb_encode_program_id ( const char *  name)

References COB_FOLD_LOWER, COB_FOLD_UPPER, COB_MINI_BUFF, cob_u8_t, cobc_check_string(), hexval, likely, NULL, p, unlikely, and valid_char.

Referenced by cb_build_program_id(), emit_entry(), output_call(), output_cancel(), process_filename(), and user_func_upper().

1112 {
1113  unsigned char *p;
1114  const unsigned char *s;
1115  const unsigned char *t;
1116  unsigned char buff[COB_MINI_BUFF];
1117 
1118  s = NULL;
1119  for (t = (const unsigned char *)name; *t; t++) {
1120  if (*t == (unsigned char)'/' || *t == (unsigned char)'\\') {
1121  s = t + 1;
1122  }
1123  }
1124  if (!s) {
1125  s = (const unsigned char *)name;
1126  }
1127  p = buff;
1128  /* Encode the initial digit */
1129  if (*s <= (unsigned char)'9' && *s >= (unsigned char)'0') {
1130  *p++ = (unsigned char)'_';
1131  }
1132  /* Encode invalid letters */
1133  for (; *s; s++) {
1134  if (likely(valid_char[*s])) {
1135  *p++ = *s;
1136  } else {
1137  *p++ = (unsigned char)'_';
1138  if (*s == (unsigned char)'-') {
1139  *p++ = (unsigned char)'_';
1140  } else {
1141  *p++ = hexval[*s / 16U];
1142  *p++ = hexval[*s % 16U];
1143  }
1144  }
1145  }
1146  *p = 0;
1147 
1148  /* Check case folding */
1149  if (unlikely(cb_fold_call)) {
1150  if (cb_fold_call == COB_FOLD_UPPER) {
1151  for (p = buff; *p; p++) {
1152  if (islower (*p)) {
1153  *p = (cob_u8_t)toupper (*p);
1154  }
1155  }
1156  } else if (cb_fold_call == COB_FOLD_LOWER) {
1157  for (p = buff; *p; p++) {
1158  if (isupper (*p)) {
1159  *p = (cob_u8_t)tolower (*p);
1160  }
1161  }
1162  }
1163  }
1164 
1165  return cobc_check_string ((char *)buff);
1166 }
static cb_tree cb_expr_finish ( void  )
static

References _, cb_error(), cb_error_node, expr_expand(), expr_index, expr_reduce(), expr_node::value, and value.

Referenced by cb_build_expr().

3037 {
3038  /* Reduce all */
3039  (void)expr_reduce (0);
3040 
3041  if (expr_index != 4) {
3042  cb_error (_("Invalid expression"));
3043  return cb_error_node;
3044  }
3045 
3046  if (!expr_stack[3].value) {
3047  cb_error (_("Invalid expression"));
3048  return cb_error_node;
3049  }
3050  expr_expand (&expr_stack[3].value);
3051  if (expr_stack[3].token != 'x') {
3052  cb_error (_("Invalid expression"));
3053  return cb_error_node;
3054  }
3055  return expr_stack[3].value;
3056 }
static void cb_expr_init ( void  )
static

References cobc_main_malloc(), expr_index, expr_op, expr_stack_size, initialized, NULL, and START_STACK_SIZE.

Referenced by cb_build_expr().

2643 {
2644  if (initialized == 0) {
2645  initialized = 1;
2646  /* Init stack */
2647  expr_stack_size = START_STACK_SIZE;
2648  expr_stack = cobc_main_malloc (sizeof (struct expr_node) * START_STACK_SIZE);
2649  } else {
2650  memset (expr_stack, 0, expr_stack_size * sizeof (struct expr_node));
2651  }
2652  expr_op = 0;
2653  expr_lh = NULL;
2654  /* First three entries are dummies */
2655  expr_index = 3;
2656 }
static void cb_expr_shift ( int  token,
cb_tree  value 
)
static

References cb_build_binary_op(), CB_BUILD_PARENTHESIS, cb_expr_shift_sign(), cb_zero, cobc_main_realloc(), expr_index, expr_op, expr_reduce(), expr_stack_size, TOKEN, VALUE, and value.

Referenced by cb_build_expr().

2899 {
2900  switch (token) {
2901  case 'M':
2902  break;
2903  case 'x':
2904  /* Sign ZERO condition */
2905  if (value == cb_zero) {
2906  if (TOKEN (-1) == 'x' || TOKEN (-1) == '!') {
2907  cb_expr_shift_sign ('=');
2908  return;
2909  }
2910  }
2911 
2912  /* Unary sign */
2913  if ((TOKEN (-1) == '+' || TOKEN (-1) == '-') &&
2914  TOKEN (-2) != 'x') {
2915  if (TOKEN (-1) == '-') {
2916  value = cb_build_binary_op (cb_zero, '-', value);
2917  }
2918  expr_index -= 1;
2919  }
2920  break;
2921 
2922  case '(':
2923  /* 'x' op '(' --> '(' 'x' op */
2924  switch (TOKEN (-1)) {
2925  case '=':
2926  case '~':
2927  case '<':
2928  case '>':
2929  case '[':
2930  case ']':
2931  expr_op = TOKEN (-1);
2932  if (TOKEN (-2) == 'x') {
2933  expr_lh = VALUE (-2);
2934  }
2935  break;
2936  default:
2937  break;
2938  }
2939  break;
2940 
2941  case ')':
2942  /* Enclosed by parentheses */
2943  (void)expr_reduce (token);
2944  if (TOKEN (-2) == '(') {
2945  value = CB_BUILD_PARENTHESIS (VALUE (-1));
2946  expr_index -= 2;
2947  cb_expr_shift ('x', value);
2948  return;
2949  }
2950  break;
2951 
2952  default:
2953  /* '<' '|' '=' --> '[' */
2954  /* '>' '|' '=' --> ']' */
2955  if (token == '=' && TOKEN (-1) == '|' &&
2956  (TOKEN (-2) == '<' || TOKEN (-2) == '>')) {
2957  token = (TOKEN (-2) == '<') ? '[' : ']';
2958  expr_index -= 2;
2959  }
2960 
2961  /* '!' '=' --> '~', etc. */
2962  if (TOKEN (-1) == '!') {
2963  switch (token) {
2964  case '=':
2965  token = '~';
2966  expr_index--;
2967  break;
2968  case '~':
2969  token = '=';
2970  expr_index--;
2971  break;
2972  case '<':
2973  token = ']';
2974  expr_index--;
2975  break;
2976  case '>':
2977  token = '[';
2978  expr_index--;
2979  break;
2980  case '[':
2981  token = '>';
2982  expr_index--;
2983  break;
2984  case ']':
2985  token = '<';
2986  expr_index--;
2987  break;
2988  default:
2989  break;
2990  }
2991  }
2992  break;
2993  }
2994 
2995  /* Reduce */
2996  /* Catch invalid condition */
2997  if (expr_reduce (token) > 0) {
2998  return;
2999  }
3000 
3001  /* Allocate sufficient stack memory */
3002  if (expr_index >= expr_stack_size) {
3003  while (expr_stack_size <= expr_index) {
3004  expr_stack_size *= 2;
3005  }
3006  expr_stack = cobc_main_realloc (expr_stack, sizeof (struct expr_node) * expr_stack_size);
3007  }
3008 
3009  /* Put on the stack */
3010  TOKEN (0) = token;
3011  VALUE (0) = value;
3012  expr_index++;
3013 }
static void cb_expr_shift_class ( const char *  name)
static

References CB_BUILD_FUNCALL_1, CB_BUILD_NEGATION, expr_index, expr_reduce(), TOKEN, and VALUE.

Referenced by cb_build_expr().

2879 {
2880  int have_not;
2881 
2882  if (TOKEN (-1) == '!') {
2883  have_not = 1;
2884  expr_index--;
2885  } else {
2886  have_not = 0;
2887  }
2888  (void)expr_reduce ('=');
2889  if (TOKEN (-1) == 'x') {
2890  VALUE (-1) = CB_BUILD_FUNCALL_1 (name, VALUE (-1));
2891  if (have_not) {
2892  VALUE (-1) = CB_BUILD_NEGATION (VALUE (-1));
2893  }
2894  }
2895 }
static void cb_expr_shift_sign ( const int  op)
static

References cb_build_binary_op(), CB_BUILD_NEGATION, cb_zero, expr_index, expr_reduce(), TOKEN, and VALUE.

Referenced by cb_build_expr(), and cb_expr_shift().

2859 {
2860  int have_not;
2861 
2862  if (TOKEN (-1) == '!') {
2863  have_not = 1;
2864  expr_index--;
2865  } else {
2866  have_not = 0;
2867  }
2868  (void)expr_reduce ('=');
2869  if (TOKEN (-1) == 'x') {
2870  VALUE (-1) = cb_build_binary_op (VALUE (-1), op, cb_zero);
2871  if (have_not) {
2872  VALUE (-1) = CB_BUILD_NEGATION (VALUE (-1));
2873  }
2874  }
2875 }
static int cb_field_size ( const cb_tree  x)
static

References _, CB_FIELD, cb_get_int(), CB_LITERAL, CB_LITERAL_P, CB_REFERENCE, CB_TAG_FIELD, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_TAG, cobc_abort_pr(), COBC_DUMB_ABORT, cb_reference::length, cb_reference::offset, cb_field::size, and cb_reference::value.

Referenced by cb_build_cond(), cb_build_length(), cb_build_length_1(), cb_build_memset(), cb_build_move_copy(), cb_build_move_field(), cb_check_overlapping(), cb_chk_alpha_cond(), and validate_move().

784 {
785  struct cb_reference *r;
786  struct cb_field *f;
787 
788  switch (CB_TREE_TAG (x)) {
789  case CB_TAG_LITERAL:
790  return CB_LITERAL (x)->size;
791  case CB_TAG_FIELD:
792  return CB_FIELD (x)->size;
793  case CB_TAG_REFERENCE:
794  r = CB_REFERENCE (x);
795  f = CB_FIELD (r->value);
796 
797  if (r->length) {
798  if (CB_LITERAL_P (r->length)) {
799  return cb_get_int (r->length);
800  } else {
801  return -1;
802  }
803  } else if (r->offset) {
804  if (CB_LITERAL_P (r->offset)) {
805  return f->size - cb_get_int (r->offset) + 1;
806  } else {
807  return -1;
808  }
809  } else {
810  return f->size;
811  }
812  default:
813  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
814  /* Use dumb variant */
815  COBC_DUMB_ABORT ();
816  }
817  /* NOT REACHED */
818 #ifndef _MSC_VER
819  return 0;
820 #endif
821 }
static void cb_gen_field_accept ( cb_tree  var,
cb_tree  pos,
cb_tree  fgc,
cb_tree  bgc,
cb_tree  scroll,
cb_tree  timeout,
cb_tree  prompt,
int  dispattrs 
)
static

References CB_BUILD_FUNCALL_9, cb_emit, cb_int(), CB_LIST_P, CB_PAIR_X, CB_PAIR_Y, line, and NULL.

Referenced by cb_emit_accept().

4173 {
4174  cb_tree line;
4175  cb_tree column;
4176 
4177  if (!pos) {
4178  cb_emit (CB_BUILD_FUNCALL_9 ("cob_field_accept",
4179  var, NULL, NULL, fgc, bgc, scroll,
4180  timeout, prompt, cb_int (dispattrs)));
4181  } else if (CB_LIST_P (pos)) {
4182  line = CB_PAIR_X (pos);
4183  column = CB_PAIR_Y (pos);
4184  cb_emit (CB_BUILD_FUNCALL_9 ("cob_field_accept",
4185  var, line, column, fgc, bgc, scroll,
4186  timeout, prompt, cb_int (dispattrs)));
4187  } else {
4188  cb_emit (CB_BUILD_FUNCALL_9 ("cob_field_accept",
4189  var, pos, NULL, fgc, bgc, scroll,
4190  timeout, prompt, cb_int (dispattrs)));
4191  }
4192 }
void cb_init_tallying ( void  )

References inspect_func, and NULL.

5639 {
5640  inspect_func = NULL;
5641  inspect_data = NULL;
5642 }
void cb_list_system ( void  )

References _, system_table::syst_name, and system_table::syst_params.

Referenced by process_command_line().

827 {
828  const struct system_table *psyst;
829  const char *s;
830  size_t n;
831 
832  putchar ('\n');
833  printf (_("System routine\t\t\tParameters"));
834  puts ("\n");
835  for (psyst = system_tab; psyst->syst_name; psyst++) {
836  switch (*(unsigned char *)(psyst->syst_name)) {
837  case 'C':
838  case 'S':
839  printf ("%s", psyst->syst_name);
840  break;
841  case 0xF4:
842  printf ("X\"F4\"");
843  break;
844  case 0xF5:
845  printf ("X\"F5\"");
846  break;
847  case 0x91:
848  printf ("X\"91\"");
849  break;
850  case 0xE4:
851  printf ("X\"E4\"");
852  break;
853  case 0xE5:
854  printf ("X\"E5\"");
855  break;
856  default:
857  break;
858  }
859  n = strlen (psyst->syst_name);
860  switch (n / 8) {
861  case 0:
862  s = "\t\t\t\t";
863  break;
864  case 1:
865  s = "\t\t\t";
866  break;
867  case 2:
868  s = "\t\t";
869  break;
870  default:
871  s = "\t";
872  break;
873  }
874  printf ("%s%d\n", s, psyst->syst_params);
875  }
876 }
static void cb_validate_collating ( struct cb_program *  prog)
static

References _, CB_ALPHABET_CUSTOM, CB_ALPHABET_NAME, CB_ALPHABET_NAME_P, cb_build_alphanumeric_literal(), cb_error_x(), cb_high, CB_LITERAL, cb_low, cb_name(), cb_ref(), cb_program::collating_sequence, and NULL.

Referenced by cb_validate_program_environment().

1804 {
1805  cb_tree x;
1806 
1807  x = cb_ref (prog->collating_sequence);
1808  if (!CB_ALPHABET_NAME_P (x)) {
1809  cb_error_x (prog->collating_sequence, _("'%s' is not an alphabet name"),
1810  cb_name (prog->collating_sequence));
1811  prog->collating_sequence = NULL;
1812  return;
1813  }
1814  if (CB_ALPHABET_NAME (x)->alphabet_type != CB_ALPHABET_CUSTOM) {
1815  return;
1816  }
1817  if (CB_ALPHABET_NAME (x)->low_val_char) {
1818  cb_low = cb_build_alphanumeric_literal ("\0", (size_t)1);
1819  CB_LITERAL(cb_low)->data[0] = (unsigned char)CB_ALPHABET_NAME (x)->low_val_char;
1820  CB_LITERAL(cb_low)->all = 1;
1821  }
1822  if (CB_ALPHABET_NAME (x)->high_val_char != 255){
1823  cb_high = cb_build_alphanumeric_literal ("\0", (size_t)1);
1824  CB_LITERAL(cb_high)->data[0] = (unsigned char)CB_ALPHABET_NAME (x)->high_val_char;
1825  CB_LITERAL(cb_high)->all = 1;
1826  }
1827 }
static size_t cb_validate_list ( cb_tree  l)
static

References CB_CHAIN, cb_validate_one(), and CB_VALUE.

Referenced by cb_emit_arithmetic(), cb_emit_display(), cb_emit_free(), cb_emit_initialize(), cb_emit_move(), cb_emit_set_on_off(), cb_emit_set_to(), cb_emit_set_up_down(), cb_emit_sort_giving(), cb_emit_sort_init(), cb_emit_sort_using(), and cb_emit_unstring().

575 {
576  for (; l; l = CB_CHAIN (l)) {
577  if (cb_validate_one (CB_VALUE (l))) {
578  return 1;
579  }
580  }
581  return 0;
582 }
static size_t cb_validate_one ( cb_tree  x)
static

References _, cb_error_node, cb_error_x(), CB_FIELD, CB_FIELD_P, cb_ref(), and CB_REFERENCE_P.

Referenced by cb_build_unstring_delimited(), cb_build_unstring_into(), cb_emit_accept(), cb_emit_accept_arg_number(), cb_emit_accept_arg_value(), cb_emit_accept_command_line(), cb_emit_accept_date(), cb_emit_accept_date_yyyymmdd(), cb_emit_accept_day(), cb_emit_accept_day_of_week(), cb_emit_accept_day_yyyyddd(), cb_emit_accept_environment(), cb_emit_accept_escape_key(), cb_emit_accept_exception_status(), cb_emit_accept_line_or_col(), cb_emit_accept_mnemonic(), cb_emit_accept_name(), cb_emit_accept_time(), cb_emit_accept_user_name(), cb_emit_allocate(), cb_emit_arg_number(), cb_emit_arithmetic(), cb_emit_cancel(), cb_emit_command_line(), cb_emit_corresponding(), cb_emit_display(), cb_emit_divide(), cb_emit_env_name(), cb_emit_env_value(), cb_emit_get_environment(), cb_emit_move(), cb_emit_move_corresponding(), cb_emit_release(), cb_emit_return(), cb_emit_rewrite(), cb_emit_search(), cb_emit_search_all(), cb_emit_set_attribute(), cb_emit_set_to(), cb_emit_set_up_down(), cb_emit_start(), cb_emit_string(), cb_emit_unstring(), cb_emit_write(), and cb_validate_list().

546 {
547  cb_tree y;
548 
549  if (x == cb_error_node) {
550  return 1;
551  }
552  if (!x) {
553  return 0;
554  }
555  if (CB_REFERENCE_P (x)) {
556  y = cb_ref (x);
557  if (y == cb_error_node) {
558  return 1;
559  }
560  if (CB_FIELD_P (y)) {
561  if (CB_FIELD (y)->level == 88) {
562  cb_error_x (x, _("Invalid use of 88 level item"));
563  return 1;
564  }
565  if (CB_FIELD (y)->flag_invalid) {
566  return 1;
567  }
568  }
569  }
570  return 0;
571 }
void cb_validate_program_body ( struct cb_program *  prog)

References _, cb_program::all_procedure, cb_label::alter_gotos, cb_program::alter_gotos, cb_program::alter_list, CB_CHAIN, cb_error_node, cb_error_x(), CB_FIELD, CB_FIELD_PTR, CB_LABEL, CB_LABEL_P, cb_list_reverse(), cb_name(), CB_PURPOSE, cb_ref(), CB_REFERENCE, CB_TAG_FIELD, CB_TAG_FILE, CB_TAG_LABEL, CB_TREE_TAG, CB_VALUE, cb_warning_x(), cobc_cs_check, cobc_parse_malloc(), current_paragraph, current_program, current_section, cb_program::debug_list, cb_program::exec_list, cb_program::file_list, cb_program::flag_debugging, cb_label::flag_first_is_goto, cb_alter_id::goto_id, cb_label::id, cb_program::label_list, cb_field::memory_size, cb_field::name, cb_label::name, cb_alter_id::next, cb_field::size, and value.

2483 {
2484  cb_tree l;
2485  cb_tree x;
2486  cb_tree v;
2487  struct cb_label *save_section;
2488  struct cb_label *save_paragraph;
2489  struct cb_alter_id *aid;
2490  struct cb_label *l1;
2491  struct cb_label *l2;
2492  struct cb_field *f;
2493  int size;
2494 
2495  /* Resolve all labels */
2496  save_section = current_section;
2497  save_paragraph = current_paragraph;
2498  for (l = cb_list_reverse (prog->label_list); l; l = CB_CHAIN (l)) {
2499  x = CB_VALUE (l);
2500  current_section = CB_REFERENCE (x)->section;
2501  current_paragraph = CB_REFERENCE (x)->paragraph;
2502  v = cb_ref (x);
2503  /* Check refs in to / out of DECLARATIVES */
2504  if (CB_LABEL_P (v)) {
2505  if (CB_REFERENCE (x)->flag_in_decl &&
2506  !CB_LABEL (v)->flag_declaratives) {
2507  if (!cb_relaxed_syntax_check) {
2508  cb_error_x (x, _("'%s' is not in DECLARATIVES"),
2509  CB_LABEL (v)->name);
2510  } else {
2511  cb_warning_x (x, _("'%s' is not in DECLARATIVES"),
2512  CB_LABEL (v)->name);
2513  }
2514  }
2515  if (CB_LABEL (v)->flag_declaratives &&
2516  !CB_REFERENCE (x)->flag_in_decl &&
2517  !CB_REFERENCE (x)->flag_decl_ok) {
2518  cb_error_x (x, _("Invalid reference to '%s' (In DECLARATIVES)"), CB_LABEL (v)->name);
2519  }
2520  CB_LABEL (v)->flag_begin = 1;
2521  if (CB_REFERENCE (x)->length) {
2522  CB_LABEL (v)->flag_return = 1;
2523  }
2524  } else if (v != cb_error_node) {
2525  cb_error_x (x, _("'%s' not a procedure name"), cb_name (x));
2526  }
2527  }
2528 
2529  /* Resolve DEBUG references */
2530  /* For data items, we may need to adjust the size of DEBUG-CONTENTS */
2531  /* Basic size of DEBUG-CONTENTS is 31 */
2532  size = 31;
2533  for (l = prog->debug_list; l; l = CB_CHAIN (l)) {
2534  x = CB_VALUE (l);
2535  current_section = CB_REFERENCE (x)->section;
2536  current_paragraph = CB_REFERENCE (x)->paragraph;
2537  v = cb_ref (x);
2538  if (v == cb_error_node) {
2539  continue;
2540  }
2541  switch (CB_TREE_TAG (v)) {
2542  case CB_TAG_LABEL:
2543  if (current_program->all_procedure) {
2544  cb_error_x (x, _("'%s' - DEBUGGING target invalid with ALL PROCEDURES"),
2545  cb_name (x));
2546  }
2547  if (!CB_LABEL (v)->flag_real_label) {
2548  cb_error_x (x, _("'%s' - DEBUGGING target invalid"),
2549  cb_name (x));
2550  }
2551  CB_LABEL (v)->debug_section =
2552  CB_REFERENCE (x)->debug_section;
2553  CB_LABEL (v)->flag_debugging_mode = 1;
2554  break;
2555  case CB_TAG_FILE:
2556  break;
2557  case CB_TAG_FIELD:
2558  if (CB_FIELD (v)->size > size) {
2559  size = CB_FIELD (v)->size;
2560  }
2561  break;
2562  default:
2563  cb_error_x (x, _("'%s' is not a valid DEBUGGING target"),
2564  cb_name (x));
2565  break;
2566  }
2567  }
2568  /* If necessary, adjust size of DEBUG-CONTENTS (and DEBUG-ITEM) */
2569  if (current_program->flag_debugging) {
2570  if (size != 31) {
2571  f = CB_FIELD_PTR (cb_debug_contents);
2572  f->size = size;
2573  f->memory_size = size;
2574  size -= 31;
2575  f = CB_FIELD_PTR (cb_debug_item);
2576  f->size += size;
2577  f->memory_size += size;
2578  }
2579  }
2580 
2581  /* Build ALTER ids - We need to remove duplicates */
2582  for (l = prog->alter_list; l; l = CB_CHAIN (l)) {
2583  if (CB_PURPOSE (l) == cb_error_node) {
2584  continue;
2585  }
2586  if (CB_VALUE (l) == cb_error_node) {
2587  continue;
2588  }
2589  x = CB_PURPOSE (l);
2590  v = CB_VALUE (l);
2591  if (CB_REFERENCE (x)->value == cb_error_node) {
2592  continue;
2593  }
2594  if (CB_REFERENCE (v)->value == cb_error_node) {
2595  continue;
2596  }
2597  l1 = CB_LABEL (CB_REFERENCE (x)->value);
2598  l2 = CB_LABEL (CB_REFERENCE (v)->value);
2599  current_section = CB_REFERENCE (x)->section;
2600  current_paragraph = CB_REFERENCE (x)->paragraph;
2601  /* First statement in paragraph must be a GO TO */
2602  if (!l1->flag_first_is_goto) {
2603  cb_error_x (x, _("'%s' is not an alterable paragraph"),
2604  l1->name);
2605  continue;
2606  }
2607  for (aid = l1->alter_gotos; aid; aid = aid->next) {
2608  if (aid->goto_id == l2->id) {
2609  break;
2610  }
2611  }
2612  if (!aid) {
2613  aid = cobc_parse_malloc (sizeof(struct cb_alter_id));
2614  aid->next = l1->alter_gotos;
2615  aid->goto_id = l2->id;
2616  l1->alter_gotos = aid;
2617  }
2618  for (aid = prog->alter_gotos; aid; aid = aid->next) {
2619  if (aid->goto_id == l1->id) {
2620  break;
2621  }
2622  }
2623  if (!aid) {
2624  aid = cobc_parse_malloc (sizeof(struct cb_alter_id));
2625  aid->next = prog->alter_gotos;
2626  aid->goto_id = l1->id;
2627  prog->alter_gotos = aid;
2628  }
2629  }
2630 
2631  current_section = save_section;
2632  current_paragraph = save_paragraph;
2633  cobc_cs_check = 0;
2634 
2635  prog->file_list = cb_list_reverse (prog->file_list);
2636  prog->exec_list = cb_list_reverse (prog->exec_list);
2637 }
void cb_validate_program_data ( struct cb_program *  prog)

References _, build_literal(), CB_ASSIGN_MF, cb_build_field(), cb_build_field_reference(), cb_build_implicit_field(), cb_build_picture(), cb_build_reference(), CB_CATEGORY_ALPHANUMERIC, CB_CHAIN, cb_depend_check, cb_error(), cb_error_node, cb_error_x(), CB_FIELD, CB_FIELD_ADD, CB_FIELD_P, CB_FIELD_PTR, CB_FILE, CB_LIST_INIT, cb_list_reverse(), CB_LITERAL, CB_NAME, cb_name(), cb_needs_01, CB_PICTURE, cb_ref(), CB_REF_OR_FIELD_P, CB_REFERENCE_P, CB_REPORT, CB_STORAGE_LINKAGE, CB_STORAGE_LOCAL, CB_STORAGE_WORKING, CB_TREE, CB_USAGE_DISPLAY, CB_USAGE_UNSIGNED_INT, CB_VALID_TREE, cb_validate_field(), CB_VALUE, cb_warning(), CB_WORD_COUNT, cb_zero, check_level_78(), cb_report::cname, COB_MINI_BUFF, COB_MINI_MAX, COB_SMALL_BUFF, cb_program::crt_status, current_program, cb_program::cursor_pos, cb_field::depending, cb_program::file_list, finalize_file(), cb_file::flag_finalized, cb_field::flag_is_global, cb_field::flag_no_init, cb_field::flag_odo_item, cb_report::line_counter, cb_field::name, cb_report::name, NULL, p, cb_report::page_counter, cb_field::parent, cb_field::pic, cb_file::record_depending, cb_field::redefines, redefinition_error(), cb_program::reference_list, cb_program::report_list, cb_field::sister, cb_field::storage, cb_field::usage, cb_field::values, and cb_program::working_storage.

2284 {
2285  cb_tree l;
2286  cb_tree x;
2287  cb_tree assign;
2288  struct cb_field *p;
2289  struct cb_field *q;
2290  struct cb_field *depfld;
2291  struct cb_file *f;
2292  struct cb_report *rep;
2293  unsigned char *c;
2294  char buff[COB_MINI_BUFF];
2295 
2296  for (l = current_program->report_list; l; l = CB_CHAIN (l)) {
2297  /* Set up LINE-COUNTER / PAGE-COUNTER */
2298  rep = CB_REPORT (CB_VALUE (l));
2299  snprintf (buff, (size_t)COB_MINI_MAX,
2300  "LINE-COUNTER %s", rep->cname);
2301  x = cb_build_field (cb_build_reference (buff));
2302  CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
2303  CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
2304  CB_FIELD (x)->count++;
2305  cb_validate_field (CB_FIELD (x));
2306  rep->line_counter = cb_build_field_reference (CB_FIELD (x), NULL);
2307  CB_FIELD_ADD (current_program->working_storage, CB_FIELD (x));
2308  snprintf (buff, (size_t)COB_MINI_MAX,
2309  "PAGE-COUNTER %s", rep->cname);
2310  x = cb_build_field (cb_build_reference (buff));
2311  CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
2312  CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
2313  CB_FIELD (x)->count++;
2314  cb_validate_field (CB_FIELD (x));
2315  rep->page_counter = cb_build_field_reference (CB_FIELD (x), NULL);
2316  CB_FIELD_ADD (current_program->working_storage, CB_FIELD (x));
2317  }
2318 
2319  for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
2320  f = CB_FILE (CB_VALUE (l));
2321  if (!f->flag_finalized) {
2322  finalize_file (f, NULL);
2323  }
2324  }
2325 
2326  /* Build undeclared assignment name now */
2327  if (cb_assign_clause == CB_ASSIGN_MF) {
2328  for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
2329  assign = CB_FILE (CB_VALUE (l))->assign;
2330  if (!assign) {
2331  continue;
2332  }
2333  if (CB_REFERENCE_P (assign)) {
2334  for (x = current_program->file_list; x; x = CB_CHAIN (x)) {
2335  if (!strcmp (CB_FILE (CB_VALUE (x))->name,
2336  CB_NAME (assign))) {
2337  redefinition_error (assign);
2338  }
2339  }
2340  p = check_level_78 (CB_NAME (assign));
2341  if (p) {
2342  c = (unsigned char *)CB_LITERAL(CB_VALUE(p->values))->data;
2343  assign = CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, c, strlen ((char *)c)));
2344  CB_FILE (CB_VALUE (l))->assign = assign;
2345  }
2346  }
2347  if (CB_REFERENCE_P (assign) &&
2348  CB_WORD_COUNT (assign) == 0) {
2349  if (cb_warn_implicit_define) {
2350  cb_warning (_("'%s' will be implicitly defined"), CB_NAME (assign));
2351  }
2352  x = cb_build_implicit_field (assign, COB_SMALL_BUFF);
2353  CB_FIELD (x)->count++;
2354  p = current_program->working_storage;
2355  if (p) {
2356  while (p->sister) {
2357  p = p->sister;
2358  }
2359  p->sister = CB_FIELD (x);
2360  } else {
2361  current_program->working_storage = CB_FIELD (x);
2362  }
2363  }
2364  if (CB_REFERENCE_P (assign)) {
2365  x = cb_ref (assign);
2366  if (CB_FIELD_P (x) && CB_FIELD (x)->level == 88) {
2367  cb_error_x (assign, _("ASSIGN data item '%s' invalid"), CB_NAME (assign));
2368  }
2369  }
2370  }
2371  }
2372 
2373  if (prog->cursor_pos) {
2374  x = cb_ref (prog->cursor_pos);
2375  if (x == cb_error_node) {
2376  prog->cursor_pos = NULL;
2377  } else if (CB_FIELD(x)->size != 6 && CB_FIELD(x)->size != 4) {
2378  cb_error_x (prog->cursor_pos, _("'%s' CURSOR is not 4 or 6 characters long"),
2379  cb_name (prog->cursor_pos));
2380  prog->cursor_pos = NULL;
2381  }
2382  }
2383  if (prog->crt_status) {
2384  x = cb_ref (prog->crt_status);
2385  if (x == cb_error_node) {
2386  prog->crt_status = NULL;
2387  } else if (CB_FIELD(x)->size != 4) {
2388  cb_error_x (prog->crt_status, _("'%s' CRT STATUS is not 4 characters long"),
2389  cb_name (prog->crt_status));
2390  prog->crt_status = NULL;
2391  }
2392  } else {
2393  l = cb_build_reference ("COB-CRT-STATUS");
2394  p = CB_FIELD (cb_build_field (l));
2395  p->usage = CB_USAGE_DISPLAY;
2396  p->pic = CB_PICTURE (cb_build_picture ("9(4)"));
2397  cb_validate_field (p);
2398  p->flag_no_init = 1;
2399  /* Do not initialize/bump ref count here
2400  p->values = CB_LIST_INIT (cb_zero);
2401  p->count++;
2402  */
2403  CB_FIELD_ADD (current_program->working_storage, p);
2404  prog->crt_status = l;
2405  }
2406 
2407  /* Resolve all references so far */
2408  for (l = cb_list_reverse (prog->reference_list); l; l = CB_CHAIN (l)) {
2409  cb_ref (CB_VALUE (l));
2410  }
2411 
2412  /* Check ODO items */
2413  for (l = cb_depend_check; l; l = CB_CHAIN (l)) {
2414  x = CB_VALUE(l);
2415  if (x == cb_error_node) {
2416  continue;
2417  }
2418  q = CB_FIELD_PTR (x);
2419  if (cb_ref (q->depending) != cb_error_node) {
2420  depfld = CB_FIELD_PTR (q->depending);
2421  } else {
2422  depfld = NULL;
2423  }
2424  /* The data item that contains a OCCURS DEPENDING clause must be
2425  the last data item in the group */
2426  for (p = q; p->parent; p = p->parent) {
2427  for (; p->sister; p = p->sister) {
2428  if (p->sister == depfld) {
2429  cb_error_x (x,
2430  _("'%s' ODO field item invalid here"),
2431  p->sister->name);
2432  }
2433  if (!p->sister->redefines) {
2434  if (!cb_complex_odo) {
2435  cb_error_x (x,
2436  _("'%s' cannot have OCCURS DEPENDING"),
2437  cb_name (x));
2438  break;
2439  }
2440  p->flag_odo_item = 1;
2441  }
2442  }
2443  }
2444  /* If the field is GLOBAL, then the ODO must also be GLOBAL */
2445  if (q->flag_is_global && depfld) {
2446  if (!depfld->flag_is_global) {
2447  cb_error_x (x, _("'%s' ODO item must have GLOBAL attribute"),
2448  depfld->name);
2449  }
2450  }
2451  }
2452  cb_depend_check = NULL;
2453  cb_needs_01 = 0;
2454 
2455  for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
2456  f = CB_FILE (CB_VALUE (l));
2457  if (CB_VALID_TREE(f->record_depending)) {
2458  x = f->record_depending;
2459  if (cb_ref (x) != cb_error_node) {
2460 #if 0 /* RXWRXW - This breaks old legacy programs */
2461  if (CB_REF_OR_FIELD_P(x)) {
2462  p = CB_FIELD_PTR (x);
2463  switch (p->storage) {
2464  case CB_STORAGE_WORKING:
2465  case CB_STORAGE_LOCAL:
2466  case CB_STORAGE_LINKAGE:
2467  break;
2468  default:
2469  cb_error (_("RECORD DEPENDING item must be in WORKING/LOCAL/LINKAGE section"));
2470  }
2471  } else {
2472 #endif
2473  if (!CB_REF_OR_FIELD_P(x)) {
2474  cb_error (_("Invalid RECORD DEPENDING item"));
2475  }
2476  }
2477  }
2478  }
2479 }
void cb_validate_program_environment ( struct cb_program *  prog)

References _, cb_program::alphabet_name_list, cb_alphabet_name::alphabet_type, cb_alphabet_name::alphachr, CB_ALPHABET_ASCII, CB_ALPHABET_EBCDIC, CB_ALPHABET_NAME, CB_ALPHABET_NAME_P, CB_ALPHABET_NATIVE, cb_build_symbolic_chars(), CB_CHAIN, CB_CLASS_NAME, cb_error_node, cb_error_x(), cb_high, cb_int1, CB_LIST_P, CB_LITERAL, CB_LITERAL_P, CB_LOCALE_NAME_P, cb_low, cb_name(), cb_norm_high, cb_norm_low, CB_NUMERIC_LITERAL_P, CB_PAIR_P, CB_PAIR_X, CB_PAIR_Y, CB_PURPOSE, cb_ref(), cb_validate_collating(), CB_VALUE, cb_warning_x(), cb_program::class_name_list, cb_program::classification, cob_refer_ascii, cob_refer_ebcdic, cb_program::collating_sequence, current_program, cb_alphabet_name::custom_list, get_value(), cb_alphabet_name::high_val_char, cb_class_name::list, cb_alphabet_name::low_val_char, NULL, cb_program::symbolic_char_list, and cb_alphabet_name::values.

1831 {
1832  cb_tree x;
1833  cb_tree y;
1834  cb_tree l;
1835  cb_tree ls;
1836  struct cb_alphabet_name *ap;
1837  struct cb_class_name *cp;
1838  unsigned char *data;
1839  size_t dupls;
1840  size_t unvals;
1841  size_t count;
1842  int lower;
1843  int upper;
1844  int size;
1845  int n;
1846  int i;
1847  int lastval;
1848  int tableval;
1849  int values[256];
1850  int charvals[256];
1851 
1852  /* Check ALPHABET clauses */
1853  /* Complicated by difference between code set and collating sequence */
1854  for (l = current_program->alphabet_name_list; l; l = CB_CHAIN (l)) {
1855  ap = CB_ALPHABET_NAME (CB_VALUE (l));
1856 
1857  /* Native */
1858  if (ap->alphabet_type == CB_ALPHABET_NATIVE) {
1859  for (n = 0; n < 256; n++) {
1860  ap->values[n] = n;
1861  ap->alphachr[n] = n;
1862  }
1863  continue;
1864  }
1865 
1866  /* ASCII */
1867  if (ap->alphabet_type == CB_ALPHABET_ASCII) {
1868  for (n = 0; n < 256; n++) {
1869 #ifdef COB_EBCDIC_MACHINE
1870  ap->values[n] = (int)cob_refer_ascii[n];
1871  ap->alphachr[n] = (int)cob_refer_ascii[n];
1872 #else
1873  ap->values[n] = n;
1874  ap->alphachr[n] = n;
1875 #endif
1876  }
1877  continue;
1878  }
1879 
1880  /* EBCDIC */
1881  if (ap->alphabet_type == CB_ALPHABET_EBCDIC) {
1882  for (n = 0; n < 256; n++) {
1883 #ifdef COB_EBCDIC_MACHINE
1884  ap->values[n] = n;
1885  ap->alphachr[n] = n;
1886 #else
1887  ap->values[n] = (int)cob_refer_ebcdic[n];
1888  ap->alphachr[n] = (int)cob_refer_ebcdic[n];
1889 #endif
1890  }
1891  continue;
1892  }
1893 
1894  /* Custom alphabet */
1895  dupls = 0;
1896  unvals = 0;
1897  count = 0;
1898  lastval = 0;
1899  tableval = 0;
1900  for (n = 0; n < 256; n++) {
1901  values[n] = -1;
1902  charvals[n] = -1;
1903  ap->values[n] = -1;
1904  ap->alphachr[n] = -1;
1905  }
1906  ap->low_val_char = 0;
1907  ap->high_val_char = 255;
1908  for (y = ap->custom_list; y; y = CB_CHAIN (y)) {
1909  if (count > 255) {
1910  unvals = 1;
1911  break;
1912  }
1913  x = CB_VALUE (y);
1914  if (CB_PAIR_P (x)) {
1915  /* X THRU Y */
1916  lower = get_value (CB_PAIR_X (x));
1917  upper = get_value (CB_PAIR_Y (x));
1918  lastval = upper;
1919  if (!count) {
1920  ap->low_val_char = lower;
1921  }
1922  if (lower < 0 || lower > 255) {
1923  unvals = 1;
1924  continue;
1925  }
1926  if (upper < 0 || upper > 255) {
1927  unvals = 1;
1928  continue;
1929  }
1930  if (lower <= upper) {
1931  for (i = lower; i <= upper; i++) {
1932  if (values[i] != -1) {
1933  dupls = 1;
1934  }
1935  values[i] = i;
1936  charvals[i] = i;
1937  ap->alphachr[tableval] = i;
1938  ap->values[i] = tableval++;
1939  count++;
1940  }
1941  } else {
1942  for (i = lower; i >= upper; i--) {
1943  if (values[i] != -1) {
1944  dupls = 1;
1945  }
1946  values[i] = i;
1947  charvals[i] = i;
1948  ap->alphachr[tableval] = i;
1949  ap->values[i] = tableval++;
1950  count++;
1951  }
1952  }
1953  } else if (CB_LIST_P (x)) {
1954  /* X ALSO Y ... */
1955  if (!count) {
1956  ap->low_val_char = get_value (CB_VALUE (x));
1957  }
1958  for (ls = x; ls; ls = CB_CHAIN (ls)) {
1959  n = get_value (CB_VALUE (ls));
1960  if (!CB_CHAIN (ls)) {
1961  lastval = n;
1962  }
1963  if (n < 0 || n > 255) {
1964  unvals = 1;
1965  continue;
1966  }
1967  if (values[n] != -1) {
1968  dupls = 1;
1969  }
1970  values[n] = n;
1971  ap->values[n] = tableval;
1972  if (ls == x) {
1973  ap->alphachr[tableval] = n;
1974  charvals[n] = n;
1975  }
1976  count++;
1977  }
1978  tableval++;
1979  } else {
1980  /* Literal */
1981  if (CB_NUMERIC_LITERAL_P (x)) {
1982  n = get_value (x);
1983  lastval = n;
1984  if (!count) {
1985  ap->low_val_char = n;
1986  }
1987  if (n < 0 || n > 255) {
1988  unvals = 1;
1989  continue;
1990  }
1991  if (values[n] != -1) {
1992  dupls = 1;
1993  }
1994  values[n] = n;
1995  charvals[n] = n;
1996  ap->alphachr[tableval] = n;
1997  ap->values[n] = tableval++;
1998  count++;
1999  } else if (CB_LITERAL_P (x)) {
2000  size = (int)CB_LITERAL (x)->size;
2001  data = CB_LITERAL (x)->data;
2002  if (!count) {
2003  ap->low_val_char = data[0];
2004  }
2005  lastval = data[size - 1];
2006  for (i = 0; i < size; i++) {
2007  n = data[i];
2008  if (values[n] != -1) {
2009  dupls = 1;
2010  }
2011  values[n] = n;
2012  charvals[n] = n;
2013  ap->alphachr[tableval] = n;
2014  ap->values[n] = tableval++;
2015  count++;
2016  }
2017  } else {
2018  n = get_value (x);
2019  lastval = n;
2020  if (!count) {
2021  ap->low_val_char = n;
2022  }
2023  if (n < 0 || n > 255) {
2024  unvals = 1;
2025  continue;
2026  }
2027  if (values[n] != -1) {
2028  dupls = 1;
2029  }
2030  values[n] = n;
2031  charvals[n] = n;
2032  ap->alphachr[tableval] = n;
2033  ap->values[n] = tableval++;
2034  count++;
2035  }
2036  }
2037  }
2038  if (dupls || unvals) {
2039  if (dupls) {
2040  cb_error_x (l, _("Duplicate character values in alphabet '%s'"),
2041  cb_name (CB_VALUE(l)));
2042  }
2043  if (unvals) {
2044  cb_error_x (l, _("Invalid character values in alphabet '%s'"),
2045  cb_name (CB_VALUE(l)));
2046  }
2047  ap->low_val_char = 0;
2048  ap->high_val_char = 255;
2049  continue;
2050  }
2051  /* Calculate HIGH-VALUE */
2052  /* If all 256 values have been specified, */
2053  /* HIGH-VALUE is the last one */
2054  /* Otherwise if HIGH-VALUE has been specified, find the highest */
2055  /* value that has not been used */
2056  if (count == 256) {
2057  ap->high_val_char = lastval;
2058  } else if (values[255] != -1) {
2059  for (n = 254; n >= 0; n--) {
2060  if (values[n] == -1) {
2061  ap->high_val_char = n;
2062  break;
2063  }
2064  }
2065  }
2066 
2067  /* Get rest of code set */
2068  for (n = tableval; n < 256; ++n) {
2069  for (i = 0; i < 256; ++i) {
2070  if (charvals[i] < 0) {
2071  charvals[i] = 0;
2072  ap->alphachr[n] = i;
2073  break;
2074  }
2075  }
2076  }
2077 
2078  /* Fill in missing characters */
2079  for (n = 0; n < 256; n++) {
2080  if (ap->values[n] < 0) {
2081  ap->values[n] = tableval++;
2082  }
2083  }
2084  }
2085 
2086  /* Reset HIGH/LOW-VALUES */
2087  cb_low = cb_norm_low;
2088  cb_high = cb_norm_high;
2089 
2090  /* Check and generate SYMBOLIC clauses */
2091  for (l = current_program->symbolic_char_list; l; l = CB_CHAIN (l)) {
2092  if (CB_VALUE (l)) {
2093  y = cb_ref (CB_VALUE (l));
2094  if (y == cb_error_node) {
2095  continue;
2096  }
2097  if (!CB_ALPHABET_NAME_P (y)) {
2098  cb_error_x (y, _("Invalid ALPHABET name"));
2099  continue;
2100  }
2101  } else {
2102  y = NULL;
2103  }
2104  cb_build_symbolic_chars (CB_PURPOSE (l), y);
2105  }
2106 
2107  /* Check CLASS clauses */
2108  for (l = current_program->class_name_list; l; l = CB_CHAIN (l)) {
2109  dupls = 0;
2110  memset (values, 0, sizeof(values));
2111  cp = CB_CLASS_NAME (CB_VALUE (l));
2112  for (y = cp->list; y; y = CB_CHAIN (y)) {
2113  x = CB_VALUE (y);
2114  if (CB_PAIR_P (x)) {
2115  /* X THRU Y */
2116  lower = get_value (CB_PAIR_X (x));
2117  upper = get_value (CB_PAIR_Y (x));
2118  for (i = lower; i <= upper; i++) {
2119  if (values[i]) {
2120  dupls = 1;
2121  }
2122  values[i] = 1;
2123  }
2124  } else {
2125  if (CB_NUMERIC_LITERAL_P (x)) {
2126  n = get_value (x);
2127  if (values[n]) {
2128  dupls = 1;
2129  }
2130  values[n] = 1;
2131  } else if (CB_LITERAL_P (x)) {
2132  size = (int)CB_LITERAL (x)->size;
2133  data = CB_LITERAL (x)->data;
2134  for (i = 0; i < size; i++) {
2135  n = data[i];
2136  if (values[n]) {
2137  dupls = 1;
2138  }
2139  values[n] = 1;
2140  }
2141  } else {
2142  n = get_value (x);
2143  if (values[n]) {
2144  dupls = 1;
2145  }
2146  values[n] = 1;
2147  }
2148  }
2149  }
2150  if (dupls) {
2151  if (!cb_relaxed_syntax_check) {
2152  cb_error_x (CB_VALUE(l),
2153  _("Duplicate values in class '%s'"),
2154  cb_name (CB_VALUE(l)));
2155  } else {
2156  cb_warning_x (CB_VALUE(l),
2157  _("Duplicate values in class '%s'"),
2158  cb_name (CB_VALUE(l)));
2159  }
2160  }
2161  }
2162 
2163  /* Resolve the program collating sequence */
2164  if (prog->collating_sequence) {
2165  cb_validate_collating (prog);
2166  }
2167 
2168  /* Resolve the program classification */
2169  if (prog->classification && prog->classification != cb_int1) {
2170  x = cb_ref (prog->classification);
2171  if (!CB_LOCALE_NAME_P (x)) {
2172  cb_error_x (prog->classification,
2173  _("'%s' is not a locale name"),
2174  cb_name (prog->classification));
2175  prog->classification = NULL;
2176  return;
2177  }
2178  }
2179 }
static unsigned int check_valid_key ( const struct cb_file *  cbf,
const struct cb_field *  f 
)
static

References _, cb_file::alt_key_list, cb_error_node, cb_error_x(), cb_field_founder(), CB_FIELD_PTR, cb_ref(), CB_TREE, COB_ORG_INDEXED, current_statement, cb_alt_key::key, cb_file::key, cb_alt_key::next, cb_field::offset, cb_file::organization, cb_file::record, and cb_field::sister.

Referenced by cb_emit_start().

8130 {
8131  cb_tree kfld;
8132  struct cb_alt_key *cbak;
8133  struct cb_field *f1;
8134  struct cb_field *ff;
8135 
8136  if (cbf->organization != COB_ORG_INDEXED) {
8137  if (CB_FIELD_PTR (cbf->key) != f) {
8138  cb_error_x (CB_TREE (current_statement),
8139  _("Invalid key item"));
8140  return 1;
8141  }
8142  return 0;
8143  }
8144 
8145  ff = cb_field_founder (f);
8146  for (f1 = cbf->record; f1; f1 = f1->sister) {
8147  if (f1 == ff) {
8148  break;
8149  }
8150  }
8151  if (!f1) {
8152  cb_error_x (CB_TREE (current_statement), _("Invalid key item"));
8153  return 1;
8154  }
8155 
8156  kfld = cb_ref (cbf->key);
8157  if (kfld == cb_error_node) {
8158  return 1;
8159  }
8160  if (f->offset == CB_FIELD_PTR (kfld)->offset) {
8161  return 0;
8162  }
8163  for (cbak = cbf->alt_key_list; cbak; cbak = cbak->next) {
8164  kfld = cb_ref (cbak->key);
8165  if (kfld == cb_error_node) {
8166  return 1;
8167  }
8168  if (f->offset == CB_FIELD_PTR (kfld)->offset) {
8169  return 0;
8170  }
8171  }
8172  cb_error_x (CB_TREE (current_statement), _("Invalid key item"));
8173  return 1;
8174 }
static void cob_put_sign_ebcdic ( unsigned char *  p,
const int  sign 
)
static

Referenced by cb_build_move_literal().

6729 {
6730  if (sign < 0) {
6731  switch (*p) {
6732  case '0':
6733  *p = (unsigned char)'}';
6734  return;
6735  case '1':
6736  *p = (unsigned char)'J';
6737  return;
6738  case '2':
6739  *p = (unsigned char)'K';
6740  return;
6741  case '3':
6742  *p = (unsigned char)'L';
6743  return;
6744  case '4':
6745  *p = (unsigned char)'M';
6746  return;
6747  case '5':
6748  *p = (unsigned char)'N';
6749  return;
6750  case '6':
6751  *p = (unsigned char)'O';
6752  return;
6753  case '7':
6754  *p = (unsigned char)'P';
6755  return;
6756  case '8':
6757  *p = (unsigned char)'Q';
6758  return;
6759  case '9':
6760  *p = (unsigned char)'R';
6761  return;
6762  default:
6763  /* What to do here */
6764  *p = (unsigned char)'}';
6765  return;
6766  }
6767  }
6768  switch (*p) {
6769  case '0':
6770  *p = (unsigned char)'{';
6771  return;
6772  case '1':
6773  *p = (unsigned char)'A';
6774  return;
6775  case '2':
6776  *p = (unsigned char)'B';
6777  return;
6778  case '3':
6779  *p = (unsigned char)'C';
6780  return;
6781  case '4':
6782  *p = (unsigned char)'D';
6783  return;
6784  case '5':
6785  *p = (unsigned char)'E';
6786  return;
6787  case '6':
6788  *p = (unsigned char)'F';
6789  return;
6790  case '7':
6791  *p = (unsigned char)'G';
6792  return;
6793  case '8':
6794  *p = (unsigned char)'H';
6795  return;
6796  case '9':
6797  *p = (unsigned char)'I';
6798  return;
6799  default:
6800  /* What to do here */
6801  *p = (unsigned char)'{';
6802  return;
6803  }
6804 }
void cobc_init_typeck ( void  )

References expr_prio, p, pvalid_char, and valid_char.

Referenced by main().

8511 {
8512  const unsigned char *p;
8513 
8514  memset (valid_char, 0, sizeof(valid_char));
8515  for (p = pvalid_char; *p; ++p) {
8516  valid_char[*p] = 1;
8517  }
8518  memset(expr_prio, 0, sizeof(expr_prio));
8519  expr_prio['x' & 0xFF] = 0;
8520  expr_prio['^' & 0xFF] = 1;
8521  expr_prio['*' & 0xFF] = 2;
8522  expr_prio['/' & 0xFF] = 2;
8523  expr_prio['+' & 0xFF] = 3;
8524  expr_prio['-' & 0xFF] = 3;
8525  expr_prio['=' & 0xFF] = 4;
8526  expr_prio['~' & 0xFF] = 4;
8527  expr_prio['<' & 0xFF] = 4;
8528  expr_prio['>' & 0xFF] = 4;
8529  expr_prio['[' & 0xFF] = 4;
8530  expr_prio[']' & 0xFF] = 4;
8531  expr_prio['!' & 0xFF] = 5;
8532  expr_prio['&' & 0xFF] = 6;
8533  expr_prio['|' & 0xFF] = 7;
8534  expr_prio[')' & 0xFF] = 8;
8535  expr_prio['(' & 0xFF] = 9;
8536  expr_prio[0] = 10;
8537 }
static int count_pic_alphanumeric_edited ( struct cb_field *  field)
static

References cb_field::count, p, cb_field::pic, and cb_picture::str.

Referenced by validate_move().

5850 {
5851  unsigned char *p;
5852  int count;
5853  int repeat;
5854 
5855  /* Count number of free places in an alphanumeric edited field */
5856  count = 0;
5857  for (p = (unsigned char *)(field->pic->str); *p; p += 5) {
5858  if (*p == '9' || *p == 'A' || *p == 'X') {
5859  memcpy ((void *)&repeat, p + 1, sizeof(int));
5860  count += repeat;
5861  }
5862  }
5863  return count;
5864 }
static cb_tree decimal_alloc ( void  )
static

References _, cb_build_decimal(), COB_MAX_DEC_STRUCT, COBC_ABORT, cobc_abort_pr(), current_program, current_statement, cb_program::decimal_index, cb_program::decimal_index_max, and cb_statement::name.

Referenced by build_decimal_assign(), cb_build_cond(), and decimal_expand().

3153 {
3154  cb_tree x;
3155 
3156  x = cb_build_decimal (current_program->decimal_index);
3157  current_program->decimal_index++;
3158  if (current_program->decimal_index >= COB_MAX_DEC_STRUCT) {
3159  cobc_abort_pr (_("Internal decimal structure size exceeded - %d"),
3160  COB_MAX_DEC_STRUCT);
3161  if (strcmp(current_statement->name, "COMPUTE") == 0) {
3162  cobc_abort_pr (_("Try to minimize the number of parenthesis "
3163  "or split into multiple computations."));
3164  }
3165  COBC_ABORT ();
3166  }
3167  if (current_program->decimal_index > current_program->decimal_index_max) {
3168  current_program->decimal_index_max = current_program->decimal_index;
3169  }
3170  return x;
3171 }
static void decimal_assign ( cb_tree  x,
cb_tree  d,
cb_tree  round_opt 
)
static

References build_store_option(), CB_BUILD_FUNCALL_3, and dpush.

Referenced by build_decimal_assign().

3285 {
3286  dpush (CB_BUILD_FUNCALL_3 ("cob_decimal_get_field", d, x,
3287  build_store_option (x, round_opt)));
3288 }
static void decimal_compute ( const int  op,
cb_tree  x,
cb_tree  y 
)
static

References _, CB_BUILD_FUNCALL_2, COBC_ABORT, cobc_abort_pr(), and dpush.

Referenced by build_decimal_assign(), and decimal_expand().

3181 {
3182  const char *func;
3183 
3184  switch (op) {
3185  case '+':
3186  func = "cob_decimal_add";
3187  break;
3188  case '-':
3189  func = "cob_decimal_sub";
3190  break;
3191  case '*':
3192  func = "cob_decimal_mul";
3193  break;
3194  case '/':
3195  func = "cob_decimal_div";
3196  break;
3197  case '^':
3198  func = "cob_decimal_pow";
3199  break;
3200  default:
3201  cobc_abort_pr (_("Unexpected operation %d"), op);
3202  COBC_ABORT ();
3203  }
3204  dpush (CB_BUILD_FUNCALL_2 (func, x, y));
3205 }
static void decimal_expand ( cb_tree  d,
cb_tree  x 
)
static

References _, CB_BINARY_OP, cb_build_cast_llint(), CB_BUILD_FUNCALL_1, CB_BUILD_FUNCALL_2, CB_BUILD_STRING0, cb_emit, CB_EXCEPTION_ENABLE, CB_FIELD_PTR, cb_int0, CB_LITERAL, CB_TAG_BINARY_OP, CB_TAG_CONST, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_TAG, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_6, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_INDEX, CB_USAGE_PACKED, cb_zero, COB_EC_DATA_INCOMPATIBLE, COBC_ABORT, cobc_abort_pr(), decimal_alloc(), decimal_compute(), decimal_free(), dpush, cb_field::name, cb_binary_op::op, p, cb_field::pic, cb_literal::scale, cb_picture::scale, cb_literal::size, cb_field::size, cb_field::usage, cb_binary_op::x, and cb_binary_op::y.

Referenced by build_decimal_assign(), and cb_build_cond().

3209 {
3210  struct cb_literal *l;
3211  struct cb_field *f;
3212  struct cb_binary_op *p;
3213  cb_tree t;
3214 
3215  switch (CB_TREE_TAG (x)) {
3216  case CB_TAG_CONST:
3217  if (x == cb_zero) {
3218  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_llint", d,
3219  cb_int0));
3220  } else {
3221  cobc_abort_pr (_("Unexpected constant expansion"));
3222  COBC_ABORT ();
3223  }
3224  break;
3225  case CB_TAG_LITERAL:
3226  /* Set d, N */
3227  l = CB_LITERAL (x);
3228  if (l->size < 19 && l->scale == 0) {
3229  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_llint", d,
3230  cb_build_cast_llint (x)));
3231  } else {
3232  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_field", d, x));
3233  }
3234  break;
3235  case CB_TAG_REFERENCE:
3236  /* Set d, X */
3237  f = CB_FIELD_PTR (x);
3238  /* Check numeric */
3239  if (cb_flag_correct_numeric && f->usage == CB_USAGE_DISPLAY) {
3240  cb_emit (CB_BUILD_FUNCALL_1 ("cob_correct_numeric", x));
3241  }
3242  if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE)) {
3243  if (f->usage == CB_USAGE_DISPLAY ||
3244  f->usage == CB_USAGE_PACKED ||
3245  f->usage == CB_USAGE_COMP_6) {
3246  dpush (CB_BUILD_FUNCALL_2 ("cob_check_numeric",
3247  x, CB_BUILD_STRING0 (f->name)));
3248  }
3249  }
3250 
3251  if ((f->usage == CB_USAGE_BINARY ||
3252  f->usage == CB_USAGE_COMP_5 ||
3253  f->usage == CB_USAGE_INDEX ||
3254  f->usage == CB_USAGE_COMP_X) &&
3255  !f->pic->scale &&
3256  (f->size == 1 || f->size == 2 || f->size == 4 ||
3257  f->size == 8)) {
3258  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_llint", d, cb_build_cast_llint (x)));
3259  } else {
3260  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_field", d, x));
3261  }
3262  break;
3263  case CB_TAG_BINARY_OP:
3264  /* Set d, X
3265  * Set t, Y
3266  * OP d, t */
3267  p = CB_BINARY_OP (x);
3268  decimal_expand (d, p->x);
3269  t = decimal_alloc ();
3270  decimal_expand (t, p->y);
3271  decimal_compute (p->op, d, t);
3272  decimal_free ();
3273  break;
3274  case CB_TAG_INTRINSIC:
3275  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_field", d, x));
3276  break;
3277  default:
3278  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
3279  COBC_ABORT ();
3280  }
3281 }
static void decimal_free ( void  )
static

References current_program, and cb_program::decimal_index.

Referenced by build_decimal_assign(), cb_build_cond(), and decimal_expand().

3175 {
3176  current_program->decimal_index--;
3177 }
static unsigned int emit_corresponding ( cb_tree(*)(cb_tree f1, cb_tree f2, cb_tree f3)  func,
cb_tree  x1,
cb_tree  x2,
cb_tree  opt 
)
static

References cb_build_field_reference(), cb_emit, CB_FIELD_PTR, cb_field::children, cb_field::flag_occurs, found, cb_field::name, cb_field::redefines, and cb_field::sister.

Referenced by cb_emit_corresponding().

4019 {
4020  struct cb_field *f1, *f2;
4021  cb_tree t1;
4022  cb_tree t2;
4023  unsigned int found;
4024 
4025  found = 0;
4026  for (f1 = CB_FIELD_PTR (x1)->children; f1; f1 = f1->sister) {
4027  if (!f1->redefines && !f1->flag_occurs) {
4028  for (f2 = CB_FIELD_PTR (x2)->children; f2; f2 = f2->sister) {
4029  if (!f2->redefines && !f2->flag_occurs) {
4030  if (strcmp (f1->name, f2->name) == 0) {
4031  t1 = cb_build_field_reference (f1, x1);
4032  t2 = cb_build_field_reference (f2, x2);
4033  if (f1->children && f2->children) {
4034  found += emit_corresponding (func, t1, t2, opt);
4035  } else {
4036  found++;
4037  cb_emit (func (t1, t2, opt));
4038  }
4039  }
4040  }
4041  }
4042  }
4043  }
4044  return found;
4045 }
static unsigned int emit_move_corresponding ( cb_tree  x1,
cb_tree  x2 
)
static

References cb_build_field_reference(), cb_build_move(), cb_emit, CB_FIELD_PTR, cb_field::children, cb_field::flag_occurs, found, cb_field::name, cb_field::redefines, and cb_field::sister.

Referenced by cb_emit_move_corresponding().

4070 {
4071  struct cb_field *f1, *f2;
4072  cb_tree t1;
4073  cb_tree t2;
4074  unsigned int found;
4075 
4076  found = 0;
4077  for (f1 = CB_FIELD_PTR (x1)->children; f1; f1 = f1->sister) {
4078  if (!f1->redefines && !f1->flag_occurs) {
4079  for (f2 = CB_FIELD_PTR (x2)->children; f2; f2 = f2->sister) {
4080  if (!f2->redefines && !f2->flag_occurs) {
4081  if (strcmp (f1->name, f2->name) == 0) {
4082  t1 = cb_build_field_reference (f1, x1);
4083  t2 = cb_build_field_reference (f2, x2);
4084  if (f1->children && f2->children) {
4085  found += emit_move_corresponding (t1, t2);
4086  } else {
4087  cb_emit (cb_build_move (t1, t2));
4088  found++;
4089  }
4090  }
4091  }
4092  }
4093  }
4094  }
4095  return found;
4096 }
static cb_tree evaluate_test ( cb_tree  s,
cb_tree  o 
)
static

References _, cb_any, cb_build_binary_op(), CB_BUILD_NEGATION, cb_error_x(), cb_false, CB_FIELD, CB_FIELD_P, CB_PAIR_X, CB_PAIR_Y, CB_PURPOSE_INT, CB_REFERENCE, CB_REFERENCE_P, CB_TREE, cb_true, CB_VALUE, current_statement, NULL, and value.

Referenced by build_evaluate().

5228 {
5229  cb_tree x;
5230  cb_tree y;
5231  cb_tree t;
5232  int flag;
5233 
5234  /* ANY is always true */
5235  if (o == cb_any) {
5236  return cb_true;
5237  }
5238 
5239  /* Object TRUE or FALSE */
5240  if (o == cb_true) {
5241  return s;
5242  }
5243  if (o == cb_false) {
5244  return CB_BUILD_NEGATION (s);
5245  }
5246 
5247  flag = CB_PURPOSE_INT (o);
5248  x = CB_PAIR_X (CB_VALUE (o));
5249  y = CB_PAIR_Y (CB_VALUE (o));
5250 
5251  /* Subject TRUE or FALSE */
5252  if (s == cb_true) {
5253  return flag ? CB_BUILD_NEGATION (x) : x;
5254  }
5255  if (s == cb_false) {
5256  return flag ? x : CB_BUILD_NEGATION (x);
5257  }
5258 
5259  /* x THRU y */
5260  if (y) {
5261  t = cb_build_binary_op (cb_build_binary_op (x, '[', s),
5262  '&',
5263  cb_build_binary_op (s, '[', y));
5264 
5265  return flag ? CB_BUILD_NEGATION (t) : t;
5266  }
5267 
5268  if (CB_REFERENCE_P(x) && CB_FIELD_P(CB_REFERENCE(x)->value) &&
5269  CB_FIELD(CB_REFERENCE(x)->value)->level == 88) {
5270  cb_error_x (CB_TREE (current_statement),
5271  _("Invalid use of 88 level in WHEN expression"));
5272  return NULL;
5273  }
5274 
5275  /* Regular comparison */
5276  switch (flag) {
5277  case 0:
5278  /* Equal comparison */
5279  return cb_build_binary_op (s, '=', x);
5280  case 1:
5281  /* Unequal comparison */
5282  return cb_build_binary_op (s, '~', x);
5283  default:
5284  /* Class and relational conditions */
5285  return x;
5286  }
5287 }
static int expr_chk_cond ( cb_tree  expr_1,
cb_tree  expr_2 
)
static

References CB_CAST, CB_CAST_ADDR_OF_ADDR, CB_CAST_ADDRESS, CB_CAST_P, CB_CAST_PROGRAM_POINTER, CB_FIELD_PTR, cb_null, CB_REF_OR_FIELD_P, cb_field::flag_is_pointer, and cb_field::level.

Referenced by expr_reduce().

2660 {
2661  struct cb_field *f1;
2662  struct cb_field *f2;
2663  int is_ptr_1;
2664  int is_ptr_2;
2665 
2666  /* 88 level is invalid here */
2667  /* Likewise combination of pointer and non-pointer */
2668  is_ptr_1 = 0;
2669  is_ptr_2 = 0;
2670  if (CB_REF_OR_FIELD_P (expr_1)) {
2671  f1 = CB_FIELD_PTR (expr_1);
2672  if (f1->level == 88) {
2673  return 1;
2674  }
2675  if (f1->flag_is_pointer) {
2676  is_ptr_1 = 1;
2677  }
2678  } else if (CB_CAST_P (expr_1)) {
2679  switch (CB_CAST (expr_1)->cast_type) {
2680  case CB_CAST_ADDRESS:
2681  case CB_CAST_ADDR_OF_ADDR:
2682  case CB_CAST_PROGRAM_POINTER:
2683  is_ptr_1 = 1;
2684  break;
2685  default:
2686  break;
2687  }
2688  } else if (expr_1 == cb_null) {
2689  is_ptr_1 = 1;
2690  }
2691  if (CB_REF_OR_FIELD_P (expr_2)) {
2692  f2 = CB_FIELD_PTR (expr_2);
2693  if (f2->level == 88) {
2694  return 1;
2695  }
2696  if (f2->flag_is_pointer) {
2697  is_ptr_2 = 1;
2698  }
2699  } else if (CB_CAST_P (expr_2)) {
2700  switch (CB_CAST (expr_2)->cast_type) {
2701  case CB_CAST_ADDRESS:
2702  case CB_CAST_ADDR_OF_ADDR:
2703  case CB_CAST_PROGRAM_POINTER:
2704  is_ptr_2 = 1;
2705  break;
2706  default:
2707  break;
2708  }
2709  } else if (expr_2 == cb_null) {
2710  is_ptr_2 = 1;
2711  }
2712  return is_ptr_1 ^ is_ptr_2;
2713 }
static void expr_expand ( cb_tree *  x)
static

References CB_BINARY_OP, CB_BINARY_OP_P, cb_binary_op::op, p, cb_binary_op::x, and cb_binary_op::y.

Referenced by cb_expr_finish().

3017 {
3018  struct cb_binary_op *p;
3019 
3020 start:
3021  /* Remove parenthesis */
3022  if (CB_BINARY_OP_P (*x)) {
3023  p = CB_BINARY_OP (*x);
3024  if (p->op == '@') {
3025  *x = p->x;
3026  goto start;
3027  }
3028  expr_expand (&p->x);
3029  if (p->y) {
3030  expr_expand (&p->y);
3031  }
3032  }
3033 }
static int expr_reduce ( int  token)
static

References _, CB_BINARY_OP, CB_BINARY_OP_P, cb_build_binary_op(), CB_BUILD_NEGATION, CB_CLASS_BOOLEAN, cb_error_node, CB_TREE_CLASS, cb_warning(), expr_chk_cond(), expr_index, expr_op, expr_prio, TOKEN, and VALUE.

Referenced by cb_expr_finish(), cb_expr_shift(), cb_expr_shift_class(), and cb_expr_shift_sign().

2717 {
2718  /* Example:
2719  * index: -3 -2 -1 0
2720  * token: 'x' '*' 'x' '+' ...
2721  */
2722 
2723  int op;
2724 
2725  while (expr_prio[TOKEN (-2)] <= expr_prio[token]) {
2726  /* Reduce the expression depending on the last operator */
2727  op = TOKEN (-2);
2728  switch (op) {
2729  case 'x':
2730  return 0;
2731 
2732  case '+':
2733  case '-':
2734  case '*':
2735  case '/':
2736  case '^':
2737  /* Arithmetic operators: 'x' op 'x' */
2738  if (TOKEN (-1) != 'x' || TOKEN (-3) != 'x') {
2739  return -1;
2740  }
2741  TOKEN (-3) = 'x';
2742  VALUE (-3) = cb_build_binary_op (VALUE (-3), op, VALUE (-1));
2743  expr_index -= 2;
2744  break;
2745 
2746  case '!':
2747  /* Negation: '!' 'x' */
2748  if (TOKEN (-1) != 'x') {
2749  return -1;
2750  }
2751  /* 'x' '=' 'x' '|' '!' 'x' */
2752  if (expr_lh) {
2753  if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
2754  VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
2755  }
2756  }
2757  TOKEN (-2) = 'x';
2758  VALUE (-2) = CB_BUILD_NEGATION (VALUE (-1));
2759  expr_index -= 1;
2760  break;
2761 
2762  case '&':
2763  case '|':
2764  /* Logical AND/OR: 'x' op 'x' */
2765  if (TOKEN (-1) != 'x' || TOKEN (-3) != 'x') {
2766  return -1;
2767  }
2768  /* 'x' '=' 'x' '|' 'x' */
2769  if (expr_lh) {
2770  if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
2771  VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
2772  }
2773  if (CB_TREE_CLASS (VALUE (-3)) != CB_CLASS_BOOLEAN) {
2774  VALUE (-3) = cb_build_binary_op (expr_lh, expr_op, VALUE (-3));
2775  }
2776  }
2777  /* Warning for complex expressions without explicit parentheses
2778  (i.e., "a OR b AND c" or "a AND b OR c") */
2779  if (cb_warn_parentheses && op == '|') {
2780  if ((CB_BINARY_OP_P (VALUE (-3)) &&
2781  CB_BINARY_OP (VALUE (-3))->op == '&') ||
2782  (CB_BINARY_OP_P (VALUE (-1)) &&
2783  CB_BINARY_OP (VALUE (-1))->op == '&')) {
2784  cb_warning (_("Suggest parentheses around AND within OR"));
2785  }
2786  }
2787  TOKEN (-3) = 'x';
2788  VALUE (-3) = cb_build_binary_op (VALUE (-3), op,
2789  VALUE (-1));
2790  expr_index -= 2;
2791  break;
2792 
2793  case '(':
2794  case ')':
2795  return 0;
2796 
2797  default:
2798  /* Relational operators */
2799  if (TOKEN (-1) != 'x') {
2800  return -1;
2801  }
2802  switch (TOKEN (-3)) {
2803  case 'x':
2804  /* Simple condition: 'x' op 'x' */
2805  if (VALUE (-3) == cb_error_node ||
2806  VALUE (-1) == cb_error_node) {
2807  VALUE (-3) = cb_error_node;
2808  } else {
2809  expr_lh = VALUE (-3);
2810  if (expr_chk_cond (expr_lh, VALUE (-1))) {
2811  VALUE (-3) = cb_error_node;
2812  return 1;
2813  }
2814  expr_op = op;
2815  TOKEN (-3) = 'x';
2816  if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
2817  VALUE (-3) = cb_build_binary_op (expr_lh, op, VALUE (-1));
2818  } else {
2819  VALUE (-3) = VALUE (-1);
2820  }
2821  }
2822  expr_index -= 2;
2823  break;
2824  case '&':
2825  case '|':
2826  /* Complex condition: 'x' '=' 'x' '|' op 'x' */
2827  if (VALUE (-1) == cb_error_node) {
2828  VALUE (-2) = cb_error_node;
2829  } else {
2830  expr_op = op;
2831  TOKEN (-2) = 'x';
2832  if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN && expr_lh) {
2833  VALUE (-2) = cb_build_binary_op (expr_lh, op, VALUE (-1));
2834  } else {
2835  VALUE (-2) = VALUE (-1);
2836  }
2837  }
2838  expr_index -= 1;
2839  break;
2840  default:
2841  return -1;
2842  }
2843  break;
2844  }
2845  }
2846 
2847  /* Handle special case "op OR x AND" */
2848  if (token == '&' && TOKEN (-2) == '|' &&
2849  CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
2850  TOKEN (-1) = 'x';
2851  VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
2852  }
2853 
2854  return 0;
2855 }
static int get_value ( cb_tree  x)
static

References CB_CLASS_NUMERIC, cb_get_int(), CB_LITERAL, cb_norm_high, cb_norm_low, cb_null, cb_quote, cb_space, CB_TREE_CLASS, and cb_zero.

Referenced by cb_validate_program_environment().

1783 {
1784  if (x == cb_space) {
1785  return ' ';
1786  } else if (x == cb_zero) {
1787  return '0';
1788  } else if (x == cb_quote) {
1789  return cb_flag_apostrophe ? '\'' : '"';
1790  } else if (x == cb_norm_low) {
1791  return 0;
1792  } else if (x == cb_norm_high) {
1793  return 255;
1794  } else if (x == cb_null) {
1795  return 0;
1796  } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
1797  return cb_get_int (x) - 1;
1798  }
1799  return CB_LITERAL (x)->data[0];
1800 }
static void move_warning ( cb_tree  src,
cb_tree  dst,
const unsigned int  value_flag,
const int  flag,
const int  src_flag,
const char *  msg 
)
static

References CB_LITERAL_P, cb_warning_x(), cb_tree_common::source_line, suppress_warn, and warning_destination().

Referenced by validate_move().

5816 {
5817  cb_tree loc;
5818 
5819  if (suppress_warn) {
5820  return;
5821  }
5822  loc = src->source_line ? src : dst;
5823  if (value_flag) {
5824  /* VALUE clause */
5825  if (CB_LITERAL_P (src)) {
5826  cb_warning_x (dst, msg);
5827  } else {
5828  cb_warning_x (loc, msg);
5829  }
5830  } else {
5831  /* MOVE statement */
5832  if (flag) {
5833  if (CB_LITERAL_P (src)) {
5834  cb_warning_x (dst, msg);
5835  } else {
5836  cb_warning_x (loc, msg);
5837  }
5838  if (src_flag) {
5839  warning_destination (src);
5840  }
5841  warning_destination (dst);
5842  }
5843  }
5844 
5845  return;
5846 }
static void output_screen_from ( struct cb_field *  p,
const unsigned int  sisters 
)
static

References CB_BUILD_FUNCALL_2, cb_emit, CB_TREE, cb_field::children, COB_SCREEN_TYPE_ATTRIBUTE, COB_SCREEN_TYPE_FIELD, COB_SCREEN_TYPE_GROUP, COB_SCREEN_TYPE_VALUE, cb_field::count, cb_field::screen_from, cb_field::sister, cb_field::size, and cb_field::values.

Referenced by cb_emit_accept(), and cb_emit_display().

4124 {
4125  int type;
4126 
4127  if (sisters && p->sister) {
4128  output_screen_from (p->sister, 1U);
4129  }
4130  if (p->children) {
4131  output_screen_from (p->children, 1U);
4132  }
4133 
4134  type = (p->children ? COB_SCREEN_TYPE_GROUP :
4135  p->values ? COB_SCREEN_TYPE_VALUE :
4136  (p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
4137  if (type == COB_SCREEN_TYPE_FIELD && p->screen_from) {
4138  /* Bump reference count */
4139  p->count++;
4140  cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", p->screen_from,
4141  CB_TREE (p)));
4142  }
4143 }
static void output_screen_to ( struct cb_field *  p,
const unsigned int  sisters 
)
static

References CB_BUILD_FUNCALL_2, cb_emit, CB_TREE, cb_field::children, COB_SCREEN_TYPE_ATTRIBUTE, COB_SCREEN_TYPE_FIELD, COB_SCREEN_TYPE_GROUP, COB_SCREEN_TYPE_VALUE, cb_field::count, cb_field::screen_to, cb_field::sister, cb_field::size, and cb_field::values.

Referenced by cb_emit_accept().

4147 {
4148  int type;
4149 
4150  if (sisters && p->sister) {
4151  output_screen_to (p->sister, 1U);
4152  }
4153  if (p->children) {
4154  output_screen_to (p->children, 1U);
4155  }
4156 
4157  type = (p->children ? COB_SCREEN_TYPE_GROUP :
4158  p->values ? COB_SCREEN_TYPE_VALUE :
4159  (p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
4160  if (type == COB_SCREEN_TYPE_FIELD && p->screen_to) {
4161  /* Bump reference count */
4162  p->count++;
4163  cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", CB_TREE (p), p->screen_to));
4164  }
4165 }
static unsigned int search_set_keys ( struct cb_field *  f,
cb_tree  x 
)
static

References _, build_cond_88(), CB_BINARY_OP, cb_error_node, cb_error_x(), CB_FIELD_PTR, CB_REF_OR_FIELD_P, CB_REFERENCE_P, CB_TREE, current_statement, cb_key::key, cb_field::keys, cb_field::nkeys, NULL, cb_binary_op::op, p, cb_key::ref, cb_key::val, cb_binary_op::x, and cb_binary_op::y.

Referenced by cb_build_search_all().

7622 {
7623  struct cb_binary_op *p;
7624  struct cb_field *fldx;
7625  struct cb_field *fldy;
7626  int i;
7627 
7628  if (CB_REFERENCE_P (x)) {
7629  x = build_cond_88 (x);
7630  if (!x || x == cb_error_node) {
7631  return 1;
7632  }
7633  }
7634 
7635  p = CB_BINARY_OP (x);
7636  switch (p->op) {
7637  case '&':
7638  if (search_set_keys (f, p->x)) {
7639  return 1;
7640  }
7641  if (search_set_keys (f, p->y)) {
7642  return 1;
7643  }
7644  break;
7645  case '=':
7646  fldx = NULL;
7647  fldy = NULL;
7648  /* One of the operands must be a key reference */
7649  if (CB_REF_OR_FIELD_P (p->x)) {
7650  fldx = CB_FIELD_PTR (p->x);
7651  }
7652  if (CB_REF_OR_FIELD_P (p->y)) {
7653  fldy = CB_FIELD_PTR (p->y);
7654  }
7655  if (!fldx && !fldy) {
7656  cb_error_x (CB_TREE (current_statement),
7657  _("Invalid SEARCH ALL condition"));
7658  return 1;
7659  }
7660 
7661  for (i = 0; i < f->nkeys; ++i) {
7662  if (fldx == CB_FIELD_PTR (f->keys[i].key)) {
7663  f->keys[i].ref = p->x;
7664  f->keys[i].val = p->y;
7665  break;
7666  }
7667  }
7668  if (i == f->nkeys) {
7669  for (i = 0; i < f->nkeys; ++i) {
7670  if (fldy == CB_FIELD_PTR (f->keys[i].key)) {
7671  f->keys[i].ref = p->y;
7672  f->keys[i].val = p->x;
7673  break;
7674  }
7675  }
7676  if (i == f->nkeys) {
7677  cb_error_x (CB_TREE (current_statement),
7678  _("Invalid SEARCH ALL condition"));
7679  return 1;
7680  }
7681  }
7682  break;
7683  default:
7684  cb_error_x (CB_TREE (current_statement),
7685  _("Invalid SEARCH ALL condition"));
7686  return 1;
7687  }
7688  return 0;
7689 }
static void validate_inspect ( cb_tree  x,
cb_tree  y,
const unsigned int  replconv 
)
static

References _, CB_ALPHABET_NAME_P, cb_error_node, cb_error_x(), CB_FIELD_PTR, cb_get_int(), CB_LITERAL, CB_LITERAL_P, cb_ref(), CB_REF_OR_FIELD_P, CB_REFERENCE, CB_TAG_CONST, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE, CB_TREE_TAG, current_statement, cb_reference::length, and cb_reference::offset.

Referenced by cb_build_converting(), cb_build_replacing_all(), cb_build_replacing_first(), cb_build_replacing_leading(), and cb_build_replacing_trailing().

5504 {
5505  cb_tree l;
5506  struct cb_reference *r;
5507  size_t size1;
5508  size_t size2;
5509  int offset;
5510 
5511  size1 = 0;
5512  size2 = 0;
5513  switch (CB_TREE_TAG(x)) {
5514  case CB_TAG_REFERENCE:
5515  r = CB_REFERENCE (x);
5516  l = cb_ref (x);
5517  if (l == cb_error_node) {
5518  return;
5519  }
5520  if (CB_REF_OR_FIELD_P (l)) {
5521  size1 = CB_FIELD_PTR (x)->size;
5522  } else if (CB_ALPHABET_NAME_P (l)) {
5523  size1 = 256;
5524  }
5525  if (size1 && r->offset) {
5526  if (!CB_LITERAL_P (r->offset)) {
5527  return;
5528  }
5529  offset = cb_get_int (r->offset);
5530  if (r->length) {
5531  if (!CB_LITERAL_P (r->length)) {
5532  return;
5533  }
5534  size1 = cb_get_int (r->length);
5535  } else {
5536  size1 -= (offset - 1);
5537  }
5538  }
5539  break;
5540  case CB_TAG_LITERAL:
5541  size1 = CB_LITERAL(x)->size;
5542  break;
5543  case CB_TAG_CONST:
5544  size1 = 1;
5545  break;
5546  default:
5547  break;
5548  }
5549  switch (CB_TREE_TAG(y)) {
5550  case CB_TAG_REFERENCE:
5551  r = CB_REFERENCE (y);
5552  l = cb_ref (y);
5553  if (l == cb_error_node) {
5554  return;
5555  }
5556  if (CB_REF_OR_FIELD_P (l)) {
5557  size2 = CB_FIELD_PTR (y)->size;
5558  } else if (CB_ALPHABET_NAME_P (l)) {
5559  size2 = 256;
5560  }
5561  if (size2 && r->offset) {
5562  if (!CB_LITERAL_P (r->offset)) {
5563  return;
5564  }
5565  offset = cb_get_int (r->offset);
5566  if (r->length) {
5567  if (!CB_LITERAL_P (r->length)) {
5568  return;
5569  }
5570  size2 = cb_get_int (r->length);
5571  } else {
5572  size2 -= (offset - 1);
5573  }
5574  }
5575  break;
5576  case CB_TAG_LITERAL:
5577  size2 = CB_LITERAL(y)->size;
5578  break;
5579  default:
5580  break;
5581  }
5582  if (size1 && size2 && size1 != size2) {
5583  if (replconv == 1) {
5584  cb_error_x (CB_TREE (current_statement),
5585  _("%s operands differ in size"), "REPLACING");
5586  } else {
5587  cb_error_x (CB_TREE (current_statement),
5588  _("%s operands differ in size"), "CONVERTING");
5589  }
5590  }
5591 }
int validate_move ( cb_tree  src,
cb_tree  dst,
const unsigned int  is_value 
)

References _, cb_literal::all, CB_ALPHABET_NAME_P, CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_ALPHANUMERIC_EDITED, CB_CATEGORY_BOOLEAN, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, cb_check_overlapping(), CB_CLASS_NUMERIC, CB_CLASS_POINTER, CB_ERROR, cb_error_x(), CB_FIELD_PTR, cb_field_size(), CB_FILE_P, cb_get_long_long(), cb_high, CB_LITERAL, cb_low, cb_quote, CB_REFERENCE, CB_REFERENCE_P, cb_space, CB_TAG_BINARY_OP, CB_TAG_CONST, CB_TAG_FIELD, CB_TAG_FUNCALL, CB_TAG_INTEGER, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_CATEGORY, CB_TREE_CLASS, CB_TREE_TAG, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_X, CB_USAGE_DOUBLE, CB_USAGE_FLOAT, CB_USAGE_FP_BIN128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_DEC128, CB_USAGE_FP_DEC64, CB_USAGE_LONG_DOUBLE, cb_warning_x(), cb_zero, cb_field::children, COB_S64_C, cob_s64_t, COBC_ABORT, cobc_abort_pr(), count_pic_alphanumeric_edited(), cb_literal::data, cb_picture::digits, cb_field::flag_real_binary, cb_picture::have_sign, move_warning(), overlapping, p, cb_field::pic, cb_literal::scale, cb_picture::scale, cb_literal::sign, cb_literal::size, cb_picture::size, cb_field::size, cb_tree_common::source_line, suppress_warn, cb_field::usage, value, and warningopt.

Referenced by cb_build_move(), and validate_field_value().

5939 {
5940  struct cb_field *fdst;
5941  struct cb_field *fsrc;
5942  struct cb_literal *l;
5943  unsigned char *p;
5944  cb_tree loc;
5945  cob_s64_t val;
5946  size_t i;
5947  size_t is_numeric_edited;
5948  int src_scale_mod;
5949  int dst_scale_mod;
5950  int dst_size_mod;
5951  int size;
5952  int most_significant;
5953  int least_significant;
5954 
5955  loc = src->source_line ? src : dst;
5956  is_numeric_edited = 0;
5957  overlapping = 0;
5958  if (CB_REFERENCE_P (dst)) {
5959  if (CB_ALPHABET_NAME_P(CB_REFERENCE(dst)->value)) {
5960  goto invalid;
5961  }
5962  if (CB_FILE_P(CB_REFERENCE(dst)->value)) {
5963  goto invalid;
5964  }
5965  }
5966  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_BOOLEAN) {
5967  cb_error_x (loc, _("Invalid destination for MOVE"));
5968  return -1;
5969  }
5970 
5971  if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER) {
5972  if (CB_TREE_CLASS (src) == CB_CLASS_POINTER) {
5973  return 0;
5974  } else {
5975  goto invalid;
5976  }
5977  }
5978 
5979  fdst = CB_FIELD_PTR (dst);
5980  switch (CB_TREE_TAG (src)) {
5981  case CB_TAG_CONST:
5982  if (src == cb_space) {
5983  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC ||
5984  (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED && !is_value)) {
5985  if (!cb_relaxed_syntax_check || is_value) {
5986  goto invalid;
5987  }
5988  cb_warning_x (loc, _("Source is non-numeric - substituting zero"));
5989  }
5990  } else if (src == cb_zero) {
5991  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHABETIC) {
5992  goto invalid;
5993  }
5994  } else if (src == cb_low || src == cb_high || src == cb_quote) {
5995  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC ||
5996  CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED) {
5997  if (!cb_relaxed_syntax_check || is_value) {
5998  goto invalid;
5999  }
6000  cb_warning_x (loc, _("Source is non-numeric - substituting zero"));
6001  }
6002  }
6003  break;
6004  case CB_TAG_LITERAL:
6005  l = CB_LITERAL (src);
6006  if (CB_TREE_CLASS (src) == CB_CLASS_NUMERIC) {
6007  /* Numeric literal */
6008  if (l->all) {
6009  goto invalid;
6010  }
6011  if (fdst->usage == CB_USAGE_DOUBLE ||
6012  fdst->usage == CB_USAGE_FLOAT ||
6013  fdst->usage == CB_USAGE_LONG_DOUBLE ||
6014  fdst->usage == CB_USAGE_FP_BIN32 ||
6015  fdst->usage == CB_USAGE_FP_BIN64 ||
6016  fdst->usage == CB_USAGE_FP_BIN128 ||
6017  fdst->usage == CB_USAGE_FP_DEC64 ||
6018  fdst->usage == CB_USAGE_FP_DEC128) {
6019  break;
6020  }
6021  most_significant = -999;
6022  least_significant = 999;
6023 
6024  /* Compute the most significant figure place */
6025  for (i = 0; i < l->size; i++) {
6026  if (l->data[i] != '0') {
6027  break;
6028  }
6029  }
6030  if (i != l->size) {
6031  most_significant = (int) (l->size - l->scale - i - 1);
6032  }
6033 
6034  /* Compute the least significant figure place */
6035  for (i = 0; i < l->size; i++) {
6036  if (l->data[l->size - i - 1] != '0') {
6037  break;
6038  }
6039  }
6040  if (i != l->size) {
6041  least_significant = (int) (-l->scale + i);
6042  }
6043 
6044  /* Value check */
6045  switch (CB_TREE_CATEGORY (dst)) {
6046  case CB_CATEGORY_ALPHANUMERIC:
6047  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6048  if (is_value) {
6049  goto expect_alphanumeric;
6050  }
6051  if (l->scale == 0) {
6052  goto expect_alphanumeric;
6053  }
6054  goto non_integer_move;
6055  case CB_CATEGORY_NUMERIC:
6056  if (fdst->pic->scale < 0) {
6057  /* Check for PIC 9(n)P(m) */
6058  if (least_significant < -fdst->pic->scale) {
6059  goto value_mismatch;
6060  }
6061  } else if (fdst->pic->scale > fdst->pic->size) {
6062  /* Check for PIC P(n)9(m) */
6063  if (most_significant >= fdst->pic->size - fdst->pic->scale) {
6064  goto value_mismatch;
6065  }
6066  }
6067  break;
6068  case CB_CATEGORY_NUMERIC_EDITED:
6069  if (is_value) {
6070  goto expect_alphanumeric;
6071  }
6072 
6073  /* TODO */
6074  break;
6075  case CB_CATEGORY_ALPHABETIC:
6076  if (is_value) {
6077  goto expect_alphanumeric;
6078  }
6079  /* Coming from codegen */
6080  if (!suppress_warn) {
6081  goto invalid;
6082  }
6083 #if 1 /* RXWRXW - Initialize warn */
6084  if (warningopt) {
6085  cb_warning_x (loc, _("Numeric move to ALPHABETIC"));
6086  }
6087 #endif
6088  break;
6089  default:
6090  if (is_value) {
6091  goto expect_alphanumeric;
6092  }
6093  goto invalid;
6094  }
6095 
6096  /* Sign check */
6097  if (l->sign != 0 && !fdst->pic->have_sign) {
6098  if (is_value) {
6099  cb_error_x (loc, _("Data item not signed"));
6100  return -1;
6101  }
6102  if (cb_warn_constant) {
6103  cb_warning_x (loc, _("Ignoring sign"));
6104  }
6105  }
6106 
6107  /* Size check */
6108  if (fdst->flag_real_binary ||
6109  ((fdst->usage == CB_USAGE_COMP_5 ||
6110  fdst->usage == CB_USAGE_COMP_X ||
6111  fdst->usage == CB_USAGE_BINARY) &&
6112  fdst->pic->scale == 0)) {
6113  p = l->data;
6114  for (i = 0; i < l->size; i++) {
6115  if (l->data[i] != '0') {
6116  p = &l->data[i];
6117  break;
6118  }
6119  }
6120  i = l->size - i;
6121  switch (fdst->size) {
6122  case 1:
6123  if (i > 18) {
6124  goto numlit_overflow;
6125  }
6126  val = cb_get_long_long (src);
6127  if (fdst->pic->have_sign) {
6128  if (val < COB_S64_C(-128) ||
6129  val > COB_S64_C(127)) {
6130  goto numlit_overflow;
6131  }
6132  } else {
6133  if (val > COB_S64_C(255)) {
6134  goto numlit_overflow;
6135  }
6136  }
6137  break;
6138  case 2:
6139  if (i > 18) {
6140  goto numlit_overflow;
6141  }
6142  val = cb_get_long_long (src);
6143  if (fdst->pic->have_sign) {
6144  if (val < COB_S64_C(-32768) ||
6145  val > COB_S64_C(32767)) {
6146  goto numlit_overflow;
6147  }
6148  } else {
6149  if (val > COB_S64_C(65535)) {
6150  goto numlit_overflow;
6151  }
6152  }
6153  break;
6154  case 3:
6155  if (i > 18) {
6156  goto numlit_overflow;
6157  }
6158  val = cb_get_long_long (src);
6159  if (fdst->pic->have_sign) {
6160  if (val < COB_S64_C(-8388608) ||
6161  val > COB_S64_C(8388607)) {
6162  goto numlit_overflow;
6163  }
6164  } else {
6165  if (val > COB_S64_C(16777215)) {
6166  goto numlit_overflow;
6167  }
6168  }
6169  break;
6170  case 4:
6171  if (i > 18) {
6172  goto numlit_overflow;
6173  }
6174  val = cb_get_long_long (src);
6175  if (fdst->pic->have_sign) {
6176  if (val < COB_S64_C(-2147483648) ||
6177  val > COB_S64_C(2147483647)) {
6178  goto numlit_overflow;
6179  }
6180  } else {
6181  if (val > COB_S64_C(4294967295)) {
6182  goto numlit_overflow;
6183  }
6184  }
6185  break;
6186  case 5:
6187  if (i > 18) {
6188  goto numlit_overflow;
6189  }
6190  val = cb_get_long_long (src);
6191  if (fdst->pic->have_sign) {
6192  if (val < COB_S64_C(-549755813888) ||
6193  val > COB_S64_C(549755813887)) {
6194  goto numlit_overflow;
6195  }
6196  } else {
6197  if (val > COB_S64_C(1099511627775)) {
6198  goto numlit_overflow;
6199  }
6200  }
6201  break;
6202  case 6:
6203  if (i > 18) {
6204  goto numlit_overflow;
6205  }
6206  val = cb_get_long_long (src);
6207  if (fdst->pic->have_sign) {
6208  if (val < COB_S64_C(-140737488355328) ||
6209  val > COB_S64_C(140737488355327)) {
6210  goto numlit_overflow;
6211  }
6212  } else {
6213  if (val > COB_S64_C(281474976710655)) {
6214  goto numlit_overflow;
6215  }
6216  }
6217  break;
6218  case 7:
6219  if (i > 18) {
6220  goto numlit_overflow;
6221  }
6222  val = cb_get_long_long (src);
6223  if (fdst->pic->have_sign) {
6224  if (val < COB_S64_C(-36028797018963968) ||
6225  val > COB_S64_C(36028797018963967)) {
6226  goto numlit_overflow;
6227  }
6228  } else {
6229  if (val > COB_S64_C(72057594037927935)) {
6230  goto numlit_overflow;
6231  }
6232  }
6233  break;
6234  default:
6235  if (fdst->pic->have_sign) {
6236  if (i < 19) {
6237  break;
6238  }
6239  if (i > 19) {
6240  goto numlit_overflow;
6241  }
6242  if (memcmp (p, "9223372036854775807", (size_t)19) > 0) {
6243  goto numlit_overflow;
6244  }
6245  } else {
6246  if (i < 20) {
6247  break;
6248  }
6249  if (i > 20) {
6250  goto numlit_overflow;
6251  }
6252  if (memcmp (p, "18446744073709551615", (size_t)20) > 0) {
6253  goto numlit_overflow;
6254  }
6255  }
6256  break;
6257  }
6258  return 0;
6259  }
6260  if (least_significant < -fdst->pic->scale) {
6261  goto size_overflow;
6262  }
6263  if (fdst->pic->scale > 0) {
6264  size = fdst->pic->digits - fdst->pic->scale;
6265  } else {
6266  size = fdst->pic->digits;
6267  }
6268  if (most_significant >= size) {
6269  goto size_overflow;
6270  }
6271  } else {
6272  /* Alphanumeric literal */
6273 
6274  /* Value check */
6275  switch (CB_TREE_CATEGORY (dst)) {
6276  case CB_CATEGORY_ALPHABETIC:
6277  for (i = 0; i < l->size; i++) {
6278  if (!isalpha (l->data[i]) &&
6279  l->data[i] != ' ') {
6280  goto value_mismatch;
6281  }
6282  }
6283  break;
6284  case CB_CATEGORY_NUMERIC:
6285  goto expect_numeric;
6286  case CB_CATEGORY_NUMERIC_EDITED:
6287  if (!is_value) {
6288  goto expect_numeric;
6289  }
6290 
6291  /* TODO: validate the value */
6292  break;
6293  default:
6294  break;
6295  }
6296 
6297  /* Size check */
6298  size = cb_field_size (dst);
6299  if (size > 0 && (int)l->size > size) {
6300  goto size_overflow;
6301  }
6302  }
6303  break;
6304  case CB_TAG_FIELD:
6305  case CB_TAG_REFERENCE:
6306  if (CB_REFERENCE_P(src) &&
6307  CB_ALPHABET_NAME_P(CB_REFERENCE(src)->value)) {
6308  break;
6309  }
6310  if (CB_REFERENCE_P(src) &&
6311  CB_FILE_P(CB_REFERENCE(src)->value)) {
6312  goto invalid;
6313  }
6314  fsrc = CB_FIELD_PTR (src);
6315  size = cb_field_size (src);
6316  if (size < 0) {
6317  size = fsrc->size;
6318  }
6319 
6320  /* Check basic overlapping */
6321  overlapping = cb_check_overlapping (src, dst, fsrc, fdst);
6322 
6323  /* Non-elementary move */
6324  if (fsrc->children || fdst->children) {
6325  if (size > fdst->size) {
6326  goto size_overflow_1;
6327  }
6328  break;
6329  }
6330 
6331  /* Elementary move */
6332  switch (CB_TREE_CATEGORY (src)) {
6333  case CB_CATEGORY_ALPHANUMERIC:
6334  switch (CB_TREE_CATEGORY (dst)) {
6335  case CB_CATEGORY_NUMERIC:
6336  case CB_CATEGORY_NUMERIC_EDITED:
6337  if (size > (int)fdst->pic->digits) {
6338  goto size_overflow_2;
6339  }
6340  break;
6341  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6342  if (size > count_pic_alphanumeric_edited (fdst)) {
6343  goto size_overflow_1;
6344  }
6345  break;
6346  default:
6347  if (size > fdst->size) {
6348  goto size_overflow_1;
6349  }
6350  break;
6351  }
6352  break;
6353  case CB_CATEGORY_ALPHABETIC:
6354  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6355  switch (CB_TREE_CATEGORY (dst)) {
6356  case CB_CATEGORY_NUMERIC:
6357  case CB_CATEGORY_NUMERIC_EDITED:
6358  goto invalid;
6359  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6360  if (size > count_pic_alphanumeric_edited(fdst)) {
6361  goto size_overflow_1;
6362  }
6363  break;
6364  default:
6365  if (size > fdst->size) {
6366  goto size_overflow_1;
6367  }
6368  break;
6369  }
6370  break;
6371  case CB_CATEGORY_NUMERIC:
6372  case CB_CATEGORY_NUMERIC_EDITED:
6373  switch (CB_TREE_CATEGORY (dst)) {
6374  case CB_CATEGORY_ALPHABETIC:
6375  goto invalid;
6376  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6377  is_numeric_edited = 1;
6378  /* Drop through */
6379  case CB_CATEGORY_ALPHANUMERIC:
6380  if (!fsrc->pic) {
6381  return -1;
6382  }
6383  if (is_numeric_edited) {
6384  dst_size_mod = count_pic_alphanumeric_edited (fdst);
6385  } else {
6386  dst_size_mod = fdst->size;
6387  }
6388  if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC &&
6389  fsrc->pic->scale > 0) {
6390  goto non_integer_move;
6391  }
6392  if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC &&
6393  (int)fsrc->pic->digits > dst_size_mod) {
6394  goto size_overflow_2;
6395  }
6396  if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC_EDITED &&
6397  fsrc->size > dst_size_mod) {
6398  goto size_overflow_1;
6399  }
6400  break;
6401  default:
6402  if (!fsrc->pic) {
6403  return -1;
6404  }
6405  if (!fdst->pic) {
6406  return -1;
6407  }
6408  src_scale_mod = fsrc->pic->scale < 0 ?
6409  0 : fsrc->pic->scale;
6410  dst_scale_mod = fdst->pic->scale < 0 ?
6411  0 : fdst->pic->scale;
6412  if (fsrc->pic->digits - src_scale_mod >
6413  fdst->pic->digits - dst_scale_mod ||
6414  src_scale_mod > dst_scale_mod) {
6415  goto size_overflow_2;
6416  }
6417  break;
6418  }
6419  break;
6420  default:
6421  cb_error_x (loc, _("Invalid source for MOVE"));
6422  return -1;
6423  }
6424  break;
6425  case CB_TAG_INTEGER:
6426  case CB_TAG_BINARY_OP:
6427  case CB_TAG_INTRINSIC:
6428  case CB_TAG_FUNCALL:
6429  /* TODO: check this */
6430  break;
6431  default:
6432  cobc_abort_pr (_("Unexpected tree tag %d"),
6433  (int)CB_TREE_TAG (src));
6434  COBC_ABORT ();
6435  }
6436  return 0;
6437 
6438 invalid:
6439  if (is_value) {
6440  cb_error_x (loc, _("Invalid VALUE clause"));
6441  } else {
6442  cb_error_x (loc, _("Invalid MOVE statement"));
6443  }
6444  return -1;
6445 
6446 numlit_overflow:
6447  if (is_value) {
6448  cb_error_x (loc, _("Invalid VALUE clause - literal exceeds data size"));
6449  return -1;
6450  }
6451  if (cb_warn_constant && !suppress_warn) {
6452  cb_warning_x (loc, _("Numeric literal exceeds data size"));
6453  }
6454  return 0;
6455 
6456 non_integer_move:
6457  if (!suppress_warn) {
6458  if (cb_move_noninteger_to_alphanumeric == CB_ERROR) {
6459  goto invalid;
6460  }
6461  cb_warning_x (loc, _("Move non-integer to alphanumeric"));
6462  }
6463  return 0;
6464 
6465 expect_numeric:
6466  move_warning (src, dst, is_value, cb_warn_strict_typing, 0,
6467  _("Numeric value is expected"));
6468  return 0;
6469 
6470 expect_alphanumeric:
6471  move_warning (src, dst, is_value, cb_warn_strict_typing, 0,
6472  _("Alphanumeric value is expected"));
6473  return 0;
6474 
6475 value_mismatch:
6476  move_warning (src, dst, is_value, cb_warn_constant, 0,
6477  _("Value does not fit the picture string"));
6478  return 0;
6479 
6480 size_overflow:
6481  move_warning (src, dst, is_value, cb_warn_constant, 0,
6482  _("Value size exceeds data size"));
6483  return 0;
6484 
6485 size_overflow_1:
6486  move_warning (src, dst, is_value, cb_warn_truncate, 1,
6487  _("Sending field larger than receiving field"));
6488  return 0;
6489 
6490 size_overflow_2:
6491  move_warning (src, dst, is_value, cb_warn_truncate, 1,
6492  _("Some digits may be truncated"));
6493  return 0;
6494 }
static void warning_destination ( cb_tree  x)
static

References _, CB_FIELD, cb_name(), CB_REFERENCE, CB_TREE, CB_USAGE_DOUBLE, CB_USAGE_FLOAT, CB_USAGE_FP_BIN128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_DEC128, CB_USAGE_FP_DEC64, CB_USAGE_LONG_DOUBLE, cb_warning(), cb_warning_x(), cb_field::flag_real_binary, cb_field::name, cb_reference::offset, cb_picture::orig, cb_field::pic, cb_field::size, cb_field::usage, and cb_reference::value.

Referenced by move_warning().

5759 {
5760  struct cb_reference *r;
5761  struct cb_field *f;
5762  cb_tree loc;
5763 
5764  r = CB_REFERENCE (x);
5765  f = CB_FIELD (r->value);
5766  loc = CB_TREE (f);
5767 
5768  if (r->offset) {
5769  return;
5770  }
5771 
5772  if (!strcmp (f->name, "RETURN-CODE") ||
5773  !strcmp (f->name, "SORT-RETURN") ||
5774  !strcmp (f->name, "NUMBER-OF-CALL-PARAMETERS")) {
5775  cb_warning (_("Internal register '%s' defined as BINARY-LONG"),
5776  f->name);
5777  } else if (f->flag_real_binary) {
5778  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
5779  f->name, f->pic->orig);
5780  } else if (f->usage == CB_USAGE_FLOAT) {
5781  cb_warning_x (loc, _("'%s' defined here as USAGE FLOAT"),
5782  f->name);
5783  } else if (f->usage == CB_USAGE_DOUBLE) {
5784  cb_warning_x (loc, _("'%s' defined here as USAGE DOUBLE"),
5785  f->name);
5786  } else if (f->usage == CB_USAGE_LONG_DOUBLE) {
5787  cb_warning_x (loc, _("'%s' defined here as USAGE FLOAT EXTENDED"),
5788  f->name);
5789  } else if (f->usage == CB_USAGE_FP_BIN32) {
5790  cb_warning_x (loc, _("'%s' defined here as USAGE FLOAT-BINARY-7"),
5791  f->name);
5792  } else if (f->usage == CB_USAGE_FP_BIN64) {
5793  cb_warning_x (loc, _("'%s' defined here as USAGE FLOAT-BINARY-16"),
5794  f->name);
5795  } else if (f->usage == CB_USAGE_FP_BIN128) {
5796  cb_warning_x (loc, _("'%s' defined here as USAGE FLOAT-BINARY-34"),
5797  f->name);
5798  } else if (f->usage == CB_USAGE_FP_DEC64) {
5799  cb_warning_x (loc, _("'%s' defined here as USAGE FLOAT-DECIMAL-16"),
5800  f->name);
5801  } else if (f->usage == CB_USAGE_FP_DEC128) {
5802  cb_warning_x (loc, _("'%s' defined here as USAGE FLOAT-DECIMAL-34"),
5803  f->name);
5804  } else if (f->pic) {
5805  cb_warning_x (loc, _("'%s' defined here as PIC %s"),
5806  cb_name (loc), f->pic->orig);
5807  } else {
5808  cb_warning_x (loc, _("'%s' defined here as a group of length %d"),
5809  cb_name (loc), f->size);
5810  }
5811 }

Variable Documentation

struct optim_table bin_add_funcs[]
static
struct optim_table bin_compare_funcs[]
static
struct optim_table bin_set_funcs[]
static
Initial value:
= {
{ NULL, COB_OPTIM_MIN },
{ "cob_setswp_u16", COB_SETSWP_U16 },
{ "cob_setswp_u24", COB_SETSWP_U24 },
{ "cob_setswp_u32", COB_SETSWP_U32 },
{ "cob_setswp_u40", COB_SETSWP_U40 },
{ "cob_setswp_u48", COB_SETSWP_U48 },
{ "cob_setswp_u56", COB_SETSWP_U56 },
{ "cob_setswp_u64", COB_SETSWP_U64 },
{ NULL, COB_OPTIM_MIN },
{ "cob_setswp_s16", COB_SETSWP_S16 },
{ "cob_setswp_s24", COB_SETSWP_S24 },
{ "cob_setswp_s32", COB_SETSWP_S32 },
{ "cob_setswp_s40", COB_SETSWP_S40 },
{ "cob_setswp_s48", COB_SETSWP_S48 },
{ "cob_setswp_s56", COB_SETSWP_S56 },
{ "cob_setswp_s64", COB_SETSWP_S64 }
}
struct optim_table bin_sub_funcs[]
static
cb_tree cb_debug_contents

Referenced by cb_build_perform_varying(), emit_entry(), output_alter(), output_cond_debug(), output_file_error(), output_funcall_debug(), output_goto(), output_goto_1(), output_perform(), output_perform_until(), and output_stmt().

cb_tree cb_debug_item
cb_tree cb_debug_line

Referenced by output_stmt().

cb_tree cb_debug_name

Referenced by cb_build_perform_varying(), output_alter(), output_cond_debug(), output_funcall_debug(), output_goto(), output_goto_1(), output_perform(), output_perform_call(), output_perform_until(), and output_stmt().

cb_tree cb_debug_sub_1
cb_tree cb_debug_sub_2
cb_tree cb_debug_sub_3
const unsigned char cob_refer_ascii[256]
static

Referenced by cb_validate_program_environment().

const unsigned char cob_refer_ebcdic[256]
static

Referenced by cb_validate_program_environment().

cb_tree decimal_stack = NULL
static
int expr_index
static

Referenced by cb_expr_finish(), cb_expr_init(), cb_expr_shift(), cb_expr_shift_class(), cb_expr_shift_sign(), and expr_reduce().

cb_tree expr_lh
static
int expr_op
static

Referenced by cb_expr_init(), cb_expr_shift(), and expr_reduce().

unsigned char expr_prio[256]
static

Referenced by cobc_init_typeck(), and expr_reduce().

struct expr_node* expr_stack
static
int expr_stack_size
static

Referenced by cb_expr_init(), and cb_expr_shift().

const unsigned char hexval[] = "0123456789ABCDEF"
static

Referenced by cb_encode_program_id(), output_integer(), and output_long_integer().

size_t initialized = 0
static

Referenced by cb_expr_init().

cb_tree inspect_data
static
const char* inspect_func
static

Referenced by cb_build_tallying_all(), cb_build_tallying_characters(), cb_build_tallying_leading(), cb_build_tallying_trailing(), cb_build_tallying_value(), and cb_init_tallying().

size_t overlapping = 0
static

Referenced by cb_build_move_copy(), and validate_move().

const unsigned char pvalid_char[]
static
Initial value:
=
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"

Referenced by cobc_init_typeck().

size_t suppress_warn = 0

Referenced by cb_check_overlapping(), move_warning(), output_move(), and validate_move().

struct system_table system_tab[]
static
unsigned char valid_char[256]
static

Referenced by cb_encode_program_id(), and cobc_init_typeck().