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

Data Structures

struct  int_node
 

Macros

#define PIC_ALPHABETIC   0x01
 
#define PIC_NUMERIC   0x02
 
#define PIC_NATIONAL   0x04
 
#define PIC_EDITED   0x08
 
#define PIC_ALPHANUMERIC   (PIC_ALPHABETIC | PIC_NUMERIC)
 
#define PIC_ALPHABETIC_EDITED   (PIC_ALPHABETIC | PIC_EDITED)
 
#define PIC_ALPHANUMERIC_EDITED   (PIC_ALPHANUMERIC | PIC_EDITED)
 
#define PIC_NUMERIC_EDITED   (PIC_NUMERIC | PIC_EDITED)
 
#define PIC_NATIONAL_EDITED   (PIC_NATIONAL | PIC_EDITED)
 
#define CB_FILE_ERR_REQUIRED   1
 
#define CB_FILE_ERR_INVALID_FT   2
 
#define CB_FILE_ERR_INVALID   3
 

Functions

static size_t hash (const unsigned char *s)
 
static void lookup_word (struct cb_reference *p, const char *name)
 
static void file_error (cb_tree name, const char *clause, const char errtype)
 
static void * make_tree (const enum cb_tag tag, const enum cb_category category, const size_t size)
 
static cb_tree make_constant (const enum cb_category category, const char *val)
 
static cb_tree make_constant_label (const char *name)
 
static size_t cb_name_1 (char *s, cb_tree x)
 
static cb_tree make_intrinsic (cb_tree name, struct cb_intrinsic_table *cbp, cb_tree args, cb_tree field, cb_tree refmod, const int isuser)
 
static cb_tree global_check (struct cb_reference *r, cb_tree items, size_t *ambiguous)
 
static int iso_8601_func (const enum cb_intr_enum intr)
 
static int valid_format (const enum cb_intr_enum intr, const char *format)
 
static const char * try_get_constant_data (cb_tree val)
 
static int offset_time_format (const char *format)
 
static int offset_arg_param_num (const enum cb_intr_enum intr)
 
static int valid_const_date_time_args (const cb_tree tree, const struct cb_intrinsic_table *intr, cb_tree args)
 
char * cb_to_cname (const char *s)
 
struct cb_literal * build_literal (const enum cb_category category, const void *data, const size_t size)
 
char * cb_name (cb_tree x)
 
enum cb_category cb_tree_category (cb_tree x)
 
enum cb_class cb_tree_class (cb_tree x)
 
int cb_category_is_alpha (cb_tree x)
 
int cb_tree_type (const cb_tree x, const struct cb_field *f)
 
int cb_fits_int (const cb_tree x)
 
int cb_fits_long_long (const cb_tree x)
 
int cb_get_int (const cb_tree x)
 
cob_s64_t cb_get_long_long (const cb_tree x)
 
cob_u64_t cb_get_u_long_long (const cb_tree x)
 
void cb_init_constants (void)
 
cb_tree cb_build_list (cb_tree purpose, cb_tree value, cb_tree chain)
 
cb_tree cb_list_append (cb_tree l1, cb_tree l2)
 
cb_tree cb_list_add (cb_tree l, cb_tree x)
 
cb_tree cb_pair_add (cb_tree l, cb_tree x, cb_tree y)
 
cb_tree cb_list_reverse (cb_tree l)
 
int cb_list_length (cb_tree l)
 
void cb_list_map (cb_tree(*func)(cb_tree x), cb_tree l)
 
const char * cb_define (cb_tree name, cb_tree val)
 
static struct nested_list * add_contained_prog (struct nested_list *parent_list, struct cb_program *child_prog)
 
struct cb_program * cb_build_program (struct cb_program *last_program, const int nest_level)
 
void cb_add_common_prog (struct cb_program *prog)
 
void cb_insert_common_prog (struct cb_program *prog, struct cb_program *comprog)
 
cb_tree cb_int (const int n)
 
cb_tree cb_int_hex (const int n)
 
cb_tree cb_build_string (const void *data, const size_t size)
 
cb_tree cb_build_comment (const char *str)
 
cb_tree cb_build_direct (const char *str, const unsigned int flagnl)
 
cb_tree cb_build_debug (const cb_tree target, const char *str, const cb_tree fld)
 
cb_tree cb_build_debug_call (struct cb_label *target)
 
cb_tree cb_build_alphabet_name (cb_tree name)
 
cb_tree cb_build_class_name (cb_tree name, cb_tree list)
 
cb_tree cb_build_locale_name (cb_tree name, cb_tree list)
 
cb_tree cb_build_system_name (const enum cb_system_name_category category, const int token)
 
cb_tree cb_build_numeric_literal (const int sign, const void *data, const int scale)
 
cb_tree cb_build_numsize_literal (const void *data, const size_t size, const int sign)
 
cb_tree cb_build_alphanumeric_literal (const void *data, const size_t size)
 
cb_tree cb_concat_literals (const cb_tree x1, const cb_tree x2)
 
cb_tree cb_build_decimal (const int id)
 
struct cb_picture * cb_build_binary_picture (const char *str, const cob_u32_t size, const cob_u32_t sign)
 
cb_tree cb_build_picture (const char *str)
 
cb_tree cb_build_field (cb_tree name)
 
cb_tree cb_build_implicit_field (cb_tree name, const int len)
 
cb_tree cb_build_constant (cb_tree name, cb_tree value)
 
struct cb_field * cb_field_add (struct cb_field *f, struct cb_field *p)
 
struct cb_field * cb_field_founder (const struct cb_field *f)
 
struct cb_field * cb_field_variable_size (const struct cb_field *f)
 
unsigned int cb_field_variable_address (const struct cb_field *fld)
 
int cb_field_subordinate (const struct cb_field *pfld, const struct cb_field *f)
 
void cb_build_symbolic_chars (const cb_tree sym_list, const cb_tree alphabet)
 
struct cb_report * build_report (cb_tree name)
 
struct cb_file * build_file (cb_tree name)
 
void validate_file (struct cb_file *f, cb_tree name)
 
void finalize_file (struct cb_file *f, struct cb_field *records)
 
cb_tree cb_build_reference (const char *name)
 
cb_tree cb_build_filler (void)
 
cb_tree cb_build_field_reference (struct cb_field *f, cb_tree ref)
 
static void cb_define_system_name (const char *name)
 
void cb_set_system_names (void)
 
cb_tree cb_ref (cb_tree x)
 
cb_tree cb_build_binary_op (cb_tree x, const int op, cb_tree y)
 
cb_tree cb_build_binary_list (cb_tree l, const int op)
 
cb_tree cb_build_funcall (const char *name, const int argc, const cb_tree a1, const cb_tree a2, const cb_tree a3, const cb_tree a4, const cb_tree a5, const cb_tree a6, const cb_tree a7, const cb_tree a8, const cb_tree a9, const cb_tree a10)
 
cb_tree cb_build_cast (const enum cb_cast_type type, const cb_tree val)
 
cb_tree cb_build_cast_int (const cb_tree val)
 
cb_tree cb_build_cast_llint (const cb_tree val)
 
cb_tree cb_build_label (cb_tree name, struct cb_label *section)
 
cb_tree cb_build_assign (const cb_tree var, const cb_tree val)
 
cb_tree cb_build_initialize (const cb_tree var, const cb_tree val, const cb_tree rep, const unsigned int def, const unsigned int is_statement, const unsigned int no_filler_init)
 
cb_tree cb_build_search (const int flag_all, const cb_tree table, const cb_tree var, const cb_tree end_stmt, const cb_tree whens)
 
cb_tree cb_build_call (const cb_tree name, const cb_tree args, const cb_tree stmt1, const cb_tree stmt2, const cb_tree returning, const cob_u32_t is_system_call, const int convention)
 
cb_tree cb_build_cancel (const cb_tree target)
 
cb_tree cb_build_alter (const cb_tree source, const cb_tree target)
 
cb_tree cb_build_goto (const cb_tree target, const cb_tree depending)
 
cb_tree cb_build_if (const cb_tree test, const cb_tree stmt1, const cb_tree stmt2, const unsigned int is_if)
 
cb_tree cb_build_perform (const enum cb_perform_type type)
 
cb_tree cb_build_perform_varying (cb_tree name, cb_tree from, cb_tree by, cb_tree until)
 
struct cb_statement * cb_build_statement (const char *name)
 
cb_tree cb_build_continue (void)
 
cb_tree cb_build_set_attribute (const struct cb_field *fld, const int val_on, const int val_off)
 
cb_tree cb_build_any_intrinsic (cb_tree args)
 
cb_tree cb_build_intrinsic (cb_tree name, cb_tree args, cb_tree refmod, const int isuser)
 

Variables

static enum cb_class category_to_class_table []
 
static int category_is_alphanumeric []
 
static struct int_node * int_node_table = NULL
 
static char * scratch_buff = NULL
 
static char * pic_buff = NULL
 
static int filler_id = 1
 
static int class_id = 0
 
static int toplev_count
 
static struct cb_program * container_progs [64]
 
static const char *const cb_const_subs []
 
static struct cb_intrinsic_table userbp
 
cb_tree cb_any
 
cb_tree cb_true
 
cb_tree cb_false
 
cb_tree cb_null
 
cb_tree cb_zero
 
cb_tree cb_one
 
cb_tree cb_space
 
cb_tree cb_low
 
cb_tree cb_high
 
cb_tree cb_norm_low
 
cb_tree cb_norm_high
 
cb_tree cb_quote
 
cb_tree cb_int0
 
cb_tree cb_int1
 
cb_tree cb_int2
 
cb_tree cb_int3
 
cb_tree cb_int4
 
cb_tree cb_int5
 
cb_tree cb_i [COB_MAX_SUBSCRIPTS]
 
cb_tree cb_error_node
 
cb_tree cb_intr_whencomp = NULL
 
cb_tree cb_standard_error_handler = NULL
 
unsigned int gen_screen_ptr = 0
 

Macro Definition Documentation

#define CB_FILE_ERR_INVALID   3

Referenced by file_error(), and validate_file().

#define CB_FILE_ERR_INVALID_FT   2

Referenced by file_error(), and validate_file().

#define CB_FILE_ERR_REQUIRED   1

Referenced by file_error(), and validate_file().

#define PIC_ALPHABETIC   0x01

Referenced by cb_build_picture().

#define PIC_ALPHABETIC_EDITED   (PIC_ALPHABETIC | PIC_EDITED)

Referenced by cb_build_picture().

#define PIC_ALPHANUMERIC   (PIC_ALPHABETIC | PIC_NUMERIC)

Referenced by cb_build_picture().

#define PIC_ALPHANUMERIC_EDITED   (PIC_ALPHANUMERIC | PIC_EDITED)

Referenced by cb_build_picture().

#define PIC_EDITED   0x08

Referenced by cb_build_picture().

#define PIC_NATIONAL   0x04

Referenced by cb_build_picture().

#define PIC_NATIONAL_EDITED   (PIC_NATIONAL | PIC_EDITED)

Referenced by cb_build_picture().

#define PIC_NUMERIC   0x02

Referenced by cb_build_picture().

#define PIC_NUMERIC_EDITED   (PIC_NUMERIC | PIC_EDITED)

Referenced by cb_build_picture().

Function Documentation

static struct nested_list* add_contained_prog ( struct nested_list *  parent_list,
struct cb_program *  child_prog 
)
staticread

References cobc_parse_malloc(), nested_list::nested_prog, and nested_list::next.

Referenced by cb_add_common_prog(), cb_build_program(), and cb_insert_common_prog().

1230 {
1231  struct nested_list *nlp;
1232 
1233  /* Check for reuse */
1234  for (nlp = parent_list; nlp; nlp = nlp->next) {
1235  if (nlp->nested_prog == child_prog) {
1236  return parent_list;
1237  }
1238  }
1239  nlp = cobc_parse_malloc (sizeof (struct nested_list));
1240  nlp->next = parent_list;
1241  nlp->nested_prog = child_prog;
1242  return nlp;
1243 }
struct cb_file* build_file ( cb_tree  name)
read

References cb_file::access_mode, CB_CATEGORY_UNKNOWN, cb_define(), CB_LABEL, CB_TAG_FILE, cb_to_cname(), CB_TREE, cb_file::cname, COB_ACCESS_SEQUENTIAL, COB_ORG_SEQUENTIAL, current_program, cb_file::handler, cb_file::handler_prog, make_tree(), cb_file::name, cb_file::organization, and p.

2203 {
2204  struct cb_file *p;
2205 
2206  p = make_tree (CB_TAG_FILE, CB_CATEGORY_UNKNOWN, sizeof (struct cb_file));
2207  p->name = cb_define (name, CB_TREE (p));
2208  p->cname = cb_to_cname (p->name);
2209 
2210  p->organization = COB_ORG_SEQUENTIAL;
2211  p->access_mode = COB_ACCESS_SEQUENTIAL;
2212  p->handler = CB_LABEL (cb_standard_error_handler);
2213  p->handler_prog = current_program;
2214  return p;
2215 }
struct cb_literal* build_literal ( const enum cb_category  category,
const void *  data,
const size_t  size 
)
read

References CB_TAG_LITERAL, cobc_parse_malloc(), cb_literal::data, make_tree(), p, and cb_literal::size.

Referenced by cb_build_alphanumeric_literal(), cb_build_numeric_literal(), cb_build_numsize_literal(), and cb_validate_program_data().

631 {
632  struct cb_literal *p;
633 
634  p = make_tree (CB_TAG_LITERAL, category, sizeof (struct cb_literal));
635  p->data = cobc_parse_malloc (size + 1U);
636  p->size = size;
637  memcpy (p->data, data, size);
638  return p;
639 }
struct cb_report* build_report ( cb_tree  name)
read

References CB_CATEGORY_UNKNOWN, cb_define(), CB_LABEL, CB_TAG_REPORT, cb_to_cname(), CB_TREE, cb_report::cname, COB_ACCESS_SEQUENTIAL, COB_ORG_SEQUENTIAL, current_program, make_tree(), cb_report::name, and p.

2183 {
2184  struct cb_report *p;
2185 
2186  p = make_tree (CB_TAG_REPORT, CB_CATEGORY_UNKNOWN, sizeof (struct cb_report));
2187  p->name = cb_define (name, CB_TREE (p));
2188  p->cname = cb_to_cname (p->name);
2189 
2190 #if 0 /* RXWRXW RP */
2191  p->organization = COB_ORG_SEQUENTIAL;
2192  p->access_mode = COB_ACCESS_SEQUENTIAL;
2193  p->handler = CB_LABEL (cb_standard_error_handler);
2194  p->handler_prog = current_program;
2195 #endif
2196  return p;
2197 }
void cb_add_common_prog ( struct cb_program *  prog)

References add_contained_prog(), cb_program::common_prog_list, and cb_program::nested_level.

1312 {
1313  struct cb_program *q;
1314 
1315  /* Here we are sure that nested >= 1 */
1316  q = container_progs[prog->nested_level - 1];
1317  q->common_prog_list = add_contained_prog (q->common_prog_list, prog);
1318 }
cb_tree cb_build_alphabet_name ( cb_tree  name)

References CB_CATEGORY_UNKNOWN, cb_define(), CB_TAG_ALPHABET_NAME, cb_to_cname(), CB_TREE, cb_alphabet_name::cname, make_tree(), cb_alphabet_name::name, NULL, and p.

1448 {
1449  struct cb_alphabet_name *p;
1450 
1451  if (!name || name == cb_error_node) {
1452  return NULL;
1453  }
1454  p = make_tree (CB_TAG_ALPHABET_NAME, CB_CATEGORY_UNKNOWN,
1455  sizeof (struct cb_alphabet_name));
1456  p->name = cb_define (name, CB_TREE (p));
1457  p->cname = cb_to_cname (p->name);
1458  return CB_TREE (p);
1459 }
cb_tree cb_build_alphanumeric_literal ( const void *  data,
const size_t  size 
)

References build_literal(), CB_CATEGORY_ALPHANUMERIC, and CB_TREE.

Referenced by cb_build_assignment_name(), cb_build_registers(), cb_build_symbolic_chars(), cb_validate_collating(), finalize_file(), read_literal(), scan_define_options(), scan_x(), scan_z(), and while().

1546 {
1547  return CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, data, size));
1548 }
cb_tree cb_build_alter ( const cb_tree  source,
const cb_tree  target 
)

References cb_program::alter_list, CB_BUILD_PAIR, CB_CATEGORY_UNKNOWN, cb_list_append(), CB_TAG_ALTER, CB_TREE, current_program, make_tree(), p, cb_alter::source, and cb_alter::target.

Referenced by cb_emit_alter().

2952 {
2953  struct cb_alter *p;
2954 
2955  p = make_tree (CB_TAG_ALTER, CB_CATEGORY_UNKNOWN,
2956  sizeof (struct cb_alter));
2957  p->source = source;
2958  p->target = target;
2959  current_program->alter_list =
2960  cb_list_append (current_program->alter_list,
2961  CB_BUILD_PAIR (source, target));
2962  return CB_TREE (p);
2963 }
cb_tree cb_build_any_intrinsic ( cb_tree  args)

References lookup_intrinsic(), make_intrinsic(), and NULL.

Referenced by cb_build_length().

3093 {
3094  struct cb_intrinsic_table *cbp;
3095 
3096  cbp = lookup_intrinsic ("LENGTH", 0, 0);
3097  return make_intrinsic (NULL, cbp, args, NULL, NULL, 0);
3098 }
cb_tree cb_build_assign ( const cb_tree  var,
const cb_tree  val 
)

References CB_CATEGORY_UNKNOWN, CB_TAG_ASSIGN, CB_TREE, make_tree(), p, cb_assign::val, and cb_assign::var.

Referenced by cb_build_length(), cb_build_move(), cb_build_move_literal(), cb_build_move_num_zero(), cb_build_optim_add(), and cb_build_optim_sub().

2865 {
2866  struct cb_assign *p;
2867 
2868  p = make_tree (CB_TAG_ASSIGN, CB_CATEGORY_UNKNOWN,
2869  sizeof (struct cb_assign));
2870  p->var = var;
2871  p->val = val;
2872  return CB_TREE (p);
2873 }
cb_tree cb_build_binary_list ( cb_tree  l,
const int  op 
)

References cb_build_binary_op(), CB_CHAIN, and CB_VALUE.

2754 {
2755  cb_tree e;
2756 
2757  e = CB_VALUE (l);
2758  for (l = CB_CHAIN (l); l; l = CB_CHAIN (l)) {
2759  e = cb_build_binary_op (e, op, CB_VALUE (l));
2760  }
2761  return e;
2762 }
cb_tree cb_build_binary_op ( cb_tree  x,
const int  op,
cb_tree  y 
)

References _, CB_CATEGORY_BOOLEAN, CB_CATEGORY_DATA_POINTER, CB_CATEGORY_NUMERIC, CB_CATEGORY_UNKNOWN, cb_check_numeric_value(), CB_CLASS_BOOLEAN, CB_CLASS_POINTER, cb_error_node, cb_error_x(), CB_FIELD, cb_ref(), CB_REF_OR_FIELD_P, CB_TAG_BINARY_OP, CB_TREE, CB_TREE_CATEGORY, CB_TREE_CLASS, COBC_ABORT, cobc_abort_pr(), make_tree(), cb_binary_op::op, p, cb_binary_op::x, and cb_binary_op::y.

Referenced by build_cond_88(), build_evaluate(), cb_build_add(), cb_build_binary_list(), cb_build_cond(), cb_build_div(), cb_build_length_1(), cb_build_mul(), cb_build_optim_add(), cb_build_optim_sub(), cb_build_search_all(), cb_build_sub(), cb_build_write_advancing_lines(), cb_expr_shift(), cb_expr_shift_sign(), evaluate_test(), and expr_reduce().

2679 {
2680  struct cb_binary_op *p;
2681  enum cb_category category = CB_CATEGORY_UNKNOWN;
2682 
2683  switch (op) {
2684  case '+':
2685  case '-':
2686  case '*':
2687  case '/':
2688  case '^':
2689  /* Arithmetic operators */
2690  if (CB_TREE_CLASS (x) == CB_CLASS_POINTER ||
2691  CB_TREE_CLASS (y) == CB_CLASS_POINTER) {
2692  category = CB_CATEGORY_DATA_POINTER;
2693  break;
2694  }
2695  x = cb_check_numeric_value (x);
2696  y = cb_check_numeric_value (y);
2697  if (x == cb_error_node || y == cb_error_node) {
2698  return cb_error_node;
2699  }
2700  category = CB_CATEGORY_NUMERIC;
2701  break;
2702 
2703  case '=':
2704  case '~':
2705  case '<':
2706  case '>':
2707  case '[':
2708  case ']':
2709  /* Relational operators */
2710  if ((CB_REF_OR_FIELD_P (x)) &&
2711  CB_FIELD (cb_ref (x))->level == 88) {
2712  cb_error_x (x, _("Invalid expression"));
2713  return cb_error_node;
2714  }
2715  if ((CB_REF_OR_FIELD_P (y)) &&
2716  CB_FIELD (cb_ref (y))->level == 88) {
2717  cb_error_x (y, _("Invalid expression"));
2718  return cb_error_node;
2719  }
2720  category = CB_CATEGORY_BOOLEAN;
2721  break;
2722 
2723  case '!':
2724  case '&':
2725  case '|':
2726  /* Logical operators */
2727  if (CB_TREE_CLASS (x) != CB_CLASS_BOOLEAN ||
2728  (y && CB_TREE_CLASS (y) != CB_CLASS_BOOLEAN)) {
2729  cb_error_x (x, _("Invalid expression"));
2730  return cb_error_node;
2731  }
2732  category = CB_CATEGORY_BOOLEAN;
2733  break;
2734 
2735  case '@':
2736  /* Parentheses */
2737  category = CB_TREE_CATEGORY (x);
2738  break;
2739 
2740  default:
2741  cobc_abort_pr (_("Unexpected operator -> %d"), op);
2742  COBC_ABORT ();
2743  }
2744 
2745  p = make_tree (CB_TAG_BINARY_OP, category, sizeof (struct cb_binary_op));
2746  p->op = op;
2747  p->x = x;
2748  p->y = y;
2749  return CB_TREE (p);
2750 }
struct cb_picture* cb_build_binary_picture ( const char *  str,
const cob_u32_t  size,
const cob_u32_t  sign 
)
read

References cb_picture::category, CB_CATEGORY_NUMERIC, CB_TAG_PICTURE, cobc_check_string(), cb_picture::digits, cb_picture::have_sign, make_tree(), cb_picture::orig, cb_picture::scale, sign, and cb_picture::size.

Referenced by validate_field_1().

1643 {
1644  struct cb_picture *pic;
1645 
1646  pic = make_tree (CB_TAG_PICTURE, CB_CATEGORY_NUMERIC,
1647  sizeof (struct cb_picture));
1648  pic->orig = cobc_check_string (str);
1649  pic->size = size;
1650  pic->digits = size;
1651  pic->scale = 0;
1652  pic->have_sign = sign;
1653  pic->category = CB_CATEGORY_NUMERIC;
1654  return pic;
1655 }
cb_tree cb_build_call ( const cb_tree  name,
const cb_tree  args,
const cb_tree  stmt1,
const cb_tree  stmt2,
const cb_tree  returning,
const cob_u32_t  is_system_call,
const int  convention 
)

References cb_call::args, cb_call::call_returning, CB_CATEGORY_UNKNOWN, CB_TAG_CALL, CB_TREE, cb_call::convention, cb_call::is_system, make_tree(), cb_call::name, p, cb_call::stmt1, and cb_call::stmt2.

Referenced by cb_emit_call().

2920 {
2921  struct cb_call *p;
2922 
2923  p = make_tree (CB_TAG_CALL, CB_CATEGORY_UNKNOWN,
2924  sizeof (struct cb_call));
2925  p->name = name;
2926  p->args = args;
2927  p->stmt1 = stmt1;
2928  p->stmt2 = stmt2;
2929  p->call_returning = returning;
2930  p->is_system = is_system_call;
2931  p->convention = convention;
2932  return CB_TREE (p);
2933 }
cb_tree cb_build_cancel ( const cb_tree  target)

References CB_CATEGORY_UNKNOWN, CB_TAG_CANCEL, CB_TREE, make_tree(), p, and cb_cancel::target.

Referenced by cb_emit_cancel().

2939 {
2940  struct cb_cancel *p;
2941 
2942  p = make_tree (CB_TAG_CANCEL, CB_CATEGORY_UNKNOWN,
2943  sizeof (struct cb_cancel));
2944  p->target = target;
2945  return CB_TREE (p);
2946 }
cb_tree cb_build_cast ( const enum cb_cast_type  type,
const cb_tree  val 
)

References cb_cast::cast_type, CB_CAST_INTEGER, CB_CATEGORY_NUMERIC, CB_CATEGORY_UNKNOWN, CB_TAG_CAST, CB_TREE, make_tree(), p, and cb_cast::val.

2798 {
2799  struct cb_cast *p;
2800  enum cb_category category;
2801 
2802  if (type == CB_CAST_INTEGER) {
2803  category = CB_CATEGORY_NUMERIC;
2804  } else {
2805  category = CB_CATEGORY_UNKNOWN;
2806  }
2807  p = make_tree (CB_TAG_CAST, category, sizeof (struct cb_cast));
2808  p->cast_type = type;
2809  p->val = val;
2810  return CB_TREE (p);
2811 }
cb_tree cb_build_cast_int ( const cb_tree  val)

References cb_cast::cast_type, CB_CAST_INTEGER, CB_CATEGORY_NUMERIC, CB_TAG_CAST, CB_TREE, make_tree(), p, and cb_cast::val.

Referenced by cb_build_identifier(), cb_build_move(), cb_build_optim_add(), cb_build_optim_cond(), cb_build_optim_sub(), cb_build_write_advancing_lines(), cb_emit_sort_init(), cb_emit_stop_run(), and output_goto().

2815 {
2816  struct cb_cast *p;
2817 
2818  p = make_tree (CB_TAG_CAST, CB_CATEGORY_NUMERIC, sizeof (struct cb_cast));
2819  p->cast_type = CB_CAST_INTEGER;
2820  p->val = val;
2821  return CB_TREE (p);
2822 }
cb_tree cb_build_cast_llint ( const cb_tree  val)

References cb_cast::cast_type, CB_CAST_LONG_INT, CB_CATEGORY_NUMERIC, CB_TAG_CAST, CB_TREE, make_tree(), p, and cb_cast::val.

Referenced by cb_build_move_literal(), cb_build_optim_cond(), decimal_expand(), and output_perform().

2826 {
2827  struct cb_cast *p;
2828 
2829  p = make_tree (CB_TAG_CAST, CB_CATEGORY_NUMERIC, sizeof (struct cb_cast));
2830  p->cast_type = CB_CAST_LONG_INT;
2831  p->val = val;
2832  return CB_TREE (p);
2833 }
cb_tree cb_build_class_name ( cb_tree  name,
cb_tree  list 
)

References CB_CATEGORY_BOOLEAN, cb_define(), CB_TAG_CLASS_NAME, cb_to_cname(), CB_TREE, class_id, cb_class_name::cname, COB_MINI_BUFF, COB_MINI_MAX, cobc_main_malloc(), cobc_parse_strdup(), cb_class_name::list, make_tree(), cb_class_name::name, NULL, p, and scratch_buff.

1465 {
1466  struct cb_class_name *p;
1467 
1468  if (!name || name == cb_error_node) {
1469  return NULL;
1470  }
1471  p = make_tree (CB_TAG_CLASS_NAME, CB_CATEGORY_BOOLEAN,
1472  sizeof (struct cb_class_name));
1473  p->name = cb_define (name, CB_TREE (p));
1474  if (!scratch_buff) {
1475  scratch_buff = cobc_main_malloc ((size_t)COB_MINI_BUFF);
1476  }
1477  snprintf (scratch_buff, (size_t)COB_MINI_MAX, "cob_is_%s_%d",
1478  cb_to_cname (p->name), class_id++);
1479  p->cname = cobc_parse_strdup (scratch_buff);
1480  p->list = list;
1481  return CB_TREE (p);
1482 }
cb_tree cb_build_comment ( const char *  str)

References CB_CATEGORY_ALPHANUMERIC, cb_source_file, cb_source_line, CB_TAG_DIRECT, CB_TREE, cb_direct::line, make_tree(), and p.

Referenced by build_evaluate(), cb_build_direct(), cb_emit_evaluate(), and while().

1383 {
1384  struct cb_direct *p;
1385 
1386  p = make_tree (CB_TAG_DIRECT, CB_CATEGORY_ALPHANUMERIC,
1387  sizeof (struct cb_direct));
1388  p->line = str;
1389  CB_TREE (p)->source_file = cb_source_file;
1390  CB_TREE (p)->source_line = cb_source_line;
1391  return CB_TREE (p);
1392 }
cb_tree cb_build_constant ( cb_tree  name,
cb_tree  value 
)

References cb_tree_common::category, cb_build_field(), CB_FIELD, CB_LIST_INIT, CB_STORAGE_CONSTANT, and cb_tree_category().

Referenced by build_nested_special(), cb_add_const_var(), cb_build_registers(), cb_build_symbolic_chars(), and cb_define_switch_name().

2048 {
2049  cb_tree x;
2050 
2051  x = cb_build_field (name);
2052  x->category = cb_tree_category (value);
2053  CB_FIELD (x)->storage = CB_STORAGE_CONSTANT;
2054  CB_FIELD (x)->values = CB_LIST_INIT (value);
2055  return x;
2056 }
cb_tree cb_build_continue ( void  )

References CB_CATEGORY_UNKNOWN, CB_TAG_CONTINUE, CB_TREE, make_tree(), and p.

Referenced by cb_emit_continue().

3065 {
3066  struct cb_continue *p;
3067 
3068  p = make_tree (CB_TAG_CONTINUE, CB_CATEGORY_UNKNOWN,
3069  sizeof (struct cb_continue));
3070  return CB_TREE (p);
3071 }
cb_tree cb_build_debug ( const cb_tree  target,
const char *  str,
const cb_tree  fld 
)

References CB_CATEGORY_ALPHANUMERIC, CB_FIELD_PTR, cb_source_file, cb_source_line, CB_TAG_DEBUG, CB_TREE, cobc_parse_strdup(), cb_debug::fld, make_tree(), NULL, p, cb_debug::size, cb_debug::target, and cb_debug::value.

Referenced by cb_build_perform_varying(), cb_check_field_debug(), cb_emit_close(), cb_emit_open(), cb_emit_perform(), cb_emit_read(), cb_emit_rewrite(), cb_emit_sort_input(), cb_emit_sort_output(), cb_emit_write(), emit_entry(), output_alter(), output_cond_debug(), output_file_error(), output_funcall_debug(), output_goto(), output_goto_1(), output_perform(), output_perform_call(), output_perform_until(), and output_stmt().

1409 {
1410  struct cb_debug *p;
1411 
1412  p = make_tree (CB_TAG_DEBUG, CB_CATEGORY_ALPHANUMERIC,
1413  sizeof (struct cb_debug));
1414  p->target = target;
1415  if (str) {
1416  p->value = cobc_parse_strdup (str);
1417  p->fld = NULL;
1418  p->size = strlen (str);
1419  } else {
1420  p->value = NULL;
1421  p->fld = fld;
1422  p->size = (size_t)CB_FIELD_PTR (fld)->size;
1423  }
1424  CB_TREE (p)->source_file = cb_source_file;
1425  CB_TREE (p)->source_line = cb_source_line;
1426  return CB_TREE (p);
1427 }
cb_tree cb_build_debug_call ( struct cb_label *  target)

References CB_CATEGORY_ALPHANUMERIC, cb_source_file, cb_source_line, CB_TAG_DEBUG_CALL, CB_TREE, make_tree(), p, and cb_debug_call::target.

Referenced by cb_build_perform_varying(), cb_check_field_debug(), cb_emit_close(), cb_emit_open(), cb_emit_read(), cb_emit_rewrite(), and cb_emit_write().

1433 {
1434  struct cb_debug_call *p;
1435 
1436  p = make_tree (CB_TAG_DEBUG_CALL, CB_CATEGORY_ALPHANUMERIC,
1437  sizeof (struct cb_debug_call));
1438  p->target = target;
1439  CB_TREE (p)->source_file = cb_source_file;
1440  CB_TREE (p)->source_line = cb_source_line;
1441  return CB_TREE (p);
1442 }
cb_tree cb_build_decimal ( const int  id)

References CB_CATEGORY_NUMERIC, CB_TAG_DECIMAL, CB_TREE, cb_decimal::id, make_tree(), and p.

Referenced by decimal_alloc().

1629 {
1630  struct cb_decimal *p;
1631 
1632  p = make_tree (CB_TAG_DECIMAL, CB_CATEGORY_NUMERIC,
1633  sizeof (struct cb_decimal));
1634  p->id = id;
1635  return CB_TREE (p);
1636 }
cb_tree cb_build_direct ( const char *  str,
const unsigned int  flagnl 
)

References cb_build_comment(), and CB_DIRECT.

Referenced by cb_check_needs_break(), and cb_emit_evaluate().

1396 {
1397  cb_tree x;
1398 
1399  x = cb_build_comment (str);
1400  CB_DIRECT (x)->flag_is_direct = 1;
1401  CB_DIRECT (x)->flag_new_line = flagnl;
1402  return x;
1403 }
cb_tree cb_build_field ( cb_tree  name)

References CB_CATEGORY_UNKNOWN, cb_define(), cb_field_id, CB_STORAGE_WORKING, CB_TAG_FIELD, CB_TREE, CB_USAGE_DISPLAY, cb_field::ename, cb_field::id, make_tree(), cb_field::name, NULL, cb_field::occurs_max, p, cb_field::storage, and cb_field::usage.

Referenced by cb_build_constant(), cb_build_field_tree(), cb_build_implicit_field(), cb_build_index(), cb_validate_program_data(), and finalize_file().

2018 {
2019  struct cb_field *p;
2020 
2021  p = make_tree (CB_TAG_FIELD, CB_CATEGORY_UNKNOWN,
2022  sizeof (struct cb_field));
2023  p->id = cb_field_id++;
2024  p->name = cb_define (name, CB_TREE (p));
2025  p->ename = NULL;
2026  p->usage = CB_USAGE_DISPLAY;
2027  p->storage = CB_STORAGE_WORKING;
2028  p->occurs_max = 1;
2029  return CB_TREE (p);
2030 }
cb_tree cb_build_field_reference ( struct cb_field *  f,
cb_tree  ref 
)

References cb_tree_common::category, cb_build_reference(), CB_CATEGORY_UNKNOWN, CB_REFERENCE, CB_TREE, and cb_field::name.

Referenced by build_cond_88(), cb_build_identifier(), cb_build_length_1(), cb_emit_read(), cb_emit_return(), cb_emit_set_false(), cb_emit_set_true(), cb_validate_program_data(), emit_corresponding(), emit_move_corresponding(), finalize_file(), output_initial_values(), output_initialize(), output_initialize_compound(), output_param(), and output_screen_init().

2456 {
2457  cb_tree x;
2458  struct cb_word *word;
2459 
2460  x = cb_build_reference (f->name);
2461  word = CB_REFERENCE (x)->word;
2462  if (ref) {
2463  memcpy (x, ref, sizeof (struct cb_reference));
2464  }
2465  x->category = CB_CATEGORY_UNKNOWN;
2466  CB_REFERENCE (x)->word = word;
2467  CB_REFERENCE (x)->value = CB_TREE (f);
2468  return x;
2469 }
cb_tree cb_build_filler ( void  )

References cb_build_reference(), CB_REFERENCE, cb_source_line, filler_id, and cb_tree_common::source_line.

Referenced by cb_build_debug_item(), cb_build_field_tree(), and cb_build_length().

2443 {
2444  cb_tree x;
2445  char name[20];
2446 
2447  sprintf (name, "FILLER %d", filler_id++);
2448  x = cb_build_reference (name);
2449  x->source_line = cb_source_line;
2450  CB_REFERENCE (x)->flag_filler_ref = 1;
2451  return x;
2452 }
cb_tree cb_build_funcall ( const char *  name,
const int  argc,
const cb_tree  a1,
const cb_tree  a2,
const cb_tree  a3,
const cb_tree  a4,
const cb_tree  a5,
const cb_tree  a6,
const cb_tree  a7,
const cb_tree  a8,
const cb_tree  a9,
const cb_tree  a10 
)

References cb_funcall::argc, cb_funcall::argv, CB_CATEGORY_BOOLEAN, CB_TAG_FUNCALL, CB_TREE, gen_screen_ptr, make_tree(), cb_funcall::name, p, cb_funcall::screenptr, and cb_funcall::varcnt.

2772 {
2773  struct cb_funcall *p;
2774 
2775  p = make_tree (CB_TAG_FUNCALL, CB_CATEGORY_BOOLEAN,
2776  sizeof (struct cb_funcall));
2777  p->name = name;
2778  p->argc = argc;
2779  p->varcnt = 0;
2780  p->screenptr = gen_screen_ptr;
2781  p->argv[0] = a1;
2782  p->argv[1] = a2;
2783  p->argv[2] = a3;
2784  p->argv[3] = a4;
2785  p->argv[4] = a5;
2786  p->argv[5] = a6;
2787  p->argv[6] = a7;
2788  p->argv[7] = a8;
2789  p->argv[8] = a9;
2790  p->argv[9] = a10;
2791  return CB_TREE (p);
2792 }
cb_tree cb_build_goto ( const cb_tree  target,
const cb_tree  depending 
)

References CB_CATEGORY_UNKNOWN, CB_TAG_GOTO, CB_TREE, cb_goto::depending, make_tree(), p, and cb_goto::target.

Referenced by cb_emit_exit(), and cb_emit_goto().

2969 {
2970  struct cb_goto *p;
2971 
2972  p = make_tree (CB_TAG_GOTO, CB_CATEGORY_UNKNOWN,
2973  sizeof (struct cb_goto));
2974  p->target = target;
2975  p->depending = depending;
2976  return CB_TREE (p);
2977 }
cb_tree cb_build_if ( const cb_tree  test,
const cb_tree  stmt1,
const cb_tree  stmt2,
const unsigned int  is_if 
)

References CB_CATEGORY_UNKNOWN, CB_TAG_IF, CB_TREE, cb_if::is_if, make_tree(), p, cb_if::stmt1, cb_if::stmt2, and cb_if::test.

Referenced by build_evaluate(), cb_build_if_check_break(), cb_emit_if(), and cb_emit_search_all().

2984 {
2985  struct cb_if *p;
2986 
2987  p = make_tree (CB_TAG_IF, CB_CATEGORY_UNKNOWN,
2988  sizeof (struct cb_if));
2989  p->test = test;
2990  p->stmt1 = stmt1;
2991  p->stmt2 = stmt2;
2992  p->is_if = is_if;
2993  return CB_TREE (p);
2994 }
cb_tree cb_build_implicit_field ( cb_tree  name,
const int  len 
)

References cb_build_field(), cb_build_picture(), CB_FIELD, CB_PICTURE, cb_validate_field(), and cb_field::pic.

Referenced by cb_validate_program_data(), and finalize_file().

2034 {
2035  cb_tree x;
2036  char pic[32];
2037 
2038  x = cb_build_field (name);
2039  memset (pic, 0, sizeof(pic));
2040  snprintf (pic, sizeof(pic), "X(%d)", len);
2041  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture (pic));
2042  cb_validate_field (CB_FIELD (x));
2043  return x;
2044 }
cb_tree cb_build_initialize ( const cb_tree  var,
const cb_tree  val,
const cb_tree  rep,
const unsigned int  def,
const unsigned int  is_statement,
const unsigned int  no_filler_init 
)

References CB_CATEGORY_UNKNOWN, CB_TAG_INITIALIZE, CB_TREE, cob_u8_t, cb_initialize::flag_default, cb_initialize::flag_init_statement, cb_initialize::flag_no_filler_init, make_tree(), p, cb_initialize::rep, cb_initialize::val, and cb_initialize::var.

Referenced by cb_emit_allocate(), cb_emit_initialize(), and output_initial_values().

2882 {
2883  struct cb_initialize *p;
2884 
2885  p = make_tree (CB_TAG_INITIALIZE, CB_CATEGORY_UNKNOWN,
2886  sizeof (struct cb_initialize));
2887  p->var = var;
2888  p->val = val;
2889  p->rep = rep;
2890  p->flag_default = (cob_u8_t)def;
2891  p->flag_init_statement = (cob_u8_t)is_statement;
2892  p->flag_no_filler_init = (cob_u8_t)no_filler_init;
2893  return CB_TREE (p);
2894 }
cb_tree cb_build_intrinsic ( cb_tree  name,
cb_tree  args,
cb_tree  refmod,
const int  isuser 
)

References _, cb_intrinsic_table::args, cb_build_length(), CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, cb_error_node, cb_error_x(), cb_get_int(), CB_INTR_ABS, CB_INTR_ACOS, CB_INTR_ANNUITY, CB_INTR_ASIN, CB_INTR_ATAN, CB_INTR_BOOLEAN_OF_INTEGER, CB_INTR_BYTE_LENGTH, CB_INTR_CHAR, CB_INTR_CHAR_NATIONAL, CB_INTR_COMBINED_DATETIME, CB_INTR_CONCATENATE, CB_INTR_COS, CB_INTR_CURRENCY_SYMBOL, CB_INTR_CURRENT_DATE, CB_INTR_DATE_OF_INTEGER, CB_INTR_DATE_TO_YYYYMMDD, CB_INTR_DAY_OF_INTEGER, CB_INTR_DAY_TO_YYYYDDD, CB_INTR_DISPLAY_OF, CB_INTR_E, CB_INTR_EXCEPTION_FILE, CB_INTR_EXCEPTION_FILE_N, CB_INTR_EXCEPTION_LOCATION, CB_INTR_EXCEPTION_LOCATION_N, CB_INTR_EXCEPTION_STATEMENT, CB_INTR_EXCEPTION_STATUS, CB_INTR_EXP, CB_INTR_EXP10, CB_INTR_FACTORIAL, CB_INTR_FORMATTED_CURRENT_DATE, CB_INTR_FORMATTED_DATE, CB_INTR_FORMATTED_DATETIME, CB_INTR_FORMATTED_TIME, CB_INTR_FRACTION_PART, CB_INTR_HIGHEST_ALGEBRAIC, CB_INTR_INTEGER, CB_INTR_INTEGER_OF_BOOLEAN, CB_INTR_INTEGER_OF_DATE, CB_INTR_INTEGER_OF_DAY, CB_INTR_INTEGER_OF_FORMATTED_DATE, CB_INTR_INTEGER_PART, CB_INTR_LENGTH, CB_INTR_LOCALE_COMPARE, CB_INTR_LOCALE_DATE, CB_INTR_LOCALE_TIME, CB_INTR_LOCALE_TIME_FROM_SECS, CB_INTR_LOG, CB_INTR_LOG10, CB_INTR_LOWER_CASE, CB_INTR_LOWEST_ALGEBRAIC, CB_INTR_MAX, CB_INTR_MEAN, CB_INTR_MEDIAN, CB_INTR_MIDRANGE, CB_INTR_MIN, CB_INTR_MOD, CB_INTR_MODULE_CALLER_ID, CB_INTR_MODULE_DATE, CB_INTR_MODULE_FORMATTED_DATE, CB_INTR_MODULE_ID, CB_INTR_MODULE_PATH, CB_INTR_MODULE_SOURCE, CB_INTR_MODULE_TIME, CB_INTR_MON_DECIMAL_POINT, CB_INTR_MON_THOUSANDS_SEP, CB_INTR_NATIONAL_OF, CB_INTR_NUM_DECIMAL_POINT, CB_INTR_NUM_THOUSANDS_SEP, CB_INTR_NUMVAL, CB_INTR_NUMVAL_C, CB_INTR_NUMVAL_F, CB_INTR_ORD, CB_INTR_ORD_MAX, CB_INTR_ORD_MIN, CB_INTR_PI, CB_INTR_PRESENT_VALUE, CB_INTR_RANDOM, CB_INTR_RANGE, CB_INTR_REM, CB_INTR_REVERSE, CB_INTR_SECONDS_FROM_FORMATTED_TIME, CB_INTR_SECONDS_PAST_MIDNIGHT, CB_INTR_SIGN, CB_INTR_SIN, CB_INTR_SQRT, CB_INTR_STANDARD_COMPARE, CB_INTR_STANDARD_DEVIATION, CB_INTR_STORED_CHAR_LENGTH, CB_INTR_SUBSTITUTE, CB_INTR_SUBSTITUTE_CASE, CB_INTR_SUM, CB_INTR_TAN, CB_INTR_TEST_DATE_YYYYMMDD, CB_INTR_TEST_DAY_YYYYDDD, CB_INTR_TEST_FORMATTED_DATETIME, CB_INTR_TEST_NUMVAL, CB_INTR_TEST_NUMVAL_C, CB_INTR_TEST_NUMVAL_F, CB_INTR_TRIM, CB_INTR_UPPER_CASE, CB_INTR_VARIANCE, CB_INTR_WHEN_COMPILED, cb_intr_whencomp, CB_INTR_YEAR_TO_YYYY, CB_LIST_INIT, cb_list_length(), CB_LITERAL_P, CB_NAME, CB_PAIR_X, CB_PAIR_Y, CB_REF_OR_FIELD_P, cb_tree_category(), CB_VALUE, current_program, cb_intrinsic_table::implemented, cb_intrinsic_table::intr_enum, iso_8601_func(), lookup_intrinsic(), make_intrinsic(), cb_program::max_call_param, cb_intrinsic_table::min_args, cb_intrinsic_table::name, NULL, cb_intrinsic_table::refmod, unlikely, and valid_const_date_time_args().

3103 {
3104  struct cb_intrinsic_table *cbp;
3105  cb_tree x;
3106  int numargs;
3107  enum cb_category catg;
3108 
3109  numargs = cb_list_length (args);
3110 
3111  if (unlikely(isuser)) {
3112  if (refmod && CB_LITERAL_P(CB_PAIR_X(refmod)) &&
3113  cb_get_int (CB_PAIR_X(refmod)) < 1) {
3114  cb_error_x (name, _("FUNCTION '%s' has invalid reference modification"), CB_NAME(name));
3115  return cb_error_node;
3116  }
3117  if (refmod && CB_PAIR_Y(refmod) &&
3118  CB_LITERAL_P(CB_PAIR_Y(refmod)) &&
3119  cb_get_int (CB_PAIR_Y(refmod)) < 1) {
3120  cb_error_x (name, _("FUNCTION '%s' has invalid reference modification"), CB_NAME(name));
3121  return cb_error_node;
3122  }
3123  if (numargs > current_program->max_call_param) {
3124  current_program->max_call_param = numargs;
3125  }
3126  return make_intrinsic (name, &userbp, args, cb_int1, refmod, 1);
3127  }
3128 
3129  cbp = lookup_intrinsic (CB_NAME (name), 0, 1);
3130  if (!cbp) {
3131  cb_error_x (name, _("FUNCTION '%s' unknown"), CB_NAME (name));
3132  return cb_error_node;
3133  }
3134  if (!cbp->implemented) {
3135  cb_error_x (name, _("FUNCTION '%s' not implemented"),
3136  cbp->name);
3137  return cb_error_node;
3138  }
3139  if ((cbp->args >= 0 && numargs != cbp->args) ||
3140  (cbp->args < 0 && numargs < cbp->min_args)) {
3141  cb_error_x (name,
3142  _("FUNCTION '%s' has wrong number of arguments"),
3143  cbp->name);
3144  return cb_error_node;
3145  }
3146  if (refmod) {
3147  if (!cbp->refmod) {
3148  cb_error_x (name, _("FUNCTION '%s' can not have reference modification"), cbp->name);
3149  return cb_error_node;
3150  }
3151  if (CB_LITERAL_P(CB_PAIR_X(refmod)) &&
3152  cb_get_int (CB_PAIR_X(refmod)) < 1) {
3153  cb_error_x (name, _("FUNCTION '%s' has invalid reference modification"), cbp->name);
3154  return cb_error_node;
3155  }
3156  if (CB_PAIR_Y(refmod) && CB_LITERAL_P(CB_PAIR_Y(refmod)) &&
3157  cb_get_int (CB_PAIR_Y(refmod)) < 1) {
3158  cb_error_x (name, _("FUNCTION '%s' has invalid reference modification"), cbp->name);
3159  return cb_error_node;
3160  }
3161  }
3162 
3163  if (iso_8601_func (cbp->intr_enum)) {
3164  if (!valid_const_date_time_args (name, cbp, args)) {
3165  return cb_error_node;
3166  }
3167  }
3168 
3169  switch (cbp->intr_enum) {
3170  case CB_INTR_LENGTH:
3171  case CB_INTR_BYTE_LENGTH:
3172  x = CB_VALUE (args);
3173  if (CB_LITERAL_P (x)) {
3174  return cb_build_length (x);
3175  } else {
3176  return make_intrinsic (name, cbp, args, NULL, NULL, 0);
3177  }
3178 
3179  case CB_INTR_WHEN_COMPILED:
3180  if (refmod) {
3181  return make_intrinsic (name, cbp,
3182  CB_LIST_INIT (cb_intr_whencomp), NULL, refmod, 0);
3183  } else {
3184  return cb_intr_whencomp;
3185  }
3186 
3187  case CB_INTR_ABS:
3188  case CB_INTR_ACOS:
3189  case CB_INTR_ASIN:
3190  case CB_INTR_ATAN:
3191  case CB_INTR_COS:
3192  case CB_INTR_DATE_OF_INTEGER:
3193  case CB_INTR_DAY_OF_INTEGER:
3194  case CB_INTR_EXP:
3195  case CB_INTR_EXP10:
3196  case CB_INTR_FACTORIAL:
3197  case CB_INTR_FRACTION_PART:
3198  case CB_INTR_INTEGER:
3199  case CB_INTR_INTEGER_OF_DATE:
3200  case CB_INTR_INTEGER_OF_DAY:
3201  case CB_INTR_INTEGER_PART:
3202  case CB_INTR_LOG:
3203  case CB_INTR_LOG10:
3204  case CB_INTR_SIGN:
3205  case CB_INTR_SIN:
3206  case CB_INTR_SQRT:
3207  case CB_INTR_TAN:
3208  case CB_INTR_TEST_DATE_YYYYMMDD:
3209  case CB_INTR_TEST_DAY_YYYYDDD:
3210  x = CB_VALUE (args);
3211  if (cb_tree_category (x) != CB_CATEGORY_NUMERIC) {
3212  cb_error_x (name, _("FUNCTION '%s' has invalid parameter"), cbp->name);
3213  return cb_error_node;
3214  }
3215  return make_intrinsic (name, cbp, args, NULL, refmod, 0);
3216 
3217  case CB_INTR_ANNUITY:
3218  case CB_INTR_BOOLEAN_OF_INTEGER:
3219  case CB_INTR_CHAR:
3220  case CB_INTR_CHAR_NATIONAL:
3221  case CB_INTR_COMBINED_DATETIME:
3222  case CB_INTR_CURRENCY_SYMBOL:
3223  case CB_INTR_CURRENT_DATE:
3224  case CB_INTR_E:
3225  case CB_INTR_EXCEPTION_FILE:
3226  case CB_INTR_EXCEPTION_FILE_N:
3227  case CB_INTR_EXCEPTION_LOCATION:
3228  case CB_INTR_EXCEPTION_LOCATION_N:
3229  case CB_INTR_EXCEPTION_STATUS:
3230  case CB_INTR_EXCEPTION_STATEMENT:
3231  case CB_INTR_FORMATTED_CURRENT_DATE:
3232  case CB_INTR_FORMATTED_DATE:
3233  case CB_INTR_INTEGER_OF_BOOLEAN:
3234  case CB_INTR_INTEGER_OF_FORMATTED_DATE:
3235  case CB_INTR_LOCALE_DATE:
3236  case CB_INTR_LOCALE_TIME:
3237  case CB_INTR_LOCALE_TIME_FROM_SECS:
3238  case CB_INTR_LOWER_CASE:
3239  case CB_INTR_MOD:
3240  case CB_INTR_MODULE_CALLER_ID:
3241  case CB_INTR_MODULE_DATE:
3242  case CB_INTR_MODULE_FORMATTED_DATE:
3243  case CB_INTR_MODULE_ID:
3244  case CB_INTR_MODULE_PATH:
3245  case CB_INTR_MODULE_SOURCE:
3246  case CB_INTR_MODULE_TIME:
3247  case CB_INTR_MON_DECIMAL_POINT:
3248  case CB_INTR_MON_THOUSANDS_SEP:
3249  case CB_INTR_NUM_DECIMAL_POINT:
3250  case CB_INTR_NUM_THOUSANDS_SEP:
3251  case CB_INTR_NUMVAL:
3252  case CB_INTR_NUMVAL_C:
3253  case CB_INTR_NUMVAL_F:
3254  case CB_INTR_ORD:
3255  case CB_INTR_PI:
3256  case CB_INTR_REM:
3257  case CB_INTR_REVERSE:
3258  case CB_INTR_SECONDS_FROM_FORMATTED_TIME:
3259  case CB_INTR_SECONDS_PAST_MIDNIGHT:
3260  case CB_INTR_STORED_CHAR_LENGTH:
3261  case CB_INTR_TEST_FORMATTED_DATETIME:
3262  case CB_INTR_TEST_NUMVAL:
3263  case CB_INTR_TEST_NUMVAL_C:
3264  case CB_INTR_TEST_NUMVAL_F:
3265  case CB_INTR_TRIM:
3266  case CB_INTR_UPPER_CASE:
3267  return make_intrinsic (name, cbp, args, NULL, refmod, 0);
3268 
3269  case CB_INTR_HIGHEST_ALGEBRAIC:
3270  case CB_INTR_LOWEST_ALGEBRAIC:
3271  x = CB_VALUE (args);
3272  if (!CB_REF_OR_FIELD_P (x)) {
3273  cb_error_x (name, _("FUNCTION '%s' has invalid parameter"), cbp->name);
3274  return cb_error_node;
3275  }
3276  catg = cb_tree_category (x);
3277  if (catg != CB_CATEGORY_NUMERIC &&
3278  catg != CB_CATEGORY_NUMERIC_EDITED) {
3279  cb_error_x (name, _("FUNCTION '%s' has invalid parameter"), cbp->name);
3280  return cb_error_node;
3281  }
3282  return make_intrinsic (name, cbp, args, NULL, refmod, 0);
3283 
3284 
3285  case CB_INTR_CONCATENATE:
3286  case CB_INTR_DISPLAY_OF:
3287  case CB_INTR_FORMATTED_DATETIME:
3288  case CB_INTR_FORMATTED_TIME:
3289  case CB_INTR_NATIONAL_OF:
3290  return make_intrinsic (name, cbp, args, cb_int1, refmod, 0);
3291 
3292  case CB_INTR_DATE_TO_YYYYMMDD:
3293  case CB_INTR_DAY_TO_YYYYDDD:
3294  case CB_INTR_LOCALE_COMPARE:
3295  case CB_INTR_MAX:
3296  case CB_INTR_MEAN:
3297  case CB_INTR_MEDIAN:
3298  case CB_INTR_MIDRANGE:
3299  case CB_INTR_MIN:
3300  case CB_INTR_ORD_MAX:
3301  case CB_INTR_ORD_MIN:
3302  case CB_INTR_PRESENT_VALUE:
3303  case CB_INTR_RANDOM:
3304  case CB_INTR_RANGE:
3305  case CB_INTR_STANDARD_COMPARE:
3306  case CB_INTR_STANDARD_DEVIATION:
3307  case CB_INTR_SUM:
3308  case CB_INTR_VARIANCE:
3309  case CB_INTR_YEAR_TO_YYYY:
3310  return make_intrinsic (name, cbp, args, cb_int1, NULL, 0);
3311  case CB_INTR_SUBSTITUTE:
3312  case CB_INTR_SUBSTITUTE_CASE:
3313  if ((numargs % 2) == 0) {
3314  cb_error_x (name, _("FUNCTION '%s' has wrong number of arguments"), cbp->name);
3315  return cb_error_node;
3316  }
3317 #if 0 /* RXWRXW - Substitute param 1 */
3318  x = CB_VALUE (args);
3319  if (!CB_REF_OR_FIELD_P (x)) {
3320  cb_error_x (name, _("FUNCTION '%s' has invalid first parameter"), cbp->name);
3321  return cb_error_node;
3322  }
3323 #endif
3324  return make_intrinsic (name, cbp, args, cb_int1, refmod, 0);
3325 
3326  default:
3327  cb_error_x (name, _("FUNCTION '%s' unknown"), CB_NAME (name));
3328  return cb_error_node;
3329  }
3330 }
cb_tree cb_build_label ( cb_tree  name,
struct cb_label *  section 
)

References CB_CATEGORY_UNKNOWN, cb_define(), cb_id, CB_TAG_LABEL, CB_TREE, cobc_parse_malloc(), cb_label::id, make_tree(), cb_label::name, cb_para_label::next, cb_label::orig_name, p, cb_para_label::para, cb_label::para_label, cb_label::section, and cb_label::section_id.

Referenced by emit_entry(), and make_constant_label().

2839 {
2840  struct cb_label *p;
2841  struct cb_para_label *l;
2842 
2843  p = make_tree (CB_TAG_LABEL, CB_CATEGORY_UNKNOWN,
2844  sizeof (struct cb_label));
2845  p->id = cb_id++;
2846  p->name = cb_define (name, CB_TREE (p));
2847  p->orig_name = p->name;
2848  p->section = section;
2849  if (section) {
2850  l = cobc_parse_malloc (sizeof(struct cb_para_label));
2851  l->next = section->para_label;
2852  l->para= p;
2853  section->para_label = l;
2854  p->section_id = p->section->id;
2855  } else {
2856  p->section_id = p->id;
2857  }
2858  return CB_TREE (p);
2859 }
cb_tree cb_build_list ( cb_tree  purpose,
cb_tree  value,
cb_tree  chain 
)

References CB_CATEGORY_UNKNOWN, CB_TAG_LIST, CB_TREE, cb_list::chain, make_tree(), p, cb_list::purpose, value, and cb_list::value.

1134 {
1135  struct cb_list *p;
1136 
1137  p = make_tree (CB_TAG_LIST, CB_CATEGORY_UNKNOWN, sizeof (struct cb_list));
1138  p->chain = chain;
1139  p->value = value;
1140  p->purpose = purpose;
1141  return CB_TREE (p);
1142 }
cb_tree cb_build_locale_name ( cb_tree  name,
cb_tree  list 
)

References _, CB_CATEGORY_UNKNOWN, cb_define(), cb_error(), cb_error_node, CB_LITERAL_P, CB_NUMERIC_LITERAL_P, CB_TAG_LOCALE_NAME, cb_to_cname(), CB_TREE, cb_class_name::cname, cb_class_name::list, make_tree(), cb_class_name::name, NULL, and p.

1488 {
1489  struct cb_class_name *p;
1490 
1491  if (!name || name == cb_error_node) {
1492  return NULL;
1493  }
1494  if (!CB_LITERAL_P (list) || CB_NUMERIC_LITERAL_P (list)) {
1495  cb_error (_("Invalid LOCALE literal"));
1496  return cb_error_node;
1497  }
1498  p = make_tree (CB_TAG_LOCALE_NAME, CB_CATEGORY_UNKNOWN,
1499  sizeof (struct cb_locale_name));
1500  p->name = cb_define (name, CB_TREE (p));
1501  p->cname = cb_to_cname (p->name);
1502  p->list = list;
1503  return CB_TREE (p);
1504 }
cb_tree cb_build_numeric_literal ( const int  sign,
const void *  data,
const int  scale 
)

References build_literal(), CB_CATEGORY_NUMERIC, CB_TREE, p, cb_literal::scale, and cb_literal::sign.

Referenced by cb_build_const_length(), cb_build_length(), cb_emit_allocate(), cb_init_constants(), scan_define_options(), scan_floating_numeric(), scan_h(), and scan_numeric().

1525 {
1526  struct cb_literal *p;
1527 
1528  p = build_literal (CB_CATEGORY_NUMERIC, data, strlen (data));
1529  p->sign = (short)sign;
1530  p->scale = scale;
1531  return CB_TREE (p);
1532 }
cb_tree cb_build_numsize_literal ( const void *  data,
const size_t  size,
const int  sign 
)

References build_literal(), CB_CATEGORY_NUMERIC, CB_TREE, p, and cb_literal::sign.

Referenced by cb_check_lit_subs().

1536 {
1537  struct cb_literal *p;
1538 
1539  p = build_literal (CB_CATEGORY_NUMERIC, data, size);
1540  p->sign = (short)sign;
1541  return CB_TREE (p);
1542 }
cb_tree cb_build_perform ( const enum cb_perform_type  type)

References CB_CATEGORY_UNKNOWN, CB_TAG_PERFORM, CB_TREE, make_tree(), p, and cb_perform::perform_type.

Referenced by cb_build_perform_exit(), cb_build_perform_forever(), cb_build_perform_once(), cb_build_perform_times(), and cb_build_perform_until().

3000 {
3001  struct cb_perform *p;
3002 
3003  p = make_tree (CB_TAG_PERFORM, CB_CATEGORY_UNKNOWN,
3004  sizeof (struct cb_perform));
3005  p->perform_type = type;
3006  return CB_TREE (p);
3007 }
cb_tree cb_build_perform_varying ( cb_tree  name,
cb_tree  from,
cb_tree  by,
cb_tree  until 
)

References cb_build_add(), cb_build_debug(), cb_build_debug_call(), CB_CATEGORY_UNKNOWN, cb_debug_contents, cb_debug_name, CB_FIELD, CB_FIELD_P, CB_FIELD_PTR, cb_list_add(), CB_LIST_INIT, cb_ref(), CB_TAG_PERFORM_VARYING, CB_TREE, current_program, current_statement, cb_program::flag_debugging, cb_statement::flag_in_debug, cb_perform_varying::from, make_tree(), cb_perform_varying::name, NULL, p, cb_perform_varying::step, and cb_perform_varying::until.

3011 {
3012  struct cb_perform_varying *p;
3013  cb_tree x;
3014  cb_tree l;
3015 
3016  p = make_tree (CB_TAG_PERFORM_VARYING, CB_CATEGORY_UNKNOWN,
3017  sizeof (struct cb_perform_varying));
3018  p->name = name;
3019  p->from = from;
3020  p->until = until;
3021  if (name) {
3022  if (name == cb_error_node) {
3023  p->step = NULL;
3024  return CB_TREE (p);
3025  }
3026  l = cb_ref (name);
3027  x = cb_build_add (name, by, cb_high);
3028  if (current_program->flag_debugging &&
3029  !current_statement->flag_in_debug &&
3030  CB_FIELD_P (l) && CB_FIELD (l)->flag_field_debug) {
3031  p->step = CB_LIST_INIT (x);
3032  x = cb_build_debug (cb_debug_name, CB_FIELD_PTR (name)->name,
3033  NULL);
3034  p->step = cb_list_add (p->step, x);
3035  x = cb_build_debug (cb_debug_contents, NULL, name);
3036  p->step = cb_list_add (p->step, x);
3037  x = cb_build_debug_call (CB_FIELD_PTR (name)->debug_section);
3038  p->step = cb_list_add (p->step, x);
3039  } else {
3040  p->step = x;
3041  }
3042  } else {
3043  p->step = NULL;
3044  }
3045  return CB_TREE (p);
3046 }
cb_tree cb_build_picture ( const char *  str)

References _, cb_picture::category, CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_ALPHANUMERIC_EDITED, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, CB_CATEGORY_UNKNOWN, cb_error(), CB_TAG_PICTURE, CB_TREE, COB_MAX_DIGITS, COB_NATIONAL_SIZE, COB_SMALL_BUFF, cob_u32_t, cobc_check_string(), cobc_main_malloc(), cobc_parse_malloc(), cb_program::currency_symbol, current_program, cb_program::decimal_point, cb_picture::digits, cb_picture::have_sign, cb_picture::lenstr, make_tree(), cb_picture::orig, p, PIC_ALPHABETIC, PIC_ALPHABETIC_EDITED, PIC_ALPHANUMERIC, PIC_ALPHANUMERIC_EDITED, pic_buff, PIC_EDITED, PIC_NATIONAL, PIC_NATIONAL_EDITED, PIC_NUMERIC, PIC_NUMERIC_EDITED, cb_picture::real_digits, cb_picture::scale, cb_picture::size, and cb_picture::str.

Referenced by cb_build_debug_item(), cb_build_implicit_field(), cb_validate_program_data(), check_picture_item(), scan_picture(), setup_parameters(), and validate_field_1().

1659 {
1660  struct cb_picture *pic;
1661  const unsigned char *p;
1662  size_t idx;
1663  size_t buffcnt;
1664  cob_u32_t at_beginning;
1665  cob_u32_t at_end;
1666  cob_u32_t p_char_seen;
1667  cob_u32_t s_char_seen;
1668  cob_u32_t dp_char_seen;
1669  cob_u32_t real_digits;
1670  cob_u32_t s_count;
1671  cob_u32_t v_count;
1672  cob_u32_t allocated;
1673  cob_u32_t x_digits;
1674  cob_u32_t digits;
1675  int category;
1676  int size;
1677  int scale;
1678  int i;
1679  int n;
1680  unsigned char c;
1681  unsigned char lastonechar;
1682  unsigned char lasttwochar;
1683 
1684  pic = make_tree (CB_TAG_PICTURE, CB_CATEGORY_UNKNOWN,
1685  sizeof (struct cb_picture));
1686  if (strlen (str) > 50) {
1687  goto error;
1688  }
1689  if (!pic_buff) {
1690  pic_buff = cobc_main_malloc ((size_t)COB_SMALL_BUFF);
1691  }
1692 
1693  idx = 0;
1694  buffcnt = 0;
1695  p_char_seen = 0;
1696  s_char_seen = 0;
1697  dp_char_seen = 0;
1698  category = 0;
1699  size = 0;
1700  allocated = 0;
1701  digits = 0;
1702  x_digits = 0;
1703  real_digits = 0;
1704  scale = 0;
1705  s_count = 0;
1706  v_count = 0;
1707  lastonechar = 0;
1708  lasttwochar = 0;
1709 
1710  for (p = (const unsigned char *)str; *p; p++) {
1711  n = 1;
1712  c = *p;
1713 repeat:
1714  /* Count the number of repeated chars */
1715  while (p[1] == c) {
1716  p++, n++;
1717  }
1718 
1719  /* Add parenthesized numbers */
1720  if (p[1] == '(') {
1721  i = 0;
1722  p += 2;
1723  for (; *p == '0'; p++) {
1724  ;
1725  }
1726  for (; *p != ')'; p++) {
1727  if (!isdigit (*p)) {
1728  goto error;
1729  } else {
1730  allocated++;
1731  if (allocated > 9) {
1732  goto error;
1733  }
1734  i = i * 10 + (*p - '0');
1735  }
1736  }
1737  if (i == 0) {
1738  goto error;
1739  }
1740  n += i - 1;
1741  goto repeat;
1742  }
1743 
1744  /* Check grammar and category */
1745  /* FIXME: need more error checks */
1746  switch (c) {
1747  case 'A':
1748  if (s_char_seen || p_char_seen) {
1749  goto error;
1750  }
1751  category |= PIC_ALPHABETIC;
1752  x_digits += n;
1753  break;
1754 
1755  case 'X':
1756  if (s_char_seen || p_char_seen) {
1757  goto error;
1758  }
1759  category |= PIC_ALPHANUMERIC;
1760  x_digits += n;
1761  break;
1762 
1763  case '9':
1764  category |= PIC_NUMERIC;
1765  digits += n;
1766  real_digits += n;
1767  if (v_count) {
1768  scale += n;
1769  }
1770  break;
1771 
1772  case 'N':
1773  if (s_char_seen || p_char_seen) {
1774  goto error;
1775  }
1776  category |= PIC_NATIONAL;
1777  x_digits += n;
1778  break;
1779 
1780  case 'S':
1781  category |= PIC_NUMERIC;
1782  if (category & PIC_ALPHABETIC) {
1783  goto error;
1784  }
1785  s_count++;
1786  if (s_count > 1 || idx != 0) {
1787  goto error;
1788  }
1789  s_char_seen = 1;
1790  continue;
1791 
1792  case ',':
1793  case '.':
1794  category |= PIC_NUMERIC_EDITED;
1795  if (s_char_seen || p_char_seen) {
1796  goto error;
1797  }
1798  if (c != current_program->decimal_point) {
1799  break;
1800  }
1801  dp_char_seen = 1;
1802  /* fall through */
1803  case 'V':
1804  category |= PIC_NUMERIC;
1805  if (category & PIC_ALPHABETIC) {
1806  goto error;
1807  }
1808  v_count++;
1809  if (v_count > 1) {
1810  goto error;
1811  }
1812  break;
1813 
1814  case 'P':
1815  category |= PIC_NUMERIC;
1816  if (category & PIC_ALPHABETIC) {
1817  goto error;
1818  }
1819  if (p_char_seen || dp_char_seen) {
1820  goto error;
1821  }
1822  at_beginning = 0;
1823  at_end = 0;
1824  switch (buffcnt) {
1825  case 0:
1826  /* P..... */
1827  at_beginning = 1;
1828  break;
1829  case 1:
1830  /* VP.... */
1831  /* SP.... */
1832  if (lastonechar == 'V' || lastonechar == 'S') {
1833  at_beginning = 1;
1834  }
1835  break;
1836  case 2:
1837  /* SVP... */
1838  if (lasttwochar == 'S' && lastonechar == 'V') {
1839  at_beginning = 1;
1840  }
1841  break;
1842  default:
1843  break;
1844  }
1845  if (p[1] == 0 || (p[1] == 'V' && p[2] == 0)) {
1846  /* .....P */
1847  /* ....PV */
1848  at_end = 1;
1849  }
1850  if (!at_beginning && !at_end) {
1851  goto error;
1852  }
1853  p_char_seen = 1;
1854  if (at_beginning) {
1855  /* Implicit V */
1856  v_count++;
1857  }
1858  digits += n;
1859  if (v_count) {
1860  scale += n;
1861  } else {
1862  scale -= n;
1863  }
1864  break;
1865 
1866  case '0':
1867  case 'B':
1868  case '/':
1869  category |= PIC_EDITED;
1870  if (s_char_seen || p_char_seen) {
1871  goto error;
1872  }
1873  break;
1874 
1875  case '*':
1876  case 'Z':
1877  category |= PIC_NUMERIC_EDITED;
1878  if (category & PIC_ALPHABETIC) {
1879  goto error;
1880  }
1881  if (s_char_seen || p_char_seen) {
1882  goto error;
1883  }
1884  digits += n;
1885  if (v_count) {
1886  scale += n;
1887  }
1888  break;
1889 
1890  case '+':
1891  case '-':
1892  category |= PIC_NUMERIC_EDITED;
1893  if (category & PIC_ALPHABETIC) {
1894  goto error;
1895  }
1896  if (s_char_seen || p_char_seen) {
1897  goto error;
1898  }
1899  digits += n - 1;
1900  s_count++;
1901  /* FIXME: need more check */
1902  break;
1903 
1904  case 'C':
1905  category |= PIC_NUMERIC_EDITED;
1906  if (!(p[1] == 'R' && p[2] == 0)) {
1907  goto error;
1908  }
1909  if (s_char_seen || p_char_seen) {
1910  goto error;
1911  }
1912  p++;
1913  s_count++;
1914  break;
1915 
1916  case 'D':
1917  category |= PIC_NUMERIC_EDITED;
1918  if (!(p[1] == 'B' && p[2] == 0)) {
1919  goto error;
1920  }
1921  if (s_char_seen || p_char_seen) {
1922  goto error;
1923  }
1924  p++;
1925  s_count++;
1926  break;
1927 
1928  default:
1929  if (c == current_program->currency_symbol) {
1930  category |= PIC_NUMERIC_EDITED;
1931  digits += n - 1;
1932  /* FIXME: need more check */
1933  break;
1934  }
1935 
1936  goto error;
1937  }
1938 
1939  /* Calculate size */
1940  if (c != 'V' && c != 'P') {
1941  size += n;
1942  }
1943  if (c == 'C' || c == 'D') {
1944  size += n;
1945  }
1946  if (c == 'N') {
1947  size += n * (COB_NATIONAL_SIZE - 1);
1948  }
1949 
1950  /* Store in the buffer */
1951  pic_buff[idx++] = c;
1952  lasttwochar = lastonechar;
1953  lastonechar = c;
1954  memcpy (&pic_buff[idx], (void *)&n, sizeof(int));
1955  idx += sizeof(int);
1956  ++buffcnt;
1957  }
1958  pic_buff[idx] = 0;
1959 
1960  if (size == 0 && v_count) {
1961  goto error;
1962  }
1963  /* Set picture */
1964  pic->orig = cobc_check_string (str);
1965  pic->size = size;
1966  pic->digits = digits;
1967  pic->scale = scale;
1968  pic->have_sign = s_count;
1969  pic->real_digits = real_digits;
1970 
1971  /* Set picture category */
1972  switch (category) {
1973  case PIC_ALPHABETIC:
1974  pic->category = CB_CATEGORY_ALPHABETIC;
1975  break;
1976  case PIC_NUMERIC:
1977  pic->category = CB_CATEGORY_NUMERIC;
1978  if (digits > COB_MAX_DIGITS) {
1979  cb_error (_("Numeric field cannot be larger than %d digits"), COB_MAX_DIGITS);
1980  }
1981  break;
1982  case PIC_ALPHANUMERIC:
1983  case PIC_NATIONAL:
1984  pic->category = CB_CATEGORY_ALPHANUMERIC;
1985  break;
1986  case PIC_NUMERIC_EDITED:
1987  pic->str = cobc_parse_malloc (idx + 1);
1988  memcpy (pic->str, pic_buff, idx);
1989  pic->category = CB_CATEGORY_NUMERIC_EDITED;
1990  pic->lenstr = idx;
1991  break;
1992  case PIC_EDITED:
1993  case PIC_ALPHABETIC_EDITED:
1994  case PIC_ALPHANUMERIC_EDITED:
1995  case PIC_NATIONAL_EDITED:
1996  pic->str = cobc_parse_malloc (idx + 1);
1997  memcpy (pic->str, pic_buff, idx);
1998  pic->category = CB_CATEGORY_ALPHANUMERIC_EDITED;
1999  pic->lenstr = idx;
2000  pic->digits = x_digits;
2001  break;
2002  default:
2003  goto error;
2004  }
2005  goto end;
2006 
2007 error:
2008  cb_error (_("Invalid picture string - '%s'"), str);
2009 
2010 end:
2011  return CB_TREE (pic);
2012 }
struct cb_program* cb_build_program ( struct cb_program *  last_program,
const int  nest_level 
)
read

References add_contained_prog(), cb_program::alphabet_name_list, cb_clear_real_field(), CB_FIELD_PTR, cb_flag_functions_all, cb_reset_78(), cb_reset_global_78(), cb_program::cb_return_code, CB_WORD_TABLE_SIZE, cb_program::class_name_list, cb_program::class_spec_list, cb_program::classification, cobc_cs_check, cobc_in_procedure, cobc_in_repository, cobc_parse_malloc(), cb_program::collating_sequence, cb_program::currency_symbol, cb_program::decimal_point, cb_program::flag_console_is_crt, cb_program::flag_trailing_separate, cb_program::function_spec_list, functions_are_all, cb_program::global_file_list, cb_program::interface_spec_list, cb_program::locale_list, cb_program::mnemonic_spec_list, cb_program::nested_level, cb_program::nested_prog_list, cb_program::next_program, cb_program::numeric_separator, p, cb_program::program_spec_list, cb_program::property_spec_list, cb_program::symbolic_char_list, toplev_count, cb_program::toplev_count, cb_program::user_spec_list, and cb_program::word_table.

1247 {
1248  struct cb_program *p;
1249  struct cb_program *q;
1250 
1251  if (!last_program) {
1252  toplev_count = 0;
1253  }
1254  cb_reset_78 ();
1255  cobc_in_procedure = 0;
1256  cobc_in_repository = 0;
1257  cobc_cs_check = 0;
1258  cb_clear_real_field ();
1259 
1260  p = cobc_parse_malloc (sizeof (struct cb_program));
1261  p->word_table = cobc_parse_malloc (CB_WORD_TABLE_SIZE);
1262 
1263  p->next_program = last_program;
1264  p->nested_level = nest_level;
1265  p->decimal_point = '.';
1266  p->currency_symbol = '$';
1267  p->numeric_separator = ',';
1268  /* Save current program as actual at it's level */
1269  container_progs[nest_level] = p;
1270  if (nest_level) {
1271  /* Contained program */
1272  /* Inherit from upper level */
1273  p->global_file_list = last_program->global_file_list;
1274  p->collating_sequence = last_program->collating_sequence;
1275  p->classification = last_program->classification;
1276  p->mnemonic_spec_list = last_program->mnemonic_spec_list;
1277  p->class_spec_list = last_program->class_spec_list;
1278  p->interface_spec_list = last_program->interface_spec_list;
1279  p->function_spec_list = last_program->function_spec_list;
1280  p->user_spec_list = last_program->user_spec_list;
1281  p->program_spec_list = last_program->program_spec_list;
1282  p->property_spec_list = last_program->property_spec_list;
1283  p->alphabet_name_list = last_program->alphabet_name_list;
1284  p->symbolic_char_list = last_program->symbolic_char_list;
1285  p->class_name_list = last_program->class_name_list;
1286  p->locale_list = last_program->locale_list;
1287  p->decimal_point = last_program->decimal_point;
1288  p->numeric_separator = last_program->numeric_separator;
1289  p->currency_symbol = last_program->currency_symbol;
1290  p->flag_trailing_separate = last_program->flag_trailing_separate;
1291  p->flag_console_is_crt = last_program->flag_console_is_crt;
1292  /* RETURN-CODE is global for contained programs */
1293  p->cb_return_code = last_program->cb_return_code;
1294  CB_FIELD_PTR (last_program->cb_return_code)->flag_is_global = 1;
1295  p->toplev_count = last_program->toplev_count;
1296  /* Add program to itself for possible recursion */
1297  p->nested_prog_list = add_contained_prog (p->nested_prog_list, p);
1298  /* Add contained program to it's parent */
1299  q = container_progs[nest_level - 1];
1300  q->nested_prog_list = add_contained_prog (q->nested_prog_list, p);
1301  } else {
1302  /* Top level program */
1303  p->toplev_count = toplev_count++;
1304  functions_are_all = cb_flag_functions_all;
1305  cb_reset_global_78 ();
1306  }
1307  return p;
1308 }
cb_tree cb_build_reference ( const char *  name)

References CB_CATEGORY_UNKNOWN, CB_TAG_REFERENCE, CB_TREE, lookup_word(), make_tree(), and p.

Referenced by build_nested_special(), cb_add_const_var(), cb_build_debug_item(), cb_build_field_reference(), cb_build_filler(), cb_build_registers(), cb_define_system_name(), cb_validate_program_data(), emit_entry(), finalize_file(), make_constant_label(), and while().

2431 {
2432  struct cb_reference *p;
2433 
2434  p = make_tree (CB_TAG_REFERENCE, CB_CATEGORY_UNKNOWN,
2435  sizeof (struct cb_reference));
2436  /* Look up / insert word into hash list */
2437  lookup_word (p, name);
2438  return CB_TREE (p);
2439 }
cb_tree cb_build_search ( const int  flag_all,
const cb_tree  table,
const cb_tree  var,
const cb_tree  end_stmt,
const cb_tree  whens 
)

References CB_CATEGORY_UNKNOWN, CB_TAG_SEARCH, CB_TREE, cb_search::end_stmt, cb_search::flag_all, make_tree(), p, cb_search::table, cb_search::var, and cb_search::whens.

Referenced by cb_emit_search(), and cb_emit_search_all().

2901 {
2902  struct cb_search *p;
2903 
2904  p = make_tree (CB_TAG_SEARCH, CB_CATEGORY_UNKNOWN,
2905  sizeof (struct cb_search));
2906  p->flag_all = flag_all;
2907  p->table = table;
2908  p->var = var;
2909  p->end_stmt = end_stmt;
2910  p->whens = whens;
2911  return CB_TREE (p);
2912 }
cb_tree cb_build_set_attribute ( const struct cb_field *  fld,
const int  val_on,
const int  val_off 
)

References CB_CATEGORY_UNKNOWN, CB_TAG_SET_ATTR, CB_TREE, cb_set_attr::fld, make_tree(), p, cb_set_attr::val_off, and cb_set_attr::val_on.

Referenced by cb_emit_set_attribute().

3078 {
3079  struct cb_set_attr *p;
3080 
3081  p = make_tree (CB_TAG_SET_ATTR, CB_CATEGORY_UNKNOWN,
3082  sizeof (struct cb_set_attr));
3083  p->fld = (struct cb_field *)fld;
3084  p->val_on = val_on;
3085  p->val_off = val_off;
3086  return CB_TREE (p);
3087 }
struct cb_statement* cb_build_statement ( const char *  name)
read

References CB_CATEGORY_UNKNOWN, CB_TAG_STATEMENT, make_tree(), cb_statement::name, and p.

Referenced by begin_implicit_statement(), and begin_statement().

3052 {
3053  struct cb_statement *p;
3054 
3055  p = make_tree (CB_TAG_STATEMENT, CB_CATEGORY_UNKNOWN,
3056  sizeof (struct cb_statement));
3057  p->name = name;
3058  return p;
3059 }
cb_tree cb_build_string ( const void *  data,
const size_t  size 
)

References CB_CATEGORY_ALPHANUMERIC, CB_TAG_STRING, CB_TREE, cb_string::data, make_tree(), p, and cb_string::size.

Referenced by cb_build_move_literal().

1369 {
1370  struct cb_string *p;
1371 
1372  p = make_tree (CB_TAG_STRING, CB_CATEGORY_ALPHANUMERIC,
1373  sizeof (struct cb_string));
1374  p->size = size;
1375  p->data = data;
1376  return CB_TREE (p);
1377 }
void cb_build_symbolic_chars ( const cb_tree  sym_list,
const cb_tree  alphabet 
)

References cb_alphabet_name::alphachr, CB_ALPHABET_NAME, cb_build_alphanumeric_literal(), cb_build_constant(), CB_CHAIN, CB_FIELD, cb_get_int(), CB_LITERAL, CB_PURPOSE, cb_validate_78_item(), CB_VALUE, and NULL.

Referenced by cb_validate_program_environment().

2148 {
2149  cb_tree l;
2150  cb_tree x;
2151  cb_tree x2;
2152  struct cb_alphabet_name *ap;
2153  int n;
2154  unsigned char buff[4];
2155 
2156  if (alphabet) {
2157  ap = CB_ALPHABET_NAME (alphabet);
2158  } else {
2159  ap = NULL;
2160  }
2161  for (l = sym_list; l; l = CB_CHAIN (l)) {
2162  n = cb_get_int (CB_PURPOSE (l)) - 1;
2163  if (ap) {
2164  buff[0] = (unsigned char)ap->alphachr[n];
2165  } else {
2166  buff[0] = (unsigned char)n;
2167  }
2168  buff[1] = 0;
2169  x2 = cb_build_alphanumeric_literal (buff, (size_t)1);
2170  CB_LITERAL (x2)->all = 1;
2171  x = cb_build_constant (CB_VALUE (l), x2);
2172  CB_FIELD (x)->flag_item_78 = 1;
2173  CB_FIELD (x)->flag_is_global = 1;
2174  CB_FIELD (x)->level = 1;
2175  (void)cb_validate_78_item (CB_FIELD (x), 0);
2176  }
2177 }
cb_tree cb_build_system_name ( const enum cb_system_name_category  category,
const int  token 
)

References cb_system_name::category, CB_CATEGORY_UNKNOWN, CB_TAG_SYSTEM_NAME, CB_TREE, make_tree(), p, and cb_system_name::token.

Referenced by lookup_system_name().

1510 {
1511  struct cb_system_name *p;
1512 
1513  p = make_tree (CB_TAG_SYSTEM_NAME, CB_CATEGORY_UNKNOWN,
1514  sizeof (struct cb_system_name));
1515  p->category = category;
1516  p->token = token;
1517  return CB_TREE (p);
1518 }
int cb_category_is_alpha ( cb_tree  x)

References category_is_alphanumeric, and CB_TREE_CATEGORY.

Referenced by cb_emit_allocate().

751 {
752  return category_is_alphanumeric[CB_TREE_CATEGORY (x)];
753 }
cb_tree cb_concat_literals ( const cb_tree  x1,
const cb_tree  x2 
)

References CB_CATEGORY_ALPHANUMERIC, CB_CONST_P, cb_error_node, CB_LITERAL, CB_LITERAL_P, CB_TAG_LITERAL, CB_TREE, cobc_parse_malloc(), cb_literal::data, make_tree(), p, and cb_literal::size.

1552 {
1553  unsigned char *data1;
1554  unsigned char *data2;
1555  struct cb_literal *p;
1556  size_t size1;
1557  size_t size2;
1558 
1559  if (x1 == cb_error_node || x2 == cb_error_node) {
1560  return cb_error_node;
1561  }
1562  if (CB_LITERAL_P (x1)) {
1563  data1 = CB_LITERAL (x1)->data;
1564  size1 = CB_LITERAL (x1)->size;
1565  } else if (CB_CONST_P (x1)) {
1566  size1 = 1;
1567  if (x1 == cb_space) {
1568  data1 = (unsigned char *)" ";
1569  } else if (x1 == cb_zero) {
1570  data1 = (unsigned char *)"0";
1571  } else if (x1 == cb_quote) {
1572  if (cb_flag_apostrophe) {
1573  data1 = (unsigned char *)"'";
1574  } else {
1575  data1 = (unsigned char *)"\"";
1576  }
1577  } else if (x1 == cb_norm_low) {
1578  data1 = (unsigned char *)"\0";
1579  } else if (x1 == cb_norm_high) {
1580  data1 = (unsigned char *)"\255";
1581  } else if (x1 == cb_null) {
1582  data1 = (unsigned char *)"\0";
1583  } else {
1584  return cb_error_node;
1585  }
1586  } else {
1587  return cb_error_node;
1588  }
1589  if (CB_LITERAL_P (x2)) {
1590  data2 = CB_LITERAL (x2)->data;
1591  size2 = CB_LITERAL (x2)->size;
1592  } else if (CB_CONST_P (x2)) {
1593  size2 = 1;
1594  if (x2 == cb_space) {
1595  data2 = (unsigned char *)" ";
1596  } else if (x2 == cb_zero) {
1597  data2 = (unsigned char *)"0";
1598  } else if (x2 == cb_quote) {
1599  if (cb_flag_apostrophe) {
1600  data2 = (unsigned char *)"'";
1601  } else {
1602  data2 = (unsigned char *)"\"";
1603  }
1604  } else if (x2 == cb_norm_low) {
1605  data2 = (unsigned char *)"\0";
1606  } else if (x2 == cb_norm_high) {
1607  data2 = (unsigned char *)"\255";
1608  } else if (x2 == cb_null) {
1609  data2 = (unsigned char *)"\0";
1610  } else {
1611  return cb_error_node;
1612  }
1613  } else {
1614  return cb_error_node;
1615  }
1616  p = make_tree (CB_TAG_LITERAL, CB_CATEGORY_ALPHANUMERIC,
1617  sizeof (struct cb_literal));
1618  p->data = cobc_parse_malloc (size1 + size2 + 1U);
1619  p->size = size1 + size2;
1620  memcpy (p->data, data1, size1);
1621  memcpy (p->data + size1, data2, size2);
1622  return CB_TREE (p);
1623 }
const char* cb_define ( cb_tree  name,
cb_tree  val 
)

References cb_list_add(), CB_REFERENCE, cb_word::count, cb_word::items, cb_word::name, cb_tree_common::source_file, and cb_tree_common::source_line.

Referenced by build_file(), build_nested_special(), build_report(), cb_build_alphabet_name(), cb_build_class_name(), cb_build_field(), cb_build_label(), cb_build_locale_name(), and cb_define_system_name().

1214 {
1215  struct cb_word *w;
1216 
1217  w = CB_REFERENCE (name)->word;
1218  w->items = cb_list_add (w->items, val);
1219  w->count++;
1220  val->source_file = name->source_file;
1221  val->source_line = name->source_line;
1222  CB_REFERENCE (name)->value = val;
1223  return w->name;
1224 }
static void cb_define_system_name ( const char *  name)
static

References cb_build_reference(), cb_define(), CB_WORD_COUNT, and lookup_system_name().

Referenced by cb_set_system_names().

2473 {
2474  cb_tree x;
2475  cb_tree y;
2476 
2477  x = cb_build_reference (name);
2478  if (CB_WORD_COUNT (x) == 0) {
2479  y = lookup_system_name (name);
2480  /* Paranoid */
2481  if (y) {
2482  cb_define (x, y);
2483  }
2484  }
2485 }
struct cb_field* cb_field_add ( struct cb_field *  f,
struct cb_field *  p 
)
read

References NULL, p, and cb_field::sister.

2071 {
2072  struct cb_field *t;
2073 
2074  if (f == NULL) {
2075  return p;
2076  }
2077  for (t = f; t->sister; t = t->sister) {
2078  ;
2079  }
2080  t->sister = p;
2081  return f;
2082 }
struct cb_field* cb_field_founder ( const struct cb_field *  f)
read

References cb_field::parent.

Referenced by cb_build_field_tree(), cb_build_identifier(), cb_check_overlapping(), cb_ref(), check_valid_key(), finalize_file(), and global_check().

2086 {
2087  const struct cb_field *ff;
2088 
2089  ff = f;
2090  while (ff->parent) {
2091  ff = ff->parent;
2092  }
2093  return (struct cb_field *)ff;
2094 }
int cb_field_subordinate ( const struct cb_field *  pfld,
const struct cb_field *  f 
)

References p, and cb_field::parent.

Referenced by output_size().

2133 {
2134  struct cb_field *p;
2135 
2136  for (p = pfld->parent; p; p = p->parent) {
2137  if (p == f) {
2138  return 1;
2139  }
2140  }
2141  return 0;
2142 }
unsigned int cb_field_variable_address ( const struct cb_field *  fld)

References cb_field_variable_size(), cb_field::children, cb_field::depending, p, cb_field::parent, and cb_field::sister.

2114 {
2115  const struct cb_field *p;
2116  const struct cb_field *f;
2117 
2118  f = fld;
2119  for (p = f->parent; p; f = f->parent, p = f->parent) {
2120  for (p = p->children; p != f; p = p->sister) {
2121  if (p->depending || cb_field_variable_size (p)) {
2122  return 1;
2123  }
2124  }
2125  }
2126  return 0;
2127 }
struct cb_field* cb_field_variable_size ( const struct cb_field *  f)
read

References cb_field_variable_size(), cb_field::children, cb_field::depending, NULL, p, and cb_field::sister.

Referenced by cb_build_const_length(), cb_build_length(), cb_build_length_1(), cb_build_move_field(), cb_build_move_literal(), cb_check_overlapping(), cb_chk_alpha_cond(), cb_field_variable_address(), cb_field_variable_size(), finalize_file(), and validate_field_1().

2098 {
2099  struct cb_field *p;
2100  struct cb_field *fc;
2101 
2102  for (fc = f->children; fc; fc = fc->sister) {
2103  if (fc->depending) {
2104  return fc;
2105  } else if ((p = cb_field_variable_size (fc)) != NULL) {
2106  return p;
2107  }
2108  }
2109  return NULL;
2110 }
int cb_fits_int ( const cb_tree  x)

References CB_FIELD, cb_fits_int(), CB_LITERAL, CB_REFERENCE, CB_TAG_FIELD, CB_TAG_INTEGER, 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_LENGTH, CB_USAGE_PACKED, cb_field::children, cb_literal::data, cb_picture::digits, p, cb_field::pic, cb_literal::scale, cb_picture::scale, cb_literal::sign, cb_literal::size, cb_field::size, cb_field::usage, and value.

Referenced by cb_build_add(), cb_build_move_literal(), cb_build_sub(), cb_fits_int(), output_bin_field(), output_call(), and output_integer().

822 {
823  struct cb_literal *l;
824  struct cb_field *f;
825  const char *s;
826  const unsigned char *p;
827  size_t size;
828 
829  switch (CB_TREE_TAG (x)) {
830  case CB_TAG_LITERAL:
831  l = CB_LITERAL (x);
832  if (l->scale > 0) {
833  return 0;
834  }
835  for (size = 0, p = l->data; size < l->size; ++size, ++p) {
836  if (*p != (unsigned char)'0') {
837  break;
838  }
839  }
840  size = l->size - size;
841  if (size < 10) {
842  return 1;
843  }
844  if (size > 10) {
845  return 0;
846  }
847  if (l->sign < 0) {
848  s = "2147483648";
849  } else {
850  s = "2147483647";
851  }
852  if (memcmp (p, s, (size_t)10) > 0) {
853  return 0;
854  }
855  return 1;
856  case CB_TAG_FIELD:
857  f = CB_FIELD (x);
858  if (f->children) {
859  return 0;
860  }
861  switch (f->usage) {
862  case CB_USAGE_INDEX:
863  case CB_USAGE_LENGTH:
864  return 1;
865  case CB_USAGE_BINARY:
866  case CB_USAGE_COMP_5:
867  case CB_USAGE_COMP_X:
868  if (f->pic->scale <= 0 && f->size <= (int)sizeof (int)) {
869  return 1;
870  }
871  return 0;
872  case CB_USAGE_DISPLAY:
873  if (f->size < 10) {
874  if (!f->pic || f->pic->scale <= 0) {
875  return 1;
876  }
877  }
878  return 0;
879  case CB_USAGE_PACKED:
880  case CB_USAGE_COMP_6:
881  if (f->pic->scale <= 0 && f->pic->digits < 10) {
882  return 1;
883  }
884  return 0;
885  default:
886  return 0;
887  }
888  case CB_TAG_REFERENCE:
889  return cb_fits_int (CB_REFERENCE (x)->value);
890  case CB_TAG_INTEGER:
891  return 1;
892  default:
893  return 0;
894  }
895 }
int cb_fits_long_long ( const cb_tree  x)

References CB_FIELD, cb_fits_long_long(), CB_LITERAL, CB_REFERENCE, CB_TAG_FIELD, CB_TAG_INTEGER, 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_LENGTH, CB_USAGE_PACKED, cb_field::children, cob_s64_t, cb_literal::data, cb_picture::digits, p, cb_field::pic, cb_literal::scale, cb_picture::scale, cb_literal::sign, cb_literal::size, cb_field::size, cb_field::usage, and value.

Referenced by cb_build_cond(), cb_build_optim_cond(), cb_fits_long_long(), and output_long_integer().

899 {
900  struct cb_literal *l;
901  struct cb_field *f;
902  const char *s;
903  const unsigned char *p;
904  size_t size;
905 
906  switch (CB_TREE_TAG (x)) {
907  case CB_TAG_LITERAL:
908  l = CB_LITERAL (x);
909  if (l->scale > 0) {
910  return 0;
911  }
912  for (size = 0, p = l->data; size < l->size; ++size, ++p) {
913  if (*p != (unsigned char)'0') {
914  break;
915  }
916  }
917  size = l->size - size;
918  if (size < 19) {
919  return 1;
920  }
921  if (size > 19) {
922  return 0;
923  }
924  if (l->sign < 0) {
925  s = "9223372036854775808";
926  } else {
927  s = "9223372036854775807";
928  }
929  if (memcmp (p, s, (size_t)19) > 0) {
930  return 0;
931  }
932  return 1;
933  case CB_TAG_FIELD:
934  f = CB_FIELD (x);
935  if (f->children) {
936  return 0;
937  }
938  switch (f->usage) {
939  case CB_USAGE_INDEX:
940  case CB_USAGE_LENGTH:
941  return 1;
942  case CB_USAGE_BINARY:
943  case CB_USAGE_COMP_5:
944  case CB_USAGE_COMP_X:
945  if (f->pic->scale <= 0 &&
946  f->size <= (int)sizeof (cob_s64_t)) {
947  return 1;
948  }
949  return 0;
950  case CB_USAGE_DISPLAY:
951  if (f->pic->scale <= 0 && f->size < 19) {
952  return 1;
953  }
954  return 0;
955  case CB_USAGE_PACKED:
956  case CB_USAGE_COMP_6:
957  if (f->pic->scale <= 0 && f->pic->digits < 19) {
958  return 1;
959  }
960  return 0;
961  default:
962  return 0;
963  }
964  case CB_TAG_REFERENCE:
965  return cb_fits_long_long (CB_REFERENCE (x)->value);
966  case CB_TAG_INTEGER:
967  return 1;
968  default:
969  return 0;
970  }
971 }
int cb_get_int ( const cb_tree  x)

References _, CB_LITERAL, CB_LITERAL_P, COBC_ABORT, cobc_abort_pr(), cb_literal::data, cb_literal::sign, and cb_literal::size.

Referenced by cb_build_identifier(), cb_build_intrinsic(), cb_build_move_literal(), cb_build_symbolic_chars(), cb_build_write_advancing_lines(), cb_emit_call(), cb_field_size(), get_value(), literal_value(), output_call(), output_index(), output_integer(), and validate_inspect().

975 {
976  struct cb_literal *l;
977 #if 0 /* RXWRXW Fixme SZ */
978  const char *s;
979  size_t size;
980 #endif
981  size_t i;
982  int val;
983 
984  if (!CB_LITERAL_P (x)) {
985  cobc_abort_pr (_("Invalid literal cast - Aborting"));
986  COBC_ABORT ();
987  }
988  l = CB_LITERAL (x);
989  for (i = 0; i < l->size; i++) {
990  if (l->data[i] != '0') {
991  break;
992  }
993  }
994 
995 #if 0 /* RXWRXW Fixme SZ */
996  if (l->sign < 0) {
997  s = "2147483648";
998  } else {
999  s = "2147483647";
1000  }
1001  size = l->size - i;
1002  if (size > 10U || (size == 10U && memcmp (&l->data[i], s, 10) > 0)) {
1003  cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
1004  COBC_ABORT ();
1005  }
1006 #endif
1007 
1008  val = 0;
1009  for (; i < l->size; i++) {
1010  val = val * 10 + l->data[i] - '0';
1011  }
1012  if (val && l->sign < 0) {
1013  val = -val;
1014  }
1015  return val;
1016 }
cob_s64_t cb_get_long_long ( const cb_tree  x)

References _, CB_LITERAL, CB_LITERAL_P, cob_s64_t, COBC_ABORT, cobc_abort_pr(), cb_literal::data, cb_literal::sign, and cb_literal::size.

Referenced by cb_emit_call(), output_call(), output_call_by_value_args(), output_long_integer(), and validate_move().

1020 {
1021  struct cb_literal *l;
1022  const char *s;
1023  size_t i;
1024  size_t size;
1025  cob_s64_t val;
1026 
1027  if (!CB_LITERAL_P (x)) {
1028  cobc_abort_pr (_("Invalid literal cast - Aborting"));
1029  COBC_ABORT ();
1030  }
1031  l = CB_LITERAL (x);
1032  for (i = 0; i < l->size; i++) {
1033  if (l->data[i] != '0') {
1034  break;
1035  }
1036  }
1037 
1038  size = l->size - i;
1039  if (size > 19U) {
1040  cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
1041  COBC_ABORT ();
1042  }
1043  if (size == 19U) {
1044  if (l->sign < 0) {
1045  s = "9223372036854775808";
1046  } else {
1047  s = "9223372036854775807";
1048  }
1049  if (memcmp (&(l->data[i]), s, (size_t)19) > 0) {
1050  cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
1051  COBC_ABORT ();
1052  }
1053  }
1054 
1055  val = 0;
1056  for (; i < l->size; i++) {
1057  val = val * 10 + (l->data[i] & 0x0F);
1058  }
1059  if (val && l->sign < 0) {
1060  val = -val;
1061  }
1062  return val;
1063 }
cob_u64_t cb_get_u_long_long ( const cb_tree  x)

References _, CB_LITERAL, cob_u64_t, COBC_ABORT, cobc_abort_pr(), cb_literal::data, and cb_literal::size.

Referenced by output_call(), and output_call_by_value_args().

1067 {
1068  struct cb_literal *l;
1069  size_t i;
1070  size_t size;
1071  cob_u64_t val;
1072 
1073  l = CB_LITERAL (x);
1074  for (i = 0; i < l->size; i++) {
1075  if (l->data[i] != '0') {
1076  break;
1077  }
1078  }
1079 
1080  size = l->size - i;
1081  if (size > 20U) {
1082  cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
1083  COBC_ABORT ();
1084  }
1085  if (size == 20U) {
1086  if (memcmp (&(l->data[i]), "18446744073709551615", (size_t)20) > 0) {
1087  cobc_abort_pr (_("Numeric literal exceeds limit - Aborting"));
1088  COBC_ABORT ();
1089  }
1090  }
1091  val = 0;
1092  for (; i < l->size; i++) {
1093  val = val * 10 + (l->data[i] & 0x0F);
1094  }
1095  return val;
1096 }
void cb_init_constants ( void  )

References cb_build_numeric_literal(), CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_BOOLEAN, CB_CATEGORY_DATA_POINTER, CB_CATEGORY_NUMERIC, CB_CATEGORY_UNKNOWN, cb_const_subs, cb_high, cb_int(), CB_LABEL, cb_low, COB_MAX_SUBSCRIPTS, make_constant(), make_constant_label(), and NULL.

Referenced by process_translate().

1100 {
1101  int i;
1102 
1103  cb_error_node = make_constant (CB_CATEGORY_UNKNOWN, NULL);
1104  cb_any = make_constant (CB_CATEGORY_UNKNOWN, NULL);
1105  cb_true = make_constant (CB_CATEGORY_BOOLEAN, "1");
1106  cb_false = make_constant (CB_CATEGORY_BOOLEAN, "0");
1107  cb_null = make_constant (CB_CATEGORY_DATA_POINTER, "0");
1108  cb_zero = make_constant (CB_CATEGORY_NUMERIC, "&cob_all_zero");
1109  cb_space = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_all_space");
1110  cb_low = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_all_low");
1111  cb_norm_low = cb_low;
1112  cb_high = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_all_high");
1113  cb_norm_high = cb_high;
1114  cb_quote = make_constant (CB_CATEGORY_ALPHANUMERIC, "&cob_all_quote");
1115  cb_one = cb_build_numeric_literal (0, "1", 0);
1116  cb_int0 = cb_int (0);
1117  cb_int1 = cb_int (1);
1118  cb_int2 = cb_int (2);
1119  cb_int3 = cb_int (3);
1120  cb_int4 = cb_int (4);
1121  cb_int5 = cb_int (5);
1122  for (i = 0; i < COB_MAX_SUBSCRIPTS; i++) {
1123  cb_i[i] = make_constant (CB_CATEGORY_NUMERIC, cb_const_subs[i]);
1124  }
1125  cb_standard_error_handler = make_constant_label ("Default Error Handler");
1126  CB_LABEL (cb_standard_error_handler)->flag_default_handler = 1;
1127  memset (container_progs, 0, sizeof(container_progs));
1128 }
void cb_insert_common_prog ( struct cb_program *  prog,
struct cb_program *  comprog 
)

References add_contained_prog(), and cb_program::nested_prog_list.

Referenced by process_translate().

1322 {
1323  prog->nested_prog_list = add_contained_prog (prog->nested_prog_list,
1324  comprog);
1325 }
cb_tree cb_int ( const int  n)

References cb_tree_common::category, CB_CATEGORY_NUMERIC, CB_TAG_INTEGER, CB_TREE, cobc_main_malloc(), cb_integer::common, int_node_table, int_node::n, int_node::next, int_node::node, p, cb_tree_common::tag, and cb_integer::val.

Referenced by build_store_option(), cb_build_cond(), cb_build_identifier(), cb_build_length_1(), cb_build_memset(), cb_build_move_literal(), cb_build_optim_cond(), cb_build_write_advancing_lines(), cb_check_field_debug(), cb_define_switch_name(), cb_emit_accept(), cb_emit_accept_line_or_col(), cb_emit_display(), cb_emit_open(), cb_emit_read(), cb_emit_rewrite(), cb_emit_set_on_off(), cb_emit_sort_init(), cb_emit_unstring(), cb_emit_write(), cb_gen_field_accept(), cb_init_constants(), and cb_int_hex().

1331 {
1332  struct cb_integer *x;
1333  struct int_node *p;
1334 
1335  for (p = int_node_table; p; p = p->next) {
1336  if (p->n == n) {
1337  return p->node;
1338  }
1339  }
1340 
1341  /* Do not use make_tree here */
1342  x = cobc_main_malloc (sizeof (struct cb_integer));
1343  x->common.tag = CB_TAG_INTEGER;
1344  x->common.category = CB_CATEGORY_NUMERIC;
1345  x->val = n;
1346 
1347  p = cobc_main_malloc (sizeof (struct int_node));
1348  p->n = n;
1349  p->node = CB_TREE (x);
1350  p->next = int_node_table;
1351  int_node_table = p;
1352  return CB_TREE (x);
1353 }
cb_tree cb_int_hex ( const int  n)

References cb_int(), and CB_INTEGER.

Referenced by cb_build_write_advancing_lines(), cb_build_write_advancing_mnemonic(), cb_build_write_advancing_page(), and cb_emit_write().

1357 {
1358  cb_tree x;
1359 
1360  x = cb_int (n);
1361  CB_INTEGER (x)->hexval = 1;
1362  return x;
1363 }
cb_tree cb_list_add ( cb_tree  l,
cb_tree  x 
)

References cb_list_append(), and CB_LIST_INIT.

Referenced by begin_implicit_statement(), build_evaluate(), cb_build_assignment_name(), cb_build_converting(), cb_build_identifier(), cb_build_perform_varying(), cb_build_replacing_all(), cb_build_replacing_characters(), cb_build_replacing_first(), cb_build_replacing_leading(), cb_build_replacing_trailing(), cb_build_tallying_characters(), cb_build_tallying_value(), cb_check_field_debug(), cb_check_needs_break(), cb_define(), cb_emit_read(), codegen(), setup_use_file(), and validate_field_1().

1162 {
1163  return cb_list_append (l, CB_LIST_INIT (x));
1164 }
cb_tree cb_list_append ( cb_tree  l1,
cb_tree  l2 
)

References CB_CHAIN, and NULL.

Referenced by build_decimal_assign(), cb_build_alter(), cb_list_add(), cb_pair_add(), and emit_entry().

1146 {
1147  cb_tree l;
1148 
1149  if (l1 == NULL) {
1150  return l2;
1151  }
1152  l = l1;
1153  while (CB_CHAIN (l)) {
1154  l = CB_CHAIN (l);
1155  }
1156  CB_CHAIN (l) = l2;
1157  return l1;
1158 }
int cb_list_length ( cb_tree  l)

References CB_CHAIN.

Referenced by cb_build_address(), cb_build_identifier(), cb_build_intrinsic(), cb_emit_call(), cb_emit_display(), cb_emit_move(), cb_emit_sort_giving(), cb_emit_sort_init(), cb_emit_unstring(), output_error_handler(), output_internal_function(), output_param(), and valid_const_date_time_args().

1189 {
1190  int n;
1191 
1192  if (l == cb_error_node) {
1193  return 0;
1194  }
1195  n = 0;
1196  for (; l; l = CB_CHAIN (l)) {
1197  n++;
1198  }
1199  return n;
1200 }
void cb_list_map ( cb_tree(*)(cb_tree x)  func,
cb_tree  l 
)

References CB_CHAIN, and CB_VALUE.

1204 {
1205  for (; l; l = CB_CHAIN (l)) {
1206  CB_VALUE (l) = func (CB_VALUE (l));
1207  }
1208 }
cb_tree cb_list_reverse ( cb_tree  l)

References CB_CHAIN, next, and NULL.

Referenced by build_decimal_assign(), cb_build_cond(), cb_build_identifier(), cb_check_field_debug(), cb_emit_search(), cb_name_1(), cb_validate_program_body(), cb_validate_program_data(), and process_translate().

1174 {
1175  cb_tree next;
1176  cb_tree last;
1177 
1178  last = NULL;
1179  for (; l; l = next) {
1180  next = CB_CHAIN (l);
1181  CB_CHAIN (l) = last;
1182  last = l;
1183  }
1184  return last;
1185 }
char* cb_name ( cb_tree  x)

References cb_name_1(), COB_NORMAL_BUFF, and cobc_parse_malloc().

Referenced by ambiguous_error(), build_nested_special(), cb_build_tallying_value(), cb_check_group_name(), cb_check_integer_value(), cb_check_numeric_edited_name(), cb_check_numeric_name(), cb_check_numeric_value(), cb_emit_accept_mnemonic(), cb_emit_accept_name(), cb_emit_display(), cb_emit_move(), cb_emit_set_to(), cb_validate_collating(), cb_validate_program_body(), cb_validate_program_data(), cb_validate_program_environment(), check_picture_item(), cobc_tree_cast_error(), compute_size(), emit_entry(), group_error(), level_except_error(), level_redundant_error(), level_require_error(), output_param(), validate_field_1(), and warning_destination().

643 {
644  char *s;
645 
646  s = cobc_parse_malloc ((size_t)COB_NORMAL_BUFF);
647  (void)cb_name_1 (s, x);
648  return s;
649 }
static size_t cb_name_1 ( char *  s,
cb_tree  x 
)
static

References _, cb_funcall::argc, cb_funcall::argv, CB_ALPHABET_NAME, CB_BINARY_OP, CB_CHAIN, CB_CLASS_NAME, CB_CLASS_NUMERIC, CB_FIELD, CB_FILE, CB_FUNCALL, CB_INTRINSIC, CB_LABEL, cb_list_reverse(), CB_LITERAL, CB_LOCALE_NAME, CB_REFERENCE, CB_TAG_ALPHABET_NAME, CB_TAG_BINARY_OP, CB_TAG_CLASS_NAME, CB_TAG_CONST, CB_TAG_FIELD, CB_TAG_FILE, CB_TAG_FUNCALL, CB_TAG_INTRINSIC, CB_TAG_LABEL, CB_TAG_LITERAL, CB_TAG_LOCALE_NAME, CB_TAG_REFERENCE, CB_TREE_CLASS, CB_TREE_TAG, CB_VALUE, cb_reference::chain, cb_field::flag_filler, cb_reference::flag_filler_ref, cb_intrinsic::intr_tab, cb_intrinsic::isuser, cb_reference::length, cb_field::name, cb_word::name, cb_funcall::name, cb_intrinsic_table::name, cb_intrinsic::name, cb_reference::offset, cb_binary_op::op, p, cb_reference::subs, cb_reference::word, cb_binary_op::x, and cb_binary_op::y.

Referenced by cb_name().

258 {
259  char *orig;
260  struct cb_funcall *cbip;
261  struct cb_binary_op *cbop;
262  struct cb_reference *p;
263  struct cb_field *f;
264  struct cb_intrinsic *cbit;
265  cb_tree l;
266  int i;
267 
268  orig = s;
269  if (!x) {
270  strcpy (s, "(void pointer)");
271  return strlen (orig);
272  }
273  switch (CB_TREE_TAG (x)) {
274  case CB_TAG_CONST:
275  if (x == cb_any) {
276  strcpy (s, "ANY");
277  } else if (x == cb_true) {
278  strcpy (s, "TRUE");
279  } else if (x == cb_false) {
280  strcpy (s, "FALSE");
281  } else if (x == cb_null) {
282  strcpy (s, "NULL");
283  } else if (x == cb_zero) {
284  strcpy (s, "ZERO");
285  } else if (x == cb_space) {
286  strcpy (s, "SPACE");
287  } else if (x == cb_low || x == cb_norm_low) {
288  strcpy (s, "LOW-VALUE");
289  } else if (x == cb_high || x == cb_norm_high) {
290  strcpy (s, "HIGH-VALUE");
291  } else if (x == cb_quote) {
292  strcpy (s, "QUOTE");
293  } else if (x == cb_error_node) {
294  strcpy (s, _("Internal error node"));
295  } else {
296  strcpy (s, _("Unknown constant"));
297  }
298  break;
299 
300  case CB_TAG_LITERAL:
301  if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
302  strcpy (s, (char *)CB_LITERAL (x)->data);
303  } else {
304  sprintf (s, "\"%s\"", (char *)CB_LITERAL (x)->data);
305  }
306  break;
307 
308  case CB_TAG_FIELD:
309  f = CB_FIELD (x);
310  if (f->flag_filler) {
311  strcpy (s, "FILLER");
312  } else {
313  strcpy (s, f->name);
314  }
315  break;
316 
317  case CB_TAG_REFERENCE:
318  p = CB_REFERENCE (x);
319  if (p->flag_filler_ref) {
320  s += sprintf (s, "FILLER");
321  } else {
322  s += sprintf (s, "%s", p->word->name);
323  }
324  if (p->subs) {
325  s += sprintf (s, " (");
326  p->subs = cb_list_reverse (p->subs);
327  for (l = p->subs; l; l = CB_CHAIN (l)) {
328  s += cb_name_1 (s, CB_VALUE (l));
329  s += sprintf (s, CB_CHAIN (l) ? ", " : ")");
330  }
331  p->subs = cb_list_reverse (p->subs);
332  }
333  if (p->offset) {
334  s += sprintf (s, " (");
335  s += cb_name_1 (s, p->offset);
336  s += sprintf (s, ":");
337  if (p->length) {
338  s += cb_name_1 (s, p->length);
339  }
340  strcpy (s, ")");
341  }
342  if (p->chain) {
343  s += sprintf (s, " in ");
344  s += cb_name_1 (s, p->chain);
345  }
346  break;
347 
348  case CB_TAG_LABEL:
349  sprintf (s, "%s", (char *)(CB_LABEL (x)->name));
350  break;
351 
352  case CB_TAG_ALPHABET_NAME:
353  sprintf (s, "%s", CB_ALPHABET_NAME (x)->name);
354  break;
355 
356  case CB_TAG_CLASS_NAME:
357  sprintf (s, "%s", CB_CLASS_NAME (x)->name);
358  break;
359 
360  case CB_TAG_LOCALE_NAME:
361  sprintf (s, "%s", CB_LOCALE_NAME (x)->name);
362  break;
363 
364  case CB_TAG_BINARY_OP:
365  cbop = CB_BINARY_OP (x);
366  if (cbop->op == '@') {
367  s += sprintf (s, "(");
368  s += cb_name_1 (s, cbop->x);
369  s += sprintf (s, ")");
370  } else if (cbop->op == '!') {
371  s += sprintf (s, "!");
372  s += cb_name_1 (s, cbop->x);
373  } else {
374  s += sprintf (s, "(");
375  s += cb_name_1 (s, cbop->x);
376  s += sprintf (s, " %c ", cbop->op);
377  s += cb_name_1 (s, cbop->y);
378  strcpy (s, ")");
379  }
380  break;
381 
382  case CB_TAG_FUNCALL:
383  cbip = CB_FUNCALL (x);
384  s += sprintf (s, "%s", cbip->name);
385  for (i = 0; i < cbip->argc; i++) {
386  s += sprintf (s, (i == 0) ? "(" : ", ");
387  s += cb_name_1 (s, cbip->argv[i]);
388  }
389  s += sprintf (s, ")");
390  break;
391 
392  case CB_TAG_INTRINSIC:
393  cbit = CB_INTRINSIC (x);
394  if (cbit->isuser) {
395  sprintf (s, "USER FUNCTION");
396  } else {
397  sprintf (s, "FUNCTION %s", cbit->intr_tab->name);
398  }
399  break;
400  case CB_TAG_FILE:
401  sprintf (s, "FILE %s", CB_FILE (x)->name);
402  break;
403  default:
404  sprintf (s, _("<Unexpected tree tag %d>"), (int)CB_TREE_TAG (x));
405  }
406 
407  return strlen (orig);
408 }
cb_tree cb_pair_add ( cb_tree  l,
cb_tree  x,
cb_tree  y 
)

References CB_BUILD_PAIR, and cb_list_append().

1168 {
1169  return cb_list_append (l, CB_BUILD_PAIR (x, y));
1170 }
cb_tree cb_ref ( cb_tree  x)

References ambiguous_error(), CB_CHAIN, cb_error_node, CB_FIELD, cb_field_founder(), CB_FIELD_P, CB_FILE, CB_FILE_P, CB_INVALID_TREE, CB_LABEL, CB_LABEL_P, CB_NAME, cb_ref(), CB_REFERENCE, CB_TAG_FIELD, CB_TAG_LABEL, CB_TREE_TAG, CB_VALUE, CB_WORD_COUNT, cb_reference::chain, current_program, cb_word::error, file, cb_reference::flag_alter_code, cb_program::flag_gen_error, global_check(), cb_reference::hashval, cb_word::items, likely, cb_field::name, cb_label::name, cb_word::name, cb_program::nested_level, cb_word::next, cb_program::next_program, NULL, cb_reference::offset, p, cb_field::parent, undefined_error(), cb_reference::value, cb_reference::word, and cb_program::word_table.

Referenced by cb_build_address(), cb_build_binary_op(), cb_build_cond(), cb_build_const_length(), cb_build_display_mnemonic(), cb_build_expr(), cb_build_identifier(), cb_build_length(), cb_build_length_1(), cb_build_perform_varying(), cb_build_ppointer(), cb_build_write_advancing_mnemonic(), cb_check_field_debug(), cb_check_group_name(), cb_check_integer_value(), cb_check_numeric_edited_name(), cb_check_numeric_name(), cb_emit_accept(), cb_emit_accept_mnemonic(), cb_emit_close(), cb_emit_delete(), cb_emit_delete_file(), cb_emit_display(), cb_emit_open(), cb_emit_read(), cb_emit_release(), cb_emit_return(), cb_emit_rewrite(), cb_emit_set_attribute(), cb_emit_set_on_off(), cb_emit_set_to(), cb_emit_sort_finish(), cb_emit_sort_giving(), cb_emit_sort_init(), cb_emit_sort_using(), cb_emit_start(), cb_emit_unlock(), cb_emit_write(), cb_ref(), cb_validate_collating(), cb_validate_one(), cb_validate_program_body(), cb_validate_program_data(), cb_validate_program_environment(), check_valid_key(), emit_entry(), finalize_file(), global_check(), output(), output_call(), output_goto(), output_goto_1(), output_module_init(), output_perform(), output_perform_once(), output_perform_until(), output_search_whens(), and validate_inspect().

2505 {
2506  struct cb_reference *r;
2507  struct cb_field *p;
2508  struct cb_label *s;
2509  cb_tree candidate;
2510  cb_tree items;
2511  cb_tree cb1;
2512  cb_tree cb2;
2513  cb_tree v;
2514  cb_tree c;
2515  struct cb_program *prog;
2516  struct cb_word *w;
2517  size_t val;
2518  size_t ambiguous;
2519 
2520  if (CB_INVALID_TREE (x)) {
2521  return cb_error_node;
2522  }
2523  r = CB_REFERENCE (x);
2524  /* If this reference has already been resolved (and the value
2525  has been cached), then just return the value */
2526  if (r->value) {
2527  return r->value;
2528  }
2529 
2530  /* Resolve the value */
2531 
2532  candidate = NULL;
2533  ambiguous = 0;
2534  items = r->word->items;
2535  for (; items; items = CB_CHAIN (items)) {
2536  /* Find a candidate value by resolving qualification */
2537  v = CB_VALUE (items);
2538  c = r->chain;
2539  switch (CB_TREE_TAG (v)) {
2540  case CB_TAG_FIELD:
2541  /* In case the value is a field, it might be qualified
2542  by its parent names and a file name */
2543  if (CB_FIELD (v)->flag_indexed_by) {
2544  p = CB_FIELD (v)->index_qual;
2545  } else {
2546  p = CB_FIELD (v)->parent;
2547  }
2548  /* Resolve by parents */
2549  for (; p; p = p->parent) {
2550  if (c && strcasecmp (CB_NAME (c), p->name) == 0) {
2551  c = CB_REFERENCE (c)->chain;
2552  }
2553  }
2554 
2555  /* Resolve by file */
2556  if (c && CB_REFERENCE (c)->chain == NULL) {
2557  if (CB_WORD_COUNT (c) == 1 &&
2558  CB_FILE_P (cb_ref (c)) &&
2559  (CB_FILE (cb_ref (c)) == cb_field_founder (CB_FIELD (v))->file)) {
2560  c = CB_REFERENCE (c)->chain;
2561  }
2562  }
2563 
2564  break;
2565  case CB_TAG_LABEL:
2566  /* In case the value is a label, it might be qualified
2567  by its section name */
2568  s = CB_LABEL (v)->section;
2569 
2570  /* Unqualified paragraph name referenced within the section
2571  is resolved without ambiguity check if not duplicated */
2572  if (c == NULL && r->offset && s == CB_LABEL (r->offset)) {
2573  for (cb1 = CB_CHAIN (items); cb1; cb1 = CB_CHAIN (cb1)) {
2574  cb2 = CB_VALUE (cb1);
2575  if (s == CB_LABEL (cb2)->section) {
2576  ambiguous_error (x);
2577  goto error;
2578  }
2579  }
2580  candidate = v;
2581  goto end;
2582  }
2583 
2584  /* Resolve by section name */
2585  if (c && s && strcasecmp (CB_NAME (c), (char *)s->name) == 0) {
2586  c = CB_REFERENCE (c)->chain;
2587  }
2588 
2589  break;
2590  default:
2591  /* Other values cannot be qualified */
2592  break;
2593  }
2594 
2595  /* A well qualified value is a good candidate */
2596  if (c == NULL) {
2597  if (candidate == NULL) {
2598  /* Keep the first candidate */
2599  candidate = v;
2600  } else {
2601  /* Multiple candidates and possibly ambiguous */
2602  ambiguous = 1;
2603  /* Continue search because the reference might not
2604  be ambiguous and exit loop by "goto end" later */
2605  }
2606  }
2607  }
2608 
2609  /* There is no candidate */
2610  if (candidate == NULL) {
2611  if (likely(current_program->nested_level <= 0)) {
2612  goto undef_error;
2613  }
2614  /* Nested program - check parents for GLOBAL candidate */
2615  ambiguous = 0;
2616 /* RXWRXW
2617  val = hash ((const unsigned char *)r->word->name);
2618 */
2619  val = r->hashval;
2620  prog = current_program->next_program;
2621  for (; prog; prog = prog->next_program) {
2622  if (prog->nested_level >= current_program->nested_level) {
2623  continue;
2624  }
2625  for (w = prog->word_table[val]; w; w = w->next) {
2626  if (strcasecmp (r->word->name, w->name) == 0) {
2627  candidate = global_check (r, w->items, &ambiguous);
2628  if (candidate) {
2629  if (ambiguous) {
2630  ambiguous_error (x);
2631  goto error;
2632  }
2633  if (CB_FILE_P(candidate)) {
2634  current_program->flag_gen_error = 1;
2635  }
2636  goto end;
2637  }
2638  }
2639  }
2640  if (prog->nested_level == 0) {
2641  break;
2642  }
2643  }
2644  goto undef_error;
2645  }
2646 
2647  /* Reference is ambiguous */
2648  if (ambiguous) {
2649  ambiguous_error (x);
2650  goto error;
2651  }
2652 
2653 end:
2654  if (CB_FIELD_P (candidate)) {
2655  CB_FIELD (candidate)->count++;
2656  if (CB_FIELD (candidate)->flag_invalid) {
2657  goto error;
2658  }
2659  } else if (CB_LABEL_P (candidate) && r->flag_alter_code) {
2660  CB_LABEL (candidate)->flag_alter = 1;
2661  }
2662 
2663  r->value = candidate;
2664  return r->value;
2665 
2666 undef_error:
2667  undefined_error (x);
2668  /* Fall through */
2669 
2670 error:
2671  r->value = cb_error_node;
2672  return cb_error_node;
2673 }
void cb_set_system_names ( void  )

References cb_define_system_name().

2489 {
2490  cb_define_system_name ("CONSOLE");
2491  cb_define_system_name ("SYSIN");
2492  cb_define_system_name ("SYSIPT");
2493  cb_define_system_name ("STDIN");
2494  cb_define_system_name ("SYSOUT");
2495  cb_define_system_name ("STDOUT");
2496  cb_define_system_name ("SYSERR");
2497  cb_define_system_name ("STDERR");
2498  cb_define_system_name ("SYSLST");
2499  cb_define_system_name ("SYSLIST");
2500  cb_define_system_name ("FORMFEED");
2501 }
char* cb_to_cname ( const char *  s)

References cob_u8_t, cobc_parse_strdup(), copy, and p.

Referenced by build_file(), build_report(), cb_build_alphabet_name(), cb_build_class_name(), and cb_build_locale_name().

613 {
614  char *copy;
615  unsigned char *p;
616 
617  copy = cobc_parse_strdup (s);
618  for (p = (unsigned char *)copy; *p; p++) {
619  if (*p == '-' || *p == ' ') {
620  *p = '_';
621  } else {
622  *p = (cob_u8_t)toupper (*p);
623  }
624  }
625  return copy;
626 }
enum cb_category cb_tree_category ( cb_tree  x)

References _, cb_cast::cast_type, cb_tree_common::category, cb_picture::category, CB_CAST, CB_CAST_ADDR_OF_ADDR, CB_CAST_ADDRESS, CB_CAST_PROGRAM_POINTER, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_BOOLEAN, CB_CATEGORY_DATA_POINTER, CB_CATEGORY_PROGRAM_POINTER, CB_CATEGORY_UNKNOWN, CB_FIELD, CB_INTRINSIC, CB_REFERENCE, CB_TAG_ALPHABET_NAME, CB_TAG_BINARY_OP, CB_TAG_CAST, CB_TAG_FIELD, CB_TAG_INTRINSIC, CB_TAG_LOCALE_NAME, CB_TAG_REFERENCE, CB_TREE, cb_tree_category(), CB_TREE_TAG, CB_USAGE_POINTER, CB_USAGE_PROGRAM_POINTER, cb_field::children, COBC_ABORT, cobc_abort_pr(), cb_field::level, cb_reference::offset, p, cb_field::pic, cb_field::redefines, cb_field::rename_thru, cb_field::usage, and cb_reference::value.

Referenced by cb_build_constant(), cb_build_intrinsic(), and cb_tree_category().

653 {
654  struct cb_cast *p;
655  struct cb_reference *r;
656  struct cb_field *f;
657 
658  if (x == cb_error_node) {
659  return (enum cb_category)0;
660  }
661  if (x->category != CB_CATEGORY_UNKNOWN) {
662  return x->category;
663  }
664 
665  switch (CB_TREE_TAG (x)) {
666  case CB_TAG_CAST:
667  p = CB_CAST (x);
668  switch (p->cast_type) {
669  case CB_CAST_ADDRESS:
670  case CB_CAST_ADDR_OF_ADDR:
671  x->category = CB_CATEGORY_DATA_POINTER;
672  break;
673  case CB_CAST_PROGRAM_POINTER:
674  x->category = CB_CATEGORY_PROGRAM_POINTER;
675  break;
676  default:
677  cobc_abort_pr (_("Unexpected cast type -> %d"),
678  (int)(p->cast_type));
679  COBC_ABORT ();
680  }
681  break;
682  case CB_TAG_REFERENCE:
683  r = CB_REFERENCE (x);
684  if (r->offset) {
685  x->category = CB_CATEGORY_ALPHANUMERIC;
686  } else {
687  x->category = cb_tree_category (r->value);
688  }
689  break;
690  case CB_TAG_FIELD:
691  f = CB_FIELD (x);
692  if (f->children) {
693  x->category = CB_CATEGORY_ALPHANUMERIC;
694  } else if (f->usage == CB_USAGE_POINTER && f->level != 88) {
695  x->category = CB_CATEGORY_DATA_POINTER;
696  } else if (f->usage == CB_USAGE_PROGRAM_POINTER && f->level != 88) {
697  x->category = CB_CATEGORY_PROGRAM_POINTER;
698  } else {
699  switch (f->level) {
700  case 66:
701  if (f->rename_thru) {
702  x->category = CB_CATEGORY_ALPHANUMERIC;
703  } else {
704  x->category = cb_tree_category (CB_TREE (f->redefines));
705  }
706  break;
707  case 88:
708  x->category = CB_CATEGORY_BOOLEAN;
709  break;
710  default:
711  if (f->pic) {
712  x->category = f->pic->category;
713  } else {
714  x->category = (enum cb_category)0;
715  }
716  break;
717  }
718  }
719  break;
720  case CB_TAG_ALPHABET_NAME:
721  case CB_TAG_LOCALE_NAME:
722  x->category = CB_CATEGORY_ALPHANUMERIC;
723  break;
724  case CB_TAG_BINARY_OP:
725  x->category = CB_CATEGORY_BOOLEAN;
726  break;
727  case CB_TAG_INTRINSIC:
728  x->category = CB_INTRINSIC(x)->intr_tab->category;
729  break;
730  default:
731 #if 0 /* RXWRXW - Tree tag */
732  cobc_abort_pr (_("Unknown tree tag %d Category %d"),
733  (int)CB_TREE_TAG (x), (int)x->category);
734  COBC_ABORT ();
735 #endif
736  return CB_CATEGORY_UNKNOWN;
737  }
738 
739  return x->category;
740 }
enum cb_class cb_tree_class ( cb_tree  x)

References category_to_class_table, and CB_TREE_CATEGORY.

Referenced by cb_emit_set_to().

744 {
745 
746  return category_to_class_table[CB_TREE_CATEGORY (x)];
747 }
int cb_tree_type ( const cb_tree  x,
const struct cb_field *  f 
)

References _, CB_CATEGORY_ALPHABETIC, CB_CATEGORY_ALPHANUMERIC, CB_CATEGORY_ALPHANUMERIC_EDITED, CB_CATEGORY_DATA_POINTER, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, CB_CATEGORY_OBJECT_REFERENCE, CB_CATEGORY_PROGRAM_POINTER, CB_TREE_CATEGORY, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_6, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, 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_INDEX, CB_USAGE_LENGTH, CB_USAGE_LONG_DOUBLE, CB_USAGE_PACKED, cb_field::children, COB_TYPE_ALPHANUMERIC, COB_TYPE_ALPHANUMERIC_EDITED, COB_TYPE_GROUP, COB_TYPE_NUMERIC_BINARY, COB_TYPE_NUMERIC_DISPLAY, COB_TYPE_NUMERIC_DOUBLE, COB_TYPE_NUMERIC_EDITED, COB_TYPE_NUMERIC_FLOAT, COB_TYPE_NUMERIC_FP_BIN128, COB_TYPE_NUMERIC_FP_BIN32, COB_TYPE_NUMERIC_FP_BIN64, COB_TYPE_NUMERIC_FP_DEC128, COB_TYPE_NUMERIC_FP_DEC64, COB_TYPE_NUMERIC_L_DOUBLE, COB_TYPE_NUMERIC_PACKED, COBC_ABORT, cobc_abort_pr(), COBC_DUMB_ABORT, and cb_field::usage.

Referenced by initialize_type(), initialize_uniform_char(), and output_attr().

757 {
758  if (f->children) {
759  return COB_TYPE_GROUP;
760  }
761 
762  switch (CB_TREE_CATEGORY (x)) {
763  case CB_CATEGORY_ALPHABETIC:
764  case CB_CATEGORY_ALPHANUMERIC:
765  return COB_TYPE_ALPHANUMERIC;
766  case CB_CATEGORY_ALPHANUMERIC_EDITED:
767  return COB_TYPE_ALPHANUMERIC_EDITED;
768  case CB_CATEGORY_NUMERIC:
769  switch (f->usage) {
770  case CB_USAGE_DISPLAY:
771  return COB_TYPE_NUMERIC_DISPLAY;
772  case CB_USAGE_BINARY:
773  case CB_USAGE_COMP_5:
774  case CB_USAGE_COMP_X:
775  case CB_USAGE_INDEX:
776  case CB_USAGE_LENGTH:
777  return COB_TYPE_NUMERIC_BINARY;
778  case CB_USAGE_FLOAT:
779  return COB_TYPE_NUMERIC_FLOAT;
780  case CB_USAGE_DOUBLE:
781  return COB_TYPE_NUMERIC_DOUBLE;
782  case CB_USAGE_PACKED:
783  case CB_USAGE_COMP_6:
784  return COB_TYPE_NUMERIC_PACKED;
785  case CB_USAGE_LONG_DOUBLE:
786  return COB_TYPE_NUMERIC_L_DOUBLE;
787  case CB_USAGE_FP_BIN32:
788  return COB_TYPE_NUMERIC_FP_BIN32;
789  case CB_USAGE_FP_BIN64:
790  return COB_TYPE_NUMERIC_FP_BIN64;
791  case CB_USAGE_FP_BIN128:
792  return COB_TYPE_NUMERIC_FP_BIN128;
793  case CB_USAGE_FP_DEC64:
794  return COB_TYPE_NUMERIC_FP_DEC64;
795  case CB_USAGE_FP_DEC128:
796  return COB_TYPE_NUMERIC_FP_DEC128;
797  default:
798  cobc_abort_pr (_("Unexpected numeric usage -> %d"),
799  (int)f->usage);
800  COBC_ABORT ();
801  }
802  case CB_CATEGORY_NUMERIC_EDITED:
803  return COB_TYPE_NUMERIC_EDITED;
804  case CB_CATEGORY_OBJECT_REFERENCE:
805  case CB_CATEGORY_DATA_POINTER:
806  case CB_CATEGORY_PROGRAM_POINTER:
807  return COB_TYPE_NUMERIC_BINARY;
808  default:
809  cobc_abort_pr (_("Unexpected category -> %d"),
810  (int)CB_TREE_CATEGORY (x));
811  /* Use dumb variant */
812  COBC_DUMB_ABORT ();
813  }
814  /* NOT REACHED */
815 #ifndef _MSC_VER
816  return 0;
817 #endif
818 }
static void file_error ( cb_tree  name,
const char *  clause,
const char  errtype 
)
static

References _, cb_error_x(), CB_FILE_ERR_INVALID, CB_FILE_ERR_INVALID_FT, CB_FILE_ERR_REQUIRED, and CB_NAME.

Referenced by validate_file().

205 {
206  switch (errtype) {
207  case CB_FILE_ERR_REQUIRED:
208  cb_error_x (name, _("%s clause is required for file '%s'"),
209  clause, CB_NAME (name));
210  break;
211  case CB_FILE_ERR_INVALID_FT:
212  cb_error_x (name, _("%s clause is invalid for file '%s' (file type)"),
213  clause, CB_NAME (name));
214  break;
215  case CB_FILE_ERR_INVALID:
216  cb_error_x (name, _("%s clause is invalid for file '%s'"),
217  clause, CB_NAME (name));
218  break;
219  }
220 }
void finalize_file ( struct cb_file *  f,
struct cb_field *  records 
)

References _, cb_file::alt_key_list, cb_file::assign, cb_build_alphanumeric_literal(), cb_build_field(), cb_build_field_reference(), cb_build_implicit_field(), cb_build_reference(), CB_CHAIN, cb_error(), CB_FIELD, CB_FIELD_ADD, cb_field_founder(), CB_FIELD_PTR, cb_field_variable_size(), CB_FILE, CB_LIST_INIT, cb_ref(), CB_USAGE_UNSIGNED_INT, cb_validate_field(), CB_VALUE, COB_MINI_BUFF, COB_MINI_MAX, COB_ORG_INDEXED, COB_ORG_LINE_SEQUENTIAL, cobc_main_malloc(), cb_field::count, current_program, cb_field::file, cb_program::file_list, cb_field::flag_external, cb_file::flag_external, cb_file::flag_fileid, cb_file::flag_finalized, cb_program::flag_has_external, cb_field::flag_is_global, cb_file::flag_line_adv, cb_alt_key::key, cb_file::key, cb_file::linage, cb_file::linage_ctr, MAX_FD_RECORD, cb_field::name, cb_file::name, cb_alt_key::next, NULL, cb_field::occurs_min, cb_field::offset, cb_file::organization, p, cb_file::record, cb_file::record_max, cb_file::record_min, cb_field::redefines, cb_file::same_clause, scratch_buff, cb_field::sister, cb_field::size, cb_file::special, and cb_program::working_storage.

Referenced by cb_validate_program_data().

2268 {
2269  struct cb_field *p;
2270  struct cb_field *v;
2271  struct cb_alt_key *cbak;
2272  cb_tree l;
2273  cb_tree x;
2274 
2275  /* stdin/stderr and LINE ADVANCING are L/S */
2276  if (f->special || f->flag_line_adv) {
2277  f->organization = COB_ORG_LINE_SEQUENTIAL;
2278  }
2279  if (f->flag_fileid && !f->assign) {
2280  f->assign = cb_build_alphanumeric_literal (f->name,
2281  strlen (f->name));
2282  }
2283 
2284  if (f->key && f->organization == COB_ORG_INDEXED &&
2285  (l = cb_ref (f->key)) != cb_error_node) {
2286  v = cb_field_founder (CB_FIELD_PTR (l));
2287  for (p = records; p; p = p->sister) {
2288  if (p == v) {
2289  break;
2290  }
2291  }
2292  if (!p) {
2293  cb_error (_("Invalid KEY item '%s'"),
2294  CB_FIELD_PTR (l)->name);
2295  }
2296  }
2297  if (f->alt_key_list) {
2298  for (cbak = f->alt_key_list; cbak; cbak = cbak->next) {
2299  l = cb_ref (cbak->key);
2300  if (l == cb_error_node) {
2301  continue;
2302  }
2303  v = cb_field_founder (CB_FIELD_PTR (l));
2304  for (p = records; p; p = p->sister) {
2305  if (p == v) {
2306  break;
2307  }
2308  }
2309  if (!p) {
2310  cb_error (_("Invalid KEY item '%s'"),
2311  CB_FIELD_PTR (l)->name);
2312  }
2313  }
2314  }
2315 
2316  /* Check the record size if it is limited */
2317  for (p = records; p; p = p->sister) {
2318  if (f->record_min > 0) {
2319  if (p->size < f->record_min) {
2320  cb_error (_("Record size too small '%s'"),
2321  p->name);
2322  }
2323  }
2324  if (f->record_max > 0) {
2325  if (p->size > f->record_max) {
2326  cb_error (_("Record size too large '%s' (%d)"),
2327  p->name, p->size);
2328  }
2329  }
2330  }
2331 
2332  /* Compute the record size */
2333  if (f->record_min == 0) {
2334  if (records) {
2335  f->record_min = records->size;
2336  } else {
2337  f->record_min = 0;
2338  }
2339  }
2340  for (p = records; p; p = p->sister) {
2341  v = cb_field_variable_size (p);
2342  if (v && v->offset + v->size * v->occurs_min < f->record_min) {
2343  f->record_min = v->offset + v->size * v->occurs_min;
2344  }
2345  if (p->size < f->record_min) {
2346  f->record_min = p->size;
2347  }
2348  if (p->size > f->record_max) {
2349  f->record_max = p->size;
2350  }
2351  }
2352 
2353  if (f->record_max > MAX_FD_RECORD) {
2354  cb_error (_("Record size exceeds maximum allowed (%d) - File '%s'"),
2355  MAX_FD_RECORD, f->name);
2356  }
2357 
2358  if (f->same_clause) {
2359  for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
2360  if (CB_FILE (CB_VALUE (l))->same_clause == f->same_clause) {
2361  if (CB_FILE (CB_VALUE (l))->flag_finalized) {
2362  if (f->record_max > CB_FILE (CB_VALUE (l))->record->memory_size) {
2363  CB_FILE (CB_VALUE (l))->record->memory_size =
2364  f->record_max;
2365  }
2366  f->record = CB_FILE (CB_VALUE (l))->record;
2367  for (p = records; p; p = p->sister) {
2368  p->file = f;
2369  p->redefines = f->record;
2370  }
2371  for (p = f->record->sister; p; p = p->sister) {
2372  if (!p->sister) {
2373  p->sister = records;
2374  break;
2375  }
2376  }
2377  f->flag_finalized = 1;
2378  return;
2379  }
2380  }
2381  }
2382  }
2383  /* Create record */
2384  if (f->record_max == 0) {
2385  f->record_max = 32;
2386  f->record_min = 32;
2387  }
2388  if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
2389  f->record_min = 0;
2390  }
2391  if (!scratch_buff) {
2392  scratch_buff = cobc_main_malloc ((size_t)COB_MINI_BUFF);
2393  }
2394  snprintf (scratch_buff, (size_t)COB_MINI_MAX, "%s Record", f->name);
2395  f->record = CB_FIELD (cb_build_implicit_field (cb_build_reference (scratch_buff),
2396  f->record_max));
2397  f->record->sister = records;
2398  f->record->count++;
2399  if (f->flag_external) {
2400  current_program->flag_has_external = 1;
2401  f->record->flag_external = 1;
2402  }
2403 
2404  for (p = records; p; p = p->sister) {
2405  p->file = f;
2406  p->redefines = f->record;
2407 #if 1 /* RXWRXW - Global/External */
2408  if (p->flag_is_global) {
2409  f->record->flag_is_global = 1;
2410  }
2411 #endif
2412  }
2413  f->flag_finalized = 1;
2414  if (f->linage) {
2415  snprintf (scratch_buff, (size_t)COB_MINI_MAX,
2416  "LINAGE-COUNTER %s", f->name);
2417  x = cb_build_field (cb_build_reference (scratch_buff));
2418  CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
2419  CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
2420  CB_FIELD (x)->count++;
2421  cb_validate_field (CB_FIELD (x));
2422  f->linage_ctr = cb_build_field_reference (CB_FIELD (x), NULL);
2423  CB_FIELD_ADD (current_program->working_storage, CB_FIELD (x));
2424  }
2425 }
static cb_tree global_check ( struct cb_reference *  r,
cb_tree  items,
size_t *  ambiguous 
)
static

References CB_CHAIN, CB_FIELD, cb_field_founder(), CB_FIELD_P, CB_FILE, CB_FILE_P, CB_NAME, cb_ref(), CB_REFERENCE, CB_VALUE, CB_WORD_COUNT, cb_reference::chain, file, cb_field::flag_indexed_by, cb_field::flag_is_global, cb_field::name, NULL, p, and cb_field::parent.

Referenced by cb_ref().

452 {
453  cb_tree candidate;
454  struct cb_field *p;
455  cb_tree v;
456  cb_tree c;
457 
458  candidate = NULL;
459  for (; items; items = CB_CHAIN (items)) {
460  /* Find a candidate value by resolving qualification */
461  v = CB_VALUE (items);
462  c = r->chain;
463  if (CB_FIELD_P (v)) {
464  if (!CB_FIELD (v)->flag_is_global) {
465  continue;
466  }
467  /* In case the value is a field, it might be qualified
468  by its parent names and a file name */
469  if (CB_FIELD (v)->flag_indexed_by) {
470  p = CB_FIELD (v)->index_qual;
471  } else {
472  p = CB_FIELD (v)->parent;
473  }
474  /* Resolve by parents */
475  for (; p; p = p->parent) {
476  if (c && strcasecmp (CB_NAME (c), p->name) == 0) {
477  c = CB_REFERENCE (c)->chain;
478  }
479  }
480 
481  /* Resolve by file */
482  if (c && CB_REFERENCE (c)->chain == NULL) {
483  if (CB_WORD_COUNT (c) == 1 &&
484  CB_FILE_P (cb_ref (c)) &&
485  (CB_FILE (cb_ref (c)) == cb_field_founder (CB_FIELD (v))->file)) {
486  c = CB_REFERENCE (c)->chain;
487  }
488  }
489  }
490  /* A well qualified value is a good candidate */
491  if (c == NULL) {
492  if (candidate == NULL) {
493  /* Keep the first candidate */
494  candidate = v;
495  } else {
496  /* Multiple candidates and possibly ambiguous */
497  *ambiguous = 1;
498  }
499  }
500  }
501  return candidate;
502 }
static size_t hash ( const unsigned char *  s)
static

References CB_WORD_HASH_MASK, and CB_WORD_HASH_SIZE.

Referenced by lookup_word().

150 {
151  size_t val;
152  size_t pos;
153 
154  /* Hash a name */
155  /* We multiply by position to get a better distribution */
156  val = 0;
157  pos = 1;
158  for (; *s; s++, pos++) {
159  val += pos * toupper (*s);
160  }
161 #if 0 /* RXWRXW - Hash remainder */
162  return val % CB_WORD_HASH_SIZE;
163 #endif
164  return val & CB_WORD_HASH_MASK;
165 }
static int iso_8601_func ( const enum cb_intr_enum  intr)
static

References CB_INTR_FORMATTED_CURRENT_DATE, CB_INTR_FORMATTED_DATE, CB_INTR_FORMATTED_DATETIME, CB_INTR_FORMATTED_TIME, CB_INTR_INTEGER_OF_FORMATTED_DATE, CB_INTR_SECONDS_FROM_FORMATTED_TIME, and CB_INTR_TEST_FORMATTED_DATETIME.

Referenced by cb_build_intrinsic().

506 {
507  return intr == CB_INTR_FORMATTED_CURRENT_DATE
508  || intr == CB_INTR_FORMATTED_DATE
509  || intr == CB_INTR_FORMATTED_DATETIME
510  || intr == CB_INTR_FORMATTED_TIME
511  || intr == CB_INTR_INTEGER_OF_FORMATTED_DATE
512  || intr == CB_INTR_SECONDS_FROM_FORMATTED_TIME
513  || intr == CB_INTR_TEST_FORMATTED_DATETIME;
514 }
static void lookup_word ( struct cb_reference *  p,
const char *  name 
)
static

References cobc_parse_malloc(), cobc_parse_strdup(), current_program, cb_reference::flag_duped, hash(), cb_reference::hashval, likely, cb_word::name, cb_word::next, cb_reference::word, and cb_program::word_table.

Referenced by cb_build_reference().

169 {
170  struct cb_word *w;
171  size_t val;
172 
173  val = hash ((const unsigned char *)name);
174  /* Find an existing word */
175  if (likely(current_program)) {
176  for (w = current_program->word_table[val]; w; w = w->next) {
177  if (strcasecmp (w->name, name) == 0) {
178  p->word = w;
179  p->hashval = val;
180  p->flag_duped = 1;
181  return;
182  }
183  }
184  }
185 
186  /* Create new word */
187  w = cobc_parse_malloc (sizeof (struct cb_word));
188  w->name = cobc_parse_strdup (name);
189 
190  /* Insert it into the table */
191  if (likely(current_program)) {
192  w->next = current_program->word_table[val];
193  current_program->word_table[val] = w;
194  }
195  p->word = w;
196  p->hashval = val;
197 }
static cb_tree make_constant ( const enum cb_category  category,
const char *  val 
)
static

References CB_TAG_CONST, CB_TREE, make_tree(), p, and cb_const::val.

Referenced by cb_init_constants().

238 {
239  struct cb_const *p;
240 
241  p = make_tree (CB_TAG_CONST, category, sizeof (struct cb_const));
242  p->val = val;
243  return CB_TREE (p);
244 }
static cb_tree make_constant_label ( const char *  name)
static

References cb_build_label(), cb_build_reference(), CB_LABEL, CB_TREE, cb_label::flag_begin, NULL, and p.

Referenced by cb_init_constants().

248 {
249  struct cb_label *p;
250 
251  p = CB_LABEL (cb_build_label (cb_build_reference (name), NULL));
252  p->flag_begin = 1;
253  return CB_TREE (p);
254 }
static cb_tree make_intrinsic ( cb_tree  name,
struct cb_intrinsic_table *  cbp,
cb_tree  args,
cb_tree  field,
cb_tree  refmod,
const int  isuser 
)
static

References _, cb_intrinsic::args, cb_intrinsic_table::category, CB_CHAIN, cb_error(), cb_error_node, CB_PAIR_X, CB_PAIR_Y, CB_TAG_CONST, CB_TAG_DECIMAL, CB_TAG_FIELD, CB_TAG_INTEGER, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE, CB_TREE_TAG, CB_VALUE, cb_intrinsic::intr_field, cb_intrinsic::intr_tab, cb_intrinsic::isuser, cb_intrinsic::length, make_tree(), cb_intrinsic_table::name, cb_intrinsic::name, and cb_intrinsic::offset.

Referenced by cb_build_any_intrinsic(), and cb_build_intrinsic().

413 {
414  struct cb_intrinsic *x;
415 
416 #if 0 /* RXWRXW Leave in, we may need this */
417  cb_tree l;
418  for (l = args; l; l = CB_CHAIN(l)) {
419  switch (CB_TREE_TAG (CB_VALUE(l))) {
420  case CB_TAG_CONST:
421  case CB_TAG_INTEGER:
422  case CB_TAG_LITERAL:
423  case CB_TAG_DECIMAL:
424  case CB_TAG_FIELD:
425  case CB_TAG_REFERENCE:
426  case CB_TAG_INTRINSIC:
427  break;
428  default:
429  cb_error (_("FUNCTION %s has invalid/not supported arguments - Tag %d"),
430  cbp->name, CB_TREE_TAG(l));
431  return cb_error_node;
432 
433  }
434  }
435 #endif
436 
437  x = make_tree (CB_TAG_INTRINSIC, cbp->category, sizeof (struct cb_intrinsic));
438  x->name = name;
439  x->args = args;
440  x->intr_tab = cbp;
441  x->intr_field = field;
442  x->isuser = isuser;
443  if (refmod) {
444  x->offset = CB_PAIR_X (refmod);
445  x->length = CB_PAIR_Y (refmod);
446  }
447  return CB_TREE (x);
448 }
static void* make_tree ( const enum cb_tag  tag,
const enum cb_category  category,
const size_t  size 
)
static

References cb_tree_common::category, cobc_parse_malloc(), and cb_tree_common::tag.

Referenced by build_file(), build_literal(), build_report(), cb_build_alphabet_name(), cb_build_alter(), cb_build_assign(), cb_build_binary_op(), cb_build_binary_picture(), cb_build_call(), cb_build_cancel(), cb_build_cast(), cb_build_cast_int(), cb_build_cast_llint(), cb_build_class_name(), cb_build_comment(), cb_build_continue(), cb_build_debug(), cb_build_debug_call(), cb_build_decimal(), cb_build_field(), cb_build_funcall(), cb_build_goto(), cb_build_if(), cb_build_initialize(), cb_build_label(), cb_build_list(), cb_build_locale_name(), cb_build_perform(), cb_build_perform_varying(), cb_build_picture(), cb_build_reference(), cb_build_search(), cb_build_set_attribute(), cb_build_statement(), cb_build_string(), cb_build_system_name(), cb_concat_literals(), make_constant(), and make_intrinsic().

227 {
228  cb_tree x;
229 
230  x = cobc_parse_malloc (size);
231  x->tag = tag;
232  x->category = category;
233  return x;
234 }
static int offset_arg_param_num ( const enum cb_intr_enum  intr)
static

References CB_INTR_FORMATTED_DATETIME, and CB_INTR_FORMATTED_TIME.

Referenced by valid_const_date_time_args().

570 {
571  if (intr == CB_INTR_FORMATTED_TIME) {
572  return 3;
573  } else if (intr == CB_INTR_FORMATTED_DATETIME) {
574  return 4;
575  } else {
576  return 0;
577  }
578 }
static int offset_time_format ( const char *  format)
static

References cob_valid_datetime_format(), cob_valid_time_format(), and NULL.

Referenced by valid_const_date_time_args().

558 {
559  if (cob_valid_time_format (format)
560  || cob_valid_datetime_format (format)) {
561  /* Only offset time formats contain a '+'. */
562  return strchr (format, '+') != NULL;
563  } else {
564  return 0;
565  }
566 }
static const char* try_get_constant_data ( cb_tree  val)
static

References CB_CONST, CB_CONST_P, CB_LITERAL, CB_LITERAL_P, and NULL.

Referenced by valid_const_date_time_args().

544 {
545  if (val == NULL) {
546  return NULL;
547  } else if (CB_LITERAL_P (val)) {
548  return (char *) CB_LITERAL (val)->data;
549  } else if (CB_CONST_P (val)) {
550  return CB_CONST (val)->val;
551  } else {
552  return NULL;
553  }
554 }
static int valid_const_date_time_args ( const cb_tree  tree,
const struct cb_intrinsic_table *  intr,
cb_tree  args 
)
static

References _, cb_error_x(), cb_list_length(), CB_VALUE, cb_warning_x(), cb_intrinsic_table::intr_enum, cb_intrinsic_table::name, NULL, offset_arg_param_num(), offset_time_format(), try_get_constant_data(), and valid_format().

Referenced by cb_build_intrinsic().

583 {
584  cb_tree arg = CB_VALUE (args);
585  const char *data;
586  int error_found = 0;
587 
588  /* Precondition: iso_8601_func (intr->intr_enum) */
589 
590  data = try_get_constant_data (arg);
591  if (data != NULL) {
592  if(!valid_format (intr->intr_enum, data)) {
593  cb_error_x (tree, _("FUNCTION '%s' has invalid date/time format"),
594  intr->name);
595  error_found = 1;
596  } else if (offset_time_format (data)
597  && cb_list_length (args) < offset_arg_param_num (intr->intr_enum)) {
598  cb_error_x (tree, _("FUNCTION '%s' does not have an offset time"),
599  intr->name);
600  }
601  } else {
602  cb_warning_x (tree, _("FUNCTION '%s' has format in variable"),
603  intr->name);
604  }
605 
606  return !error_found;
607 }
static int valid_format ( const enum cb_intr_enum  intr,
const char *  format 
)
static

References CB_INTR_FORMATTED_CURRENT_DATE, CB_INTR_FORMATTED_DATE, CB_INTR_FORMATTED_DATETIME, CB_INTR_FORMATTED_TIME, CB_INTR_INTEGER_OF_FORMATTED_DATE, CB_INTR_SECONDS_FROM_FORMATTED_TIME, cob_valid_date_format(), cob_valid_datetime_format(), and cob_valid_time_format().

Referenced by valid_const_date_time_args().

518 {
519  /* Precondition: iso_8601_func (intr) */
520 
521  if (intr == CB_INTR_FORMATTED_CURRENT_DATE) {
522  return cob_valid_datetime_format (format);
523  } else if(intr == CB_INTR_FORMATTED_DATE) {
524  return cob_valid_date_format (format);
525  } else if(intr == CB_INTR_FORMATTED_DATETIME) {
526  return cob_valid_datetime_format (format);
527  } else if(intr == CB_INTR_FORMATTED_TIME) {
528  return cob_valid_time_format (format);
529  } else if(intr == CB_INTR_INTEGER_OF_FORMATTED_DATE) {
530  return cob_valid_date_format (format)
531  || cob_valid_datetime_format (format);
532  } else if(intr == CB_INTR_SECONDS_FROM_FORMATTED_TIME) {
533  return cob_valid_time_format (format)
534  || cob_valid_datetime_format (format);
535  } else { /* CB_INTR_TEST_FORMATTED_DATETIME */
536  return cob_valid_time_format (format)
537  || cob_valid_date_format (format)
538  || cob_valid_datetime_format (format);
539  }
540 }
void validate_file ( struct cb_file *  f,
cb_tree  name 
)

References cb_file::access_mode, cb_file::alt_key_list, cb_file::assign, CB_FILE_ERR_INVALID, CB_FILE_ERR_INVALID_FT, CB_FILE_ERR_REQUIRED, COB_ACCESS_DYNAMIC, COB_ACCESS_RANDOM, COB_ACCESS_SEQUENTIAL, COB_ORG_INDEXED, COB_ORG_RELATIVE, COB_ORG_SORT, file_error(), cb_file::flag_fileid, cb_file::key, NULL, and cb_file::organization.

2219 {
2220  /* Check ASSIGN clause
2221  Currently break's GNU COBOL's extension for SORT FILEs having no need
2222  for an ASSIGN clause (tested in run_extensions "SORT ASSIGN ..."
2223  According to the Programmer's Guide for 1.1 the ASSIGN is totally
2224  ignored as the SORT is either done in memory (if there's enough space)
2225  or in a temporary disk file.
2226  For supporting this f->organization = COB_ORG_SORT is done when we
2227  see an SD in FILE SECTION for the file, while validate_file is called
2228  in INPUT-OUTPUT Section.
2229  */
2230  if (!f->assign && f->organization != COB_ORG_SORT && !f->flag_fileid) {
2231  file_error (name, "ASSIGN", CB_FILE_ERR_REQUIRED);
2232  }
2233  /* Check RECORD/RELATIVE KEY clause */
2234  switch (f->organization) {
2235  case COB_ORG_INDEXED:
2236  if (f->key == NULL) {
2237  file_error (name, "RECORD KEY", CB_FILE_ERR_REQUIRED);
2238  }
2239  break;
2240  case COB_ORG_RELATIVE:
2241  if (f->key == NULL && f->access_mode != COB_ACCESS_SEQUENTIAL) {
2242  file_error (name, "RELATIVE KEY", CB_FILE_ERR_REQUIRED);
2243  }
2244  if (f->alt_key_list) {
2245  file_error (name, "ALTERNATE", CB_FILE_ERR_INVALID_FT);
2246  f->alt_key_list = NULL;
2247  }
2248  break;
2249  default:
2250  if (f->key) {
2251  file_error (name, "RECORD", CB_FILE_ERR_INVALID_FT);
2252  f->key = NULL;
2253  }
2254  if (f->alt_key_list) {
2255  file_error (name, "ALTERNATE", CB_FILE_ERR_INVALID_FT);
2256  f->alt_key_list = NULL;
2257  }
2258  if (f->access_mode == COB_ACCESS_DYNAMIC ||
2259  f->access_mode == COB_ACCESS_RANDOM) {
2260  file_error (name, "ORGANIZATION", CB_FILE_ERR_INVALID);
2261  }
2262  break;
2263  }
2264 }

Variable Documentation

int category_is_alphanumeric[]
static
Initial value:
= {
0,
1,
1,
1,
0,
0,
1,
1,
0,
1,
0,
0,
0
}

Referenced by cb_category_is_alpha().

enum cb_class category_to_class_table[]
static
Initial value:
= {
CB_CLASS_UNKNOWN,
CB_CLASS_ALPHABETIC,
CB_CLASS_ALPHANUMERIC,
CB_CLASS_ALPHANUMERIC,
CB_CLASS_BOOLEAN,
CB_CLASS_INDEX,
CB_CLASS_NATIONAL,
CB_CLASS_NATIONAL,
CB_CLASS_NUMERIC,
CB_CLASS_ALPHANUMERIC,
CB_CLASS_OBJECT,
CB_CLASS_POINTER,
CB_CLASS_POINTER
}

Referenced by cb_tree_class().

cb_tree cb_any

Referenced by cb_build_cond(), and evaluate_test().

const char* const cb_const_subs[]
static
Initial value:
= {
"i0",
"i1",
"i2",
"i3",
"i4",
"i5",
"i6",
"i7",
"i8",
"i9",
"i10",
"i11",
"i12",
"i13",
"i14",
"i15",
NULL
}

Referenced by cb_init_constants().

cb_tree cb_error_node

Referenced by build_cond_88(), build_evaluate(), cb_build_address(), cb_build_assignment_name(), cb_build_binary_op(), cb_build_cond(), cb_build_const_length(), cb_build_display_mnemonic(), cb_build_display_name(), cb_build_field_tree(), cb_build_identifier(), cb_build_intrinsic(), cb_build_length(), cb_build_locale_name(), cb_build_move(), cb_build_perform_forever(), cb_build_perform_once(), cb_build_perform_times(), cb_build_ppointer(), cb_build_section_name(), cb_build_unstring_delimited(), cb_build_unstring_into(), cb_build_write_advancing_mnemonic(), cb_check_data_incompat(), cb_check_field_debug(), cb_check_group_name(), cb_check_integer_value(), cb_check_lit_subs(), cb_check_numeric_edited_name(), cb_check_numeric_name(), cb_check_numeric_value(), cb_concat_literals(), cb_define_switch_name(), cb_emit_accept_mnemonic(), cb_emit_alter(), cb_emit_arithmetic(), cb_emit_call(), cb_emit_close(), cb_emit_delete(), cb_emit_delete_file(), cb_emit_display(), cb_emit_goto(), cb_emit_open(), cb_emit_perform(), cb_emit_read(), cb_emit_return(), cb_emit_rewrite(), cb_emit_search(), cb_emit_search_all(), cb_emit_set_false(), cb_emit_set_to(), cb_emit_set_true(), cb_emit_sort_init(), cb_emit_start(), cb_emit_unlock(), cb_emit_write(), cb_expr_finish(), cb_ref(), cb_validate_one(), cb_validate_program_body(), cb_validate_program_data(), cb_validate_program_environment(), check_picture_item(), check_valid_key(), emit_entry(), expr_reduce(), make_intrinsic(), output_move(), output_stmt(), scan_h(), scan_x(), search_set_keys(), validate_inspect(), and while().

cb_tree cb_false

Referenced by cb_build_cond(), evaluate_test(), and output_cond().

cb_tree cb_high

Referenced by cb_build_add(), cb_build_cond(), cb_build_move(), cb_build_move_high(), cb_init_constants(), cb_validate_88_item(), cb_validate_collating(), cb_validate_program_environment(), check_78_replace(), literal_value(), output_class_name_definition(), output_funcall(), output_initialize_one(), and validate_move().

cb_tree cb_i[COB_MAX_SUBSCRIPTS]

Referenced by output_initialize(), output_initialize_compound(), and output_initialize_one().

cb_tree cb_int0

Referenced by cb_build_add(), cb_build_display_mnemonic(), cb_build_display_name(), cb_build_move_num_zero(), cb_build_optim_add(), cb_build_optim_sub(), cb_build_sub(), cb_build_unstring_into(), cb_build_write_advancing_mnemonic(), cb_emit_close(), cb_emit_display(), cb_emit_divide(), cb_emit_open(), cb_emit_set_up_down(), cb_emit_string(), cb_emit_write(), decimal_expand(), and output_param().

cb_tree cb_int1

Referenced by bit_set_attr(), cb_build_display_mnemonic(), cb_build_display_name(), cb_build_identifier(), cb_build_sub(), cb_emit_exit(), cb_emit_read(), cb_emit_rewrite(), cb_emit_write(), cb_validate_program_environment(), output_goto(), output_initialize_compound(), output_internal_function(), and output_param().

cb_tree cb_int2

Referenced by cb_emit_read().

cb_tree cb_int3

Referenced by cb_emit_read().

cb_tree cb_int4

Referenced by cb_emit_read().

cb_tree cb_int5
cb_tree cb_intr_whencomp = NULL

Referenced by cb_build_intrinsic(), and cb_build_registers().

cb_tree cb_low

Referenced by cb_build_cond(), cb_build_move(), cb_build_move_low(), cb_emit_display(), cb_init_constants(), cb_validate_88_item(), cb_validate_collating(), cb_validate_program_environment(), check_78_replace(), literal_value(), output_class_name_definition(), output_funcall(), output_initialize_one(), and validate_move().

cb_tree cb_norm_high

Referenced by cb_build_move_high(), cb_validate_program_environment(), get_value(), literal_value(), and output_param().

cb_tree cb_norm_low

Referenced by cb_build_move_low(), cb_validate_program_environment(), get_value(), literal_value(), and output_param().

cb_tree cb_null

Referenced by cb_build_move(), cb_emit_accept(), cb_emit_call(), cb_emit_display(), check_78_replace(), expr_chk_cond(), get_value(), literal_value(), output_call(), output_class_name_definition(), output_data(), output_initialize_one(), output_integer(), output_long_integer(), and output_stmt().

cb_tree cb_one

Referenced by cb_build_address(), and cb_build_identifier().

cb_tree cb_quote

Referenced by cb_build_move(), cb_build_move_quote(), cb_validate_88_item(), check_78_replace(), get_value(), literal_value(), output_class_name_definition(), output_initialize_one(), output_param(), and validate_move().

cb_tree cb_space

Referenced by cb_build_cond(), cb_build_debug_item(), cb_build_move(), cb_build_move_space(), cb_emit_close(), cb_emit_display(), cb_emit_open(), cb_validate_88_item(), check_78_replace(), get_value(), literal_value(), output_class_name_definition(), output_funcall(), output_goto_1(), output_initialize_one(), output_param(), output_stmt(), and validate_move().

cb_tree cb_standard_error_handler = NULL

Referenced by output_error_handler(), and output_section_info().

cb_tree cb_true

Referenced by cb_build_cond(), cb_emit_allocate(), cb_emit_initialize(), evaluate_test(), output_cond(), and output_initial_values().

cb_tree cb_zero

Referenced by cb_build_cond(), cb_build_move(), cb_build_move_num_zero(), cb_build_move_zero(), cb_build_registers(), cb_check_integer_value(), cb_expr_shift(), cb_expr_shift_sign(), cb_validate_program_data(), check_78_replace(), decimal_expand(), get_value(), literal_value(), output_class_name_definition(), output_funcall(), output_initialize_one(), output_integer(), output_long_integer(), output_param(), output_stmt(), and validate_move().

int class_id = 0
static

Referenced by cb_build_class_name().

struct cb_program* container_progs[64]
static
int filler_id = 1
static

Referenced by cb_build_filler().

unsigned int gen_screen_ptr = 0

Referenced by cb_build_funcall(), cb_emit_accept(), and cb_emit_display().

struct int_node* int_node_table = NULL
static

Referenced by cb_int().

char* pic_buff = NULL
static

Referenced by cb_build_picture().

char* scratch_buff = NULL
static

Referenced by cb_build_class_name(), and finalize_file().

int toplev_count
static

Referenced by cb_build_program().

struct cb_intrinsic_table userbp
static
Initial value:
=
{ "USER FUNCTION", "cob_user_function", -1, 1,
CB_INTR_USER_FUNCTION, CB_CATEGORY_NUMERIC,
0, 0, 0 }