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

Data Structures

struct  sort_list
 
struct  system_table
 
struct  label_list
 
struct  string_list
 
struct  attr_list
 
struct  literal_list
 
struct  field_list
 
struct  call_list
 
struct  base_list
 

Macros

#define COB_ALIGN   ""
 
#define COB_MAX_SUBSCRIPTS   16
 
#define COB_MALLOC_ALIGN   15
 
#define COB_INSIDE_SIZE   64
 
#define INITIALIZE_NONE   0
 
#define INITIALIZE_ONE   1
 
#define INITIALIZE_DEFAULT   2
 
#define INITIALIZE_COMPOUND   3
 
#define CB_NEED_HIGH   (1U << 0)
 
#define CB_NEED_LOW   (1U << 1)
 
#define CB_NEED_QUOTE   (1U << 2)
 
#define CB_NEED_SPACE   (1U << 3)
 
#define CB_NEED_ZERO   (1U << 4)
 
#define COB_SYSTEM_GEN(x, y, z)   { x, #z },
 

Functions

static void output (const char *,...)
 
static int lookup_string (const char *p)
 
static void lookup_call (const char *p)
 
static void lookup_func_call (const char *p)
 
static struct attr_list * attr_list_reverse (struct attr_list *p)
 
static struct string_list * string_list_reverse (struct string_list *p)
 
static struct literal_list * literal_list_reverse (struct literal_list *p)
 
static int field_cache_cmp (const void *mp1, const void *mp2)
 
static int base_cache_cmp (const void *mp1, const void *mp2)
 
static void * list_cache_sort (void *inlist, int(*cmpfunc)(const void *mp1, const void *mp2))
 
static void output_newline (void)
 
static void output_prefix (void)
 
static void output_line (const char *fmt,...)
 
static void output_indent (const char *str)
 
static void output_string (const unsigned char *s, const int size, const cob_u32_t llit)
 
static void output_storage (const char *fmt,...)
 
static void output_local (const char *fmt,...)
 
static struct cb_field * real_field_founder (const struct cb_field *f)
 
static struct cb_field * chk_field_variable_size (struct cb_field *f)
 
static unsigned int chk_field_variable_address (struct cb_field *fld)
 
static void output_base (struct cb_field *f, const cob_u32_t no_output)
 
static void output_data (cb_tree x)
 
static void output_size (const cb_tree x)
 
static int lookup_attr (const int type, const cob_u32_t digits, const int scale, const cob_u32_t flags, unsigned char *pic, const int lenstr)
 
static char * user_func_upper (const char *func)
 
static void output_attr (const cb_tree x)
 
static void output_field (cb_tree x)
 
static int lookup_literal (cb_tree x)
 
static void output_integer (cb_tree x)
 
static void output_long_integer (cb_tree x)
 
static void output_index (cb_tree x)
 
static void output_param (cb_tree x, int id)
 
static void output_funcall (cb_tree x)
 
static void output_func_1 (const char *name, cb_tree x)
 
static void output_cond (cb_tree x, const int save_flag)
 
static void output_move (cb_tree src, cb_tree dst)
 
static int initialize_type (struct cb_initialize *p, struct cb_field *f, const int topfield)
 
static int initialize_uniform_char (const struct cb_field *f, const struct cb_initialize *p)
 
static void output_figurative (cb_tree x, const struct cb_field *f, const int value, const int init_occurs)
 
static void output_initialize_literal (cb_tree x, struct cb_field *f, struct cb_literal *l, const int init_occurs)
 
static void output_initialize_fp_bindec (cb_tree x, struct cb_field *f)
 
static void output_initialize_fp (cb_tree x, struct cb_field *f)
 
static void output_initialize_uniform (cb_tree x, const int c, const int size)
 
static void output_initialize_one (struct cb_initialize *p, cb_tree x)
 
static void output_initialize_compound (struct cb_initialize *p, cb_tree x)
 
static void output_initialize (struct cb_initialize *p)
 
static void output_occurs (struct cb_field *p)
 
static void output_search_whens (cb_tree table, cb_tree var, cb_tree stmt, cb_tree whens)
 
static void output_search_all (cb_tree table, cb_tree stmt, cb_tree cond, cb_tree when)
 
static void output_search (struct cb_search *p)
 
static void output_call_by_value_args (cb_tree x, cb_tree l)
 
static void output_bin_field (const cb_tree x, const cob_u32_t id)
 
static void output_call (struct cb_call *p)
 
static void output_set_attribute (const struct cb_field *f, const int val_on, const int val_off)
 
static void output_cancel (struct cb_cancel *p)
 
static void output_perform_call (struct cb_label *lb, struct cb_label *le)
 
static void output_perform_exit (struct cb_label *l)
 
static void output_funcall_debug (cb_tree x)
 
static void output_cond_debug (cb_tree x)
 
static void output_perform_once (struct cb_perform *p)
 
static void output_perform_until (struct cb_perform *p, cb_tree l)
 
static void output_perform (struct cb_perform *p)
 
static void output_file_error (struct cb_file *pfile)
 
static void output_goto_1 (cb_tree x)
 
static void output_goto (struct cb_goto *p)
 
static void output_alter (struct cb_alter *p)
 
static void output_ferror_stmt (struct cb_statement *p, const int code)
 
static void output_section_info (struct cb_label *lp)
 
static void output_trace_info (cb_tree x, struct cb_statement *p)
 
static void output_label_info (cb_tree x, struct cb_label *lp)
 
static void output_alter_check (struct cb_label *lp)
 
static void output_stmt (cb_tree x)
 
static int output_file_allocation (struct cb_file *f)
 
static void output_file_initialization (struct cb_file *f)
 
static void output_screen_definition (struct cb_field *p)
 
static void output_screen_init (struct cb_field *p)
 
static int literal_value (cb_tree x)
 
static void output_alphabet_name_definition (struct cb_alphabet_name *p)
 
static void output_class_name_definition (struct cb_class_name *p)
 
static void output_initial_values (struct cb_field *f)
 
static void output_error_handler (struct cb_program *prog)
 
static void output_module_init (struct cb_program *prog)
 
static void output_internal_function (struct cb_program *prog, cb_tree parameter_list)
 
static void output_entry_function (struct cb_program *prog, cb_tree entry, cb_tree parameter_list, const int gencode)
 
static void output_main_function (struct cb_program *prog)
 
static void output_header (FILE *fp, const char *locbuff, const struct cb_program *cp)
 
void codegen (struct cb_program *prog, const int nested)
 

Variables

static struct attr_list * attr_cache = NULL
 
static struct literal_list * literal_cache = NULL
 
static struct field_list * field_cache = NULL
 
static struct field_list * local_field_cache = NULL
 
static struct call_list * call_cache = NULL
 
static struct call_list * func_call_cache = NULL
 
static struct base_list * base_cache = NULL
 
static struct base_list * globext_cache = NULL
 
static struct base_list * local_base_cache = NULL
 
static struct string_list * string_cache = NULL
 
static char * string_buffer = NULL
 
static struct label_list * label_cache = NULL
 
static FILE * output_target = NULL
 
static FILE * cb_local_file = NULL
 
static const char * excp_current_program_id = NULL
 
static const char * excp_current_section = NULL
 
static const char * excp_current_paragraph = NULL
 
static struct cb_program * current_prog = NULL
 
static struct cb_label * last_section = NULL
 
static unsigned char * litbuff = NULL
 
static int litsize = 0
 
static unsigned int needs_exit_prog = 0
 
static unsigned int needs_unifunc = 0
 
static unsigned int need_save_exception = 0
 
static unsigned int gen_nested_tab = 0
 
static unsigned int gen_alt_ebcdic = 0
 
static unsigned int gen_ebcdic_ascii = 0
 
static unsigned int gen_full_ebcdic = 0
 
static unsigned int gen_native = 0
 
static unsigned int gen_custom = 0
 
static unsigned int gen_figurative = 0
 
static unsigned int gen_dynamic = 0
 
static int param_id = 0
 
static int stack_id = 0
 
static int string_id
 
static int num_cob_fields = 0
 
static int non_nested_count = 0
 
static int loop_counter = 0
 
static int progid = 0
 
static int last_line = 0
 
static cob_u32_t field_iteration = 0
 
static int screenptr = 0
 
static int local_mem = 0
 
static int working_mem = 0
 
static int local_working_mem = 0
 
static int output_indent_level = 0
 
static int last_segment = 0
 
static int gen_if_level = 0
 
static unsigned int nolitcast = 0
 
static unsigned int inside_check = 0
 
static unsigned int inside_stack [COB_INSIDE_SIZE]
 
static unsigned int i_counters [COB_MAX_SUBSCRIPTS]
 
static struct system_table system_tab []
 

Macro Definition Documentation

#define CB_NEED_HIGH   (1U << 0)

Referenced by codegen(), and output_param().

#define CB_NEED_LOW   (1U << 1)

Referenced by codegen(), and output_param().

#define CB_NEED_QUOTE   (1U << 2)

Referenced by codegen(), and output_param().

#define CB_NEED_SPACE   (1U << 3)

Referenced by codegen(), and output_param().

#define CB_NEED_ZERO   (1U << 4)

Referenced by codegen(), and output_param().

#define COB_ALIGN   ""

Referenced by codegen().

#define COB_INSIDE_SIZE   64

Referenced by codegen(), output_cond(), and output_param().

#define COB_MALLOC_ALIGN   15

Referenced by output_internal_function().

#define COB_MAX_SUBSCRIPTS   16

Referenced by cb_init_constants(), and codegen().

#define COB_SYSTEM_GEN (   x,
  y,
  z 
)    { x, #z },
#define INITIALIZE_COMPOUND   3

Referenced by initialize_type(), and output_initialize().

#define INITIALIZE_DEFAULT   2

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

#define INITIALIZE_NONE   0

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

#define INITIALIZE_ONE   1

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

Function Documentation

static struct attr_list* attr_list_reverse ( struct attr_list *  p)
staticread

References attr_list::next, next, NULL, and p.

Referenced by codegen().

270 {
271  struct attr_list *next;
272  struct attr_list *last;
273 
274  last = NULL;
275  for (; p; p = next) {
276  next = p->next;
277  p->next = last;
278  last = p;
279  }
280  return last;
281 }
static int base_cache_cmp ( const void *  mp1,
const void *  mp2 
)
static

References base_list::f, and cb_field::id.

Referenced by codegen().

327  {
328  const struct base_list *fl1;
329  const struct base_list *fl2;
330 
331  fl1 = (const struct base_list *)mp1;
332  fl2 = (const struct base_list *)mp2;
333  return fl1->f->id - fl2->f->id;
334 }
static unsigned int chk_field_variable_address ( struct cb_field *  fld)
static

References cb_field::children, chk_field_variable_size(), cb_field::depending, cb_field::flag_vaddr_done, p, cb_field::parent, cb_field::sister, and cb_field::vaddr.

Referenced by output_base(), and output_param().

582 {
583  struct cb_field *p;
584  struct cb_field *f;
585 
586  if (fld->flag_vaddr_done) {
587  return fld->vaddr;
588  }
589  f = fld;
590  for (p = f->parent; p; f = f->parent, p = f->parent) {
591  for (p = p->children; p != f; p = p->sister) {
592  if (p->depending || chk_field_variable_size (p)) {
593  fld->vaddr = 1;
594  fld->flag_vaddr_done = 1;
595  return 1;
596  }
597  }
598  }
599  fld->vaddr = 0;
600  fld->flag_vaddr_done = 1;
601  return 0;
602 }
static struct cb_field* chk_field_variable_size ( struct cb_field *  f)
staticread

References cb_field::children, cb_field::depending, cb_field::flag_vsize_done, NULL, p, cb_field::sister, and cb_field::vsize.

Referenced by chk_field_variable_address(), output_base(), output_param(), and output_size().

557 {
558  struct cb_field *p;
559  struct cb_field *fc;
560 
561  if (f->flag_vsize_done) {
562  return f->vsize;
563  }
564  for (fc = f->children; fc; fc = fc->sister) {
565  if (fc->depending) {
566  f->vsize = fc;
567  f->flag_vsize_done = 1;
568  return fc;
569  } else if ((p = chk_field_variable_size (fc)) != NULL) {
570  f->vsize = p;
571  f->flag_vsize_done = 1;
572  return p;
573  }
574  }
575  f->vsize = NULL;
576  f->flag_vsize_done = 1;
577  return NULL;
578 }
void codegen ( struct cb_program *  prog,
const int  nested 
)

References _, cb_program::alphabet_name_list, attr_list_reverse(), base_cache_cmp(), call_list::callname, CB_CHAIN, CB_CLASS_NAME, CB_CLASS_NUMERIC, CB_FUNCTION_TYPE, cb_list_add(), CB_LITERAL, cb_local_file, CB_NEED_HIGH, CB_NEED_LOW, CB_NEED_QUOTE, CB_NEED_SPACE, CB_NEED_ZERO, CB_PREFIX_ATTR, CB_PREFIX_BASE, CB_PREFIX_CONST, CB_PREFIX_FIELD, CB_PREFIX_STRING, CB_PROGRAM_TYPE, cb_source_file, cb_storage_file, cb_storage_file_name, CB_TREE_CLASS, CB_VALUE, CB_XSTRINGIFY, cb_program::class_name_list, COB_ALIGN, cob_gen_optim(), COB_INSIDE_SIZE, COB_KEYWORD_INLINE, COB_MAX_SUBSCRIPTS, COB_MINI_BUFF, COB_MINI_MAX, COB_OPTIM_MAX, COB_OPTIM_MIN, COB_TYPE_ALPHANUMERIC, COB_TYPE_ALPHANUMERIC_ALL, cob_u32_t, cobc_flag_main, cobc_main_malloc(), codegen(), field_list::curr_prog, base_list::curr_prog, cb_literal::data, attr_list::digits, cb_program::entry_list, excp_current_paragraph, excp_current_program_id, excp_current_section, field_list::f, base_list::f, field_cache_cmp(), cb_program::flag_chained, cb_program::flag_debugging, cb_field::flag_filler, cb_program::flag_global_use, cb_field::flag_local, cb_program::flag_main, cb_program::flag_recursive, attr_list::flags, found, gen_alt_ebcdic, gen_custom, gen_dynamic, gen_ebcdic_ascii, gen_figurative, gen_full_ebcdic, gen_if_level, gen_native, gen_nested_tab, i_counters, string_list::id, attr_list::id, literal_list::id, cb_field::id, inside_check, inside_stack, last_line, last_segment, list_cache_sort(), literal_list_reverse(), cb_literal::llit, local_filename::local_fp, cb_program::local_include, local_mem, cb_program::local_storage, local_working_mem, lookup_attr(), loop_counter, cb_program::max_call_param, cb_field::memory_size, cb_field::name, need_save_exception, needs_exit_prog, needs_unifunc, cb_program::nested_level, nested_list::nested_prog, cb_program::nested_prog_list, string_list::next, attr_list::next, literal_list::next, field_list::next, call_list::next, base_list::next, nested_list::next, cb_program::next_program, non_nested_count, NULL, num_cob_fields, optimize_defs, cb_program::orig_program_id, output(), output_attr(), output_class_name_definition(), output_entry_function(), output_field(), output_header(), output_indent_level, output_internal_function(), output_local(), output_main_function(), output_newline(), output_size(), output_storage(), output_string(), output_target, PACKAGE_VERSION, param_id, cb_program::parameter_list, PATCH_LEVEL, attr_list::pic, cb_program::prog_type, progid, cb_program::program_id, attr_list::scale, cb_literal::sign, cb_literal::size, cb_field::special_index, stack_id, string_buffer, string_id, string_list_reverse(), string_list::text, cb_program::toplev_count, attr_list::type, working_mem, literal_list::x, field_list::x, and yyout.

Referenced by codegen(), and process_translate().

7340 {
7341  cb_tree l;
7342  struct attr_list *j;
7343  struct literal_list *m;
7344  struct field_list *k;
7345  struct string_list *stp;
7346  struct call_list *clp;
7347  struct base_list *blp;
7348  unsigned char *s;
7349  struct nested_list *nlp;
7350  struct cb_program *cp;
7351 #if 0 /* RXWRXW - Const */
7352  struct cb_literal *lp;
7353 #endif
7354  cb_tree l1;
7355  cb_tree l2;
7356  const char *prevprog;
7357  struct tm *loctime;
7358  cob_u32_t inc;
7359 #if 0 /* RXWRXW - Sticky */
7360  int save_sticky;
7361 #endif
7362  int i;
7363  int found;
7364  enum cb_optim optidx;
7365  time_t sectime;
7366 
7367  /* Clear local program stuff */
7368  current_prog = prog;
7369  param_id = 0;
7370  stack_id = 0;
7371  num_cob_fields = 0;
7372  progid = 0;
7373  loop_counter = 0;
7374  output_indent_level = 0;
7375  last_line = 0;
7376  needs_exit_prog = 0;
7377  gen_custom = 0;
7378  gen_nested_tab = 0;
7379  gen_dynamic = 0;
7380  gen_if_level = 0;
7381  local_mem = 0;
7382  local_working_mem = 0;
7383  need_save_exception = 0;
7384  last_segment = 0;
7385  last_section = NULL;
7386  call_cache = NULL;
7387  func_call_cache = NULL;
7388  label_cache = NULL;
7389  local_base_cache = NULL;
7390  local_field_cache = NULL;
7391  inside_check = 0;
7392  for (i = 0; i < COB_INSIDE_SIZE; ++i) {
7393  inside_stack[i] = 0;
7394  }
7395  excp_current_program_id = prog->orig_program_id;
7396  excp_current_section = NULL;
7397  excp_current_paragraph = NULL;
7398  memset ((void *)i_counters, 0, sizeof (i_counters));
7399 #if 0 /* RXWRXW - Sticky */
7400  save_sticky = cb_sticky_linkage;
7401 #endif
7402 
7403  output_target = yyout;
7404  cb_local_file = current_prog->local_include->local_fp;
7405 
7406  if (!nested) {
7407  /* First iteration */
7408  gen_alt_ebcdic = 0;
7409  gen_ebcdic_ascii = 0;
7410  gen_full_ebcdic = 0;
7411  gen_native = 0;
7412  gen_figurative = 0;
7413  non_nested_count = 0;
7414  working_mem = 0;
7415  attr_cache = NULL;
7416  base_cache = NULL;
7417  globext_cache = NULL;
7418  literal_cache = NULL;
7419  field_cache = NULL;
7420  string_cache = NULL;
7421  string_id = 1;
7422  if (!string_buffer) {
7423  string_buffer = cobc_main_malloc ((size_t)COB_MINI_BUFF);
7424  }
7425 
7426  sectime = time (NULL);
7427  loctime = localtime (&sectime);
7428  /* Leap seconds ? */
7429  if (loctime->tm_sec >= 60) {
7430  loctime->tm_sec = 59;
7431  }
7432  if (loctime) {
7433  strftime (string_buffer, (size_t)COB_MINI_MAX,
7434  "%b %d %Y %H:%M:%S", loctime);
7435  } else {
7436  strcpy (string_buffer, _("Unknown"));
7437  }
7438  output_header (output_target, string_buffer, NULL);
7439  output_header (cb_storage_file, string_buffer, NULL);
7440  for (cp = prog; cp; cp = cp->next_program) {
7441  output_header (cp->local_include->local_fp,
7442  string_buffer, cp);
7443  }
7444 
7445 #ifndef _GNU_SOURCE
7446 #ifdef _XOPEN_SOURCE_EXTENDED
7447  output ("#ifndef\t_XOPEN_SOURCE_EXTENDED\n");
7448  output ("#define\t_XOPEN_SOURCE_EXTENDED 1\n");
7449  output ("#endif\n");
7450 #endif
7451 #endif
7452  output ("#include <stdio.h>\n");
7453  output ("#include <stdlib.h>\n");
7454  output ("#include <stddef.h>\n");
7455  output ("#include <string.h>\n");
7456  output ("#include <math.h>\n");
7457 #ifdef WORDS_BIGENDIAN
7458  output ("#define WORDS_BIGENDIAN 1\n");
7459 #endif
7460 #ifdef COB_KEYWORD_INLINE
7461  output ("#define COB_KEYWORD_INLINE %s\n",
7462  CB_XSTRINGIFY(COB_KEYWORD_INLINE));
7463 #endif
7464  output ("#include <libcob.h>\n\n");
7465 
7466  output ("#define COB_SOURCE_FILE\t\t\"%s\"\n",
7467  cb_source_file);
7468  output ("#define COB_PACKAGE_VERSION\t\t\"%s\"\n",
7469  PACKAGE_VERSION);
7470  output ("#define COB_PATCH_LEVEL\t\t%d\n",
7471  PATCH_LEVEL);
7472  /* string_buffer has formatted date from above */
7473  output ("#define COB_MODULE_FORMATTED_DATE\t\"%s\"\n",
7474  string_buffer);
7475  if (loctime) {
7476  i = ((loctime->tm_year + 1900) * 10000) +
7477  ((loctime->tm_mon + 1) * 100) +
7478  loctime->tm_mday;
7479  output ("#define COB_MODULE_DATE\t\t%d\n", i);
7480  i = (loctime->tm_hour * 10000) +
7481  (loctime->tm_min * 100) +
7482  loctime->tm_sec;
7483  output ("#define COB_MODULE_TIME\t\t%d\n", i);
7484  } else {
7485  output ("#define COB_MODULE_DATE\t\t0\n");
7486  output ("#define COB_MODULE_TIME\t\t0\n");
7487  }
7488 
7489  output_newline ();
7490  output ("/* Global variables */\n");
7491  output ("#include \"%s\"\n\n", cb_storage_file_name);
7492 
7493  output ("/* Function prototypes */\n\n");
7494  for (cp = prog; cp; cp = cp->next_program) {
7495  /* Build parameter list */
7496  for (l = cp->entry_list; l; l = CB_CHAIN (l)) {
7497  for (l1 = CB_VALUE (l); l1; l1 = CB_CHAIN (l1)) {
7498  for (l2 = cp->parameter_list; l2; l2 = CB_CHAIN (l2)) {
7499  if (strcasecmp (cb_code_field (CB_VALUE (l1))->name,
7500  cb_code_field (CB_VALUE (l2))->name) == 0) {
7501  break;
7502  }
7503  }
7504  if (l2 == NULL) {
7505  cp->parameter_list = cb_list_add (cp->parameter_list, CB_VALUE (l1));
7506  }
7507  }
7508  }
7509  if (cp->flag_main) {
7510  if (!cp->flag_recursive) {
7511  output ("static int\t\t%s ();\n",
7512  cp->program_id);
7513  } else {
7514  output ("int\t\t\t%s ();\n",
7515  cp->program_id);
7516  }
7517  } else {
7518  for (l = cp->entry_list; l; l = CB_CHAIN (l)) {
7519  output_entry_function (cp, l, cp->parameter_list, 0);
7520  }
7521  }
7522  if (cp->prog_type == CB_FUNCTION_TYPE) {
7523  non_nested_count++;
7524 #if 0 /* RXWRXW USERFUNC */
7525  output ("static cob_field\t*%s_ (const int, cob_field **",
7526 #else
7527  output ("static cob_field\t*%s_ (const int",
7528 #endif
7529  cp->program_id);
7530  } else if (!cp->nested_level) {
7531  non_nested_count++;
7532  output ("static int\t\t%s_ (const int",
7533  cp->program_id);
7534  } else {
7535  output ("static int\t\t%s_%d_ (const int",
7536  cp->program_id, cp->toplev_count);
7537  }
7538 #if 0 /* RXWRXW USERFUNC */
7539  if (!cp->flag_chained && cp->prog_type != CB_FUNCTION_TYPE) {
7540 #else
7541  if (!cp->flag_chained) {
7542 #endif
7543  for (l = cp->parameter_list; l; l = CB_CHAIN (l)) {
7544  output (", cob_u8_t *");
7545  if (cb_sticky_linkage) {
7546  output_storage ("static cob_u8_t\t\t\t*cob_parm_%d = NULL;\n",
7547  cb_code_field (CB_VALUE (l))->id);
7548  }
7549  }
7550  }
7551 #if 0 /* RXWRXW - NOINLINE */
7552  if (cb_flag_stack_check) {
7553  output (") COB_NOINLINE;\n");
7554  } else {
7555 #endif
7556  output (");\n");
7557 #if 0 /* RXWRXW - NOINLINE */
7558  }
7559 #endif
7560  }
7561  output ("\n");
7562  }
7563 
7564  /* Class-names */
7565  if (!prog->nested_level && prog->class_name_list) {
7566  output ("/* Class names */\n");
7567  for (l = prog->class_name_list; l; l = CB_CHAIN (l)) {
7568  output_class_name_definition (CB_CLASS_NAME (CB_VALUE (l)));
7569  }
7570  }
7571 
7572  /* Main function */
7573  if (prog->flag_main) {
7574  output_main_function (prog);
7575  }
7576 
7577  /* Functions */
7578  if (!nested) {
7579  output ("/* Functions */\n\n");
7580  }
7581 
7582  if (prog->prog_type == CB_FUNCTION_TYPE) {
7583  output ("/* FUNCTION-ID '%s' */\n\n", prog->orig_program_id);
7584  } else {
7585  output ("/* PROGRAM-ID '%s' */\n\n", prog->orig_program_id);
7586  }
7587 
7588  for (l = prog->entry_list; l; l = CB_CHAIN (l)) {
7589  output_entry_function (prog, l, prog->parameter_list, 1);
7590  }
7591 
7592  output_internal_function (prog, prog->parameter_list);
7593 
7594  if (!prog->next_program) {
7595  output ("/* End functions */\n\n");
7596  }
7597 
7598  if (gen_native || gen_full_ebcdic ||
7599  gen_ebcdic_ascii || prog->alphabet_name_list) {
7600  (void)lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
7601  }
7602 
7603  output_target = cb_storage_file;
7604 
7605  /* Program local stuff */
7606 
7607  /* CALL cache */
7608  if (needs_unifunc || call_cache || func_call_cache) {
7609  output_local ("\n/* Call pointers */\n");
7610  }
7611  if (needs_unifunc) {
7612  output_local ("cob_call_union\t\tcob_unifunc;\n");
7613  }
7614  for (clp = call_cache; clp; clp = clp->next) {
7615  output_local ("static cob_call_union\tcall_%s;\n",
7616  clp->callname);
7617  }
7618  for (clp = func_call_cache; clp; clp = clp->next) {
7619  output_local ("static cob_call_union\tfunc_%s;\n",
7620  clp->callname);
7621  }
7622  needs_unifunc = 0;
7623 
7624  /* Nested / contained list */
7625  if (prog->nested_prog_list && gen_nested_tab) {
7626  /* Generate contained program list */
7627  output_local ("\n/* Nested call table */\n");
7628  output_local ("static struct cob_call_struct\tcob_nest_tab[] = {\n");
7629  nlp = prog->nested_prog_list;
7630  for (; nlp; nlp = nlp->next) {
7631  if (nlp->nested_prog == prog) {
7632 #if 0 /* RXWRXW Fix recursive */
7633  if (!prog->flag_recursive) {
7634  continue;
7635  }
7636 #endif
7637  output_local ("\t{ \"%s\", { (void *(*)())%s_%d__ }, { NULL } },\n",
7638  nlp->nested_prog->orig_program_id,
7639  nlp->nested_prog->program_id,
7640  nlp->nested_prog->toplev_count);
7641  } else {
7642  output_local ("\t{ \"%s\", { (void *(*)())%s_%d__ }, { (void *(*)())%s_%d_ } },\n",
7643  nlp->nested_prog->orig_program_id,
7644  nlp->nested_prog->program_id,
7645  nlp->nested_prog->toplev_count,
7646  nlp->nested_prog->program_id,
7647  nlp->nested_prog->toplev_count);
7648  }
7649  }
7650  output_local ("\t{ NULL, { NULL }, { NULL } }\n");
7651  output_local ("};\n");
7652  }
7653 
7654  /* Local indexes */
7655  found = 0;
7656  for (i = 0; i < COB_MAX_SUBSCRIPTS; i++) {
7657  if (i_counters[i]) {
7658  if (!found) {
7659  found = 1;
7660  output_local ("\n/* Subscripts */\n");
7661  }
7662  output_local ("int\t\ti%d;\n", i);
7663  }
7664  }
7665 
7666  /* PERFORM TIMES counters */
7667  if (loop_counter) {
7668  output_local ("\n/* Loop counters */\n");
7669  for (i = 0; i < loop_counter; i++) {
7670  output_local ("cob_s64_t\tn%d = 0;\n", i);
7671  }
7672  output_local ("\n");
7673  }
7674 
7675  /* Local implicit fields */
7676  if (num_cob_fields) {
7677  output_local ("\n/* Local cob_field items */\n");
7678  for (i = 0; i < num_cob_fields; i++) {
7679  output_local ("cob_field\t\tf%d;\n", i);
7680  }
7681  output_local ("\n");
7682  }
7683 
7684  /* Debugging fields */
7685  if (prog->flag_debugging) {
7686  output_local ("\n/* DEBUG runtime switch */\n");
7687  output_local ("static int\tcob_debugging_mode = 0;\n");
7688  }
7689  if (need_save_exception) {
7690  output_local ("\n/* DEBUG exception code save */\n");
7691  output_local ("int\t\tsave_exception_code = 0;\n");
7692  }
7693 
7694  /* LOCAL storage pointer */
7695  if (prog->local_storage && local_mem) {
7696  output_local ("\n/* LOCAL storage pointer */\n");
7697  output_local ("unsigned char\t\t*cob_local_ptr = NULL;\n");
7698  if (current_prog->flag_global_use) {
7699  output_local ("static unsigned char\t*cob_local_save = NULL;\n");
7700  }
7701  }
7702 
7703  /* Call parameter stack */
7704  output_local ("\n/* Call parameters */\n");
7705  if (cb_flag_stack_on_heap || prog->flag_recursive) {
7706  output_local ("cob_field\t\t**cob_procedure_params;\n");
7707  } else {
7708  if (prog->max_call_param) {
7709  i = prog->max_call_param;
7710  } else {
7711  i = 1;
7712  }
7713  output_local ("cob_field\t\t*cob_procedure_params[%d];\n", i);
7714  }
7715 
7716  /* Frame stack */
7717  output_local ("\n/* Perform frame stack */\n");
7718  if (cb_perform_osvs && current_prog->prog_type == CB_PROGRAM_TYPE) {
7719  output_local ("struct cob_frame\t*temp_index;\n");
7720  }
7721  if (cb_flag_stack_check) {
7722  output_local ("struct cob_frame\t*frame_overflow;\n");
7723  }
7724  output_local ("struct cob_frame\t*frame_ptr;\n");
7725  if (cb_flag_stack_on_heap || prog->flag_recursive) {
7726  output_local ("struct cob_frame\t*frame_stack;\n\n");
7727  } else {
7728  output_local ("struct cob_frame\tframe_stack[%d];\n\n",
7729  cb_stack_size);
7730  }
7731 
7732  if (gen_dynamic) {
7733  output_local ("\n/* Dynamic field FUNCTION-ID pointers */\n");
7734  for (inc = 0; inc < gen_dynamic; inc++) {
7735  output_local ("cob_field\t*cob_dyn_%u = NULL;\n",
7736  inc);
7737  }
7738  }
7739 
7740  if (local_base_cache) {
7741  output_local ("\n/* Data storage */\n");
7742  local_base_cache = list_cache_sort (local_base_cache,
7743  &base_cache_cmp);
7744  for (blp = local_base_cache; blp; blp = blp->next) {
7745  if (blp->f->special_index > 1) {
7746  output_local ("int %s%d;",
7747  CB_PREFIX_BASE, blp->f->id);
7748  } else if (blp->f->special_index) {
7749  output_local ("static int %s%d;",
7750  CB_PREFIX_BASE, blp->f->id);
7751  } else {
7752  output_local ("static cob_u8_t %s%d[%d]%s;",
7753  CB_PREFIX_BASE, blp->f->id,
7754  blp->f->memory_size, COB_ALIGN);
7755  }
7756  output_local ("\t/* %s */\n", blp->f->name);
7757  }
7758  output_local ("\n/* End of data storage */\n\n");
7759  }
7760 
7761  if (local_field_cache) {
7762  /* Switch to local storage file */
7763  output_target = current_prog->local_include->local_fp;
7764  output_local ("\n/* Fields */\n");
7765  local_field_cache = list_cache_sort (local_field_cache,
7766  &field_cache_cmp);
7767  for (k = local_field_cache; k; k = k->next) {
7768  output ("static cob_field %s%d\t= ", CB_PREFIX_FIELD,
7769  k->f->id);
7770  if (!k->f->flag_local) {
7771  output_field (k->x);
7772  } else {
7773  output ("{");
7774  output_size (k->x);
7775  output (", NULL, ");
7776  output_attr (k->x);
7777  output ("}");
7778  }
7779  if (k->f->flag_filler) {
7780  output (";\t/* Implicit FILLER */\n");
7781  } else {
7782  output (";\t/* %s */\n", k->f->name);
7783  }
7784  }
7785  output_local ("\n/* End of fields */\n\n");
7786  /* Switch to main storage file */
7787  output_target = cb_storage_file;
7788  }
7789 
7790  /* Skip to next nested program */
7791 
7792  if (prog->next_program) {
7793  codegen (prog->next_program, 1);
7794  return;
7795  }
7796 
7797  /* Finalize the main include file */
7798 
7799 #if 0 /* RXWRXW - GLOBPTR */
7800  output_storage ("\n/* Global variable pointer */\n");
7801  output_storage ("static cob_global\t\t*cob_glob_ptr = NULL;\n");
7802 #endif
7803 
7804  if (!cobc_flag_main && non_nested_count > 1) {
7805  output_storage ("\n/* Module reference count */\n");
7806  output_storage ("static unsigned int\t\tcob_reference_count = 0;\n");
7807  }
7808 
7809  output_storage ("\n/* Module path */\n");
7810  output_storage ("static const char\t\t*cob_module_path = NULL;\n");
7811 
7812  if (globext_cache) {
7813  output_storage ("\n/* GLOBAL EXTERNAL pointers */\n");
7814  globext_cache = list_cache_sort (globext_cache, &base_cache_cmp);
7815  for (blp = globext_cache; blp; blp = blp->next) {
7816  output_storage ("static unsigned char\t\t*%s%d = NULL;",
7817  CB_PREFIX_BASE, blp->f->id);
7818  output_storage ("\t/* %s */\n", blp->f->name);
7819  }
7820  }
7821 
7822  if (base_cache) {
7823  output_storage ("\n/* Data storage */\n");
7824  base_cache = list_cache_sort (base_cache, &base_cache_cmp);
7825  prevprog = NULL;
7826  for (blp = base_cache; blp; blp = blp->next) {
7827  if (blp->curr_prog != prevprog) {
7828  prevprog = blp->curr_prog;
7829  output_storage ("\n/* PROGRAM-ID : %s */\n",
7830  prevprog);
7831  }
7832  if (blp->f->special_index) {
7833  output_storage ("static int %s%d;",
7834  CB_PREFIX_BASE, blp->f->id);
7835  } else {
7836  output_storage ("static cob_u8_t %s%d[%d]%s;",
7837  CB_PREFIX_BASE, blp->f->id,
7838  blp->f->memory_size, COB_ALIGN);
7839  }
7840  output_storage ("\t/* %s */\n", blp->f->name);
7841  }
7842  output_storage ("\n/* End of data storage */\n\n");
7843  }
7844 
7845  /* Attributes */
7846  if (attr_cache || gen_figurative) {
7847  output_storage ("\n/* Attributes */\n\n");
7848  attr_cache = attr_list_reverse (attr_cache);
7849  for (j = attr_cache; j; j = j->next) {
7850  output_storage ("static const cob_field_attr %s%d =\t",
7851  CB_PREFIX_ATTR, j->id);
7852  output_storage ("{0x%02x, %3u, %3d, 0x%04x, ",
7853  j->type, j->digits,
7854  j->scale, j->flags);
7855  if (j->pic) {
7856  output_storage ("\"");
7857  for (s = j->pic; *s; s += 5) {
7858  output_storage ("%c\\%03o\\%03o\\%03o\\%03o",
7859  s[0], s[1], s[2], s[3], s[4]);
7860  }
7861  output_storage ("\"");
7862  } else {
7863  output_storage ("NULL");
7864  }
7865  output_storage ("};\n");
7866  }
7867  if (gen_figurative) {
7868  output_storage ("\nstatic const cob_field_attr cob_all_attr = ");
7869  output_storage ("{0x%02x, 0, 0, 0, NULL};\n",
7870  COB_TYPE_ALPHANUMERIC_ALL);
7871  }
7872  output_storage ("\n");
7873  }
7874 
7875  if (field_cache) {
7876  output_storage ("\n/* Fields */\n");
7877  field_cache = list_cache_sort (field_cache, &field_cache_cmp);
7878  prevprog = NULL;
7879  for (k = field_cache; k; k = k->next) {
7880  if (k->curr_prog != prevprog) {
7881  prevprog = k->curr_prog;
7882  output_storage ("\n/* PROGRAM-ID : %s */\n",
7883  prevprog);
7884  }
7885  output ("static cob_field %s%d\t= ", CB_PREFIX_FIELD,
7886  k->f->id);
7887  if (!k->f->flag_local) {
7888  output_field (k->x);
7889  } else {
7890  output ("{");
7891  output_size (k->x);
7892  output (", NULL, ");
7893  output_attr (k->x);
7894  output ("}");
7895  }
7896  if (k->f->flag_filler) {
7897  output (";\t/* Implicit FILLER */\n");
7898  } else {
7899  output (";\t/* %s */\n", k->f->name);
7900  }
7901  }
7902  output_storage ("\n/* End of fields */\n\n");
7903  }
7904 
7905  /* Literals, figuratives, constants */
7906  if (literal_cache || gen_figurative) {
7907  output_storage ("\n/* Constants */\n");
7908  literal_cache = literal_list_reverse (literal_cache);
7909  for (m = literal_cache; m; m = m->next) {
7910 #if 0 /* RXWRXW - Const */
7911  output ("static const cob_fld_union %s%d\t= ",
7912  CB_PREFIX_CONST, m->id);
7913  output ("{");
7914  output_size (m->x);
7915  output (", ");
7916  lp = CB_LITERAL (m->x);
7917  if (CB_TREE_CLASS (m->x) == CB_CLASS_NUMERIC) {
7918  output ("\"%s%s\"", (char *)lp->data,
7919  (lp->sign < 0) ? "-" : (lp->sign > 0) ? "+" : "");
7920  } else {
7921  output_string (lp->data, (int) lp->size, lp->llit);
7922  }
7923  output (", ");
7924  output_attr (m->x);
7925  output ("}");
7926 #else
7927  output ("static const cob_field %s%d\t= ",
7928  CB_PREFIX_CONST, m->id);
7929  output_field (m->x);
7930 #endif
7931  output (";\n");
7932  }
7933  if (gen_figurative) {
7934  output ("\n");
7935  if (gen_figurative & CB_NEED_LOW) {
7936  output ("static cob_field cob_all_low\t= ");
7937  output ("{1, ");
7938  output ("(cob_u8_ptr)\"\\0\", ");
7939  output ("&cob_all_attr};\n");
7940  }
7941  if (gen_figurative & CB_NEED_HIGH) {
7942  output ("static cob_field cob_all_high\t= ");
7943  output ("{1, ");
7944  output ("(cob_u8_ptr)\"\\xff\", ");
7945  output ("&cob_all_attr};\n");
7946  }
7947  if (gen_figurative & CB_NEED_QUOTE) {
7948  output ("static cob_field cob_all_quote\t= ");
7949  output ("{1, ");
7950  if (cb_flag_apostrophe) {
7951  output ("(cob_u8_ptr)\"'\", ");
7952  } else {
7953  output ("(cob_u8_ptr)\"\\\"\", ");
7954  }
7955  output ("&cob_all_attr};\n");
7956  }
7957  if (gen_figurative & CB_NEED_SPACE) {
7958  output ("static cob_field cob_all_space\t= ");
7959  output ("{1, ");
7960  output ("(cob_u8_ptr)\" \", ");
7961  output ("&cob_all_attr};\n");
7962  }
7963  if (gen_figurative & CB_NEED_ZERO) {
7964  output ("static cob_field cob_all_zero\t= ");
7965  output ("{1, ");
7966  output ("(cob_u8_ptr)\"0\", ");
7967  output ("&cob_all_attr};\n");
7968  }
7969  }
7970  output ("\n");
7971  }
7972 
7973  /* Collating tables */
7974  if (gen_alt_ebcdic) {
7975  output_storage ("\n/* ASCII to EBCDIC translate table (restricted) */\n");
7976  output ("static const unsigned char\tcob_a2e[256] = {\n");
7977  /* Restricted table */
7978  output ("\t0x00, 0x01, 0x02, 0x03, 0x1D, 0x19, 0x1A, 0x1B,\n");
7979  output ("\t0x0F, 0x04, 0x16, 0x06, 0x07, 0x08, 0x09, 0x0A,\n");
7980  output ("\t0x0B, 0x0C, 0x0D, 0x0E, 0x1E, 0x1F, 0x1C, 0x17,\n");
7981  output ("\t0x10, 0x11, 0x20, 0x18, 0x12, 0x13, 0x14, 0x15,\n");
7982  output ("\t0x21, 0x27, 0x3A, 0x36, 0x28, 0x30, 0x26, 0x38,\n");
7983  output ("\t0x24, 0x2A, 0x29, 0x25, 0x2F, 0x2C, 0x22, 0x2D,\n");
7984  output ("\t0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A,\n");
7985  output ("\t0x7B, 0x7C, 0x35, 0x2B, 0x23, 0x39, 0x32, 0x33,\n");
7986  output ("\t0x37, 0x57, 0x58, 0x59, 0x5A, 0x5B, 0x5C, 0x5D,\n");
7987  output ("\t0x5E, 0x5F, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66,\n");
7988  output ("\t0x67, 0x68, 0x69, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F,\n");
7989  output ("\t0x70, 0x71, 0x72, 0x7D, 0x6A, 0x7E, 0x7F, 0x31,\n");
7990  output ("\t0x34, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F, 0x40, 0x41,\n");
7991  output ("\t0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,\n");
7992  output ("\t0x4A, 0x4B, 0x4C, 0x4E, 0x4F, 0x50, 0x51, 0x52,\n");
7993  output ("\t0x53, 0x54, 0x55, 0x56, 0x2E, 0x60, 0x4D, 0x05,\n");
7994  output ("\t0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
7995  output ("\t0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x8D, 0x8E, 0x8F,\n");
7996  output ("\t0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97,\n");
7997  output ("\t0x98, 0x99, 0x9A, 0x9B, 0x9C, 0x9D, 0x9E, 0x9F,\n");
7998  output ("\t0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7,\n");
7999  output ("\t0xA8, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF,\n");
8000  output ("\t0xB0, 0xB1, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7,\n");
8001  output ("\t0xB8, 0xB9, 0xBA, 0xBB, 0xBC, 0xBD, 0xBE, 0xBF,\n");
8002  output ("\t0xC0, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
8003  output ("\t0xC8, 0xC9, 0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF,\n");
8004  output ("\t0xD0, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7,\n");
8005  output ("\t0xD8, 0xD9, 0xDA, 0xDB, 0xDC, 0xDD, 0xDE, 0xDF,\n");
8006  output ("\t0xE0, 0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7,\n");
8007  output ("\t0xE8, 0xE9, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF,\n");
8008  output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
8009  output ("\t0xF8, 0xF9, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE, 0xFF\n");
8010  output ("};\n");
8011  output_storage ("\n");
8012  }
8013  if (gen_full_ebcdic) {
8014  output_storage ("\n/* ASCII to EBCDIC table */\n");
8015  output ("static const unsigned char\tcob_ascii_ebcdic[256] = {\n");
8016  output ("\t0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F,\n");
8017  output ("\t0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
8018  output ("\t0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26,\n");
8019  output ("\t0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,\n");
8020  output ("\t0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D,\n");
8021  output ("\t0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,\n");
8022  output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
8023  output ("\t0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,\n");
8024  output ("\t0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
8025  output ("\t0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,\n");
8026  output ("\t0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6,\n");
8027  output ("\t0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,\n");
8028  output ("\t0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
8029  output ("\t0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,\n");
8030  output ("\t0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6,\n");
8031  output ("\t0xA7, 0xA8, 0xA9, 0xC0, 0x6A, 0xD0, 0xA1, 0x07,\n");
8032  output ("\t0x68, 0xDC, 0x51, 0x42, 0x43, 0x44, 0x47, 0x48,\n");
8033  output ("\t0x52, 0x53, 0x54, 0x57, 0x56, 0x58, 0x63, 0x67,\n");
8034  output ("\t0x71, 0x9C, 0x9E, 0xCB, 0xCC, 0xCD, 0xDB, 0xDD,\n");
8035  output ("\t0xDF, 0xEC, 0xFC, 0xB0, 0xB1, 0xB2, 0x3E, 0xB4,\n");
8036  output ("\t0x45, 0x55, 0xCE, 0xDE, 0x49, 0x69, 0x9A, 0x9B,\n");
8037  output ("\t0xAB, 0x9F, 0xBA, 0xB8, 0xB7, 0xAA, 0x8A, 0x8B,\n");
8038  output ("\t0xB6, 0xB5, 0x62, 0x4F, 0x64, 0x65, 0x66, 0x20,\n");
8039  output ("\t0x21, 0x22, 0x70, 0x23, 0x72, 0x73, 0x74, 0xBE,\n");
8040  output ("\t0x76, 0x77, 0x78, 0x80, 0x24, 0x15, 0x8C, 0x8D,\n");
8041  output ("\t0x8E, 0x41, 0x06, 0x17, 0x28, 0x29, 0x9D, 0x2A,\n");
8042  output ("\t0x2B, 0x2C, 0x09, 0x0A, 0xAC, 0x4A, 0xAE, 0xAF,\n");
8043  output ("\t0x1B, 0x30, 0x31, 0xFA, 0x1A, 0x33, 0x34, 0x35,\n");
8044  output ("\t0x36, 0x59, 0x08, 0x38, 0xBC, 0x39, 0xA0, 0xBF,\n");
8045  output ("\t0xCA, 0x3A, 0xFE, 0x3B, 0x04, 0xCF, 0xDA, 0x14,\n");
8046  output ("\t0xE1, 0x8F, 0x46, 0x75, 0xFD, 0xEB, 0xEE, 0xED,\n");
8047  output ("\t0x90, 0xEF, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF\n");
8048  output ("};\n");
8049  if (gen_full_ebcdic > 1) {
8050  i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
8051  output
8052  ("static cob_field f_ascii_ebcdic = { 256, (cob_u8_ptr)cob_ascii_ebcdic, &%s%d };\n",
8053  CB_PREFIX_ATTR, i);
8054  }
8055  output_storage ("\n");
8056  }
8057  if (gen_ebcdic_ascii) {
8058  output_storage ("\n/* EBCDIC to ASCII table */\n");
8059  output ("static const unsigned char\tcob_ebcdic_ascii[256] = {\n");
8060  output ("\t0x00, 0x01, 0x02, 0x03, 0xEC, 0x09, 0xCA, 0x7F,\n");
8061  output ("\t0xE2, 0xD2, 0xD3, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
8062  output ("\t0x10, 0x11, 0x12, 0x13, 0xEF, 0xC5, 0x08, 0xCB,\n");
8063  output ("\t0x18, 0x19, 0xDC, 0xD8, 0x1C, 0x1D, 0x1E, 0x1F,\n");
8064  output ("\t0xB7, 0xB8, 0xB9, 0xBB, 0xC4, 0x0A, 0x17, 0x1B,\n");
8065  output ("\t0xCC, 0xCD, 0xCF, 0xD0, 0xD1, 0x05, 0x06, 0x07,\n");
8066  output ("\t0xD9, 0xDA, 0x16, 0xDD, 0xDE, 0xDF, 0xE0, 0x04,\n");
8067  output ("\t0xE3, 0xE5, 0xE9, 0xEB, 0x14, 0x15, 0x9E, 0x1A,\n");
8068  output ("\t0x20, 0xC9, 0x83, 0x84, 0x85, 0xA0, 0xF2, 0x86,\n");
8069  output ("\t0x87, 0xA4, 0xD5, 0x2E, 0x3C, 0x28, 0x2B, 0xB3,\n");
8070  output ("\t0x26, 0x82, 0x88, 0x89, 0x8A, 0xA1, 0x8C, 0x8B,\n");
8071  output ("\t0x8D, 0xE1, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x5E,\n");
8072  output ("\t0x2D, 0x2F, 0xB2, 0x8E, 0xB4, 0xB5, 0xB6, 0x8F,\n");
8073  output ("\t0x80, 0xA5, 0x7C, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,\n");
8074  output ("\t0xBA, 0x90, 0xBC, 0xBD, 0xBE, 0xF3, 0xC0, 0xC1,\n");
8075  output ("\t0xC2, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,\n");
8076  output ("\t0xC3, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,\n");
8077  output ("\t0x68, 0x69, 0xAE, 0xAF, 0xC6, 0xC7, 0xC8, 0xF1,\n");
8078  output ("\t0xF8, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70,\n");
8079  output ("\t0x71, 0x72, 0xA6, 0xA7, 0x91, 0xCE, 0x92, 0xA9,\n");
8080  output ("\t0xE6, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78,\n");
8081  output ("\t0x79, 0x7A, 0xAD, 0xA8, 0xD4, 0x5B, 0xD6, 0xD7,\n");
8082  output ("\t0x9B, 0x9C, 0x9D, 0xFA, 0x9F, 0xB1, 0xB0, 0xAC,\n");
8083  output ("\t0xAB, 0xFC, 0xAA, 0xFE, 0xE4, 0x5D, 0xBF, 0xE7,\n");
8084  output ("\t0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47,\n");
8085  output ("\t0x48, 0x49, 0xE8, 0x93, 0x94, 0x95, 0xA2, 0xED,\n");
8086  output ("\t0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50,\n");
8087  output ("\t0x51, 0x52, 0xEE, 0x96, 0x81, 0x97, 0xA3, 0x98,\n");
8088  output ("\t0x5C, 0xF0, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,\n");
8089  output ("\t0x59, 0x5A, 0xFD, 0xF5, 0x99, 0xF7, 0xF6, 0xF9,\n");
8090  output ("\t0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,\n");
8091  output ("\t0x38, 0x39, 0xDB, 0xFB, 0x9A, 0xF4, 0xEA, 0xFF\n");
8092  output ("};\n");
8093  if (gen_ebcdic_ascii > 1) {
8094  i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
8095  output
8096  ("static cob_field f_ebcdic_ascii = { 256, (cob_u8_ptr)cob_ebcdic_ascii, &%s%d };\n",
8097  CB_PREFIX_ATTR, i);
8098  }
8099  output_storage ("\n");
8100  }
8101  if (gen_native) {
8102  output_storage ("\n/* NATIVE table */\n");
8103  output ("static const unsigned char\tcob_native[256] = {\n");
8104  output ("\t0, 1, 2, 3, 4, 5, 6, 7,\n");
8105  output ("\t8, 9, 10, 11, 12, 13, 14, 15,\n");
8106  output ("\t16, 17, 18, 19, 20, 21, 22, 23,\n");
8107  output ("\t24, 25, 26, 27, 28, 29, 30, 31,\n");
8108  output ("\t32, 33, 34, 35, 36, 37, 38, 39,\n");
8109  output ("\t40, 41, 42, 43, 44, 45, 46, 47,\n");
8110  output ("\t48, 49, 50, 51, 52, 53, 54, 55,\n");
8111  output ("\t56, 57, 58, 59, 60, 61, 62, 63,\n");
8112  output ("\t64, 65, 66, 67, 68, 69, 70, 71,\n");
8113  output ("\t72, 73, 74, 75, 76, 77, 78, 79,\n");
8114  output ("\t80, 81, 82, 83, 84, 85, 86, 87,\n");
8115  output ("\t88, 89, 90, 91, 92, 93, 94, 95,\n");
8116  output ("\t96, 97, 98, 99, 100, 101, 102, 103,\n");
8117  output ("\t104, 105, 106, 107, 108, 109, 110, 111,\n");
8118  output ("\t112, 113, 114, 115, 116, 117, 118, 119,\n");
8119  output ("\t120, 121, 122, 123, 124, 125, 126, 127,\n");
8120  output ("\t128, 129, 130, 131, 132, 133, 134, 135,\n");
8121  output ("\t136, 137, 138, 139, 140, 141, 142, 143,\n");
8122  output ("\t144, 145, 146, 147, 148, 149, 150, 151,\n");
8123  output ("\t152, 153, 154, 155, 156, 157, 158, 159,\n");
8124  output ("\t160, 161, 162, 163, 164, 165, 166, 167,\n");
8125  output ("\t168, 169, 170, 171, 172, 173, 174, 175,\n");
8126  output ("\t176, 177, 178, 179, 180, 181, 182, 183,\n");
8127  output ("\t184, 185, 186, 187, 188, 189, 190, 191,\n");
8128  output ("\t192, 193, 194, 195, 196, 197, 198, 199,\n");
8129  output ("\t200, 201, 202, 203, 204, 205, 206, 207,\n");
8130  output ("\t208, 209, 210, 211, 212, 213, 214, 215,\n");
8131  output ("\t216, 217, 218, 219, 220, 221, 222, 223,\n");
8132  output ("\t224, 225, 226, 227, 228, 229, 230, 231,\n");
8133  output ("\t232, 233, 234, 235, 236, 237, 238, 239,\n");
8134  output ("\t240, 241, 242, 243, 244, 245, 246, 247,\n");
8135  output ("\t248, 249, 250, 251, 252, 253, 254, 255\n");
8136  output ("};\n");
8137  if (gen_native > 1) {
8138  i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
8139  output
8140  ("static cob_field f_native = { 256, (cob_u8_ptr)cob_native, &%s%d };\n",
8141  CB_PREFIX_ATTR, i);
8142  }
8143  output_storage ("\n");
8144  }
8145 
8146  /* Strings */
8147  if (string_cache) {
8148  output_storage ("\n/* Strings */\n");
8149  string_cache = string_list_reverse (string_cache);
8150  for (stp = string_cache; stp; stp = stp->next) {
8151  output ("static const char %s%d[]\t= \"%s\";\n",
8152  CB_PREFIX_STRING, stp->id, stp->text);
8153  }
8154  output_storage ("\n");
8155  }
8156 
8157  /* Optimizer output */
8158  for (optidx = COB_OPTIM_MIN; optidx < COB_OPTIM_MAX; ++optidx) {
8159  if (optimize_defs[optidx]) {
8160  cob_gen_optim (optidx);
8161  output_storage ("\n");
8162  }
8163  }
8164 }
static int field_cache_cmp ( const void *  mp1,
const void *  mp2 
)
static

References field_list::curr_prog, field_list::f, and cb_field::id.

Referenced by codegen().

313  {
314  const struct field_list *fl1;
315  const struct field_list *fl2;
316  int ret;
317 
318  fl1 = (const struct field_list *)mp1;
319  fl2 = (const struct field_list *)mp2;
320  ret = strcasecmp (fl1->curr_prog, fl2->curr_prog);
321  if (ret) {
322  return ret;
323  }
324  return fl1->f->id - fl2->f->id;
325 }
static int initialize_type ( struct cb_initialize *  p,
struct cb_field *  f,
const int  topfield 
)
static

References _, CB_CATEGORY_ALPHANUMERIC_EDITED, CB_CATEGORY_NATIONAL_EDITED, CB_CATEGORY_NUMERIC_EDITED, CB_CHAIN, CB_PURPOSE_INT, CB_TREE, CB_TREE_CATEGORY, cb_tree_type(), CB_USAGE_DOUBLE, CB_USAGE_FLOAT, CB_USAGE_FP_BIN128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_DEC128, CB_USAGE_FP_DEC64, CB_USAGE_LONG_DOUBLE, cb_field::children, COB_TYPE_NUMERIC_PACKED, COBC_ABORT, cobc_abort_pr(), cb_field::flag_chained, cb_initialize::flag_default, cb_field::flag_external, cb_field::flag_filler, cb_initialize::flag_init_statement, cb_field::flag_item_78, cb_initialize::flag_no_filler_init, INITIALIZE_COMPOUND, INITIALIZE_DEFAULT, INITIALIZE_NONE, INITIALIZE_ONE, cb_field::redefines, cb_initialize::rep, cb_field::sister, cb_field::usage, cb_initialize::val, and cb_field::values.

Referenced by output_initialize(), and output_initialize_compound().

2214 {
2215  cb_tree l;
2216  int type;
2217 
2218  if (f->flag_item_78) {
2219  cobc_abort_pr (_("Unexpected CONSTANT item"));
2220  COBC_ABORT ();
2221  }
2222 
2223  if (f->flag_chained) {
2224  return INITIALIZE_ONE;
2225  }
2226 
2227  if (f->flag_external && !p->flag_init_statement) {
2228  return INITIALIZE_NONE;
2229  }
2230 
2231  if (f->redefines && (!topfield || !p->flag_init_statement)) {
2232  return INITIALIZE_NONE;
2233  }
2234 
2235  if (f->flag_filler && p->flag_no_filler_init && !f->children) {
2236  return INITIALIZE_NONE;
2237  }
2238 
2239  if (p->val && f->values) {
2240  return INITIALIZE_ONE;
2241  }
2242 
2243  if (f->children) {
2244  type = initialize_type (p, f->children, 0);
2245  if (type == INITIALIZE_ONE) {
2246  return INITIALIZE_COMPOUND;
2247  }
2248  for (f = f->children->sister; f; f = f->sister) {
2249  if (type != initialize_type (p, f, 0)) {
2250  return INITIALIZE_COMPOUND;
2251  }
2252  }
2253  return type;
2254  } else {
2255  for (l = p->rep; l; l = CB_CHAIN (l)) {
2256  if ((int)CB_PURPOSE_INT (l) == (int)CB_TREE_CATEGORY (f)) {
2257  return INITIALIZE_ONE;
2258  }
2259  }
2260  }
2261 
2262  if (p->flag_default) {
2263  if (cb_default_byte >= 0 && !p->flag_init_statement) {
2264  return INITIALIZE_DEFAULT;
2265  }
2266  switch (f->usage) {
2267  case CB_USAGE_FLOAT:
2268  case CB_USAGE_DOUBLE:
2269  case CB_USAGE_LONG_DOUBLE:
2270  case CB_USAGE_FP_BIN32:
2271  case CB_USAGE_FP_BIN64:
2272  case CB_USAGE_FP_BIN128:
2273  case CB_USAGE_FP_DEC64:
2274  case CB_USAGE_FP_DEC128:
2275  return INITIALIZE_ONE;
2276  default:
2277  break;
2278  }
2279  switch (CB_TREE_CATEGORY (f)) {
2280  case CB_CATEGORY_NUMERIC_EDITED:
2281  case CB_CATEGORY_ALPHANUMERIC_EDITED:
2282  case CB_CATEGORY_NATIONAL_EDITED:
2283  return INITIALIZE_ONE;
2284  default:
2285  if (cb_tree_type (CB_TREE (f), f) == COB_TYPE_NUMERIC_PACKED) {
2286  return INITIALIZE_ONE;
2287  } else {
2288  return INITIALIZE_DEFAULT;
2289  }
2290  }
2291  }
2292 
2293  return INITIALIZE_NONE;
2294 }
static int initialize_uniform_char ( const struct cb_field *  f,
const struct cb_initialize *  p 
)
static

References CB_TREE, cb_tree_type(), cb_field::children, COB_TYPE_ALPHANUMERIC, COB_TYPE_NUMERIC_BINARY, COB_TYPE_NUMERIC_DISPLAY, cb_initialize::flag_init_statement, cb_field::redefines, and cb_field::sister.

Referenced by output_initialize(), and output_initialize_compound().

2299 {
2300  int c;
2301 
2302  if (f->children) {
2303  c = initialize_uniform_char (f->children, p);
2304  for (f = f->children->sister; f; f = f->sister) {
2305  if (!f->redefines) {
2306  if (c != initialize_uniform_char (f, p)) {
2307  return -1;
2308  }
2309  }
2310  }
2311  return c;
2312  } else {
2313  if (cb_default_byte >= 0 && !p->flag_init_statement) {
2314  return cb_default_byte;
2315  }
2316  switch (cb_tree_type (CB_TREE (f), f)) {
2317  case COB_TYPE_NUMERIC_BINARY:
2318  return 0;
2319  case COB_TYPE_NUMERIC_DISPLAY:
2320  return '0';
2321  case COB_TYPE_ALPHANUMERIC:
2322  return ' ';
2323  default:
2324  return -1;
2325  }
2326  }
2327 }
static void* list_cache_sort ( void *  inlist,
int(*)(const void *mp1, const void *mp2)  cmpfunc 
)
static

References sort_list::next, NULL, and p.

Referenced by codegen().

341 {
342  struct sort_list *p;
343  struct sort_list *q;
344  struct sort_list *e;
345  struct sort_list *tail;
346  struct sort_list *list;
347  size_t insize;
348  size_t nmerges;
349  size_t psize;
350  size_t qsize;
351  size_t i;
352 
353  if (!inlist) {
354  return NULL;
355  }
356  list = (struct sort_list *)inlist;
357  insize = 1;
358  for (;;) {
359  p = list;
360  list = NULL;
361  tail = NULL;
362  nmerges = 0;
363  while (p) {
364  nmerges++;
365  q = p;
366  psize = 0;
367  for (i = 0; i < insize; i++) {
368  psize++;
369  q = q->next;
370  if (!q) {
371  break;
372  }
373  }
374  qsize = insize;
375  while (psize > 0 || (qsize > 0 && q)) {
376  if (psize == 0) {
377  e = q;
378  q = q->next;
379  if (qsize) {
380  qsize--;
381  }
382  } else if (qsize == 0 || !q) {
383  e = p;
384  p = p->next;
385  if (psize) {
386  psize--;
387  }
388  } else if ((*cmpfunc) (p, q) <= 0) {
389  e = p;
390  p = p->next;
391  if (psize) {
392  psize--;
393  }
394  } else {
395  e = q;
396  q = q->next;
397  if (qsize) {
398  qsize--;
399  }
400  }
401  if (tail) {
402  tail->next = e;
403  } else {
404  list = e;
405  }
406  tail = e;
407  }
408  p = q;
409  }
410  tail->next = NULL;
411  if (nmerges <= 1) {
412  return (void *)list;
413  }
414  insize *= 2;
415  }
416 }
static struct literal_list* literal_list_reverse ( struct literal_list *  p)
staticread

References literal_list::next, next, NULL, and p.

Referenced by codegen().

300 {
301  struct literal_list *next;
302  struct literal_list *last;
303 
304  last = NULL;
305  for (; p; p = next) {
306  next = p->next;
307  p->next = last;
308  last = p;
309  }
310  return last;
311 }
static int literal_value ( cb_tree  x)
static

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

Referenced by output_class_name_definition().

5411 {
5412  if (x == cb_space) {
5413  return ' ';
5414  } else if (x == cb_zero) {
5415  return '0';
5416  } else if (x == cb_quote) {
5417  return cb_flag_apostrophe ? '\'' : '"';
5418  } else if (x == cb_norm_low) {
5419  return 0;
5420  } else if (x == cb_norm_high) {
5421  return 255;
5422  } else if (x == cb_null) {
5423  return 0;
5424  } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
5425  return cb_get_int (x) - 1;
5426  } else {
5427  return CB_LITERAL (x)->data[0];
5428  }
5429 }
static int lookup_attr ( const int  type,
const cob_u32_t  digits,
const int  scale,
const cob_u32_t  flags,
unsigned char *  pic,
const int  lenstr 
)
static

References attr_cache, cb_attr_id, cobc_parse_malloc(), attr_list::digits, attr_list::flags, attr_list::id, attr_list::lenstr, attr_list::next, attr_list::pic, attr_list::scale, and attr_list::type.

Referenced by codegen(), output_alphabet_name_definition(), output_attr(), and output_bin_field().

848 {
849  struct attr_list *l;
850 
851  /* Search attribute cache */
852  for (l = attr_cache; l; l = l->next) {
853  if (type == l->type &&
854  digits == l->digits &&
855  scale == l->scale &&
856  flags == l->flags &&
857  ((pic == l->pic) || (pic && l->pic && lenstr == l->lenstr &&
858  memcmp ((char *)pic, (char *)(l->pic), (size_t)lenstr) == 0))) {
859  return l->id;
860  }
861  }
862 
863  /* Cache new attribute */
864 
865  l = cobc_parse_malloc (sizeof (struct attr_list));
866  l->id = cb_attr_id;
867  l->type = type;
868  l->digits = digits;
869  l->scale = scale;
870  l->flags = flags;
871  l->pic = pic;
872  l->lenstr = lenstr;
873  l->next = attr_cache;
874  attr_cache = l;
875 
876  return cb_attr_id++;
877 }
static void lookup_call ( const char *  p)
static

References call_cache, call_list::callname, cobc_parse_malloc(), call_list::next, and p.

Referenced by output_call().

238 {
239  struct call_list *clp;
240 
241  for (clp = call_cache; clp; clp = clp->next) {
242  if (strcmp (p, clp->callname) == 0) {
243  return;
244  }
245  }
246  clp = cobc_parse_malloc (sizeof (struct call_list));
247  clp->callname = p;
248  clp->next = call_cache;
249  call_cache = clp;
250 }
static void lookup_func_call ( const char *  p)
static

References call_list::callname, cobc_parse_malloc(), func_call_cache, call_list::next, and p.

Referenced by output_param().

254 {
255  struct call_list *clp;
256 
257  for (clp = func_call_cache; clp; clp = clp->next) {
258  if (strcmp (p, clp->callname) == 0) {
259  return;
260  }
261  }
262  clp = cobc_parse_malloc (sizeof (struct call_list));
263  clp->callname = p;
264  clp->next = func_call_cache;
265  func_call_cache = clp;
266 }
static int lookup_literal ( cb_tree  x)
static

References cb_literal::all, CB_LITERAL, cb_literal_id, CB_TREE_CLASS, cobc_parse_malloc(), cb_literal::data, literal_list::id, literal_list::literal, literal_cache, literal_list::next, NULL, output_field(), output_target, cb_literal::scale, cb_literal::sign, cb_literal::size, and literal_list::x.

Referenced by output_param().

1026 {
1027 
1028  struct cb_literal *literal;
1029  struct literal_list *l;
1030  FILE *savetarget;
1031 
1032  literal = CB_LITERAL (x);
1033  /* Search literal cache */
1034  for (l = literal_cache; l; l = l->next) {
1035  if (CB_TREE_CLASS (literal) == CB_TREE_CLASS (l->literal) &&
1036  literal->size == l->literal->size &&
1037  literal->all == l->literal->all &&
1038  literal->sign == l->literal->sign &&
1039  literal->scale == l->literal->scale &&
1040  memcmp (literal->data, l->literal->data,
1041  (size_t)literal->size) == 0) {
1042  return l->id;
1043  }
1044  }
1045 
1046  /* Output new literal */
1047  savetarget = output_target;
1048  output_target = NULL;
1049  output_field (x);
1050 
1051  output_target = savetarget;
1052 
1053  /* Cache it */
1054  l = cobc_parse_malloc (sizeof (struct literal_list));
1055  l->id = cb_literal_id;
1056  l->literal = literal;
1057  l->x = x;
1058  l->next = literal_cache;
1059  literal_cache = l;
1060 
1061  return cb_literal_id++;
1062 }
static int lookup_string ( const char *  p)
static

References cobc_parse_malloc(), cobc_parse_strdup(), string_list::id, string_list::next, string_cache, string_id, and string_list::text.

Referenced by output_internal_function(), output_section_info(), output_stmt(), and output_trace_info().

220 {
221  struct string_list *stp;
222 
223  for (stp = string_cache; stp; stp = stp->next) {
224  if (strcmp (p, stp->text) == 0) {
225  return stp->id;
226  }
227  }
228  stp = cobc_parse_malloc (sizeof (struct string_list));
229  stp->text = cobc_parse_strdup (p);
230  stp->id = string_id;
231  stp->next = string_cache;
232  string_cache = stp;
233  return string_id++;
234 }
static void output ( const char *  fmt,
  ... 
)
static

References CB_FIELD, cb_ref(), CB_REFERENCE, CB_REFERENCE_P, likely, unlikely, and value.

Referenced by codegen(), output_attr(), output_base(), output_call(), output_call_by_value_args(), output_cancel(), output_cond(), output_data(), output_entry_function(), output_error_handler(), output_field(), output_figurative(), output_file_initialization(), output_func_1(), output_funcall(), output_goto(), output_index(), output_initialize_fp(), output_initialize_fp_bindec(), output_initialize_literal(), output_initialize_one(), output_initialize_uniform(), output_integer(), output_internal_function(), output_label_info(), output_long_integer(), output_module_init(), output_occurs(), output_param(), output_perform(), output_perform_until(), output_screen_init(), output_search_all(), output_search_whens(), output_size(), output_stmt(), output_string(), and output_trace_info().

208 {
209  if (likely(CB_REFERENCE_P (x))) {
210  if (unlikely(!CB_REFERENCE (x)->value)) {
211  return CB_FIELD (cb_ref (x));
212  }
213  return CB_FIELD (CB_REFERENCE (x)->value);
214  }
215  return CB_FIELD (x);
216 }
static void output_alphabet_name_definition ( struct cb_alphabet_name *  p)
static

References cb_alphabet_name::alphabet_type, CB_ALPHABET_CUSTOM, CB_PREFIX_ATTR, CB_PREFIX_FIELD, CB_PREFIX_SEQUENCE, cb_alphabet_name::cname, COB_TYPE_ALPHANUMERIC, lookup_attr(), NULL, output_local(), and cb_alphabet_name::values.

Referenced by output_internal_function().

5433 {
5434  int i;
5435 
5436  if (p->alphabet_type != CB_ALPHABET_CUSTOM) {
5437  return;
5438  }
5439 
5440  /* Output the table */
5441  output_local ("static const unsigned char %s%s[256] = {\n",
5442  CB_PREFIX_SEQUENCE, p->cname);
5443  for (i = 0; i < 256; i++) {
5444  if (i == 255) {
5445  output_local (" %d", p->values[i]);
5446  } else {
5447  output_local (" %d,", p->values[i]);
5448  }
5449  if (i % 16 == 15) {
5450  output_local ("\n");
5451  }
5452  }
5453  output_local ("};\n");
5454  i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
5455  output_local ("static cob_field %s%s = { 256, (cob_u8_ptr)%s%s, &%s%d };\n",
5456  CB_PREFIX_FIELD, p->cname,
5457  CB_PREFIX_SEQUENCE, p->cname,
5458  CB_PREFIX_ATTR, i);
5459  output_local ("\n");
5460 }
static void output_alter ( struct cb_alter *  p)
static

References cb_program::all_procedure, cb_build_debug(), cb_debug_contents, cb_debug_name, CB_LABEL, CB_PREFIX_LABEL, CB_REFERENCE, cb_label::debug_section, cb_label::flag_debugging_mode, cb_program::flag_gen_debug, cb_label::flag_real_label, cb_label::id, cb_label::name, NULL, output_line(), output_perform_call(), output_stmt(), cb_alter::source, and cb_alter::target.

Referenced by output_stmt().

4409 {
4410  struct cb_label *l1;
4411  struct cb_label *l2;
4412 
4413  l1 = CB_LABEL (CB_REFERENCE(p->source)->value);
4414  l2 = CB_LABEL (CB_REFERENCE(p->target)->value);
4415  output_line ("label_%s%d = %d;", CB_PREFIX_LABEL, l1->id, l2->id);
4416 
4417  /* Check for debugging on procedure name */
4418  if (current_prog->flag_gen_debug && l1->flag_real_label &&
4419  (current_prog->all_procedure || l1->flag_debugging_mode)) {
4420  output_stmt (cb_build_debug (cb_debug_name,
4421  (const char *)l1->name, NULL));
4422  output_stmt (cb_build_debug (cb_debug_contents,
4423  (const char *)l2->name, NULL));
4424  if (current_prog->all_procedure) {
4425  output_perform_call (current_prog->all_procedure,
4426  current_prog->all_procedure);
4427  } else if (l1->flag_debugging_mode) {
4428  output_perform_call (l1->debug_section,
4429  l1->debug_section);
4430  }
4431  }
4432 }
static void output_alter_check ( struct cb_label *  lp)
static

References cb_label::alter_gotos, CB_PREFIX_LABEL, cb_program::flag_segments, cb_alter_id::goto_id, cb_label::id, cb_alter_id::next, output_indent(), output_line(), output_local(), and output_newline().

Referenced by output_stmt().

4585 {
4586  struct cb_alter_id *aid;
4587 
4588  output_local ("static int\tlabel_%s%d = 0;\n",
4589  CB_PREFIX_LABEL, lp->id);
4590  if (current_prog->flag_segments) {
4591  output_local ("static int\tsave_label_%s%d = 0;\n",
4592  CB_PREFIX_LABEL, lp->id);
4593  }
4594  output_newline ();
4595  output_line ("/* ALTER processing */");
4596  output_line ("switch (label_%s%d)",
4597  CB_PREFIX_LABEL, lp->id);
4598  output_indent ("{");
4599  for (aid = lp->alter_gotos; aid; aid = aid->next) {
4600  output_line ("case %d:", aid->goto_id);
4601  output_line ("goto %s%d;", CB_PREFIX_LABEL, aid->goto_id);
4602  }
4603  output_indent ("}");
4604  output_newline ();
4605 }
static void output_attr ( const cb_tree  x)
static

References _, cb_literal::all, CB_CLASS_NUMERIC, CB_FIELD, CB_LITERAL, CB_PREFIX_ATTR, CB_REFERENCE, CB_TAG_ALPHABET_NAME, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_CLASS, CB_TREE_TAG, cb_tree_type(), CB_USAGE_BINARY, CB_USAGE_COMP_6, CB_USAGE_DOUBLE, CB_USAGE_FLOAT, CB_USAGE_FP_BIN128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_DEC128, CB_USAGE_FP_DEC64, CB_USAGE_LONG_DOUBLE, COB_FLAG_BINARY_SWAP, COB_FLAG_BINARY_TRUNC, COB_FLAG_BLANK_ZERO, COB_FLAG_HAVE_SIGN, COB_FLAG_IS_FP, COB_FLAG_IS_POINTER, COB_FLAG_JUSTIFIED, COB_FLAG_NO_SIGN_NIBBLE, COB_FLAG_REAL_BINARY, COB_FLAG_SIGN_LEADING, COB_FLAG_SIGN_SEPARATE, COB_TYPE_ALPHANUMERIC, COB_TYPE_ALPHANUMERIC_ALL, COB_TYPE_GROUP, COB_TYPE_NUMERIC_DISPLAY, cob_u32_t, cob_u8_ptr, COBC_ABORT, cobc_abort_pr(), cb_picture::digits, cb_field::flag_binary_swap, cb_field::flag_blank_zero, cb_field::flag_is_pointer, cb_field::flag_justified, cb_field::flag_real_binary, cb_field::flag_sign_leading, cb_field::flag_sign_separate, cb_picture::have_sign, cb_field::id, cb_picture::lenstr, lookup_attr(), NULL, cb_reference::offset, output(), cb_field::pic, cb_literal::scale, cb_picture::scale, cb_literal::sign, cb_literal::size, cb_picture::str, cb_field::usage, and cb_reference::value.

Referenced by codegen(), output_field(), and output_param().

896 {
897  struct cb_literal *l;
898  struct cb_reference *r;
899  struct cb_field *f;
900  int id;
901  int type;
902  cob_u32_t flags;
903 
904  id = 0;
905  switch (CB_TREE_TAG (x)) {
906  case CB_TAG_LITERAL:
907  l = CB_LITERAL (x);
908  if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
909  flags = 0;
910  if (l->sign != 0) {
911  flags = COB_FLAG_HAVE_SIGN | COB_FLAG_SIGN_SEPARATE;
912  }
913  id = lookup_attr (COB_TYPE_NUMERIC_DISPLAY,
914  l->size, l->scale, flags, NULL, 0);
915  } else {
916  if (l->all) {
917  id = lookup_attr (COB_TYPE_ALPHANUMERIC_ALL, 0, 0, 0, NULL, 0);
918  } else {
919  id = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
920  }
921  }
922  break;
923  case CB_TAG_REFERENCE:
924  r = CB_REFERENCE (x);
925  f = CB_FIELD (r->value);
926  flags = 0;
927  if (r->offset) {
928  id = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
929  } else {
930  type = cb_tree_type (x, f);
931  switch (type) {
932  case COB_TYPE_GROUP:
933  case COB_TYPE_ALPHANUMERIC:
934  if (f->flag_justified) {
935  id = lookup_attr (type, 0, 0, COB_FLAG_JUSTIFIED, NULL, 0);
936  } else {
937  id = lookup_attr (type, 0, 0, 0, NULL, 0);
938  }
939  break;
940  default:
941  if (f->pic->have_sign) {
942  flags |= COB_FLAG_HAVE_SIGN;
943  if (f->flag_sign_separate) {
944  flags |= COB_FLAG_SIGN_SEPARATE;
945  }
946  if (f->flag_sign_leading) {
947  flags |= COB_FLAG_SIGN_LEADING;
948  }
949  }
950  if (f->flag_blank_zero) {
951  flags |= COB_FLAG_BLANK_ZERO;
952  }
953  if (f->flag_justified) {
954  flags |= COB_FLAG_JUSTIFIED;
955  }
956  if (f->flag_binary_swap) {
957  flags |= COB_FLAG_BINARY_SWAP;
958  }
959  if (f->flag_real_binary) {
960  flags |= COB_FLAG_REAL_BINARY;
961  }
962  if (f->flag_is_pointer) {
963  flags |= COB_FLAG_IS_POINTER;
964  }
965  if (cb_binary_truncate &&
966  f->usage == CB_USAGE_BINARY &&
967  !f->flag_real_binary) {
968  flags |= COB_FLAG_BINARY_TRUNC;
969  }
970 
971  switch (f->usage) {
972  case CB_USAGE_COMP_6:
973  flags |= COB_FLAG_NO_SIGN_NIBBLE;
974  break;
975  case CB_USAGE_DOUBLE:
976  case CB_USAGE_FLOAT:
977  case CB_USAGE_LONG_DOUBLE:
978 #if 0 /* RXWRXW - Floating ind */
979  case CB_USAGE_FP_BIN32:
980  case CB_USAGE_FP_BIN64:
981  case CB_USAGE_FP_BIN128:
982  case CB_USAGE_FP_DEC64:
983  case CB_USAGE_FP_DEC128:
984 #endif
985  flags |= COB_FLAG_IS_FP;
986  break;
987  default:
988  break;
989  }
990 
991  id = lookup_attr (type, f->pic->digits,
992  f->pic->scale, flags,
993  (cob_u8_ptr) f->pic->str,
994  f->pic->lenstr);
995  break;
996  }
997  }
998  break;
999  case CB_TAG_ALPHABET_NAME:
1000  id = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
1001  break;
1002  default:
1003  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
1004  COBC_ABORT ();
1005  }
1006 
1007  output ("&%s%d", CB_PREFIX_ATTR, id);
1008 }
static void output_base ( struct cb_field *  f,
const cob_u32_t  no_output 
)
static

References _, base_cache, CB_PREFIX_BASE, cb_field::children, chk_field_variable_address(), chk_field_variable_size(), COBC_ABORT, cobc_abort_pr(), cobc_parse_malloc(), base_list::curr_prog, cb_field::depending, excp_current_program_id, base_list::f, cb_field::flag_base, cb_field::flag_external, cb_program::flag_file_global, cb_program::flag_global_use, cb_field::flag_is_global, cb_field::flag_item_78, cb_field::flag_local, cb_field::flag_local_storage, cb_field::id, local_base_cache, cb_field::mem_offset, cb_field::name, base_list::next, cb_field::occurs_max, cb_field::offset, output(), output_integer(), output_local(), p, cb_field::parent, real_field_founder(), cb_field::sister, cb_field::size, and cb_field::special_index.

Referenced by output_data(), output_integer(), output_internal_function(), and output_long_integer().

606 {
607  struct cb_field *f01;
608  struct cb_field *p;
609  struct cb_field *v;
610  struct base_list *bl;
611 
612  if (f->flag_item_78) {
613  cobc_abort_pr (_("Unexpected CONSTANT item"));
614  COBC_ABORT ();
615  }
616 
617  f01 = real_field_founder (f);
618 
619  /* Base storage */
620 
621  if (!f01->flag_base) {
622  if (f01->special_index > 1U) {
623  bl = cobc_parse_malloc (sizeof (struct base_list));
624  bl->f = f01;
625  bl->curr_prog = excp_current_program_id;
626  bl->next = local_base_cache;
627  local_base_cache = bl;
628  } else if (!f01->flag_external && !f01->flag_local_storage) {
629 /* RXWRXW
630  if (!f01->flag_external && !f01->flag_local_storage) {
631 */
632  if (!f01->flag_local || f01->flag_is_global) {
633  bl = cobc_parse_malloc (sizeof (struct base_list));
634  bl->f = f01;
635  bl->curr_prog = excp_current_program_id;
636  if (f01->flag_is_global ||
637  current_prog->flag_file_global) {
638  bl->next = base_cache;
639  base_cache = bl;
640  } else {
641  bl->next = local_base_cache;
642  local_base_cache = bl;
643  }
644  } else {
645  if (current_prog->flag_global_use) {
646  output_local ("unsigned char\t\t*%s%d = NULL;",
647  CB_PREFIX_BASE, f01->id);
648  output_local ("\t/* %s */\n", f01->name);
649  output_local ("static unsigned char\t*save_%s%d;\n",
650  CB_PREFIX_BASE, f01->id);
651  } else {
652  output_local ("unsigned char\t*%s%d = NULL;",
653  CB_PREFIX_BASE, f01->id);
654  output_local ("\t/* %s */\n", f01->name);
655  }
656  }
657  }
658  f01->flag_base = 1;
659  }
660  if (no_output) {
661  return;
662  }
663 
664  if (f01->special_index) {
665  output ("(cob_u8_t *)&%s%d", CB_PREFIX_BASE, f01->id);
666  return;
667  } else if (f01->flag_local_storage) {
668  if (f01->mem_offset) {
669  output ("cob_local_ptr + %d", f01->mem_offset);
670  } else {
671  output ("cob_local_ptr");
672  }
673  } else {
674  output ("%s%d", CB_PREFIX_BASE, f01->id);
675  }
676 
677  if (chk_field_variable_address (f)) {
678  for (p = f->parent; p; f = f->parent, p = f->parent) {
679  for (p = p->children; p != f; p = p->sister) {
680  v = chk_field_variable_size (p);
681  if (v) {
682  output (" + %d + ", v->offset - p->offset);
683  if (v->size != 1) {
684  output ("%d * ", v->size);
685  }
686  output_integer (v->depending);
687  } else if (p->depending && cb_flag_odoslide) {
688  output (" + ");
689  if (p->size != 1) {
690  output ("%d * ", p->size);
691  }
692  output_integer (p->depending);
693  } else {
694  output (" + %d", p->size * p->occurs_max);
695  }
696  }
697  }
698  } else if (f->offset > 0) {
699  output (" + %d", f->offset);
700  }
701 }
static void output_bin_field ( const cb_tree  x,
const cob_u32_t  id 
)
static

References cb_fits_int(), CB_LITERAL, CB_NUMERIC_LITERAL_P, CB_PREFIX_ATTR, COB_FLAG_HAVE_SIGN, COB_FLAG_REAL_BINARY, COB_TYPE_NUMERIC_BINARY, cob_u32_t, lookup_attr(), NULL, output_line(), sign, and cb_field::size.

Referenced by output_call().

3235 {
3236  int i;
3237  cob_u32_t size;
3238  cob_u32_t aflags;
3239  cob_u32_t digits;
3240 
3241  if (!CB_NUMERIC_LITERAL_P (x)) {
3242  return;
3243  }
3244  aflags = 0;
3245  if (cb_fits_int (x)) {
3246  size = 4;
3247  aflags = COB_FLAG_HAVE_SIGN;
3248  } else {
3249  size = 8;
3250  if (CB_LITERAL (x)->sign < 0) {
3251  aflags = COB_FLAG_HAVE_SIGN;
3252  }
3253  }
3254  if (size == 8) {
3255  digits = 18;
3256  } else {
3257  digits = 9;
3258  }
3259  aflags |= COB_FLAG_REAL_BINARY;
3260  i = lookup_attr (COB_TYPE_NUMERIC_BINARY, digits, 0, aflags, NULL, 0);
3261  output_line ("cob_field\tcontent_fb_%u = { %u, content_%u.data, &%s%d };",
3262  id, size, id, CB_PREFIX_ATTR, i);
3263 }
static void output_call ( struct cb_call *  p)
static

References cb_call::args, cb_call::call_returning, CB_BINARY_OP_P, CB_CALL_BY_CONTENT, CB_CALL_BY_REFERENCE, CB_CALL_BY_VALUE, CB_CAST_P, CB_CATEGORY_NUMERIC, CB_CHAIN, CB_CLASS_POINTER, CB_CONV_NO_RET_UPD, CB_CONV_STATIC_LINK, CB_CONV_STDCALL, cb_early_exit_list, cb_encode_program_id(), CB_FIELD, CB_FIELD_P, CB_FILE_P, cb_fits_int(), CB_FMT_LLD_F, CB_FMT_LLU_F, cb_get_int(), cb_get_long_long(), cb_get_u_long_long(), CB_LITERAL, CB_LITERAL_P, cb_null, CB_NUMERIC_LITERAL_P, CB_PURPOSE_INT, cb_ref(), CB_REF_OR_FIELD_P, CB_REFERENCE, CB_REFERENCE_P, cb_program::cb_return_code, cb_static_call_list, CB_TAG_FIELD, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_CATEGORY, CB_TREE_CLASS, CB_TREE_TAG, CB_USAGE_LENGTH, CB_USAGE_PROGRAM_POINTER, CB_VALUE, COB_MAX_FIELD_PARAMS, cob_u32_t, cb_call::convention, cb_literal::data, field_iteration, gen_nested_tab, cb_call::is_system, lookup_call(), cb_call::name, needs_exit_prog, needs_unifunc, nested_list::nested_prog, cb_program::nested_prog_list, cb_text_list::next, nested_list::next, NULL, output(), output_bin_field(), output_call_by_value_args(), output_data(), output_indent(), output_indent_level, output_integer(), output_line(), output_move(), output_newline(), output_param(), output_prefix(), output_size(), output_stmt(), output_string(), cb_program::program_id, sign, cb_call::stmt1, cb_call::stmt2, system_table::syst_call, system_table::syst_name, cb_text_list::text, cb_program::toplev_count, and value.

Referenced by output_stmt().

3267 {
3268  cb_tree x;
3269  cb_tree l;
3270  struct cb_literal *lp;
3271  struct nested_list *nlp;
3272  char *callp;
3273  char *system_call;
3274  const struct system_table *psyst;
3275  const char *convention;
3276  struct cb_text_list *ctl;
3277  char *s;
3278  cob_u32_t n;
3279  size_t retptr;
3280  size_t gen_exit_program;
3281  size_t dynamic_link;
3282  size_t need_brace;
3283 #if 0 /* RXWRXW - Clear params */
3284  cob_u32_t parmnum;
3285 #endif
3286 
3287  system_call = NULL;
3288  retptr = 0;
3289  gen_exit_program = 0;
3290  dynamic_link = 1;
3291  if (p->call_returning && p->call_returning != cb_null &&
3292  CB_TREE_CLASS(p->call_returning) == CB_CLASS_POINTER) {
3293  retptr = 1;
3294  }
3295 
3296 #ifdef _WIN32
3297  if (p->convention & CB_CONV_STDCALL) {
3298  convention = "_std";
3299  } else {
3300  convention = "";
3301  }
3302 #else
3303  convention = "";
3304 #endif
3305 
3306  /* System routine entry points */
3307  if (p->is_system) {
3308 #if 0 /* RXWRXW - system */
3309  lp = CB_LITERAL (p->name);
3310  for (psyst = system_tab; psyst->syst_name; psyst++) {
3311  if (!strcmp((const char *)lp->data,
3312  (const char *)psyst->syst_name)) {
3313  system_call = (char *)psyst->syst_call;
3314  dynamic_link = 0;
3315  break;
3316  }
3317  }
3318 #else
3319  n = p->is_system - 1U;
3320  psyst = &system_tab[n];
3321  system_call = (char *)psyst->syst_call;
3322  dynamic_link = 0;
3323 #endif
3324  }
3325 
3326  if (dynamic_link && CB_LITERAL_P (p->name)) {
3327  if (cb_flag_static_call || (p->convention & CB_CONV_STATIC_LINK)) {
3328  dynamic_link = 0;
3329  }
3330  lp = CB_LITERAL (p->name);
3331  for (ctl = cb_static_call_list; ctl; ctl = ctl->next) {
3332  if (!strcmp((const char *)lp->data, ctl->text)) {
3333  dynamic_link = 0;
3334  break;
3335  }
3336  }
3337  for (ctl = cb_early_exit_list; ctl; ctl = ctl->next) {
3338  if (!strcmp((const char *)lp->data, ctl->text)) {
3339  gen_exit_program = 1;
3340  break;
3341  }
3342  }
3343  }
3344  need_brace = 0;
3345 
3346 #ifdef COB_NON_ALIGNED
3347  if (dynamic_link && retptr) {
3348  if (!need_brace) {
3349  need_brace = 1;
3350  output_indent ("{");
3351  }
3352  output_line ("void *temptr;");
3353  }
3354 #endif
3355 
3356  if (CB_REFERENCE_P (p->name) &&
3357  CB_FIELD_P (CB_REFERENCE (p->name)->value) &&
3358  CB_FIELD (CB_REFERENCE (p->name)->value)->usage == CB_USAGE_PROGRAM_POINTER) {
3359  dynamic_link = 0;
3360  }
3361 
3362  /* Set up arguments */
3363  for (l = p->args, n = 1; l; l = CB_CHAIN (l), n++) {
3364  x = CB_VALUE (l);
3365  switch (CB_PURPOSE_INT (l)) {
3366  case CB_CALL_BY_REFERENCE:
3367  if (CB_NUMERIC_LITERAL_P (x) || CB_BINARY_OP_P (x)) {
3368  if (!need_brace) {
3369  need_brace = 1;
3370  output_indent ("{");
3371  }
3372  output_line ("cob_content\tcontent_%u;", n);
3373  output_bin_field (x, n);
3374  } else if (CB_CAST_P (x)) {
3375  if (!need_brace) {
3376  need_brace = 1;
3377  output_indent ("{");
3378  }
3379  output_line ("void *ptr_%u;", n);
3380  }
3381  break;
3382  case CB_CALL_BY_CONTENT:
3383  if (CB_CAST_P (x)) {
3384  if (!need_brace) {
3385  need_brace = 1;
3386  output_indent ("{");
3387  }
3388  output_line ("void *ptr_%u;", n);
3389  } else if (CB_TREE_TAG (x) != CB_TAG_INTRINSIC &&
3390  x != cb_null && !(CB_CAST_P (x))) {
3391  if (!need_brace) {
3392  need_brace = 1;
3393  output_indent ("{");
3394  }
3395  output_line ("union {");
3396  output_prefix ();
3397  output ("\tunsigned char data[");
3398  if (CB_NUMERIC_LITERAL_P (x) ||
3399  CB_BINARY_OP_P (x) || CB_CAST_P(x)) {
3400  output ("8");
3401  } else {
3402  if (CB_REF_OR_FIELD_P (x)) {
3403  output ("%u", (cob_u32_t)cb_code_field (x)->size);
3404  } else {
3405  output_size (x);
3406  }
3407  }
3408  output ("];\n");
3409  output_line ("\tcob_s64_t datall;");
3410  output_line ("\tcob_u64_t dataull;");
3411  output_line ("\tint dataint;");
3412  output_line ("} content_%u;", n);
3413  output_bin_field (x, n);
3414  }
3415  break;
3416  default:
3417  break;
3418  }
3419  }
3420 
3421  if (need_brace) {
3422  output_newline ();
3423  }
3424 
3425  for (l = p->args, n = 1; l; l = CB_CHAIN (l), n++) {
3426  x = CB_VALUE (l);
3427  switch (CB_PURPOSE_INT (l)) {
3428  case CB_CALL_BY_REFERENCE:
3429  if (CB_NUMERIC_LITERAL_P (x)) {
3430  output_prefix ();
3431  if (cb_fits_int (x)) {
3432  output ("content_%u.dataint = ", n);
3433  output ("%d", cb_get_int (x));
3434  } else {
3435  if (CB_LITERAL (x)->sign >= 0) {
3436  output ("content_%u.dataull = ", n);
3437  output (CB_FMT_LLU_F,
3438  cb_get_u_long_long (x));
3439  } else {
3440  output ("content_%u.datall = ", n);
3441  output (CB_FMT_LLD_F,
3442  cb_get_long_long (x));
3443  }
3444  }
3445  output (";\n");
3446  } else if (CB_BINARY_OP_P (x)) {
3447  output_prefix ();
3448  output ("content_%u.dataint = ", n);
3449  output_integer (x);
3450  output (";\n");
3451  } else if (CB_CAST_P (x)) {
3452  output_prefix ();
3453  output ("ptr_%u = ", n);
3454  output_integer (x);
3455  output (";\n");
3456  }
3457  break;
3458  case CB_CALL_BY_CONTENT:
3459  if (CB_CAST_P (x)) {
3460  output_prefix ();
3461  output ("ptr_%u = ", n);
3462  output_integer (x);
3463  output (";\n");
3464  } else if (CB_TREE_TAG (x) != CB_TAG_INTRINSIC) {
3465  if (CB_NUMERIC_LITERAL_P (x)) {
3466  output_prefix ();
3467  if (cb_fits_int (x)) {
3468  output ("content_%u.dataint = ", n);
3469  output ("%d", cb_get_int (x));
3470  } else {
3471  if (CB_LITERAL (x)->sign >= 0) {
3472  output ("content_%u.dataull = ", n);
3473  output (CB_FMT_LLU_F,
3474  cb_get_u_long_long (x));
3475  } else {
3476  output ("content_%u.datall = ", n);
3477  output (CB_FMT_LLD_F,
3478  cb_get_long_long (x));
3479  }
3480  }
3481  output (";\n");
3482  } else if (CB_REF_OR_FIELD_P (x) &&
3483  CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC &&
3484  cb_code_field (x)->usage == CB_USAGE_LENGTH) {
3485  output_prefix ();
3486  output ("content_%u.dataint = ", n);
3487  output_integer (x);
3488  output (";\n");
3489  } else if (x != cb_null && !(CB_CAST_P (x))) {
3490  output_prefix ();
3491  output ("memcpy (content_%u.data, ", n);
3492  output_data (x);
3493  output (", ");
3494  output_size (x);
3495  output (");\n");
3496  }
3497  }
3498  break;
3499  default:
3500  break;
3501  }
3502  }
3503 
3504  /* Set up parameter types */
3505  n = 0;
3506  for (l = p->args; l; l = CB_CHAIN (l), n++) {
3507  x = CB_VALUE (l);
3508  field_iteration = n;
3509  output_prefix ();
3510  output ("cob_procedure_params[%u] = ", n);
3511  switch (CB_TREE_TAG (x)) {
3512  case CB_TAG_LITERAL:
3513  if (CB_NUMERIC_LITERAL_P (x) &&
3514  CB_PURPOSE_INT (l) != CB_CALL_BY_VALUE) {
3515  output ("&content_fb_%u", n + 1);
3516  break;
3517  }
3518  /* Fall through */
3519  case CB_TAG_FIELD:
3520  case CB_TAG_INTRINSIC:
3521  output_param (x, -1);
3522  break;
3523  case CB_TAG_REFERENCE:
3524  switch (CB_TREE_TAG (CB_REFERENCE(x)->value)) {
3525  case CB_TAG_LITERAL:
3526  case CB_TAG_FIELD:
3527  case CB_TAG_INTRINSIC:
3528  output_param (x, -1);
3529  break;
3530  default:
3531  output ("NULL");
3532  break;
3533  }
3534  break;
3535  default:
3536  output ("NULL");
3537  break;
3538  }
3539  output (";\n");
3540  }
3541 
3542 #if 0 /* RXWRXW - Clear params */
3543  /* Clear extra parameters */
3544  if (n > COB_MAX_FIELD_PARAMS - 4) {
3545  parmnum = COB_MAX_FIELD_PARAMS - n;
3546  } else {
3547  parmnum = 4;
3548  }
3549  parmnum *= sizeof(cob_field *);
3550  output_line ("memset (&(cob_procedure_params[%u]), 0, %u);",
3551  n, parmnum);
3552 #endif
3553 
3554  /* Set number of parameters */
3555  output_prefix ();
3556  output ("cob_glob_ptr->cob_call_params = %u;\n", n);
3557 
3558  /* Function name */
3559  output_prefix ();
3560  /* Special for program pointers */
3561  if (CB_REFERENCE_P (p->name) &&
3562  CB_FIELD_P (CB_REFERENCE (p->name)->value) &&
3563  CB_FIELD (CB_REFERENCE (p->name)->value)->usage ==
3564  CB_USAGE_PROGRAM_POINTER) {
3565  needs_unifunc = 1;
3566  output ("cob_unifunc.funcvoid = ");
3567  output_integer (p->name);
3568  output (";\n");
3569  output_prefix ();
3570  if (p->call_returning == cb_null) {
3571  output ("cob_unifunc.funcnull");
3572  } else if (retptr) {
3573 #ifdef COB_NON_ALIGNED
3574  output ("temptr");
3575 #else
3576  output_integer (p->call_returning);
3577 #endif
3578  output (" = cob_unifunc.funcptr");
3579  } else {
3580  if (p->convention & CB_CONV_NO_RET_UPD) {
3581  output ("(void)cob_unifunc.funcint");
3582  } else {
3583  output_integer (current_prog->cb_return_code);
3584  output (" = cob_unifunc.funcint");
3585  }
3586  }
3587  } else if (!dynamic_link) {
3588  /* Static link */
3589  if (p->call_returning != cb_null) {
3590  if (retptr) {
3591 #ifdef COB_NON_ALIGNED
3592  output ("temptr");
3593 #else
3594  output_integer (p->call_returning);
3595 #endif
3596  output (" = (void *)");
3597  } else if (!(p->convention & CB_CONV_NO_RET_UPD)) {
3598  output_integer (current_prog->cb_return_code);
3599  output (" = ");
3600  } else {
3601  output ("(void)");
3602  }
3603  }
3604  if (system_call) {
3605  output ("%s", system_call);
3606  } else {
3607  callp = cb_encode_program_id ((char *)(CB_LITERAL (p->name)->data));
3608  /* Check contained programs */
3609  nlp = current_prog->nested_prog_list;
3610  for (; nlp; nlp = nlp->next) {
3611  if (!strcmp (callp, nlp->nested_prog->program_id)) {
3612  break;
3613  }
3614  }
3615  if (nlp) {
3616  output ("%s_%d__", callp,
3617  nlp->nested_prog->toplev_count);
3618  } else {
3619  output ("%s", callp);
3620  }
3621  }
3622  } else {
3623  /* Dynamic link */
3624  if (CB_LITERAL_P (p->name)) {
3625  s = (char *)(CB_LITERAL (p->name)->data);
3626  callp = cb_encode_program_id (s);
3627  lookup_call (callp);
3628  /* Check contained programs */
3629  nlp = current_prog->nested_prog_list;
3630  for (; nlp; nlp = nlp->next) {
3631  if (!strcmp (callp, nlp->nested_prog->program_id)) {
3632  break;
3633  }
3634  }
3635  output ("if (unlikely(call_%s.funcvoid == NULL)) {\n", callp);
3636  output_prefix ();
3637  if (nlp) {
3638  output (" call_%s.funcint = %s_%d__;\n",
3639  callp, callp,
3640  nlp->nested_prog->toplev_count);
3641  } else {
3642  output (" call_%s.funcvoid = ", callp);
3643  output ("cob_resolve_cobol (");
3644  output_string ((const unsigned char *)s,
3645  (int)strlen (s), 0);
3646  output (", %d, %d);\n", cb_fold_call, !p->stmt1);
3647  }
3648  output_prefix ();
3649  output ("}\n");
3650  } else {
3651  callp = NULL;
3652  needs_unifunc = 1;
3653  output ("cob_unifunc.funcvoid = cob_call_field (");
3654  output_param (p->name, -1);
3655  if (current_prog->nested_prog_list) {
3656  gen_nested_tab = 1;
3657  output (", cob_nest_tab, %d, %d);\n",
3658  !p->stmt1, cb_fold_call);
3659  } else {
3660  output (", NULL, %d, %d);\n",
3661  !p->stmt1, cb_fold_call);
3662  }
3663  }
3664  if (p->stmt1) {
3665  if (callp) {
3666  output_line ("if (unlikely(call_%s.funcvoid == NULL))", callp);
3667  } else {
3668  output_line ("if (unlikely(cob_unifunc.funcvoid == NULL))");
3669  }
3670  output_line ("{");
3671  output_indent_level += 2;
3672  output_stmt (p->stmt1);
3673  output_indent_level -= 2;
3674  output_line ("}");
3675  output_line ("else");
3676  output_indent ("{");
3677  }
3678  output_prefix ();
3679  if (p->call_returning == cb_null) {
3680  if (callp) {
3681  output ("call_%s.funcnull%s", callp, convention);
3682  } else {
3683  output ("cob_unifunc.funcnull%s", convention);
3684  }
3685  } else if (retptr) {
3686 #ifdef COB_NON_ALIGNED
3687  output ("temptr");
3688 #else
3689  output_integer (p->call_returning);
3690 #endif
3691  if (callp) {
3692  output (" = call_%s.funcptr%s", callp, convention);
3693  } else {
3694  output (" = cob_unifunc.funcptr%s", convention);
3695  }
3696  } else {
3697  if (!(p->convention & CB_CONV_NO_RET_UPD)) {
3698  output_integer (current_prog->cb_return_code);
3699  output (" = ");
3700  } else {
3701  output ("(void)");
3702  }
3703  if (callp) {
3704  output ("call_%s.funcint%s", callp, convention);
3705  } else {
3706  output ("cob_unifunc.funcint%s", convention);
3707  }
3708  }
3709  }
3710 
3711  /* Arguments */
3712  output (" (");
3713  for (l = p->args, n = 1; l; l = CB_CHAIN (l), n++) {
3714  x = CB_VALUE (l);
3715  field_iteration = n - 1U;
3716  switch (CB_PURPOSE_INT (l)) {
3717  case CB_CALL_BY_REFERENCE:
3718  if (CB_NUMERIC_LITERAL_P (x) || CB_BINARY_OP_P (x)) {
3719  output ("content_%u.data", n);
3720  } else if (CB_REFERENCE_P (x) && CB_FILE_P (cb_ref (x))) {
3721  output_param (cb_ref (x), -1);
3722  } else if (CB_CAST_P (x)) {
3723  output ("&ptr_%u", n);
3724  } else {
3725  output_data (x);
3726  }
3727  break;
3728  case CB_CALL_BY_CONTENT:
3729  if (CB_TREE_TAG (x) != CB_TAG_INTRINSIC && x != cb_null) {
3730  if (CB_CAST_P (x)) {
3731  output ("&ptr_%u", n);
3732  } else {
3733  output ("content_%u.data", n);
3734  }
3735  } else {
3736  output_data (x);
3737  }
3738  break;
3739  case CB_CALL_BY_VALUE:
3740  output_call_by_value_args (x, l);
3741  break;
3742  default:
3743  break;
3744  }
3745  if (CB_CHAIN (l)) {
3746  output (", ");
3747  }
3748  }
3749 
3750  output (");\n");
3751 
3752  if (p->call_returning) {
3753  if (p->call_returning == cb_null) {
3754  output_prefix ();
3755  output_integer (current_prog->cb_return_code);
3756  output (" = 0;\n");
3757  } else if (!retptr) {
3758  output_move (current_prog->cb_return_code,
3759  p->call_returning);
3760 #ifdef COB_NON_ALIGNED
3761  } else {
3762  output_prefix ();
3763  output ("memcpy (");
3764  output_data (p->call_returning);
3765  output (", &temptr, %u);\n", (cob_u32_t)sizeof (void *));
3766 #endif
3767  }
3768  }
3769  if (gen_exit_program) {
3770  needs_exit_prog = 1;
3771  output_line ("if (unlikely(module->flag_exit_program)) {");
3772  output_line ("\tmodule->flag_exit_program = 0;");
3773  output_line ("\tgoto exit_program;");
3774  output_line ("}");
3775  }
3776  if (p->stmt2) {
3777  output_stmt (p->stmt2);
3778  }
3779 
3780  if (dynamic_link && p->stmt1) {
3781  output_indent ("}");
3782  }
3783 
3784  if (need_brace) {
3785  output_indent ("}");
3786  }
3787 }
static void output_call_by_value_args ( cb_tree  x,
cb_tree  l 
)
static

References _, CB_CATEGORY_NUMERIC, CB_CLASS_NUMERIC, CB_FMT_LLD_F, CB_FMT_LLU_F, cb_get_long_long(), cb_get_u_long_long(), CB_INTRINSIC, CB_LITERAL, CB_SIZE_1, CB_SIZE_2, CB_SIZE_4, CB_SIZE_8, CB_SIZE_AUTO, CB_SIZES_INT, CB_SIZES_INT_UNSIGNED, CB_TAG_CAST, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TREE_CLASS, CB_TREE_TAG, 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_USAGE_POINTER, CB_USAGE_PROGRAM_POINTER, cob_s64_t, cob_u64_t, COBC_ABORT, cobc_abort_pr(), cb_picture::digits, cb_picture::have_sign, output(), output_data(), output_integer(), output_param(), cb_field::pic, cb_picture::scale, sign, cb_field::size, and cb_field::usage.

Referenced by output_call().

3002 {
3003  struct cb_field *f;
3004  const char *s;
3005  cob_s64_t val;
3006  cob_u64_t uval;
3007  int sizes;
3008  int sign;
3009 
3010  switch (CB_TREE_TAG (x)) {
3011  case CB_TAG_CAST:
3012  output_integer (x);
3013  return;
3014  case CB_TAG_INTRINSIC:
3015  if (CB_INTRINSIC(x)->intr_tab->category == CB_CATEGORY_NUMERIC) {
3016  output ("cob_get_int (");
3017  output_param (x, -1);
3018  output (")");
3019  } else {
3020  output_data (x);
3021  }
3022  return;
3023  case CB_TAG_LITERAL:
3024  if (CB_TREE_CLASS (x) != CB_CLASS_NUMERIC) {
3025  output ("%d", CB_LITERAL (x)->data[0]);
3026  return;
3027  }
3028  if (CB_SIZES_INT_UNSIGNED(l)) {
3029  uval = cb_get_u_long_long (x);
3030  switch (CB_SIZES_INT (l)) {
3031  case CB_SIZE_AUTO:
3032  if (uval > UINT_MAX) {
3033  output ("(cob_u64_t)");
3034  output (CB_FMT_LLU_F, uval);
3035  return;
3036  }
3037  /* Fall through to case 4 */
3038  case CB_SIZE_4:
3039  output ("(cob_u32_t)");
3040  output (CB_FMT_LLU_F, uval);
3041  return;
3042  case CB_SIZE_1:
3043  output ("(cob_u8_t)");
3044  output (CB_FMT_LLU_F, uval);
3045  return;
3046  case CB_SIZE_2:
3047  output ("(cob_u16_t)");
3048  output (CB_FMT_LLU_F, uval);
3049  return;
3050  case CB_SIZE_8:
3051  output ("(cob_u64_t)");
3052  output (CB_FMT_LLU_F, uval);
3053  return;
3054  default:
3055  cobc_abort_pr (_("Unexpected size"));
3056  COBC_ABORT ();
3057  }
3058  }
3059  val = cb_get_long_long (x);
3060  switch (CB_SIZES_INT (l)) {
3061  case CB_SIZE_AUTO:
3062  if (val > INT_MAX) {
3063  output ("(cob_s64_t)");
3064  output (CB_FMT_LLD_F, val);
3065  return;
3066  }
3067  /* Fall through to case 4 */
3068  case CB_SIZE_4:
3069  output ("(cob_s32_t)");
3070  output (CB_FMT_LLD_F, val);
3071  return;
3072  case CB_SIZE_1:
3073  output ("(cob_s8_t)");
3074  output (CB_FMT_LLD_F, val);
3075  return;
3076  case CB_SIZE_2:
3077  output ("(cob_s16_t)");
3078  output (CB_FMT_LLD_F, val);
3079  return;
3080  case CB_SIZE_8:
3081  output ("(cob_s64_t)");
3082  output (CB_FMT_LLD_F, val);
3083  return;
3084  default:
3085  cobc_abort_pr (_("Unexpected size"));
3086  COBC_ABORT ();
3087  }
3088  return;
3089  default:
3090  f = cb_code_field (x);
3091  switch (f->usage) {
3092  case CB_USAGE_BINARY:
3093  case CB_USAGE_COMP_5:
3094  case CB_USAGE_COMP_X:
3095  case CB_USAGE_PACKED:
3096  case CB_USAGE_DISPLAY:
3097  case CB_USAGE_COMP_6:
3098  sizes = CB_SIZES_INT (l);
3099  sign = 0;
3100  if (sizes == CB_SIZE_AUTO) {
3101  if (f->pic->have_sign) {
3102  sign = 1;
3103  }
3104  if (f->usage == CB_USAGE_PACKED ||
3105  f->usage == CB_USAGE_DISPLAY ||
3106  f->usage == CB_USAGE_COMP_6) {
3107  sizes = f->pic->digits - f->pic->scale;
3108  } else {
3109  sizes = f->size;
3110  }
3111  switch (sizes) {
3112  case 0:
3113  sizes = CB_SIZE_4;
3114  break;
3115  case 1:
3116  sizes = CB_SIZE_1;
3117  break;
3118  case 2:
3119  sizes = CB_SIZE_2;
3120  break;
3121  case 3:
3122  sizes = CB_SIZE_4;
3123  break;
3124  case 4:
3125  sizes = CB_SIZE_4;
3126  break;
3127  case 5:
3128  sizes = CB_SIZE_8;
3129  break;
3130  case 6:
3131  sizes = CB_SIZE_8;
3132  break;
3133  case 7:
3134  sizes = CB_SIZE_8;
3135  break;
3136  default:
3137  sizes = CB_SIZE_8;
3138  break;
3139  }
3140  } else {
3141  if (!CB_SIZES_INT_UNSIGNED(l)) {
3142  sign = 1;
3143  }
3144  }
3145  switch (sizes) {
3146  case CB_SIZE_1:
3147  if (sign) {
3148  s = "cob_c8_t";
3149  } else {
3150  s = "cob_u8_t";
3151  }
3152  break;
3153  case CB_SIZE_2:
3154  if (sign) {
3155  s = "cob_s16_t";
3156  } else {
3157  s = "cob_u16_t";
3158  }
3159  break;
3160  case CB_SIZE_4:
3161  if (sign) {
3162  s = "cob_s32_t";
3163  } else {
3164  s = "cob_u32_t";
3165  }
3166  break;
3167  case CB_SIZE_8:
3168  if (sign) {
3169  s = "cob_s64_t";
3170  } else {
3171  s = "cob_u64_t";
3172  }
3173  break;
3174  default:
3175  if (sign) {
3176  s = "cob_s32_t";
3177  } else {
3178  s = "cob_u32_t";
3179  }
3180  break;
3181  }
3182  output ("(%s)(", s);
3183  output_integer (x);
3184  output (")");
3185  return;
3186  case CB_USAGE_INDEX:
3187  case CB_USAGE_LENGTH:
3188  case CB_USAGE_POINTER:
3189  case CB_USAGE_PROGRAM_POINTER:
3190  output_integer (x);
3191  return;
3192  case CB_USAGE_FLOAT:
3193  output ("*(float *)(");
3194  output_data (x);
3195  output (")");
3196  return;
3197  case CB_USAGE_DOUBLE:
3198  output ("*(double *)(");
3199  output_data (x);
3200  output (")");
3201  return;
3202  case CB_USAGE_LONG_DOUBLE:
3203  output ("*(long double *)(");
3204  output_data (x);
3205  output (")");
3206  return;
3207  case CB_USAGE_FP_BIN32:
3208  output ("*(cob_u32_t *)(");
3209  output_data (x);
3210  output (")");
3211  return;
3212  case CB_USAGE_FP_BIN64:
3213  case CB_USAGE_FP_DEC64:
3214  output ("*(cob_u64_t *)(");
3215  output_data (x);
3216  output (")");
3217  return;
3218  case CB_USAGE_FP_BIN128:
3219  case CB_USAGE_FP_DEC128:
3220  output ("*(cob_fp_128 *)(");
3221  output_data (x);
3222  output (")");
3223  return;
3224  default:
3225  output ("*(");
3226  output_data (x);
3227  output (")");
3228  return;
3229  }
3230  }
3231 }
static void output_cancel ( struct cb_cancel *  p)
static

References cb_encode_program_id(), CB_LITERAL, CB_LITERAL_P, gen_nested_tab, nested_list::nested_prog, cb_program::nested_prog_list, nested_list::next, cb_program::num_proc_params, output(), output_param(), output_prefix(), output_string(), cb_program::program_id, cb_cancel::target, and cb_program::toplev_count.

Referenced by output_stmt().

3807 {
3808  struct nested_list *nlp;
3809  char *callp;
3810  char *s;
3811  int i;
3812 
3813  if (CB_LITERAL_P (p->target)) {
3814  s = (char *)(CB_LITERAL (p->target)->data);
3815  callp = cb_encode_program_id (s);
3816  nlp = current_prog->nested_prog_list;
3817  for (; nlp; nlp = nlp->next) {
3818  if (!strcmp (callp, nlp->nested_prog->program_id)) {
3819  break;
3820  }
3821  }
3822  if (nlp) {
3823  output_prefix ();
3824  output ("(void)%s_%d_ (-1", callp,
3825  nlp->nested_prog->toplev_count);
3826  for (i = 0; i < nlp->nested_prog->num_proc_params; ++i) {
3827  output (", NULL");
3828  }
3829  output (");\n");
3830  } else {
3831  output ("cob_cancel (");
3832  output_string ((const unsigned char *)s,
3833  (int)strlen (s), 0);
3834  output (");\n");
3835  }
3836  return;
3837  }
3838  output_prefix ();
3839  output ("cob_cancel_field (");
3840  output_param (p->target, -1);
3841  if (current_prog->nested_prog_list) {
3842  gen_nested_tab = 1;
3843  output (", cob_nest_tab");
3844  } else {
3845  output (", NULL");
3846  }
3847  output (");\n");
3848 }
static void output_class_name_definition ( struct cb_class_name *  p)
static

References CB_CHAIN, cb_high, CB_LITERAL, cb_low, cb_null, CB_NUMERIC_LITERAL_P, CB_PAIR_P, CB_PAIR_X, CB_PAIR_Y, cb_quote, cb_space, CB_VALUE, cb_zero, cb_class_name::cname, cb_class_name::list, literal_value(), output_indent(), output_line(), and output_newline().

Referenced by codegen().

5466 {
5467  cb_tree l;
5468  cb_tree x;
5469  unsigned char *data;
5470  size_t i;
5471  size_t size;
5472  int n;
5473  int lower;
5474  int upper;
5475  int vals[256];
5476 
5477  output_line ("static int");
5478  output_line ("%s (cob_field *f)", p->cname);
5479  output_indent ("{");
5480  output_line ("size_t\ti;\n");
5481  output_line ("for (i = 0; i < f->size; i++)");
5482  output_indent ("{");
5483  output_line ("switch (f->data[i]) {");
5484  memset (vals, 0, sizeof(vals));
5485  for (l = p->list; l; l = CB_CHAIN (l)) {
5486  x = CB_VALUE (l);
5487  if (CB_PAIR_P (x)) {
5488  lower = literal_value (CB_PAIR_X (x));
5489  upper = literal_value (CB_PAIR_Y (x));
5490  for (n = lower; n <= upper; ++n) {
5491  vals[n] = 1;
5492  }
5493  } else {
5494  if (CB_NUMERIC_LITERAL_P (x)) {
5495  vals[literal_value (x)] = 1;
5496  } else if (x == cb_space) {
5497  vals[' '] = 1;
5498  } else if (x == cb_zero) {
5499  vals['0'] = 1;
5500  } else if (x == cb_quote) {
5501  if (cb_flag_apostrophe) {
5502  vals['\''] = 1;
5503  } else {
5504  vals['"'] = 1;
5505  }
5506  } else if (x == cb_null) {
5507  vals[0] = 1;
5508  } else if (x == cb_low) {
5509  vals[0] = 1;
5510  } else if (x == cb_high) {
5511  vals[255] = 1;
5512  } else {
5513  size = CB_LITERAL (x)->size;
5514  data = CB_LITERAL (x)->data;
5515  for (i = 0; i < size; i++) {
5516  vals[data[i]] = 1;
5517  }
5518  }
5519  }
5520  }
5521  for (i = 0; i < 256; ++i) {
5522  if (vals[i]) {
5523  output_line ("case %d:", (int)i);
5524  }
5525  }
5526  output_line (" break;");
5527  output_line ("default:");
5528  output_line (" return 0;");
5529  output_line ("}");
5530  output_indent ("}");
5531  output_line ("return 1;");
5532  output_indent ("}");
5533  output_newline ();
5534 }
static void output_cond ( cb_tree  x,
const int  save_flag 
)
static

References _, CB_BINARY_OP, CB_CHAIN, cb_false, CB_TAG_BINARY_OP, CB_TAG_CONST, CB_TAG_FUNCALL, CB_TAG_LIST, CB_TREE_TAG, cb_true, CB_VALUE, COB_INSIDE_SIZE, COBC_ABORT, cobc_abort_pr(), inside_check, inside_stack, cb_binary_op::op, output(), output_funcall(), output_integer(), output_newline(), output_prefix(), output_stmt(), p, cb_binary_op::x, and cb_binary_op::y.

Referenced by output_perform_until(), output_search_all(), and output_stmt().

2084 {
2085  struct cb_binary_op *p;
2086 
2087  switch (CB_TREE_TAG (x)) {
2088  case CB_TAG_CONST:
2089  if (x == cb_true) {
2090  output ("1");
2091  } else if (x == cb_false) {
2092  output ("0");
2093  } else {
2094  cobc_abort_pr (_("Unexpected constant"));
2095  COBC_ABORT ();
2096  }
2097  break;
2098  case CB_TAG_BINARY_OP:
2099  p = CB_BINARY_OP (x);
2100  switch (p->op) {
2101  case '!':
2102  output ("!");
2103  output_cond (p->x, save_flag);
2104  break;
2105 
2106  case '&':
2107  case '|':
2108  output ("(");
2109  output_cond (p->x, save_flag);
2110  output (p->op == '&' ? " && " : " || ");
2111  output_newline ();
2112  output_prefix ();
2113  output (" ");
2114  output_cond (p->y, save_flag);
2115  output (")");
2116  break;
2117 
2118  case '=':
2119  case '<':
2120  case '[':
2121  case '>':
2122  case ']':
2123  case '~':
2124  output ("((int)");
2125  output_cond (p->x, save_flag);
2126  switch (p->op) {
2127  case '=':
2128  output (" == 0");
2129  break;
2130  case '<':
2131  output (" < 0");
2132  break;
2133  case '[':
2134  output (" <= 0");
2135  break;
2136  case '>':
2137  output (" > 0");
2138  break;
2139  case ']':
2140  output (" >= 0");
2141  break;
2142  case '~':
2143  output (" != 0");
2144  break;
2145  default:
2146  /* FIXME - Check */
2147  break;
2148  }
2149  output (")");
2150  break;
2151 
2152  default:
2153  output_integer (x);
2154  break;
2155  }
2156  break;
2157  case CB_TAG_FUNCALL:
2158  if (save_flag) {
2159  output ("(ret = ");
2160  }
2161  output_funcall (x);
2162  if (save_flag) {
2163  output (")");
2164  }
2165  break;
2166  case CB_TAG_LIST:
2167  if (save_flag) {
2168  output ("(ret = ");
2169  }
2170  inside_stack[inside_check++] = 0;
2171  if (inside_check >= COB_INSIDE_SIZE) {
2172  cobc_abort_pr (_("Internal statement stack depth exceeded -> %d"),
2173  COB_INSIDE_SIZE);
2174  COBC_ABORT ();
2175  }
2176  output ("(\n");
2177  for (; x; x = CB_CHAIN (x)) {
2178  output_stmt (CB_VALUE (x));
2179  }
2180  if (inside_check) {
2181  --inside_check;
2182  }
2183  output (")");
2184  if (save_flag) {
2185  output (")");
2186  }
2187  break;
2188  default:
2189  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
2190  COBC_ABORT ();
2191  }
2192 }
static void output_cond_debug ( cb_tree  x)
static

References CB_BINARY_OP, cb_build_debug(), cb_debug_contents, cb_debug_name, CB_REF_OR_FIELD_P, CB_TAG_BINARY_OP, CB_TAG_FUNCALL, CB_TAG_LIST, CB_TREE_TAG, NULL, cb_binary_op::op, output_funcall_debug(), output_perform_call(), output_stmt(), p, cb_binary_op::x, and cb_binary_op::y.

Referenced by output_perform_until().

4087 {
4088  struct cb_binary_op *p;
4089 
4090  switch (CB_TREE_TAG (x)) {
4091  case CB_TAG_FUNCALL:
4092  output_funcall_debug (x);
4093  break;
4094  case CB_TAG_LIST:
4095  break;
4096  case CB_TAG_BINARY_OP:
4097  p = CB_BINARY_OP (x);
4098  switch (p->op) {
4099  case '!':
4100  output_cond_debug (p->x);
4101  break;
4102 
4103  case '&':
4104  case '|':
4105  output_cond_debug (p->x);
4106  output_cond_debug (p->y);
4107  break;
4108 
4109  case '=':
4110  case '<':
4111  case '[':
4112  case '>':
4113  case ']':
4114  case '~':
4115  output_cond_debug (p->x);
4116  break;
4117 
4118  default:
4119  if (CB_REF_OR_FIELD_P (x) &&
4120  cb_code_field (x)->flag_field_debug) {
4121  output_stmt (cb_build_debug (cb_debug_name,
4122  (const char *)cb_code_field (x)->name, NULL));
4123  output_stmt (cb_build_debug (cb_debug_contents,
4124  NULL, x));
4125  output_perform_call (cb_code_field (x)->debug_section,
4126  cb_code_field (x)->debug_section);
4127  }
4128  break;
4129  }
4130  break;
4131  default:
4132  break;
4133  }
4134 }
static void output_data ( cb_tree  x)
static

References _, CB_CHAIN, CB_CLASS_NUMERIC, CB_FIELD, CB_LITERAL, cb_null, CB_REFERENCE, CB_TAG_CAST, CB_TAG_CONST, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_CLASS, CB_TREE_TAG, CB_VALUE, COBC_ABORT, cobc_abort_pr(), cb_literal::data, field_iteration, cb_field::flag_occurs, cb_literal::llit, cb_reference::offset, output(), output_base(), output_index(), output_param(), output_string(), cb_field::parent, cb_literal::sign, cb_literal::size, cb_field::size, cb_reference::subs, and cb_reference::value.

Referenced by output_call(), output_call_by_value_args(), output_field(), output_figurative(), output_funcall(), output_initialize_fp(), output_initialize_fp_bindec(), output_initialize_literal(), output_initialize_one(), output_initialize_uniform(), output_integer(), output_internal_function(), output_long_integer(), output_param(), and output_stmt().

705 {
706  struct cb_literal *l;
707  struct cb_reference *r;
708  struct cb_field *f;
709  cb_tree lsub;
710 
711  switch (CB_TREE_TAG (x)) {
712  case CB_TAG_LITERAL:
713  l = CB_LITERAL (x);
714  if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
715  output ("(cob_u8_ptr)\"%s%s\"", (char *)l->data,
716  (l->sign < 0) ? "-" : (l->sign > 0) ? "+" : "");
717  } else {
718  output ("(cob_u8_ptr)");
719  output_string (l->data, (int) l->size, l->llit);
720  }
721  break;
722  case CB_TAG_REFERENCE:
723  r = CB_REFERENCE (x);
724  f = CB_FIELD (r->value);
725 
726  /* Base address */
727  output_base (f, 0);
728 
729  /* Subscripts */
730  if (r->subs) {
731  lsub = r->subs;
732  for (; f && lsub; f = f->parent) {
733  if (f->flag_occurs) {
734  output (" + ");
735  if (f->size != 1) {
736  output ("%d * ", f->size);
737  }
738  output_index (CB_VALUE (lsub));
739  lsub = CB_CHAIN (lsub);
740  }
741  }
742  }
743 
744  /* Offset */
745  if (r->offset) {
746  output (" + ");
747  output_index (r->offset);
748  }
749  break;
750  case CB_TAG_CAST:
751  output ("&");
752  output_param (x, 0);
753  break;
754  case CB_TAG_INTRINSIC:
755  output ("cob_procedure_params[%u]->data",
756  field_iteration);
757  break;
758  case CB_TAG_CONST:
759  if (x == cb_null) {
760  output ("NULL");
761  return;
762  }
763  /* Fall through */
764  default:
765  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
766  COBC_ABORT ();
767  }
768 }
static void output_entry_function ( struct cb_program *  prog,
cb_tree  entry,
cb_tree  parameter_list,
const int  gencode 
)
static

References CB_CALL_BY_CONTENT, CB_CALL_BY_REFERENCE, CB_CALL_BY_VALUE, CB_CHAIN, CB_CLASS_NUMERIC, CB_FUNCTION_TYPE, CB_LABEL, CB_PREFIX_BASE, CB_PURPOSE, CB_PURPOSE_INT, CB_SIZE_1, CB_SIZE_2, CB_SIZE_4, CB_SIZE_8, CB_SIZE_UNSIGNED, CB_SIZES, CB_SIZES_INT, CB_TREE_CLASS, CB_USAGE_DOUBLE, CB_USAGE_FLOAT, CB_USAGE_FP_BIN128, CB_USAGE_FP_BIN32, CB_USAGE_FP_BIN64, CB_USAGE_FP_DEC128, CB_USAGE_FP_DEC64, CB_USAGE_LONG_DOUBLE, CB_USAGE_POINTER, CB_USAGE_PROGRAM_POINTER, CB_VALUE, COB_MAX_FIELD_PARAMS, cob_u32_t, cb_program::flag_chained, cb_program::flag_main, cb_program::flag_recursive, cb_field::id, cb_field::name, cb_program::nested_level, NULL, output(), cb_program::prog_type, progid, cb_program::program_id, cb_program::toplev_count, unlikely, and cb_field::usage.

Referenced by codegen().

6784 {
6785  const char *entry_name;
6786  cb_tree using_list;
6787  cb_tree l;
6788  cb_tree l1;
6789  cb_tree l2;
6790  struct cb_field *f;
6791  struct cb_field *f1;
6792  struct cb_field *f2;
6793  const char *s;
6794  const char *s2;
6795  const char *s_prefix;
6796  const char *s_type[COB_MAX_FIELD_PARAMS];
6797  cob_u32_t parmnum;
6798  cob_u32_t n;
6799 #if 0 /* RXWRXW - UFUNC */
6800  cob_u32_t n2;
6801 #endif
6802  int sticky_ids[COB_MAX_FIELD_PARAMS];
6803  int sticky_nonp[COB_MAX_FIELD_PARAMS];
6804 
6805  entry_name = CB_LABEL (CB_PURPOSE (entry))->name;
6806  using_list = CB_VALUE (entry);
6807 
6808  if (gencode) {
6809  output ("/* ENTRY '%s' */\n\n", entry_name);
6810  }
6811 
6812 #if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(__clang__)
6813  if (!gencode && !prog->nested_level) {
6814  output ("__declspec(dllexport) ");
6815  }
6816 #endif
6817 
6818  if (unlikely(prog->prog_type == CB_FUNCTION_TYPE)) {
6819  if (gencode) {
6820  output ("cob_field *\n");
6821  } else {
6822  output ("cob_field\t\t*");
6823  }
6824  output ("%s (", entry_name);
6825  if (!gencode) {
6826  output ("cob_field **, const int");
6827  } else {
6828  output ("cob_field **cob_fret, const int cob_pam");
6829  }
6830  parmnum = 0;
6831  if (using_list) {
6832  output (", ");
6833  n = 0;
6834  for (l = using_list; l; l = CB_CHAIN (l), ++n, ++parmnum) {
6835  if (!gencode) {
6836  output ("cob_field *");
6837  } else {
6838  output ("cob_field *f%u", n);
6839  }
6840  if (CB_CHAIN (l)) {
6841  output (", ");
6842  }
6843  }
6844  }
6845  if (gencode) {
6846  output (")\n");
6847  } else {
6848  /* Finish prototype and return */
6849  output (");\n");
6850  return;
6851  }
6852  output ("{\n");
6853  output (" struct cob_func_loc\t*floc;\n\n");
6854  output (" /* Save environment */\n");
6855  output (" floc = cob_save_func (cob_fret, cob_pam, %u",
6856  parmnum);
6857 #if 0 /* RXWRXW - UFUNC */
6858  if (!using_list) {
6859  output (" floc->ret_fld = %s_ (0);\n", prog->program_id);
6860  output (" **cob_fret = *floc->ret_fld;\n");
6861  output (" cob_restore_func (floc);\n");
6862  output (" return *cob_fret;\n}\n\n");
6863  return;
6864  }
6865  output (" switch (cob_pam) {\n");
6866  for (n = 0; n <= parmnum; ++n) {
6867  if (!n) {
6868  output (" case 0:\n");
6869  output (" break;\n");
6870  continue;
6871  }
6872  output (" case %u:\n", n);
6873  if (n == parmnum) {
6874  output (" default:\n");
6875  }
6876  for (n2 = 0; n2 < n; ++n2) {
6877  output (" if (f%u) {\n", n2);
6878  output (" floc->func_params[%u] = f%u;\n",
6879  n2, n2);
6880  output (" floc->data[%u] = f%u->data;\n",
6881  n2, n2);
6882  output (" }\n");
6883  output (" break;\n");
6884  }
6885  }
6886 #else
6887  for (n = 0; n < parmnum; ++n) {
6888  output (", f%u", n);
6889  }
6890 #endif
6891  output (");\n");
6892 
6893  output (" floc->ret_fld = %s_ (0", prog->program_id);
6894  if (parmnum != 0) {
6895  output (", ");
6896  for (n = 0; n < parmnum; ++n) {
6897  output ("floc->data[%u]", n);
6898  if (n != parmnum - 1) {
6899  output (", ");
6900  }
6901  }
6902  }
6903  output (");\n");
6904  output (" **cob_fret = *floc->ret_fld;\n");
6905  output (" /* Restore environment */\n");
6906  output (" cob_restore_func (floc);\n");
6907  output (" return *cob_fret;\n}\n\n");
6908  return;
6909  }
6910  if (prog->nested_level) {
6911  if (gencode) {
6912  output ("static int\n");
6913  } else {
6914  output ("static int\t\t");
6915  }
6916  } else {
6917  if (prog->flag_main && !prog->flag_recursive) {
6918  output ("static ");
6919  }
6920  if (gencode) {
6921  output ("int\n");
6922  } else {
6923  output ("int\t\t\t");
6924  }
6925  }
6926 
6927  if (prog->nested_level) {
6928  output ("%s_%d__ (", entry_name, prog->toplev_count);
6929  } else {
6930  output ("%s (", entry_name);
6931  }
6932  if (prog->flag_chained) {
6933  using_list = NULL;
6934  parameter_list = NULL;
6935  }
6936  if (!gencode && !using_list) {
6937  output ("void);\n");
6938  return;
6939  }
6940 
6941  memset (sticky_ids, 0, sizeof(sticky_ids));
6942  memset (sticky_nonp, 0, sizeof(sticky_ids));
6943 
6944  n = 0;
6945  for (l = using_list; l; l = CB_CHAIN (l), ++n) {
6946  f = cb_code_field (CB_VALUE (l));
6947  switch (CB_PURPOSE_INT (l)) {
6948  case CB_CALL_BY_VALUE:
6949  if (f->usage == CB_USAGE_FLOAT) {
6950  if (gencode) {
6951  output ("float %s%d",
6952  CB_PREFIX_BASE, f->id);
6953  } else {
6954  output ("float");
6955  }
6956  if (cb_sticky_linkage) {
6957  s_type[n] = "";
6958  } else {
6959  s_type[n] = "(cob_u8_ptr)&";
6960  }
6961  break;
6962  } else if (f->usage == CB_USAGE_DOUBLE) {
6963  if (gencode) {
6964  output ("double %s%d",
6965  CB_PREFIX_BASE, f->id);
6966  } else {
6967  output ("double");
6968  }
6969  if (cb_sticky_linkage) {
6970  s_type[n] = "";
6971  } else {
6972  s_type[n] = "(cob_u8_ptr)&";
6973  }
6974  break;
6975  } else if (f->usage == CB_USAGE_LONG_DOUBLE) {
6976  if (gencode) {
6977  output ("long double %s%d",
6978  CB_PREFIX_BASE, f->id);
6979  } else {
6980  output ("long double");
6981  }
6982  if (cb_sticky_linkage) {
6983  s_type[n] = "";
6984  } else {
6985  s_type[n] = "(cob_u8_ptr)&";
6986  }
6987  break;
6988  } else if (f->usage == CB_USAGE_FP_BIN32) {
6989  if (gencode) {
6990  output ("cob_u32_t %s%d",
6991  CB_PREFIX_BASE, f->id);
6992  } else {
6993  output ("cob_u32_t");
6994  }
6995  if (cb_sticky_linkage) {
6996  s_type[n] = "";
6997  } else {
6998  s_type[n] = "(cob_u8_ptr)&";
6999  }
7000  break;
7001  } else if (f->usage == CB_USAGE_FP_BIN64 ||
7002  f->usage == CB_USAGE_FP_DEC64) {
7003  if (gencode) {
7004  output ("cob_u64_t %s%d",
7005  CB_PREFIX_BASE, f->id);
7006  } else {
7007  output ("cob_u64_t");
7008  }
7009  if (cb_sticky_linkage) {
7010  s_type[n] = "";
7011  } else {
7012  s_type[n] = "(cob_u8_ptr)&";
7013  }
7014  break;
7015  } else if (f->usage == CB_USAGE_FP_BIN128 ||
7016  f->usage == CB_USAGE_FP_DEC128) {
7017  if (gencode) {
7018  output ("cob_fp_128 %s%d",
7019  CB_PREFIX_BASE, f->id);
7020  } else {
7021  output ("cob_fp_128");
7022  }
7023  if (cb_sticky_linkage) {
7024  s_type[n] = "";
7025  } else {
7026  s_type[n] = "(cob_u8_ptr)&";
7027  }
7028  break;
7029  } else if (CB_TREE_CLASS (CB_VALUE (l)) == CB_CLASS_NUMERIC) {
7030  s = "";
7031  switch (CB_SIZES_INT (l)) {
7032  case CB_SIZE_1:
7033  if (CB_SIZES(l) & CB_SIZE_UNSIGNED) {
7034  s = "cob_u8_t";
7035  } else {
7036  s = "cob_c8_t";
7037  }
7038  break;
7039  case CB_SIZE_2:
7040  if (CB_SIZES(l) & CB_SIZE_UNSIGNED) {
7041  s = "cob_u16_t";
7042  } else {
7043  s = "cob_s16_t";
7044  }
7045  break;
7046  case CB_SIZE_4:
7047  if (CB_SIZES(l) & CB_SIZE_UNSIGNED) {
7048  s = "cob_u32_t";
7049  } else {
7050  s = "cob_s32_t";
7051  }
7052  break;
7053  case CB_SIZE_8:
7054  if (CB_SIZES(l) & CB_SIZE_UNSIGNED) {
7055  s = "cob_u64_t";
7056  } else {
7057  s = "cob_s64_t";
7058  }
7059  break;
7060  default:
7061  break;
7062  }
7063  if (gencode) {
7064  output ("%s %s%d",
7065  s, CB_PREFIX_BASE, f->id);
7066  } else {
7067  output ("%s", s);
7068  }
7069  if (cb_sticky_linkage) {
7070  s_type[n] = "";
7071  } else {
7072  s_type[n] = "(cob_u8_ptr)&";
7073  }
7074  break;
7075  }
7076  /* Fall through */
7077  case CB_CALL_BY_REFERENCE:
7078  case CB_CALL_BY_CONTENT:
7079  if (gencode) {
7080  output ("cob_u8_t *%s%d",
7081  CB_PREFIX_BASE, f->id);
7082  } else {
7083  output ("cob_u8_t *");
7084  }
7085  s_type[n] = "";
7086  break;
7087  default:
7088  break;
7089  }
7090  if (CB_CHAIN (l)) {
7091  output (", ");
7092  }
7093  }
7094 
7095  if (gencode) {
7096  output (")\n");
7097  } else {
7098  /* Finish prototype and return */
7099  output (");\n");
7100  return;
7101  }
7102 
7103  output ("{\n");
7104 
7105  /* We have to cater for sticky-linkage here at the entry point site */
7106  /* Doing it in the internal function is too late as we */
7107  /* then do not have the information as to possible ENTRY clauses */
7108 
7109  parmnum = 0;
7110  /* Sticky linkage parameters */
7111  if (cb_sticky_linkage && using_list) {
7112  for (l = using_list; l; l = CB_CHAIN (l), parmnum++) {
7113  f = cb_code_field (CB_VALUE (l));
7114  sticky_ids[parmnum] = f->id;
7115  switch (CB_PURPOSE_INT (l)) {
7116  case CB_CALL_BY_VALUE:
7117  s = NULL;
7118  s2 = "0";
7119  if (f->usage == CB_USAGE_FLOAT) {
7120  s = "float";
7121  } else if (f->usage == CB_USAGE_DOUBLE) {
7122  s = "double";
7123  } else if (f->usage == CB_USAGE_LONG_DOUBLE) {
7124  s = "long double";
7125  } else if (f->usage == CB_USAGE_FP_BIN32) {
7126  s = "cob_u32_t";
7127  } else if (f->usage == CB_USAGE_FP_BIN64 ||
7128  f->usage == CB_USAGE_FP_DEC64) {
7129  s = "cob_u64_t";
7130  } else if (f->usage == CB_USAGE_FP_BIN128 ||
7131  f->usage == CB_USAGE_FP_DEC128) {
7132  s = "cob_fp_128";
7133  s2 = "{{0, 0}}";
7134  } else if (CB_TREE_CLASS (CB_VALUE (l)) == CB_CLASS_NUMERIC) {
7135  switch (CB_SIZES_INT (l)) {
7136  case CB_SIZE_1:
7137  if (CB_SIZES(l) & CB_SIZE_UNSIGNED) {
7138  s = "cob_u8_t";
7139  } else {
7140  s = "cob_c8_t";
7141  }
7142  break;
7143  case CB_SIZE_2:
7144  if (CB_SIZES(l) & CB_SIZE_UNSIGNED) {
7145  s = "cob_u16_t";
7146  } else {
7147  s = "cob_s16_t";
7148  }
7149  break;
7150  case CB_SIZE_4:
7151  if (CB_SIZES(l) & CB_SIZE_UNSIGNED) {
7152  s = "cob_u32_t";
7153  } else {
7154  s = "cob_s32_t";
7155  }
7156  break;
7157  case CB_SIZE_8:
7158  if (CB_SIZES(l) & CB_SIZE_UNSIGNED) {
7159  s = "cob_u64_t";
7160  } else {
7161  s = "cob_s64_t";
7162  }
7163  break;
7164  default:
7165  break;
7166  }
7167  }
7168  if (s) {
7169  output (" static %s\tcob_parm_l_%d = %s;\n",
7170  s, f->id, s2);
7171  sticky_nonp[parmnum] = 1;
7172  break;
7173  }
7174  /* Fall through */
7175  case CB_CALL_BY_REFERENCE:
7176  case CB_CALL_BY_CONTENT:
7177  break;
7178  default:
7179  break;
7180  }
7181  }
7182  }
7183 
7184  /* By value pointer fields */
7185  for (l2 = using_list; l2; l2 = CB_CHAIN (l2)) {
7186  f2 = cb_code_field (CB_VALUE (l2));
7187  if (CB_PURPOSE_INT (l2) == CB_CALL_BY_VALUE &&
7188  (f2->usage == CB_USAGE_POINTER ||
7189  f2->usage == CB_USAGE_PROGRAM_POINTER)) {
7190  output (" unsigned char\t\t*ptr_%d;\n", f2->id);
7191  }
7192  }
7193 
7194  /* Sticky linkage set up */
7195  if (cb_sticky_linkage && using_list) {
7196  parmnum = 0;
7197  output (" switch (cob_get_global_ptr ()->cob_call_params) {\n");
7198  for (l = using_list; l; l = CB_CHAIN (l), parmnum++) {
7199  output (" case %u:\n", parmnum);
7200  for (n = 0; n < parmnum; ++n) {
7201  if (sticky_nonp[n]) {
7202  output ("\tcob_parm_l_%d = %s%d;\n",
7203  sticky_ids[n], CB_PREFIX_BASE,
7204  sticky_ids[n]);
7205  output ("\tcob_parm_%d = (cob_u8_ptr)&cob_parm_l_%d;\n",
7206  sticky_ids[n],
7207  sticky_ids[n]);
7208  } else {
7209  output ("\tcob_parm_%d = %s%d;\n",
7210  sticky_ids[n], CB_PREFIX_BASE,
7211  sticky_ids[n]);
7212  }
7213  }
7214  output ("\tbreak;\n");
7215  }
7216  output (" default:\n");
7217  for (n = 0; n < parmnum; ++n) {
7218  if (sticky_nonp[n]) {
7219  output ("\tcob_parm_l_%d = %s%d;\n",
7220  sticky_ids[n], CB_PREFIX_BASE,
7221  sticky_ids[n]);
7222  output ("\tcob_parm_%d = (cob_u8_ptr)&cob_parm_l_%d;\n",
7223  sticky_ids[n],
7224  sticky_ids[n]);
7225  } else {
7226  output ("\tcob_parm_%d = %s%d;\n",
7227  sticky_ids[n], CB_PREFIX_BASE,
7228  sticky_ids[n]);
7229  }
7230  }
7231  output ("\tbreak;\n");
7232  output (" }\n");
7233  }
7234 
7235  if (cb_sticky_linkage) {
7236  s_prefix = "cob_parm_";
7237  } else {
7238  s_prefix = CB_PREFIX_BASE;
7239  }
7240 
7241  for (l2 = using_list; l2; l2 = CB_CHAIN (l2)) {
7242  f2 = cb_code_field (CB_VALUE (l2));
7243  if (CB_PURPOSE_INT (l2) == CB_CALL_BY_VALUE &&
7244  (f2->usage == CB_USAGE_POINTER ||
7245  f2->usage == CB_USAGE_PROGRAM_POINTER)) {
7246  output (" ptr_%d = %s%d;\n",
7247  f2->id, s_prefix, f2->id);
7248  }
7249  }
7250 
7251  if (!prog->nested_level) {
7252  output (" return %s_ (%d", prog->program_id, progid++);
7253  } else {
7254  output (" return %s_%d_ (%d", prog->program_id,
7255  prog->toplev_count, progid++);
7256  }
7257 
7258  if (!using_list && !parameter_list) {
7259  output (");\n");
7260  output ("}\n\n");
7261  return;
7262  }
7263 
7264  for (l1 = parameter_list; l1; l1 = CB_CHAIN (l1)) {
7265  f1 = cb_code_field (CB_VALUE (l1));
7266  n = 0;
7267  for (l2 = using_list; l2; l2 = CB_CHAIN (l2), ++n) {
7268  f2 = cb_code_field (CB_VALUE (l2));
7269  if (strcasecmp (f1->name, f2->name) == 0) {
7270  switch (CB_PURPOSE_INT (l2)) {
7271  case CB_CALL_BY_VALUE:
7272  if (f2->usage == CB_USAGE_POINTER ||
7273  f2->usage == CB_USAGE_PROGRAM_POINTER) {
7274  output (", (cob_u8_ptr)&ptr_%d", f2->id);
7275  break;
7276  }
7277  /* Fall through */
7278  case CB_CALL_BY_REFERENCE:
7279  case CB_CALL_BY_CONTENT:
7280  output (", %s%s%d",
7281  s_type[n], s_prefix, f2->id);
7282  break;
7283  default:
7284  break;
7285  }
7286  break;
7287  }
7288  }
7289  if (l2 == NULL) {
7290  if (cb_sticky_linkage) {
7291  output (", %s%d",
7292  s_prefix, f1->id);
7293  } else {
7294  output (", NULL");
7295  }
7296  }
7297  }
7298  output (");\n");
7299  output ("}\n\n");
7300 }
static void output_error_handler ( struct cb_program *  prog)
static

References CB_LABEL, cb_list_length(), cb_standard_error_handler, COB_OPEN_EXTEND, COB_OPEN_INPUT, cb_program::global_handler, handler_struct::handler_label, handler_struct::handler_prog, cb_label::id, cb_program::nested_level, output(), output_indent(), output_line(), output_newline(), output_perform_call(), output_perform_exit(), output_prefix(), output_stmt(), cb_program::parameter_list, cb_program::program_id, and cb_program::toplev_count.

Referenced by output_internal_function().

5557 {
5558  struct handler_struct *hstr;
5559  size_t seen;
5560  int i;
5561  int n;
5562  int parmnum;
5563 
5564  output_newline ();
5565  seen = 0;
5566  for (i = COB_OPEN_INPUT; i <= COB_OPEN_EXTEND; i++) {
5567  if (prog->global_handler[i].handler_label) {
5568  seen = 1;
5569  break;
5570  }
5571  }
5572  output_stmt (cb_standard_error_handler);
5573  output_newline ();
5574  if (seen) {
5575  output_line ("switch (cob_glob_ptr->cob_error_file->last_open_mode)");
5576  output_indent ("{");
5577  for (i = COB_OPEN_INPUT; i <= COB_OPEN_EXTEND; i++) {
5578  hstr = &prog->global_handler[i];
5579  if (hstr->handler_label) {
5580  output_line ("case %d:", i);
5581  output_indent ("{");
5582  if (prog == hstr->handler_prog) {
5583  output_perform_call (hstr->handler_label,
5584  hstr->handler_label);
5585  } else {
5586  output_prefix ();
5587  if (hstr->handler_prog->nested_level) {
5588  output ("%s_%d_ (%d",
5589  hstr->handler_prog->program_id,
5590  hstr->handler_prog->toplev_count,
5591  hstr->handler_label->id);
5592  } else {
5593  output ("%s_ (%d",
5594  hstr->handler_prog->program_id,
5595  hstr->handler_label->id);
5596  }
5597  parmnum = cb_list_length (hstr->handler_prog->parameter_list);
5598  for (n = 0; n < parmnum; n++) {
5599  output (", NULL");
5600  }
5601  output (");\n");
5602  }
5603  output_line ("break;");
5604  output_indent ("}");
5605  }
5606  }
5607  output_line ("default:");
5608  output_indent ("{");
5609  }
5610  output_line ("if (!(cob_glob_ptr->cob_error_file->flag_select_features & COB_SELECT_FILE_STATUS)) {");
5611  output_line ("\tcob_fatal_error (COB_FERROR_FILE);");
5612  output_line ("}");
5613  if (seen) {
5614  output_line ("break;");
5615  output_indent ("}");
5616  output_indent ("}");
5617  }
5618  output_perform_exit (CB_LABEL (cb_standard_error_handler));
5619  output_newline ();
5620  output_line ("/* Fatal error if reached */");
5621  output_line ("cob_fatal_error (COB_FERROR_CODEGEN);");
5622  output_newline ();
5623 }
static void output_ferror_stmt ( struct cb_statement *  p,
const int  code 
)
static

References CB_FILE, cb_statement::file, cb_statement::handler1, cb_statement::handler2, cb_statement::handler3, output_file_error(), output_indent(), output_line(), and output_stmt().

Referenced by output_stmt().

4438 {
4439  output_line ("if (unlikely(cob_glob_ptr->cob_exception_code != 0))");
4440  output_indent ("{");
4441  if (p->handler1) {
4442  if ((code & 0x00ff) == 0) {
4443  output_line ("if ((cob_glob_ptr->cob_exception_code & 0xff00) == 0x%04x)",
4444  code);
4445  } else {
4446  output_line ("if (cob_glob_ptr->cob_exception_code == 0x%04x)", code);
4447  }
4448  output_indent ("{");
4449  output_stmt (p->handler1);
4450  output_indent ("}");
4451  output_line ("else");
4452  output_indent ("{");
4453  }
4454  output_file_error (CB_FILE (p->file));
4455  output_indent ("}");
4456  if (p->handler1) {
4457  output_indent ("}");
4458  }
4459  if (p->handler2 || p->handler3) {
4460  output_line ("else");
4461  output_indent ("{");
4462  if (p->handler3) {
4463  output_stmt (p->handler3);
4464  }
4465  if (p->handler2) {
4466  output_stmt (p->handler2);
4467  }
4468  output_indent ("}");
4469  }
4470 }
static void output_field ( cb_tree  x)
static

References output(), output_attr(), output_data(), and output_size().

Referenced by codegen(), lookup_literal(), and output_param().

1012 {
1013  output ("{");
1014  output_size (x);
1015  output (", ");
1016  output_data (x);
1017  output (", ");
1018  output_attr (x);
1019  output ("}");
1020 }
static void output_figurative ( cb_tree  x,
const struct cb_field *  f,
const int  value,
const int  init_occurs 
)
static

References CB_REFERENCE, CB_REFERENCE_P, cb_field::occurs_max, output(), output_data(), output_prefix(), output_size(), and cb_field::size.

Referenced by output_initialize_one().

2332 {
2333  output_prefix ();
2334  /* Check for non-standard 01 OCCURS */
2335  if (init_occurs) {
2336  output ("memset (");
2337  output_data (x);
2338  output (", %d, %d);\n", value, f->occurs_max);
2339  } else if (f->size == 1) {
2340  output ("*(cob_u8_ptr)(");
2341  output_data (x);
2342  output (") = %d;\n", value);
2343  } else {
2344  output ("memset (");
2345  output_data (x);
2346  if (CB_REFERENCE_P(x) && CB_REFERENCE(x)->length) {
2347  output (", %d, ", value);
2348  output_size (x);
2349  output (");\n");
2350  } else {
2351  output (", %d, %d);\n", value, f->size);
2352  }
2353  }
2354 }
static int output_file_allocation ( struct cb_file *  f)
static

References cb_alphabet_name::alphabet_type, CB_ALPHABET_ASCII, CB_ALPHABET_CUSTOM, CB_ALPHABET_EBCDIC, CB_FIELD_PTR, CB_PREFIX_FILE, CB_PREFIX_KEYS, cb_file::cname, COB_ORG_INDEXED, COB_ORG_RELATIVE, cb_file::code_set, cb_file::file_status, cb_file::flag_global, gen_custom, gen_ebcdic_ascii, gen_full_ebcdic, gen_native, cb_file::linage, cb_file::name, cb_file::organization, output_local(), and output_storage().

Referenced by output_internal_function().

5048 {
5049 
5050  if (f->flag_global) {
5051 #if 0 /* RXWRXW - Global status */
5052  if (f->file_status) {
5053  /* Force status into main storage file */
5054  CB_FIELD_PTR (f->file_status)->flag_is_global = 1;
5055  }
5056 #endif
5057  output_storage ("\n/* Global file %s */\n", f->name);
5058  } else {
5059  output_local ("\n/* File %s */\n", f->name);
5060  }
5061  /* Output RELATIVE/RECORD KEY's */
5062  if (f->organization == COB_ORG_RELATIVE ||
5063  f->organization == COB_ORG_INDEXED) {
5064  if (f->flag_global) {
5065  output_storage ("static cob_file_key\t*%s%s = NULL;\n",
5066  CB_PREFIX_KEYS, f->cname);
5067  } else {
5068  output_local ("static cob_file_key\t*%s%s = NULL;\n",
5069  CB_PREFIX_KEYS, f->cname);
5070  }
5071  }
5072  if (f->flag_global) {
5073  output_storage ("static cob_file\t\t*%s%s = NULL;\n",
5074  CB_PREFIX_FILE, f->cname);
5075  output_storage ("static unsigned char\t%s%s_status[4];\n",
5076  CB_PREFIX_FILE, f->cname);
5077  } else {
5078  output_local ("static cob_file\t\t*%s%s = NULL;\n",
5079  CB_PREFIX_FILE, f->cname);
5080  output_local ("static unsigned char\t%s%s_status[4];\n",
5081  CB_PREFIX_FILE, f->cname);
5082  }
5083 
5084  if (f->code_set) {
5085  gen_native = 1;
5086  switch (f->code_set->alphabet_type) {
5087  case CB_ALPHABET_ASCII:
5088  gen_ebcdic_ascii = 1;
5089  break;
5090  case CB_ALPHABET_EBCDIC:
5091  gen_full_ebcdic = 1;
5092  break;
5093  case CB_ALPHABET_CUSTOM:
5094  gen_custom = 1;
5095  break;
5096  default:
5097  break;
5098  }
5099  }
5100 
5101  if (f->linage) {
5102  return 1;
5103  }
5104  return 0;
5105 }
static void output_file_error ( struct cb_file *  pfile)
static

References cb_build_debug(), CB_CHAIN, cb_debug_contents, CB_FILE, CB_VALUE, cb_program::flag_gen_debug, cb_program::global_file_list, cb_file::handler, cb_file::handler_prog, cb_label::id, cb_program::local_file_list, cb_file::name, cb_program::nested_level, NULL, output_line(), output_perform_call(), output_stmt(), cb_program::program_id, and cb_program::toplev_count.

Referenced by output_ferror_stmt().

4275 {
4276  struct cb_file *fl;
4277  cb_tree l;
4278 
4279  if (current_prog->flag_gen_debug) {
4280  output_stmt (cb_build_debug (cb_debug_contents,
4281  "USE PROCEDURE", NULL));
4282  }
4283  for (l = current_prog->local_file_list; l; l = CB_CHAIN (l)) {
4284  fl = CB_FILE(CB_VALUE (l));
4285  if (!strcmp (pfile->name, fl->name)) {
4286  output_perform_call (fl->handler,
4287  fl->handler);
4288  return;
4289  }
4290  }
4291  for (l = current_prog->global_file_list; l; l = CB_CHAIN (l)) {
4292  fl = CB_FILE(CB_VALUE (l));
4293  if (!strcmp (pfile->name, fl->name)) {
4294  if (fl->handler_prog == current_prog) {
4295  output_perform_call (fl->handler,
4296  fl->handler);
4297  } else {
4298  if (fl->handler_prog->nested_level) {
4299  output_line ("%s_%d_ (%d);",
4300  fl->handler_prog->program_id,
4301  fl->handler_prog->toplev_count,
4302  fl->handler->id);
4303  } else {
4304  output_line ("%s_ (%d);",
4305  fl->handler_prog->program_id,
4306  fl->handler->id);
4307  }
4308  }
4309  return;
4310  }
4311  }
4312  output_perform_call (pfile->handler, pfile->handler);
4313 }
static void output_file_initialization ( struct cb_file *  f)
static

References cb_file::access_mode, cb_file::alt_key_list, cb_file::assign, CB_PREFIX_FILE, CB_PREFIX_KEYS, CB_TREE, cb_file::cname, COB_FILE_VERSION, COB_ORG_INDEXED, COB_ORG_RELATIVE, COB_SELECT_EXTERNAL, COB_SELECT_FILE_STATUS, COB_SELECT_LINAGE, cb_alt_key::duplicates, cb_file::file_status, cb_file::flag_ext_assign, cb_file::flag_external, cb_alt_key::key, cb_file::key, cb_file::latbot, cb_file::latfoot, cb_file::lattop, cb_file::linage, cb_file::linage_ctr, cb_file::lock_mode, cb_file::name, cb_alt_key::next, cb_file::optional, cb_file::organization, output(), output_indent(), output_line(), output_param(), output_prefix(), cb_file::record, cb_file::record_depending, cb_file::record_max, cb_file::record_min, and cb_file::special.

Referenced by output_internal_function().

5109 {
5110  struct cb_alt_key *l;
5111  int nkeys;
5112  int features;
5113 
5114  nkeys = 1;
5115  if (f->flag_external) {
5116  output_line ("%s%s = cob_external_addr (\"%s\", sizeof(cob_file));",
5117  CB_PREFIX_FILE, f->cname, f->cname);
5118  output_line ("if (cob_glob_ptr->cob_initial_external)");
5119  output_indent ("{");
5120  if (f->linage) {
5121  output_line ("%s%s->linorkeyptr = cob_cache_malloc (sizeof(cob_linage));", CB_PREFIX_FILE, f->cname);
5122  }
5123  } else {
5124  output_line ("if (!%s%s)", CB_PREFIX_FILE, f->cname);
5125  output_indent ("{");
5126  output_line ("%s%s = cob_cache_malloc (sizeof(cob_file));", CB_PREFIX_FILE, f->cname);
5127  if (f->linage) {
5128  output_line ("%s%s->linorkeyptr = cob_cache_malloc (sizeof(cob_linage));", CB_PREFIX_FILE, f->cname);
5129  }
5130  output_indent ("}");
5131  }
5132  /* Output RELATIVE/RECORD KEY's */
5133  if (f->organization == COB_ORG_RELATIVE
5134  || f->organization == COB_ORG_INDEXED) {
5135  for (l = f->alt_key_list; l; l = l->next) {
5136  nkeys++;
5137  }
5138  output_line ("if (!%s%s)", CB_PREFIX_KEYS, f->cname);
5139  output_indent ("{");
5140  output_line ("%s%s = cob_cache_malloc (sizeof (cob_file_key) * %d);",
5141  CB_PREFIX_KEYS, f->cname, nkeys);
5142  output_indent ("}");
5143  nkeys = 1;
5144  output_prefix ();
5145  output ("%s%s->field = ", CB_PREFIX_KEYS, f->cname);
5146  output_param (f->key, -1);
5147  output (";\n");
5148  output_prefix ();
5149  output ("%s%s->flag = 0;\n", CB_PREFIX_KEYS, f->cname);
5150  output_prefix ();
5151  if (f->key) {
5152  output ("%s%s->offset = %d;\n", CB_PREFIX_KEYS, f->cname,
5153  cb_code_field (f->key)->offset);
5154  } else {
5155  output ("%s%s->offset = 0;\n", CB_PREFIX_KEYS, f->cname);
5156  }
5157  for (l = f->alt_key_list; l; l = l->next) {
5158  output_prefix ();
5159  output ("(%s%s + %d)->field = ", CB_PREFIX_KEYS, f->cname,
5160  nkeys);
5161  output_param (l->key, -1);
5162  output (";\n");
5163  output_prefix ();
5164  output ("(%s%s + %d)->flag = %d;\n", CB_PREFIX_KEYS,
5165  f->cname, nkeys, l->duplicates);
5166  output_prefix ();
5167  output ("(%s%s + %d)->offset = %d;\n", CB_PREFIX_KEYS,
5168  f->cname, nkeys, cb_code_field (l->key)->offset);
5169  nkeys++;
5170  }
5171  }
5172 
5173  output_line ("%s%s->select_name = (const char *)\"%s\";", CB_PREFIX_FILE,
5174  f->cname, f->name);
5175  if (f->flag_external && !f->file_status) {
5176  output_line ("%s%s->file_status = cob_external_addr (\"%s%s_status\", 4);",
5177  CB_PREFIX_FILE, f->cname, CB_PREFIX_FILE, f->cname);
5178  } else {
5179  output_line ("%s%s->file_status = %s%s_status;", CB_PREFIX_FILE,
5180  f->cname, CB_PREFIX_FILE, f->cname);
5181  output_line ("memset (%s%s_status, '0', 2);", CB_PREFIX_FILE,
5182  f->cname);
5183  }
5184  output_prefix ();
5185  output ("%s%s->assign = ", CB_PREFIX_FILE, f->cname);
5186  output_param (f->assign, -1);
5187  output (";\n");
5188  output_prefix ();
5189  output ("%s%s->record = ", CB_PREFIX_FILE, f->cname);
5190  output_param (CB_TREE (f->record), -1);
5191  output (";\n");
5192  output_prefix ();
5193  output ("%s%s->variable_record = ", CB_PREFIX_FILE, f->cname);
5194  if (f->record_depending) {
5195  output_param (f->record_depending, -1);
5196  } else {
5197  output ("NULL");
5198  }
5199  output (";\n");
5200  output_line ("%s%s->record_min = %d;", CB_PREFIX_FILE,
5201  f->cname, f->record_min);
5202  output_line ("%s%s->record_max = %d;", CB_PREFIX_FILE,
5203  f->cname, f->record_max);
5204  if (f->organization == COB_ORG_RELATIVE
5205  || f->organization == COB_ORG_INDEXED) {
5206  output_line ("%s%s->nkeys = %d;", CB_PREFIX_FILE,
5207  f->cname, nkeys);
5208  output_line ("%s%s->keys = %s%s;", CB_PREFIX_FILE,
5209  f->cname, CB_PREFIX_KEYS, f->cname);
5210  } else {
5211  output_line ("%s%s->nkeys = 0;", CB_PREFIX_FILE, f->cname);
5212  output_line ("%s%s->keys = NULL;", CB_PREFIX_FILE, f->cname);
5213  }
5214  output_line ("%s%s->file = NULL;", CB_PREFIX_FILE, f->cname);
5215 
5216  if (f->linage) {
5217  output_line ("lingptr = %s%s->linorkeyptr;",
5218  CB_PREFIX_FILE, f->cname);
5219  output_prefix ();
5220  output ("lingptr->linage = ");
5221  output_param (f->linage, -1);
5222  output (";\n");
5223  output_prefix ();
5224  output ("lingptr->linage_ctr = ");
5225  output_param (f->linage_ctr, -1);
5226  output (";\n");
5227  if (f->latfoot) {
5228  output_prefix ();
5229  output ("lingptr->latfoot = ");
5230  output_param (f->latfoot, -1);
5231  output (";\n");
5232  } else {
5233  output_line ("lingptr->latfoot = NULL;");
5234  }
5235  if (f->lattop) {
5236  output_prefix ();
5237  output ("lingptr->lattop = ");
5238  output_param (f->lattop, -1);
5239  output (";\n");
5240  } else {
5241  output_line ("lingptr->lattop = NULL;");
5242  }
5243  if (f->latbot) {
5244  output_prefix ();
5245  output ("lingptr->latbot = ");
5246  output_param (f->latbot, -1);
5247  output (";\n");
5248  } else {
5249  output_line ("lingptr->latbot = NULL;");
5250  }
5251  output_line ("lingptr->lin_lines = 0;");
5252  output_line ("lingptr->lin_foot = 0;");
5253  output_line ("lingptr->lin_top = 0;");
5254  output_line ("lingptr->lin_bot = 0;");
5255  }
5256 
5257  output_line ("%s%s->fd = -1;", CB_PREFIX_FILE, f->cname);
5258  output_line ("%s%s->organization = %d;", CB_PREFIX_FILE, f->cname,
5259  f->organization);
5260  output_line ("%s%s->access_mode = %d;", CB_PREFIX_FILE, f->cname,
5261  f->access_mode);
5262  output_line ("%s%s->lock_mode = %d;", CB_PREFIX_FILE, f->cname,
5263  f->lock_mode);
5264  output_line ("%s%s->open_mode = 0;", CB_PREFIX_FILE, f->cname);
5265  output_line ("%s%s->flag_optional = %d;", CB_PREFIX_FILE, f->cname,
5266  f->optional);
5267  output_line ("%s%s->last_open_mode = 0;", CB_PREFIX_FILE, f->cname);
5268  output_line ("%s%s->flag_operation = 0;", CB_PREFIX_FILE, f->cname);
5269  output_line ("%s%s->flag_nonexistent = 0;", CB_PREFIX_FILE, f->cname);
5270  output_line ("%s%s->flag_end_of_file = 0;", CB_PREFIX_FILE, f->cname);
5271  output_line ("%s%s->flag_begin_of_file = 0;", CB_PREFIX_FILE, f->cname);
5272  output_line ("%s%s->flag_first_read = 0;", CB_PREFIX_FILE, f->cname);
5273  output_line ("%s%s->flag_read_done = 0;", CB_PREFIX_FILE, f->cname);
5274  features = 0;
5275  if (f->file_status) {
5276  features |= COB_SELECT_FILE_STATUS;
5277  }
5278  if (f->linage) {
5279  features |= COB_SELECT_LINAGE;
5280  }
5281  if (f->flag_ext_assign) {
5282  features |= COB_SELECT_EXTERNAL;
5283  }
5284  if (f->special) {
5285  /* Special assignment */
5286  features |= f->special;
5287  }
5288  output_line ("%s%s->flag_select_features = %d;", CB_PREFIX_FILE, f->cname,
5289  features);
5290  output_line ("%s%s->flag_needs_nl = 0;", CB_PREFIX_FILE, f->cname);
5291  output_line ("%s%s->flag_needs_top = 0;", CB_PREFIX_FILE, f->cname);
5292  output_line ("%s%s->file_version = %d;", CB_PREFIX_FILE, f->cname,
5293  COB_FILE_VERSION);
5294  if (f->flag_external) {
5295  output_indent ("}");
5296  }
5297 }
static void output_func_1 ( const char *  name,
cb_tree  x 
)
static

References output(), output_param(), and param_id.

Referenced by output_integer(), and output_long_integer().

2074 {
2075  output ("%s (", name);
2076  output_param (x, param_id);
2077  output (")");
2078 }
static void output_funcall ( cb_tree  x)
static

References _, cb_funcall::argc, cb_funcall::argv, CB_CHAIN, CB_FUNCALL, cb_high, CB_LITERAL, CB_LITERAL_P, cb_low, cb_space, CB_VALUE, cb_zero, COBC_ABORT, cobc_abort_pr(), cb_funcall::name, nolitcast, cb_funcall::nolitcast, output(), output_data(), output_param(), p, screenptr, cb_funcall::screenptr, and cb_funcall::varcnt.

Referenced by output_cond(), output_param(), and output_stmt().

1991 {
1992  struct cb_funcall *p;
1993  cb_tree l;
1994  int i;
1995 
1996  p = CB_FUNCALL (x);
1997  if (p->name[0] == '$') {
1998  switch (p->name[1]) {
1999  case 'E':
2000  /* Set of one character */
2001  output ("*(");
2002  output_data (p->argv[0]);
2003  output (") = ");
2004  output_param (p->argv[1], 1);
2005  break;
2006  case 'F':
2007  /* Move of one character */
2008  output ("*(");
2009  output_data (p->argv[0]);
2010  output (") = *(");
2011  output_data (p->argv[1]);
2012  output (")");
2013  break;
2014  case 'G':
2015  /* Test of one character */
2016  output ("(int)(*(");
2017  output_data (p->argv[0]);
2018  if (p->argv[1] == cb_space) {
2019  output (") - ' ')");
2020  } else if (p->argv[1] == cb_zero) {
2021  output (") - '0')");
2022  } else if (p->argv[1] == cb_low) {
2023  output ("))");
2024  } else if (p->argv[1] == cb_high) {
2025  output (") - 255)");
2026  } else if (CB_LITERAL_P (p->argv[1])) {
2027  output (") - %d)", *(CB_LITERAL (p->argv[1])->data));
2028  } else {
2029  output (") - *(");
2030  output_data (p->argv[1]);
2031  output ("))");
2032  }
2033  break;
2034  default:
2035  cobc_abort_pr (_("Unexpected function %s"), p->name);
2036  COBC_ABORT ();
2037  }
2038  return;
2039  }
2040  screenptr = p->screenptr;
2041  output ("%s (", p->name);
2042  for (i = 0; i < p->argc; i++) {
2043  if (p->varcnt && i + 1 == p->argc) {
2044  output ("%d, ", p->varcnt);
2045  for (l = p->argv[i]; l; l = CB_CHAIN (l)) {
2046  if (CB_VALUE (l) && CB_LITERAL_P (CB_VALUE (l))) {
2047  nolitcast = p->nolitcast;
2048  }
2049  output_param (CB_VALUE (l), i);
2050  nolitcast = 0;
2051  i++;
2052  if (CB_CHAIN (l)) {
2053  output (", ");
2054  }
2055  }
2056  } else {
2057  if (p->argv[i] && CB_LITERAL_P (p->argv[i])) {
2058  nolitcast = p->nolitcast;
2059  }
2060  output_param (p->argv[i], i);
2061  nolitcast = 0;
2062  if (i + 1 < p->argc) {
2063  output (", ");
2064  }
2065  }
2066  }
2067  output (")");
2068  nolitcast = 0;
2069  screenptr = 0;
2070 }
static void output_funcall_debug ( cb_tree  x)
static

References cb_funcall::argc, cb_funcall::argv, cb_build_debug(), CB_CHAIN, cb_debug_contents, cb_debug_name, CB_FUNCALL, CB_REF_OR_FIELD_P, CB_VALUE, cb_funcall::name, NULL, output_param(), output_perform_call(), output_stmt(), p, and cb_funcall::varcnt.

Referenced by output_cond_debug().

4020 {
4021  struct cb_funcall *p;
4022  cb_tree l;
4023  cb_tree z;
4024  int i;
4025 
4026  p = CB_FUNCALL (x);
4027  if (p->name[0] == '$') {
4028  z = p->argv[0];
4029  if (CB_REF_OR_FIELD_P (z) &&
4030  cb_code_field (z)->flag_field_debug) {
4031  /* DEBUG */
4032  output_stmt (cb_build_debug (cb_debug_name,
4033  (const char *)cb_code_field (z)->name, NULL));
4034  output_stmt (cb_build_debug (cb_debug_contents,
4035  NULL, z));
4036  output_perform_call (cb_code_field (z)->debug_section,
4037  cb_code_field (z)->debug_section);
4038  }
4039  z = p->argv[1];
4040  if (CB_REF_OR_FIELD_P (z) &&
4041  cb_code_field (z)->flag_field_debug) {
4042  /* DEBUG */
4043  output_stmt (cb_build_debug (cb_debug_name,
4044  (const char *)cb_code_field (z)->name, NULL));
4045  output_stmt (cb_build_debug (cb_debug_contents,
4046  NULL, z));
4047  output_perform_call (cb_code_field (z)->debug_section,
4048  cb_code_field (z)->debug_section);
4049  }
4050  return;
4051  }
4052  for (i = 0; i < p->argc; i++) {
4053  if (p->varcnt && i + 1 == p->argc) {
4054  for (l = p->argv[i]; l; l = CB_CHAIN (l)) {
4055  output_param (CB_VALUE (l), i);
4056  z = CB_VALUE (l);
4057  if (CB_REF_OR_FIELD_P (z) &&
4058  cb_code_field (z)->flag_field_debug) {
4059  /* DEBUG */
4060  output_stmt (cb_build_debug (cb_debug_name,
4061  (const char *)cb_code_field (z)->name, NULL));
4062  output_stmt (cb_build_debug (cb_debug_contents,
4063  NULL, z));
4064  output_perform_call (cb_code_field (z)->debug_section,
4065  cb_code_field (z)->debug_section);
4066  }
4067  i++;
4068  }
4069  } else {
4070  z = p->argv[i];
4071  if (CB_REF_OR_FIELD_P (z) &&
4072  cb_code_field (z)->flag_field_debug) {
4073  /* DEBUG */
4074  output_stmt (cb_build_debug (cb_debug_name,
4075  (const char *)cb_code_field (z)->name, NULL));
4076  output_stmt (cb_build_debug (cb_debug_contents,
4077  NULL, z));
4078  output_perform_call (cb_code_field (z)->debug_section,
4079  cb_code_field (z)->debug_section);
4080  }
4081  }
4082  }
4083 }
static void output_goto ( struct cb_goto *  p)
static

References cb_build_cast_int(), cb_build_debug(), CB_CHAIN, cb_debug_contents, cb_debug_name, CB_FIELD, CB_FUNCTION_TYPE, cb_int1, cb_ref(), CB_VALUE, cb_field::debug_section, cb_goto::depending, cb_field::flag_all_debug, cb_program::flag_gen_debug, cb_field::name, needs_exit_prog, cb_program::nested_level, NULL, output(), output_goto_1(), output_indent(), output_indent_level, output_line(), output_param(), output_perform_call(), output_prefix(), output_stmt(), cb_program::prog_type, and cb_goto::target.

Referenced by output_stmt().

4355 {
4356  cb_tree l;
4357  struct cb_field *f;
4358  int i;
4359 
4360  i = 1;
4361  if (p->depending) {
4362  /* Check for debugging on the DEPENDING item */
4363  if (current_prog->flag_gen_debug) {
4364  f = CB_FIELD (cb_ref (p->depending));
4365  if (f->flag_all_debug) {
4366  output_stmt (cb_build_debug (cb_debug_name,
4367  (const char *)f->name, NULL));
4368  output_stmt (cb_build_debug (cb_debug_contents,
4369  NULL, p->depending));
4370  output_perform_call (f->debug_section,
4371  f->debug_section);
4372  }
4373  }
4374  output_prefix ();
4375  output ("switch (");
4376  output_param (cb_build_cast_int (p->depending), 0);
4377  output (")\n");
4378  output_indent ("{");
4379  for (l = p->target; l; l = CB_CHAIN (l)) {
4380  output_indent_level -= 2;
4381  output_line ("case %d:", i++);
4382  output_indent_level += 2;
4383  output_goto_1 (CB_VALUE (l));
4384  }
4385  output_indent ("}");
4386  } else if (p->target == NULL) {
4387  /* EXIT PROGRAM/FUNCTION */
4388  needs_exit_prog = 1;
4389  if (cb_flag_implicit_init || current_prog->nested_level ||
4390  current_prog->prog_type == CB_FUNCTION_TYPE) {
4391  output_line ("goto exit_program;");
4392  } else {
4393  /* Ignore if not a callee */
4394  output_line ("if (module->next)");
4395  output_line (" goto exit_program;");
4396  }
4397  } else if (p->target == cb_int1) {
4398  needs_exit_prog = 1;
4399  output_line ("goto exit_program;");
4400  } else {
4401  output_goto_1 (p->target);
4402  }
4403 }
static void output_goto_1 ( cb_tree  x)
static

References cb_program::all_procedure, cb_build_debug(), cb_debug_contents, cb_debug_name, CB_LABEL, CB_PREFIX_LABEL, cb_ref(), cb_space, cb_label::flag_alter, cb_label::flag_debugging_mode, cb_program::flag_gen_debug, cb_label::flag_real_label, cb_label::flag_section, cb_program::flag_segments, cb_label::id, last_segment, cb_label::name, cb_para_label::next, NULL, output_line(), output_move(), output_stmt(), p, cb_para_label::para, cb_label::para_label, cb_label::section, and cb_label::segment.

Referenced by output_goto().

4319 {
4320  struct cb_label *lb;
4321  struct cb_para_label *p;
4322 
4323  lb = CB_LABEL (cb_ref (x));
4324  if (current_prog->flag_segments && last_segment != lb->segment) {
4325  /* Zap independent labels */
4326  if (lb->flag_section) {
4327  p = lb->para_label;
4328  } else if (lb->section) {
4329  p = lb->section->para_label;
4330  } else {
4331  p = NULL;
4332  }
4333  for (; p; p = p->next) {
4334  if (p->para->segment > 49 &&
4335  p->para->flag_alter) {
4336  output_line ("label_%s%d = 0;",
4337  CB_PREFIX_LABEL, p->para->id);
4338  }
4339  }
4340  }
4341 
4342  /* Check for debugging on procedure */
4343  if (current_prog->flag_gen_debug && lb->flag_real_label &&
4344  (current_prog->all_procedure || lb->flag_debugging_mode)) {
4345  output_stmt (cb_build_debug (cb_debug_name,
4346  (const char *)lb->name, NULL));
4347  output_move (cb_space, cb_debug_contents);
4348  }
4349 
4350  output_line ("goto %s%d;", CB_PREFIX_LABEL, lb->id);
4351 }
static void output_header ( FILE *  fp,
const char *  locbuff,
const struct cb_program *  cp 
)
static

References cb_oc_build_stamp, cb_saveargc, cb_saveargv, cb_source_file, COB_TAR_DATE, cb_program::orig_program_id, PACKAGE_VERSION, and PATCH_LEVEL.

Referenced by codegen().

7316 {
7317  int i;
7318 
7319  if (fp) {
7320  fprintf (fp, "/* Generated by cobc %s.%d */\n",
7321  PACKAGE_VERSION, PATCH_LEVEL);
7322  fprintf (fp, "/* Generated from %s */\n", cb_source_file);
7323  fprintf (fp, "/* Generated at %s */\n", locbuff);
7324  fprintf (fp, "/* GNU Cobol build date %s */\n", cb_oc_build_stamp);
7325  fprintf (fp, "/* GNU Cobol package date %s */\n", COB_TAR_DATE);
7326  fprintf (fp, "/* Compile command ");
7327  for (i = 0; i < cb_saveargc; i++) {
7328  fprintf (fp, "%s ", cb_saveargv[i]);
7329  }
7330  fprintf (fp, "*/\n\n");
7331  if (cp) {
7332  fprintf (fp, "/* Program local variables for '%s' */\n\n",
7333  cp->orig_program_id);
7334  }
7335  }
7336 }
static void output_indent ( const char *  str)
static

References output_indent_level, output_line(), and p.

Referenced by output_alter_check(), output_call(), output_class_name_definition(), output_error_handler(), output_ferror_stmt(), output_file_initialization(), output_goto(), output_initialize(), output_initialize_compound(), output_initialize_literal(), output_initialize_one(), output_internal_function(), output_main_function(), output_perform(), output_perform_until(), output_search_all(), output_search_whens(), and output_stmt().

468 {
469  const char *p;
470  int level;
471 
472  level = 2;
473  for (p = str; *p == ' '; p++) {
474  level++;
475  }
476 
477  if (*p == '}' && strcmp (str, "})") != 0) {
478  output_indent_level -= level;
479  }
480 
481  output_line (str);
482 
483  if (*p == '{' && strcmp (str, ")}") != 0) {
484  output_indent_level += level;
485  }
486 }
static void output_index ( cb_tree  x)
static

References cb_get_int(), CB_INTEGER, CB_TAG_INTEGER, CB_TAG_LITERAL, CB_TREE_TAG, output(), and output_integer().

Referenced by output_data(), and output_size().

1571 {
1572  switch (CB_TREE_TAG (x)) {
1573  case CB_TAG_INTEGER:
1574  output ("%d", CB_INTEGER (x)->val - 1);
1575  break;
1576  case CB_TAG_LITERAL:
1577  output ("%d", cb_get_int (x) - 1);
1578  break;
1579  default:
1580  output ("(");
1581  output_integer (x);
1582  output (" - 1)");
1583  break;
1584  }
1585 }
static void output_initial_values ( struct cb_field *  f)
static

References cb_build_field_reference(), cb_build_initialize(), cb_true, cb_field::count, cb_field::flag_item_based, cb_field::flag_no_init, NULL, output_stmt(), p, and cb_field::sister.

Referenced by output_internal_function().

5538 {
5539  struct cb_field *p;
5540  cb_tree x;
5541 
5542  for (p = f; p; p = p->sister) {
5543  x = cb_build_field_reference (p, NULL);
5544  if (p->flag_item_based) {
5545  continue;
5546  }
5547  /* For special registers */
5548  if (p->flag_no_init && !p->count) {
5549  continue;
5550  }
5551  output_stmt (cb_build_initialize (x, cb_true, NULL, 1, 0, 0));
5552  }
5553 }
static void output_initialize ( struct cb_initialize *  p)
static

References CB_BUILD_CHAIN, cb_build_field_reference(), CB_CHAIN, cb_i, CB_REFERENCE, cb_initialize::flag_init_statement, cb_field::flag_occurs, i_counters, INITIALIZE_COMPOUND, INITIALIZE_DEFAULT, INITIALIZE_NONE, INITIALIZE_ONE, initialize_type(), initialize_uniform_char(), cb_field::level, NULL, cb_field::occurs_max, output_indent(), output_initialize_compound(), output_initialize_one(), output_initialize_uniform(), output_line(), cb_field::size, and cb_initialize::var.

Referenced by output_stmt().

2794 {
2795  struct cb_field *f;
2796  cb_tree x;
2797  int c;
2798  int type;
2799 
2800  f = cb_code_field (p->var);
2801  type = initialize_type (p, f, 1);
2802  /* Check for non-standard OCCURS */
2803  if ((f->level == 1 || f->level == 77) &&
2804  f->flag_occurs && !p->flag_init_statement) {
2805  switch (type) {
2806  case INITIALIZE_NONE:
2807  return;
2808  case INITIALIZE_ONE:
2809  output_initialize_one (p, p->var);
2810  return;
2811  case INITIALIZE_DEFAULT:
2812  c = initialize_uniform_char (f, p);
2813  if (c != -1) {
2814  output_initialize_uniform (p->var, c, f->occurs_max);
2815  return;
2816  }
2817  /* Fall through */
2818  case INITIALIZE_COMPOUND:
2819  i_counters[0] = 1;
2820  output_line ("for (i0 = 1; i0 <= %d; i0++)", f->occurs_max);
2821  output_indent ("{");
2822  x = cb_build_field_reference (f, NULL);
2823  CB_REFERENCE (x)->subs =
2824  CB_BUILD_CHAIN (cb_i[0], CB_REFERENCE (x)->subs);
2825  output_initialize_compound (p, x);
2826  CB_REFERENCE (x)->subs =
2827  CB_CHAIN (CB_REFERENCE (x)->subs);
2828  output_indent ("}");
2829  return;
2830  default:
2831  break;
2832  }
2833  }
2834  switch (type) {
2835  case INITIALIZE_NONE:
2836  return;
2837  case INITIALIZE_ONE:
2838  output_initialize_one (p, p->var);
2839  return;
2840  case INITIALIZE_DEFAULT:
2841  c = initialize_uniform_char (f, p);
2842  if (c != -1) {
2843  output_initialize_uniform (p->var, c, f->size);
2844  return;
2845  }
2846  /* Fall through */
2847  case INITIALIZE_COMPOUND:
2848  output_initialize_compound (p, p->var);
2849  return;
2850  default:
2851  break;
2852  }
2853 }
static void output_initialize_compound ( struct cb_initialize *  p,
cb_tree  x 
)
static

References CB_BUILD_CHAIN, cb_build_field_reference(), CB_CHAIN, cb_i, cb_int1, CB_REFERENCE, cb_field::children, cb_field::flag_occurs, i_counters, cb_field::indexes, INITIALIZE_DEFAULT, INITIALIZE_NONE, INITIALIZE_ONE, initialize_type(), initialize_uniform_char(), cb_field::occurs_max, cb_field::offset, output_indent(), output_initialize_one(), output_initialize_uniform(), output_line(), cb_field::redefines, cb_field::sister, and cb_field::size.

Referenced by output_initialize().

2717 {
2718  struct cb_field *ff;
2719  struct cb_field *f;
2720  struct cb_field *last_field;
2721  cb_tree c;
2722  size_t size;
2723  int type;
2724  int last_char;
2725  int i;
2726 
2727  ff = cb_code_field (x);
2728  for (f = ff->children; f; f = f->sister) {
2729  type = initialize_type (p, f, 0);
2730  c = cb_build_field_reference (f, x);
2731 
2732  switch (type) {
2733  case INITIALIZE_NONE:
2734  break;
2735  case INITIALIZE_DEFAULT:
2736  last_field = f;
2737  last_char = initialize_uniform_char (f, p);
2738 
2739  if (last_char != -1) {
2740  if (f->flag_occurs) {
2741  CB_REFERENCE (c)->subs =
2742  CB_BUILD_CHAIN (cb_int1,
2743  CB_REFERENCE (c)->subs);
2744  }
2745 
2746  for (; f->sister; f = f->sister) {
2747  if (!f->sister->redefines) {
2748  if (initialize_type (p, f->sister, 0) != INITIALIZE_DEFAULT ||
2749  initialize_uniform_char (f->sister, p) != last_char) {
2750  break;
2751  }
2752  }
2753  }
2754 
2755  if (f->sister) {
2756  size = f->sister->offset - last_field->offset;
2757  } else {
2758  size = ff->offset + ff->size - last_field->offset;
2759  }
2760 
2761  output_initialize_uniform (c, last_char, (int) size);
2762  break;
2763  }
2764  /* Fall through */
2765  default:
2766  if (f->flag_occurs) {
2767  /* Begin occurs loop */
2768  i = f->indexes;
2769  i_counters[i] = 1;
2770  output_line ("for (i%d = 1; i%d <= %d; i%d++)",
2771  i, i, f->occurs_max, i);
2772  output_indent ("{");
2773  CB_REFERENCE (c)->subs =
2774  CB_BUILD_CHAIN (cb_i[i], CB_REFERENCE (c)->subs);
2775  }
2776 
2777  if (type == INITIALIZE_ONE) {
2778  output_initialize_one (p, c);
2779  } else {
2780  output_initialize_compound (p, c);
2781  }
2782 
2783  if (f->flag_occurs) {
2784  /* Close loop */
2785  CB_REFERENCE (c)->subs = CB_CHAIN (CB_REFERENCE (c)->subs);
2786  output_indent ("}");
2787  }
2788  }
2789  }
2790 }
static void output_initialize_fp ( cb_tree  x,
struct cb_field *  f 
)
static

References CB_USAGE_FLOAT, output(), output_data(), output_prefix(), and cb_field::usage.

Referenced by output_initialize_one().

2432 {
2433  output_prefix ();
2434  if (f->usage == CB_USAGE_FLOAT) {
2435  output ("{float temp = 0.0;");
2436  } else {
2437  output ("{double temp = 0.0;");
2438  }
2439  output (" memcpy (");
2440  output_data (x);
2441  output (", (void *)&temp, sizeof(temp));}\n");
2442 }
static void output_initialize_fp_bindec ( cb_tree  x,
struct cb_field *  f 
)
static

References output(), output_data(), output_prefix(), and cb_field::size.

Referenced by output_initialize_one().

2423 {
2424  output_prefix ();
2425  output ("memset (");
2426  output_data (x);
2427  output (", 0, %d);\n", (int)f->size);
2428 }
static void output_initialize_literal ( cb_tree  x,
struct cb_field *  f,
struct cb_literal *  l,
const int  init_occurs 
)
static

References CB_REFERENCE, CB_REFERENCE_P, cb_literal::data, i_counters, if(), cb_literal::llit, cb_field::occurs_max, output(), output_data(), output_indent(), output_line(), output_prefix(), output_size(), output_string(), cb_literal::size, and cb_field::size.

Referenced by output_initialize_one().

2359 {
2360  int i;
2361  int n;
2362  int size;
2363  int lsize;
2364 
2365  /* Check for non-standard 01 OCCURS */
2366  if (init_occurs) {
2367  size = f->occurs_max;
2368  lsize = (int)l->size;
2369  /* Check truncated literal */
2370  if (lsize > f->size) {
2371  lsize = f->size;
2372  }
2373  } else {
2374  size = f->size;
2375  lsize = (int)l->size;
2376  }
2377  if (lsize == 1) {
2378  output_prefix ();
2379  output ("memset (");
2380  output_data (x);
2381  if (CB_REFERENCE_P(x) && CB_REFERENCE(x)->length) {
2382  output (", %d, ", l->data[0]);
2383  output_size (x);
2384  output (");\n");
2385  } else {
2386  output (", %d, %d);\n", l->data[0], size);
2387  }
2388  return;
2389  }
2390  if (lsize >= size) {
2391  output_prefix ();
2392  output ("memcpy (");
2393  output_data (x);
2394  output (", ");
2395  output_string (l->data, size, l->llit);
2396  output (", %d);\n", size);
2397  return;
2398  }
2399  i = size / lsize;
2400  i_counters[0] = 1;
2401  output_line ("for (i0 = 0; i0 < %d; i0++)", i);
2402  output_indent ("{");
2403  output_prefix ();
2404  output ("memcpy (");
2405  output_data (x);
2406  output (" + (i0 * %d), ", lsize);
2407  output_string (l->data, lsize, l->llit);
2408  output (", %d);\n", lsize);
2409  output_indent ("}");
2410  n = size % lsize;
2411  if (n) {
2412  output_prefix ();
2413  output ("memcpy (");
2414  output_data (x);
2415  output (" + (i0 * %d), ", lsize);
2416  output_string (l->data, n, l->llit);
2417  output (", %d);\n", n);
2418  }
2419 }
static void output_initialize_one ( struct cb_initialize *  p,
cb_tree  x 
)
static

References _, cb_literal::all, CB_BUILD_CHAIN, CB_CATEGORY_ALPHANUMERIC_EDITED, CB_CATEGORY_NATIONAL, CB_CATEGORY_NATIONAL_EDITED, CB_CATEGORY_NUMERIC, CB_CATEGORY_NUMERIC_EDITED, CB_CHAIN, CB_CLASS_NUMERIC, CB_CONST_P, cb_high, cb_i, CB_LITERAL, CB_LITERAL_P, cb_low, cb_null, CB_PURPOSE_INT, cb_quote, CB_REFERENCE, cb_space, CB_TREE_CATEGORY, CB_TREE_CLASS, 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_LONG_DOUBLE, CB_VALUE, cb_zero, cb_field::children, cob_u32_t, COBC_ABORT, cobc_abort_pr(), cobc_main_malloc(), cobc_main_realloc(), cb_literal::data, cb_field::flag_blank_zero, cb_field::flag_chained, cb_initialize::flag_default, cb_initialize::flag_init_statement, cb_field::flag_occurs, cb_field::flag_sign_separate, i_counters, cb_field::level, litbuff, litsize, cb_literal::llit, cb_field::occurs_max, output(), output_data(), output_figurative(), output_indent(), output_initialize_fp(), output_initialize_fp_bindec(), output_initialize_literal(), output_line(), output_move(), output_prefix(), output_string(), cb_field::param_num, cb_initialize::rep, cb_literal::size, cb_field::size, cb_field::usage, cb_initialize::val, value, and cb_field::values.

Referenced by output_initialize(), and output_initialize_compound().

2467 {
2468  struct cb_field *f;
2469  cb_tree value;
2470  cb_tree lrp;
2471  struct cb_literal *l;
2472  size_t lsize;
2473  cob_u32_t inci;
2474  int i;
2475  int n;
2476  int size;
2477  int offset;
2478  int init_occurs;
2479  unsigned char buffchar;
2480 
2481  f = cb_code_field (x);
2482 
2483  /* CHAINING */
2484  if (f->flag_chained) {
2485  output_prefix ();
2486  output ("cob_chain_setup (");
2487  output_data (x);
2488  output (", %d, %d);\n", f->param_num, f->size);
2489  return;
2490  }
2491  /* Initialize by value */
2492  if (p->val && f->values) {
2493  value = CB_VALUE (f->values);
2494  /* Check for non-standard OCCURS */
2495  if ((f->level == 1 || f->level == 77) &&
2496  f->flag_occurs && !p->flag_init_statement) {
2497  init_occurs = 1;
2498  } else {
2499  init_occurs = 0;
2500  }
2501  if (value == cb_space) {
2502  output_figurative (x, f, ' ', init_occurs);
2503  return;
2504  } else if (value == cb_low) {
2505  output_figurative (x, f, 0, init_occurs);
2506  return;
2507  } else if (value == cb_high) {
2508  output_figurative (x, f, 255, init_occurs);
2509  return;
2510  } else if (value == cb_quote) {
2511  if (cb_flag_apostrophe) {
2512  output_figurative (x, f, '\'', init_occurs);
2513  } else {
2514  output_figurative (x, f, '"', init_occurs);
2515  }
2516  return;
2517  } else if (value == cb_zero && f->usage == CB_USAGE_DISPLAY) {
2518  if (!f->flag_sign_separate && !f->flag_blank_zero) {
2519  output_figurative (x, f, '0', init_occurs);
2520  } else {
2521  output_move (cb_zero, x);
2522  }
2523  return;
2524  } else if (value == cb_null && f->usage == CB_USAGE_DISPLAY) {
2525  output_figurative (x, f, 0, init_occurs);
2526  return;
2527  } else if (CB_LITERAL_P (value) && CB_LITERAL (value)->all) {
2528  /* ALL literal */
2529  output_initialize_literal (x, f,
2530  CB_LITERAL (value), init_occurs);
2531  return;
2532  } else if (CB_CONST_P (value) ||
2533  CB_TREE_CLASS (value) == CB_CLASS_NUMERIC) {
2534  /* Figurative literal, numeric literal */
2535  /* Check for non-standard 01 OCCURS */
2536  if (init_occurs) {
2537  i_counters[0] = 1;
2538  output_line ("for (i0 = 1; i0 <= %d; i0++)",
2539  f->occurs_max);
2540  output_indent ("{");
2541  CB_REFERENCE (x)->subs =
2542  CB_BUILD_CHAIN (cb_i[0], CB_REFERENCE (x)->subs);
2543  output_move (value, x);
2544  CB_REFERENCE (x)->subs =
2545  CB_CHAIN (CB_REFERENCE (x)->subs);
2546  output_indent ("}");
2547  } else {
2548  output_move (value, x);
2549  }
2550  return;
2551  }
2552  /* Alphanumeric literal */
2553  /* We do not use output_move here because
2554  we do not want to have the value be edited. */
2555 
2556  l = CB_LITERAL (value);
2557 
2558  /* Check for non-standard 01 OCCURS */
2559  if (init_occurs) {
2560  output_initialize_literal (x, f, l, 1);
2561  return;
2562  }
2563 
2564  size = f->size;
2565 
2566  if (size == 1) {
2567  output_prefix ();
2568  output ("*(cob_u8_ptr)(");
2569  output_data (x);
2570  output (") = %u;\n", l->data[0]);
2571  return;
2572  }
2573 
2574  buffchar = l->data[0];
2575  for (lsize = 0; lsize < l->size; lsize++) {
2576  if (l->data[lsize] != buffchar) {
2577  break;
2578  }
2579  }
2580  if (lsize == l->size) {
2581  output_prefix ();
2582  output ("memset (");
2583  output_data (x);
2584  output (", %u, %d);\n", (unsigned int)buffchar,
2585  (int)lsize);
2586  if ((int)l->size < (int)size) {
2587  output_prefix ();
2588  output ("memset (");
2589  output_data (x);
2590  output (" + %d, ' ', %d);\n",
2591  (int)lsize, (int)(size - lsize));
2592  }
2593  return;
2594  }
2595 
2596  if (size > litsize) {
2597  litsize = size + 128;
2598  if (litbuff) {
2599  litbuff = cobc_main_realloc (litbuff, (size_t)litsize);
2600  } else {
2601  litbuff = cobc_main_malloc ((size_t)litsize);
2602  }
2603  }
2604 
2605  if ((int)l->size >= (int)size) {
2606  memcpy (litbuff, l->data, (size_t)size);
2607  } else {
2608  memcpy (litbuff, l->data, (size_t)l->size);
2609  memset (litbuff + l->size, ' ', (size_t)(size - l->size));
2610  }
2611 
2612  buffchar = *(litbuff + size - 1);
2613  n = 0;
2614  for (i = size - 1; i >= 0; i--, n++) {
2615  if (*(litbuff + i) != buffchar) {
2616  break;
2617  }
2618  }
2619  if (i < 0) {
2620  output_prefix ();
2621  output ("memset (");
2622  output_data (x);
2623  output (", %u, %d);\n", (unsigned int)buffchar, size);
2624  return;
2625  }
2626 
2627  if (n > 2) {
2628  offset = size - n;
2629  size -= n;
2630  } else {
2631  offset = 0;
2632  }
2633 
2634  inci = 0;
2635  for (; size > 509; size -= 509, inci += 509) {
2636  output_prefix ();
2637  output ("memcpy (");
2638  output_data (x);
2639  if (!inci) {
2640  output (", ");
2641  } else {
2642  output (" + %u, ", inci);
2643  }
2644  output_string (litbuff + inci, 509, l->llit);
2645  output (", 509);\n");
2646  }
2647 
2648  output_prefix ();
2649  output ("memcpy (");
2650  output_data (x);
2651  if (!inci) {
2652  output (", ");
2653  } else {
2654  output (" + %u, ", inci);
2655  }
2656  output_string (litbuff + inci, size, l->llit);
2657  output (", %d);\n", size);
2658 
2659  if (offset) {
2660  output_prefix ();
2661  output ("memset (");
2662  output_data (x);
2663  output (" + %d, %u, %d);\n",
2664  offset, (unsigned int)buffchar, n);
2665  }
2666  return;
2667  }
2668 
2669  /* Initialize replacing */
2670  if (!f->children) {
2671  for (lrp = p->rep; lrp; lrp = CB_CHAIN (lrp)) {
2672  if ((int)CB_PURPOSE_INT (lrp) == (int)CB_TREE_CATEGORY (x)) {
2673  output_move (CB_VALUE (lrp), x);
2674  return;
2675  }
2676  }
2677  }
2678 
2679  /* Initialize by default */
2680  if (p->flag_default) {
2681  switch (f->usage) {
2682  case CB_USAGE_FLOAT:
2683  case CB_USAGE_DOUBLE:
2684  case CB_USAGE_LONG_DOUBLE:
2685  output_initialize_fp (x, f);
2686  return;
2687  case CB_USAGE_FP_BIN32:
2688  case CB_USAGE_FP_BIN64:
2689  case CB_USAGE_FP_BIN128:
2690  case CB_USAGE_FP_DEC64:
2691  case CB_USAGE_FP_DEC128:
2692  output_initialize_fp_bindec (x, f);
2693  return;
2694  default:
2695  break;
2696  }
2697  switch (CB_TREE_CATEGORY (x)) {
2698  case CB_CATEGORY_NUMERIC:
2699  case CB_CATEGORY_NUMERIC_EDITED:
2700  output_move (cb_zero, x);
2701  break;
2702  case CB_CATEGORY_ALPHANUMERIC_EDITED:
2703  case CB_CATEGORY_NATIONAL:
2704  case CB_CATEGORY_NATIONAL_EDITED:
2705  output_move (cb_space, x);
2706  break;
2707  default:
2708  cobc_abort_pr (_("Unexpected tree category %d"),
2709  (int)CB_TREE_CATEGORY (x));
2710  COBC_ABORT ();
2711  }
2712  }
2713 }
static void output_initialize_uniform ( cb_tree  x,
const int  c,
const int  size 
)
static

References CB_REFERENCE, CB_REFERENCE_P, output(), output_data(), output_prefix(), and output_size().

Referenced by output_initialize(), and output_initialize_compound().

2446 {
2447  output_prefix ();
2448  if (size == 1) {
2449  output ("*(cob_u8_ptr)(");
2450  output_data (x);
2451  output (") = %d;\n", c);
2452  } else {
2453  output ("memset (");
2454  output_data (x);
2455  if (CB_REFERENCE_P(x) && CB_REFERENCE(x)->length) {
2456  output (", %d, ", c);
2457  output_size (x);
2458  output (");\n");
2459  } else {
2460  output (", %d, %d);\n", c, size);
2461  }
2462  }
2463 }
static void output_integer ( cb_tree  x)
static

References _, cb_cast::cast_type, CB_BINARY_OP, CB_CAST, CB_CAST_ADDRESS, CB_CAST_PROGRAM_POINTER, CB_CONST, cb_fits_int(), cb_get_int(), CB_INTEGER, cb_null, CB_PREFIX_BASE, CB_STORAGE_LINKAGE, CB_TAG_BINARY_OP, CB_TAG_CAST, CB_TAG_CONST, CB_TAG_INTEGER, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_TAG, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_X, CB_USAGE_DISPLAY, CB_USAGE_INDEX, CB_USAGE_LENGTH, CB_USAGE_PACKED, CB_USAGE_POINTER, CB_USAGE_PROGRAM_POINTER, cb_zero, COBC_ABORT, cobc_abort_pr(), cb_picture::digits, else, cb_binary_op::flag, cb_field::flag_binary_swap, gen_nested_tab, cb_picture::have_sign, hexval, cb_field::id, cb_field::indexes, cb_program::nested_prog_list, cb_field::offset, cb_binary_op::op, optimize_defs, output(), output_base(), output_data(), output_func_1(), output_param(), p, cb_field::pic, cb_picture::scale, cb_field::size, cb_field::special_index, cb_field::storage, cb_field::usage, cb_cast::val, cb_binary_op::x, and cb_binary_op::y.

Referenced by output_base(), output_call(), output_call_by_value_args(), output_cond(), output_index(), output_internal_function(), output_occurs(), output_param(), output_search_all(), output_search_whens(), output_size(), and output_stmt().

1068 {
1069  struct cb_binary_op *p;
1070  struct cb_cast *cp;
1071  struct cb_field *f;
1072 
1073  switch (CB_TREE_TAG (x)) {
1074  case CB_TAG_CONST:
1075  if (x == cb_zero) {
1076  output ("0");
1077  } else if (x == cb_null) {
1078  output ("(cob_u8_ptr)NULL");
1079  } else {
1080  output ("%s", CB_CONST (x)->val);
1081  }
1082  break;
1083  case CB_TAG_INTEGER:
1084  if (CB_INTEGER (x)->hexval) {
1085  output ("0x%X", CB_INTEGER (x)->val);
1086  } else {
1087  output ("%d", CB_INTEGER (x)->val);
1088  }
1089  break;
1090  case CB_TAG_LITERAL:
1091  output ("%d", cb_get_int (x));
1092  break;
1093  case CB_TAG_BINARY_OP:
1094  p = CB_BINARY_OP (x);
1095  if (p->flag) {
1096  if (!cb_fits_int (p->x) || !cb_fits_int (p->y)) {
1097  output ("cob_get_int (");
1098  output_param (x, -1);
1099  output (")");
1100  break;
1101  }
1102  }
1103  if (p->op == '^') {
1104  output ("(int) pow (");
1105  output_integer (p->x);
1106  output (", ");
1107  output_integer (p->y);
1108  output (")");
1109  } else {
1110  output ("(");
1111  output_integer (p->x);
1112  output (" %c ", p->op);
1113  output_integer (p->y);
1114  output (")");
1115  }
1116  break;
1117  case CB_TAG_CAST:
1118  cp = CB_CAST (x);
1119  switch (cp->cast_type) {
1120  case CB_CAST_ADDRESS:
1121  output ("(");
1122  output_data (cp->val);
1123  output (")");
1124  break;
1125  case CB_CAST_PROGRAM_POINTER:
1126  output ("cob_call_field (");
1127  output_param (x, -1);
1128  if (current_prog->nested_prog_list) {
1129  gen_nested_tab = 1;
1130  output (", cob_nest_tab, 0, %d)", cb_fold_call);
1131  } else {
1132  output (", NULL, 0, %d)", cb_fold_call);
1133  }
1134  break;
1135  default:
1136  cobc_abort_pr (_("Unexpected cast type %d"),
1137  (int)cp->cast_type);
1138  COBC_ABORT ();
1139  }
1140  break;
1141  case CB_TAG_REFERENCE:
1142  f = cb_code_field (x);
1143  switch (f->usage) {
1144  case CB_USAGE_INDEX:
1145  if (f->special_index) {
1146  output_base (f, 1U);
1147  output ("%s%d", CB_PREFIX_BASE, f->id);
1148  return;
1149  }
1150  /* Fall through */
1151  case CB_USAGE_LENGTH:
1152  output ("(*(int *) (");
1153  output_data (x);
1154  output ("))");
1155  return;
1156 
1157  case CB_USAGE_POINTER:
1158 #ifdef COB_NON_ALIGNED
1159  output ("(cob_get_pointer (");
1160  output_data (x);
1161  output ("))");
1162 #else
1163  output ("(*(unsigned char **) (");
1164  output_data (x);
1165  output ("))");
1166 #endif
1167  return;
1168 
1169  case CB_USAGE_PROGRAM_POINTER:
1170 #ifdef COB_NON_ALIGNED
1171  output ("(cob_get_prog_pointer (");
1172  output_data (x);
1173  output ("))");
1174 #else
1175  output ("(*(void **) (");
1176  output_data (x);
1177  output ("))");
1178 #endif
1179  return;
1180 
1181  case CB_USAGE_DISPLAY:
1182  if (f->pic && f->pic->scale >= 0 &&
1183  f->size - f->pic->scale > 0 &&
1184  f->size - f->pic->scale <= 9 &&
1185  f->pic->have_sign == 0 &&
1186  !cb_ebcdic_sign) {
1187  optimize_defs[COB_GET_NUMDISP] = 1;
1188  output ("cob_get_numdisp (");
1189  output_data (x);
1190  output (", %d)", f->size - f->pic->scale);
1191  return;
1192  }
1193  break;
1194 
1195  case CB_USAGE_PACKED:
1196  if (f->pic->scale == 0 && f->pic->digits < 10) {
1197  optimize_defs[COB_GET_PACKED_INT] = 1;
1198  output_func_1 ("cob_get_packed_int", x);
1199  return;
1200  }
1201  break;
1202 
1203  case CB_USAGE_BINARY:
1204  case CB_USAGE_COMP_5:
1205  case CB_USAGE_COMP_X:
1206  if (f->size == 1) {
1207  output ("(*(");
1208  if (!f->pic->have_sign) {
1209  output ("cob_u8_ptr) (");
1210  } else {
1211  output ("cob_s8_ptr) (");
1212  }
1213  output_data (x);
1214  output ("))");
1215  return;
1216  }
1217 #ifdef COB_NON_ALIGNED
1218  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 && (
1219 #ifdef COB_SHORT_BORK
1220  (f->size == 2 && (f->offset % 4 == 0)) ||
1221 #else
1222  (f->size == 2 && (f->offset % 2 == 0)) ||
1223 #endif
1224  (f->size == 4 && (f->offset % 4 == 0)) ||
1225  (f->size == 8 && (f->offset % 8 == 0)))) {
1226 #else
1227  if (f->size == 2 || f->size == 4 || f->size == 8) {
1228 #endif
1229  if (f->flag_binary_swap) {
1230  output ("((");
1231  switch (f->size) {
1232  case 2:
1233  if (!f->pic->have_sign) {
1234  output ("unsigned short)COB_BSWAP_16(");
1235  } else {
1236  output ("short)COB_BSWAP_16(");
1237  }
1238  break;
1239  case 4:
1240  if (!f->pic->have_sign) {
1241  output ("unsigned int)COB_BSWAP_32(");
1242  } else {
1243  output ("int)COB_BSWAP_32(");
1244  }
1245  break;
1246  case 8:
1247  if (!f->pic->have_sign) {
1248  output ("cob_u64_t)COB_BSWAP_64(");
1249  } else {
1250  output ("cob_s64_t)COB_BSWAP_64(");
1251  }
1252  break;
1253  default:
1254  break;
1255  }
1256  output ("*(");
1257  switch (f->size) {
1258  case 2:
1259  output ("short *)(");
1260  break;
1261  case 4:
1262  output ("int *)(");
1263  break;
1264  case 8:
1265  output ("cob_s64_t *)(");
1266  break;
1267  default:
1268  break;
1269  }
1270  output_data (x);
1271  output (")))");
1272  return;
1273  } else {
1274  output ("(*(");
1275  switch (f->size) {
1276  case 2:
1277  if (!f->pic->have_sign) {
1278  output ("unsigned short *)(");
1279  } else {
1280  output ("short *)(");
1281  }
1282  break;
1283  case 4:
1284  if (!f->pic->have_sign) {
1285  output ("unsigned int *)(");
1286  } else {
1287  output ("int *)(");
1288  }
1289  break;
1290  case 8:
1291  if (!f->pic->have_sign) {
1292  output ("cob_u64_ptr)(");
1293  } else {
1294  output ("cob_s64_ptr)(");
1295  }
1296  break;
1297  default:
1298  break;
1299  }
1300  output_data (x);
1301  output ("))");
1302  return;
1303  }
1304  }
1305  if (f->pic->have_sign == 0) {
1306  output ("(unsigned int)");
1307  }
1308  break;
1309 
1310  default:
1311  break;
1312  }
1313 
1314  output_func_1 ("cob_get_int", x);
1315  break;
1316  case CB_TAG_INTRINSIC:
1317  output ("cob_get_int (");
1318  output_param (x, -1);
1319  output (")");
1320  break;
1321  default:
1322  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
1323  COBC_ABORT ();
1324  }
1325 }
static void output_internal_function ( struct cb_program *  prog,
cb_tree  parameter_list 
)
static

References _, cb_program::alphabet_name_list, cb_program::alter_gotos, label_list::call_num, call_list::callname, CB_ALPHABET_NAME, cb_program::cb_call_params, CB_CHAIN, CB_EXCEPTION_ENABLE, CB_FILE, CB_FUNCTION_TYPE, cb_int1, CB_LABEL, cb_list_length(), CB_PREFIX_BASE, CB_PREFIX_FIELD, CB_PREFIX_FILE, CB_PREFIX_KEYS, CB_PREFIX_LABEL, CB_PREFIX_STRING, CB_PROGRAM_TYPE, CB_PURPOSE, cb_program::cb_return_code, CB_USAGE_COMP_6, CB_USAGE_DISPLAY, CB_USAGE_PACKED, CB_VALUE, cb_program::classification, cb_file::cname, COB_EC_DATA_INCOMPATIBLE, COB_MALLOC_ALIGN, COB_ORG_INDEXED, COB_ORG_RELATIVE, COB_ORG_SORT, cob_u32_t, COBC_ABORT, cobc_abort_pr(), cobc_flag_main, cobc_parse_malloc(), cb_field::count, base_list::curr_prog, cb_program::decimal_index_max, cb_field::ename, cb_program::entry_list, excp_current_program_id, cb_program::exec_list, base_list::f, cb_program::file_list, cb_field::flag_any_length, cb_field::flag_any_numeric, cb_program::flag_chained, cb_program::flag_debugging, cb_field::flag_external, cb_file::flag_external, cb_program::flag_gen_error, cb_program::flag_global_use, cb_program::flag_initial, cb_field::flag_is_global, cb_field::flag_is_returning, cb_field::flag_item_78, cb_field::flag_item_based, cb_field::flag_local_alloced, cb_field::flag_local_storage, cb_program::flag_main, cb_field::flag_no_init, cb_program::flag_recursive, cb_program::flag_segments, gen_dynamic, cb_program::global_list, globext_cache, cb_alter_id::goto_id, label_list::id, cb_field::id, cb_file::linage, cb_program::linkage_storage, cb_program::local_include, local_mem, local_filename::local_name, cb_program::local_storage, local_working_mem, lookup_string(), cb_program::max_call_param, cb_field::mem_offset, cb_field::memory_size, cb_field::name, needs_exit_prog, cb_program::nested_level, label_list::next, call_list::next, base_list::next, cb_alter_id::next, cb_program::next_program, non_nested_count, NULL, cb_program::num_proc_params, optimize_defs, cb_file::organization, cb_program::orig_program_id, output(), output_alphabet_name_definition(), output_base(), output_data(), output_error_handler(), output_file_allocation(), output_file_initialization(), output_indent(), output_initial_values(), output_integer(), output_line(), output_local(), output_module_init(), output_move(), output_newline(), output_param(), output_prefix(), output_screen_definition(), output_screen_init(), output_size(), output_stmt(), output_target, p, cb_program::parameter_list, cb_program::prog_type, cb_program::program_id, cb_field::redefines, cb_program::returning, cb_program::screen_storage, cb_field::sister, cb_field::size, string_buffer, cb_program::toplev_count, cb_field::usage, working_mem, and cb_program::working_storage.

Referenced by codegen().

5715 {
5716  cb_tree l;
5717  cb_tree l2;
5718  struct cb_field *f;
5719  struct cb_program *next_prog;
5720  struct cb_file *fl;
5721  char *p;
5722  struct label_list *pl;
5723  struct cb_alter_id *cpl;
5724  struct call_list *clp;
5725  struct base_list *bl;
5726  FILE *savetarget;
5727  const char *s;
5728  int i;
5729  cob_u32_t inc;
5730  int parmnum;
5731  int seen;
5732  int anyseen;
5733 
5734  /* Program function */
5735 #if 0 /* RXWRXW USERFUNC */
5736  if (prog->prog_type == CB_FUNCTION_TYPE) {
5737  output ("static cob_field *\n%s_ (const int entry, cob_field **cob_parms",
5738  prog->program_id);
5739 #else
5740  if (prog->prog_type == CB_FUNCTION_TYPE) {
5741  output ("static cob_field *\n%s_ (const int entry",
5742  prog->program_id);
5743 #endif
5744  } else if (!prog->nested_level) {
5745  output ("static int\n%s_ (const int entry",
5746  prog->program_id);
5747  } else {
5748  output ("static int\n%s_%d_ (const int entry",
5749  prog->program_id, prog->toplev_count);
5750  }
5751  parmnum = 0;
5752 #if 0 /* RXWRXW USERFUNC */
5753  if (!prog->flag_chained && prog->prog_type != CB_FUNCTION_TYPE) {
5754 #else
5755  if (!prog->flag_chained) {
5756 #endif
5757  for (l = parameter_list; l; l = CB_CHAIN (l)) {
5758  if (l == parameter_list) {
5759  output (", ");
5760  }
5761  if (parmnum && !(parmnum % 2)) {
5762  output ("\n\t");
5763  }
5764  output ("cob_u8_t *%s%d",
5765  CB_PREFIX_BASE, cb_code_field (CB_VALUE (l))->id);
5766  if (CB_CHAIN (l)) {
5767  output (", ");
5768  }
5769  parmnum++;
5770  }
5771  }
5772  output (")\n");
5773  output_indent ("{");
5774 
5775  /* Program local variables */
5776  output_line ("/* Program local variables */");
5777  output_line ("#include \"%s\"", prog->local_include->local_name);
5778  output_newline ();
5779 
5780  /* Alphabet-names */
5781  if (prog->alphabet_name_list) {
5782  for (l = prog->alphabet_name_list; l; l = CB_CHAIN (l)) {
5783  output_alphabet_name_definition (CB_ALPHABET_NAME (CB_VALUE (l)));
5784  }
5785  }
5786 
5787  /* Module initialization indicator */
5788  output_local ("/* Module initialization indicator */\n");
5789  output_local ("static unsigned int\tinitialized = 0;\n\n");
5790 
5791  output_local ("/* Module structure pointer */\n");
5792 #if 0 /* RXWRXW - MODULE */
5793  if (prog->flag_recursive) {
5794  output_local ("cob_module\t\t*module;\n\n");
5795  } else {
5796  output_local ("static cob_module\tmodule_data;\n");
5797  output_local ("static cob_module\t*module = &module_data;\n\n");
5798  }
5799 #else
5800  if (prog->flag_recursive) {
5801  output_local ("cob_module\t\t*module = NULL;\n\n");
5802  } else {
5803  output_local ("static cob_module\t*module = NULL;\n\n");
5804  }
5805 #endif
5806 
5807 #if 1 /* RXWRXW - GLOBPTR */
5808  output_local ("/* Global variable pointer */\n");
5809  output_local ("cob_global\t\t*cob_glob_ptr;\n\n");
5810 #endif
5811 
5812  /* Decimal structures */
5813  if (prog->decimal_index_max) {
5814  output_local ("/* Decimal structures */\n");
5815  for (i = 0; i < prog->decimal_index_max; i++) {
5816  output_local ("cob_decimal\t*d%d;\n", i);
5817  }
5818  output_local ("\n");
5819  }
5820 
5821  /* External items */
5822  seen = 0;
5823  for (f = prog->working_storage; f; f = f->sister) {
5824  if (f->flag_external) {
5825  if (f->flag_is_global) {
5826  bl = cobc_parse_malloc (sizeof (struct base_list));
5827  bl->f = f;
5828  bl->curr_prog = excp_current_program_id;
5829  bl->next = globext_cache;
5830  globext_cache = bl;
5831  continue;
5832  }
5833  if (!seen) {
5834  seen = 1;
5835  output_local ("/* EXTERNAL items */\n");
5836  }
5837  output_local ("static unsigned char\t*%s%d = NULL;",
5838  CB_PREFIX_BASE, f->id);
5839  output_local (" /* %s */\n", f->name);
5840  }
5841  }
5842  if (seen) {
5843  output_local ("\n");
5844  }
5845  for (l = prog->file_list; l; l = CB_CHAIN (l)) {
5846  f = CB_FILE (CB_VALUE (l))->record;
5847  if (f->flag_external) {
5848  if (f->flag_is_global) {
5849  bl = cobc_parse_malloc (sizeof (struct base_list));
5850  bl->f = f;
5851  bl->curr_prog = excp_current_program_id;
5852  bl->next = globext_cache;
5853  globext_cache = bl;
5854  continue;
5855  }
5856  output_local ("static unsigned char\t*%s%d = NULL;",
5857  CB_PREFIX_BASE, f->id);
5858  output_local (" /* %s */\n", f->name);
5859  }
5860  }
5861 
5862  /* Files */
5863  if (prog->file_list) {
5864  i = 0;
5865  for (l = prog->file_list; l; l = CB_CHAIN (l)) {
5866  i += output_file_allocation (CB_FILE (CB_VALUE (l)));
5867  }
5868  if (i) {
5869  output_local ("\n/* LINAGE pointer */\n");
5870  output_local ("static cob_linage\t\t*lingptr;\n");
5871  }
5872  }
5873 
5874  /* BASED working-storage */
5875  i = 0;
5876  for (f = prog->working_storage; f; f = f->sister) {
5877  if (f->redefines) {
5878  continue;
5879  }
5880  if (f->flag_item_based) {
5881  if (!i) {
5882  i = 1;
5883  output_local("\n/* BASED WORKING-STORAGE SECTION */\n");
5884  }
5885  output_local ("static unsigned char\t*%s%d = NULL; /* %s */\n",
5886  CB_PREFIX_BASE, f->id, f->name);
5887  }
5888  }
5889  if (i) {
5890  output_local ("\n");
5891  }
5892 
5893  /* BASED local-storage */
5894  i = 0;
5895  for (f = prog->local_storage; f; f = f->sister) {
5896  if (f->redefines) {
5897  continue;
5898  }
5899  if (f->flag_item_based) {
5900  if (!i) {
5901  i = 1;
5902  output_local("\n/* BASED LOCAL-STORAGE */\n");
5903  }
5904  output_local ("static unsigned char\t*%s%d = NULL; /* %s */\n",
5905  CB_PREFIX_BASE, f->id, f->name);
5906  }
5907  }
5908  if (i) {
5909  output_local ("\n");
5910  }
5911 
5912 #if 0 /* RXWRXW USERFUNC */
5913  if (prog->prog_type == CB_FUNCTION_TYPE) {
5914  /* USING parameters for user FUNCTION */
5915  seen = 0;
5916  for (l = parameter_list; l; l = CB_CHAIN (l)) {
5917  f = cb_code_field (CB_VALUE (l));
5918  if (!seen) {
5919  seen = 1;
5920  output_local ("\n/* USING parameters */\n");
5921  }
5922  output_local ("unsigned char\t*%s%d = NULL; /* %s */\n",
5923  CB_PREFIX_BASE, f->id, f->name);
5924  }
5925  if (seen) {
5926  output_local ("\n");
5927  }
5928  }
5929 #endif
5930 
5931  /* Dangling linkage section items */
5932  seen = 0;
5933  for (f = prog->linkage_storage; f; f = f->sister) {
5934  if (f->redefines) {
5935  continue;
5936  }
5937  for (l = parameter_list; l; l = CB_CHAIN (l)) {
5938  if (f == cb_code_field (CB_VALUE (l))) {
5939  break;
5940  }
5941  }
5942  if (l == NULL) {
5943  if (!seen) {
5944  seen = 1;
5945  output_local ("\n/* LINKAGE SECTION (Items not referenced by USING clause) */\n");
5946  }
5947  if (!f->flag_is_returning) {
5948  output_local ("static ");
5949  }
5950  output_local ("unsigned char\t*%s%d = NULL; /* %s */\n",
5951  CB_PREFIX_BASE, f->id, f->name);
5952  }
5953  }
5954  if (seen) {
5955  output_local ("\n");
5956  }
5957 
5958  /* Screens */
5959  if (prog->screen_storage) {
5960  optimize_defs[COB_SET_SCREEN] = 1;
5961  output_local ("\n/* Screens */\n\n");
5962  output_screen_definition (prog->screen_storage);
5963  output_local ("\n");
5964  }
5965 
5966  /* ANY LENGTH items */
5967  i = 0;
5968  anyseen = 0;
5969  for (l = parameter_list; l; l = CB_CHAIN (l), i++) {
5970  f = cb_code_field (CB_VALUE (l));
5971  if (f->flag_any_length) {
5972  anyseen = 1;
5973 #if 0 /* RXWRXW - Any */
5974  output_local ("/* ANY LENGTH variable */\n");
5975  output_local ("cob_field\t\t*cob_anylen;\n\n");
5976 #endif
5977  break;
5978  }
5979  }
5980 
5981  /* Save variables for global callback */
5982  if (prog->flag_global_use && parameter_list) {
5983  output_local ("/* Parameter save */\n");
5984  for (l = parameter_list; l; l = CB_CHAIN (l)) {
5985  f = cb_code_field (CB_VALUE (l));
5986  output_local ("static unsigned char\t*save_%s%d;\n",
5987  CB_PREFIX_BASE, f->id);
5988  }
5989  output_local ("\n");
5990  }
5991 
5992  /* Runtime DEBUGGING MODE variable */
5993  if (prog->flag_debugging) {
5994  output_line ("char\t\t*s;");
5995  output_newline ();
5996  }
5997 
5998  /* Start of function proper */
5999  output_line ("/* Start of function code */");
6000  output_newline ();
6001 
6002  /* CANCEL callback */
6003  if (prog->prog_type == CB_PROGRAM_TYPE) {
6004  output_line ("/* CANCEL callback */");
6005  output_line ("if (unlikely(entry < 0)) {");
6006  output_line ("\tgoto P_cancel;");
6007  output_line ("}");
6008  output_newline ();
6009  }
6010 
6011 #if 0 /* RXWRXW - MODULEALL */
6012  /* Recursive module initialization */
6013  if (prog->flag_recursive) {
6014  output_line ("/* Allocate cob_module structure */");
6015  output_line ("module = cob_malloc (sizeof(cob_module));");
6016  output_newline ();
6017  }
6018 #endif
6019 
6020 
6021  output_line ("/* Check initialized, check module allocated, */");
6022  output_line ("/* set global pointer, */");
6023  output_line ("/* push module stack, save call parameter count */");
6024 #if 0 /* RXWRXW - MODULEALL */
6025  output_line ("cob_module_enter (module, &cob_glob_ptr, %d);",
6026  cb_flag_implicit_init);
6027 #else
6028  output_line ("cob_module_enter (&module, &cob_glob_ptr, %d);",
6029  cb_flag_implicit_init);
6030 #endif
6031  output_newline ();
6032 
6033  /* Recursive module initialization */
6034  if (prog->flag_recursive) {
6035  output_module_init (prog);
6036  }
6037 
6038  output_line ("/* Set address of module parameter list */");
6039  if (cb_flag_stack_on_heap || prog->flag_recursive) {
6040  if (prog->max_call_param) {
6041  i = prog->max_call_param;
6042  } else {
6043  i = 1;
6044  }
6045  output_line ("cob_procedure_params = cob_malloc (%dU * sizeof(void *));",
6046  i);
6047  }
6048  output_line ("module->cob_procedure_params = cob_procedure_params;");
6049  output_newline ();
6050 
6051 #if 0 /* RXWRXW USERFUNC */
6052  if (prog->prog_type == CB_FUNCTION_TYPE) {
6053  parmnum = 0;
6054  for (l = parameter_list; l; l = CB_CHAIN (l), parmnum++) {
6055  f = cb_code_field (CB_VALUE (l));
6056  output_line ("if (cob_parms[%d])", parmnum);
6057  output_line (" %s%d = cob_parms[%d]->data;",
6058  CB_PREFIX_BASE, f->id, parmnum);
6059  output_line ("else");
6060  output_line (" %s%d = NULL;",
6061  CB_PREFIX_BASE, f->id);
6062  }
6063  output_newline ();
6064  }
6065 #endif
6066 
6067  output_line ("/* Set frame stack pointer */");
6068  if (cb_flag_stack_on_heap || prog->flag_recursive) {
6069  if (prog->flag_recursive && cb_stack_size == 255) {
6070  i = 63;
6071  } else {
6072  i = cb_stack_size;
6073  }
6074  output_line ("frame_stack = cob_malloc (%dU * sizeof(struct cob_frame));",
6075  i);
6076  output_line ("frame_ptr = frame_stack;");
6077  if (cb_flag_stack_check) {
6078  output_line ("frame_overflow = frame_ptr + %d - 1;",
6079  i);
6080  }
6081  } else {
6082  output_line ("frame_ptr = frame_stack;");
6083  output_line ("frame_ptr->perform_through = 0;");
6084  if (cb_flag_stack_check) {
6085  output_line ("frame_overflow = frame_ptr + %d - 1;",
6086  cb_stack_size);
6087  }
6088  }
6089  output_newline ();
6090 
6091  /* Initialization */
6092  output_line ("/* Initialize program */");
6093  output_line ("if (unlikely(initialized == 0)) {");
6094  output_line ("\tgoto P_initialize;");
6095  if (prog->flag_chained) {
6096  output_line ("} else {");
6097  output_line ("\tcob_fatal_error (COB_FERROR_CHAINING);");
6098  }
6099  output_line ("}");
6100  output_line ("P_ret_initialize:");
6101  output_newline ();
6102 
6103  /* Set up LOCAL-STORAGE size */
6104  if (prog->local_storage) {
6105  for (f = prog->local_storage; f; f = f->sister) {
6106  if (f->flag_item_based || f->flag_local_alloced) {
6107  continue;
6108  }
6109  if (f->redefines) {
6110  continue;
6111  }
6112  if (f->flag_item_78) {
6113  cobc_abort_pr (_("Unexpected CONSTANT item"));
6114  COBC_ABORT ();
6115  }
6116  f->flag_local_storage = 1;
6117  f->flag_local_alloced = 1;
6118  f->mem_offset = local_mem;
6119  /* Round up to COB_MALLOC_ALIGN + 1 bytes */
6120  /* Caters for current types */
6121  local_mem += ((f->memory_size + COB_MALLOC_ALIGN) &
6122  ~COB_MALLOC_ALIGN);
6123  }
6124  }
6125 
6126  if (prog->decimal_index_max) {
6127  output_line ("/* Allocate decimal numbers */");
6128  output_prefix ();
6129  if (prog->flag_recursive) {
6130  output ("cob_decimal_push (%d", prog->decimal_index_max);
6131  } else {
6132  output ("cob_decimal_alloc (%d", prog->decimal_index_max);
6133  }
6134  for (i = 0; i < prog->decimal_index_max; i++) {
6135  output (", &d%d", i);
6136  }
6137  output (");\n");
6138  output_newline ();
6139  }
6140 
6141  /* Global entry dispatch */
6142  if (prog->global_list) {
6143  output_line ("/* Global entry dispatch */");
6144  output_newline ();
6145  for (l = prog->global_list; l; l = CB_CHAIN (l)) {
6146  output_line ("if (unlikely(entry == %d)) {",
6147  CB_LABEL (CB_VALUE (l))->id);
6148  i = 0;
6149  if (local_mem) {
6150  output_line ("\tcob_local_ptr = cob_local_save;");
6151  }
6152  for (l2 = parameter_list; l2; l2 = CB_CHAIN (l2), i++) {
6153  f = cb_code_field (CB_VALUE (l2));
6154  output_line ("\t%s%d = save_%s%d;",
6155  CB_PREFIX_BASE, f->id,
6156  CB_PREFIX_BASE, f->id);
6157  }
6158  output_line ("\tgoto %s%d;",
6159  CB_PREFIX_LABEL,
6160  CB_LABEL (CB_VALUE (l))->id);
6161  output_line ("}");
6162  }
6163  output_newline ();
6164  }
6165 
6166  if (cb_flag_recursive && !prog->flag_recursive) {
6167  output_line ("/* Check active count */");
6168  output_line ("if (unlikely(module->module_active)) {");
6169  output_line ("\tcob_fatal_error (COB_FERROR_RECURSIVE);");
6170  output_line ("}");
6171  }
6172  if (!prog->flag_recursive) {
6173  output_line ("/* Increment module active */");
6174  output_line ("module->module_active++;");
6175  output_newline ();
6176  }
6177 
6178  if (!cobc_flag_main && non_nested_count > 1) {
6179  output_line ("/* Increment module reference count */");
6180  output_line ("cob_reference_count++;");
6181  output_newline ();
6182  }
6183 
6184  /* Initialize W/S unconditionally when INITIAL program */
6185  if (prog->flag_initial) {
6186  output_line ("/* Initialize INITIAL program WORKING-STORAGE */");
6187  output_initial_values (prog->working_storage);
6188  output_newline ();
6189  for (l = prog->file_list; l; l = CB_CHAIN (l)) {
6190  output_file_initialization (CB_FILE (CB_VALUE (l)));
6191  }
6192  output_newline ();
6193  }
6194 
6195  /* Allocate / initialize LOCAL storage */
6196  if (prog->local_storage) {
6197  if (local_mem) {
6198  output_line ("/* Allocate LOCAL storage */");
6199  output_line ("cob_local_ptr = cob_malloc (%dU);",
6200  local_mem);
6201  if (prog->flag_global_use) {
6202  output_line ("cob_local_save = cob_local_ptr;");
6203  }
6204  }
6205  output_newline ();
6206  output_line ("/* Initialialize LOCAL storage */");
6207  output_initial_values (prog->local_storage);
6208  output_newline ();
6209  }
6210 
6211  /* Call parameters */
6212  if (cb_code_field (prog->cb_call_params)->count) {
6213  output_line ("/* Set NUMBER-OF-CALL-PARAMETERS */");
6214  output_prefix ();
6215  output_integer (prog->cb_call_params);
6216  output (" = cob_glob_ptr->cob_call_params;\n");
6217  output_newline ();
6218  }
6219 
6220 #if 1 /* RXWRXW - Save call params */
6221  output_line ("/* Save number of call params */");
6222  output_line ("module->module_num_params = cob_glob_ptr->cob_call_params;");
6223  output_newline ();
6224 #endif
6225 
6226  /* Set up ANY length items */
6227  i = 0;
6228  if (anyseen) {
6229  output_line ("/* Initialize ANY LENGTH parameters */");
6230  }
6231  for (l = parameter_list; l; l = CB_CHAIN (l), i++) {
6232  f = cb_code_field (CB_VALUE (l));
6233  if (f->flag_any_length) {
6234  /* Force field cache */
6235  savetarget = output_target;
6236  output_target = NULL;
6237  output_param (CB_VALUE (l), i);
6238  output_target = savetarget;
6239 
6240  output_line ("if (cob_glob_ptr->cob_call_params > %d && %s%d%s)",
6241  i, "module->next->cob_procedure_params[",
6242  i, "]");
6243  if (f->flag_any_numeric) {
6244  /* Copy complete structure */
6245  output_line (" %s%d = *(%s%d%s);",
6246  CB_PREFIX_FIELD, f->id,
6247  "module->next->cob_procedure_params[",
6248  i, "]");
6249  } else {
6250  /* Copy size */
6251  output_line (" %s%d.size = %s%d%s;",
6252  CB_PREFIX_FIELD, f->id,
6253  "module->next->cob_procedure_params[",
6254  i, "]->size");
6255  }
6256  output_prefix ();
6257  output ("%s%d.data = ", CB_PREFIX_FIELD, f->id);
6258  output_data (CB_VALUE (l));
6259  output (";\n");
6260 #if 0 /* RXWRXW - Num check */
6261  if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE) &&
6262  f->flag_any_numeric &&
6263  (f->usage == CB_USAGE_DISPLAY ||
6264  f->usage == CB_USAGE_PACKED ||
6265  f->usage == CB_USAGE_COMP_6)) {
6266  output_line ("cob_check_numeric (&%s%d, %s%d);",
6267  CB_PREFIX_FIELD
6268  f->id,
6269  CB_PREFIX_STRING,
6270  lookup_string (f->name));
6271  }
6272 #endif
6273  }
6274  }
6275  if (anyseen) {
6276  output_newline ();
6277  }
6278 
6279  if (prog->prog_type == CB_FUNCTION_TYPE) {
6280  output_prefix ();
6281  output_data (prog->returning);
6282  output (" = cob_malloc (");
6283  output_size (prog->returning);
6284  output ("U);\n\n");
6285  }
6286 
6287  if (prog->flag_global_use && parameter_list) {
6288  output_line ("/* Parameter save */");
6289  for (l = parameter_list; l; l = CB_CHAIN (l)) {
6290  f = cb_code_field (CB_VALUE (l));
6291  output_line ("save_%s%d = %s%d;",
6292  CB_PREFIX_BASE, f->id,
6293  CB_PREFIX_BASE, f->id);
6294  }
6295  output_newline ();
6296  }
6297 
6298  /* Classification */
6299  if (prog->classification) {
6300  if (prog->classification == cb_int1) {
6301  output_line ("cob_set_locale (NULL, COB_LC_CLASS);");
6302  } else {
6303  output_prefix ();
6304  output ("cob_set_locale (");
6305  output_param (prog->classification, -1);
6306  output (", COB_LC_CTYPE);");
6307  }
6308  output_newline ();
6309  }
6310 
6311  /* Entry dispatch */
6312  output_line ("/* Entry dispatch */");
6313  if (cb_list_length (prog->entry_list) > 1) {
6314  output_newline ();
6315  output_line ("switch (entry)");
6316  output_line (" {");
6317  for (i = 0, l = prog->entry_list; l; l = CB_CHAIN (l)) {
6318  output_line (" case %d:", i++);
6319  output_line (" goto %s%d;", CB_PREFIX_LABEL,
6320  CB_LABEL (CB_PURPOSE (l))->id);
6321  }
6322  output_line (" }");
6323  output_line ("/* This should never be reached */");
6324  output_line ("cob_fatal_error (COB_FERROR_MODULE);");
6325  output_newline ();
6326  } else {
6327  l = prog->entry_list;
6328  output_line ("goto %s%d;", CB_PREFIX_LABEL,
6329  CB_LABEL (CB_PURPOSE (l))->id);
6330  output_newline ();
6331  }
6332 
6333  /* PROCEDURE DIVISION */
6334  output_line ("/* PROCEDURE DIVISION */");
6335  for (l = prog->exec_list; l; l = CB_CHAIN (l)) {
6336  output_stmt (CB_VALUE (l));
6337  }
6338  output_newline ();
6339 
6340  /* End of program */
6341  output_line ("/* Program exit */");
6342  output_newline ();
6343 
6344  if (needs_exit_prog) {
6345  output_line ("exit_program:");
6346  output_newline ();
6347  }
6348 
6349  if (!prog->flag_recursive) {
6350  output_line ("/* Decrement module active count */");
6351  output_line ("if (module->module_active) {");
6352  output_line ("\tmodule->module_active--;");
6353  output_line ("}");
6354  output_newline ();
6355  }
6356 
6357  if (!cobc_flag_main && non_nested_count > 1) {
6358  output_line ("/* Decrement module reference count */");
6359  output_line ("if (cob_reference_count) {");
6360  output_line ("\tcob_reference_count--;");
6361  output_line ("}");
6362  output_newline ();
6363  }
6364 
6365  if (gen_dynamic) {
6366  output_line ("/* Deallocate dynamic FUNCTION-ID fields */");
6367  for (inc = 0; inc < gen_dynamic; inc++) {
6368  output_line ("if (cob_dyn_%u) {", inc);
6369  output_line (" if (cob_dyn_%u->data) {", inc);
6370  output_line (" cob_free (cob_dyn_%u->data);", inc);
6371  output_line (" }");
6372  output_line (" cob_free (cob_dyn_%u);", inc);
6373  output_line (" cob_dyn_%u = NULL;", inc);
6374  output_line ("}");
6375  }
6376  output_newline ();
6377  }
6378 
6379  if (prog->local_storage) {
6380  output_line ("/* Deallocate LOCAL storage */");
6381  if (local_mem) {
6382  output_line ("if (cob_local_ptr) {");
6383  output_line ("\tfree (cob_local_ptr);");
6384  output_line ("\tcob_local_ptr = NULL;");
6385  if (current_prog->flag_global_use) {
6386  output_line ("\tcob_local_save = NULL;");
6387  }
6388  output_line ("}");
6389  }
6390  for (f = prog->local_storage; f; f = f->sister) {
6391  if (f->flag_item_based) {
6392  output_line ("if (%s%d) {", CB_PREFIX_BASE, f->id);
6393  output_line ("\tcob_free_alloc (&%s%d, NULL);",
6394  CB_PREFIX_BASE, f->id);
6395  output_line ("\t%s%d = NULL;",
6396  CB_PREFIX_BASE, f->id);
6397  output_line ("}");
6398  }
6399  }
6400  output_newline ();
6401  }
6402 
6403  if (prog->decimal_index_max && prog->flag_recursive) {
6404  output_line ("/* Free decimal structures */");
6405  output_prefix ();
6406  output ("cob_decimal_pop (%d", prog->decimal_index_max);
6407  for (i = 0; i < prog->decimal_index_max; i++) {
6408  output (", d%d", i);
6409  }
6410  output (");\n");
6411  output_newline ();
6412  }
6413 
6414  if (cb_flag_stack_on_heap || prog->flag_recursive) {
6415  output_line ("/* Free frame stack / call parameters */");
6416  output_line ("cob_free (frame_stack);");
6417  output_line ("cob_free (cob_procedure_params);");
6418  output_newline ();
6419  }
6420 
6421  if (cb_flag_trace) {
6422  output_line ("/* Trace program exit */");
6423  sprintf (string_buffer, "Exit: %s", excp_current_program_id);
6424  output_line ("cob_trace_section (%s%d, NULL, 0);",
6425  CB_PREFIX_STRING,
6426  lookup_string (string_buffer));
6427  output_newline ();
6428  }
6429 
6430  output_line ("/* Pop module stack */");
6431  output_line ("cob_module_leave (module);");
6432  output_newline ();
6433 
6434  if (prog->flag_recursive) {
6435  output_line ("/* Free cob_module structure */");
6436 #if 1 /* RXWRXW Mod */
6437  output_line ("cob_cache_free (module);");
6438 #else
6439  output_line ("cob_free (module);");
6440 #endif
6441  output_newline ();
6442  }
6443 
6444  /* Implicit CANCEL for INITIAL program */
6445  if (prog->flag_initial) {
6446  output_line ("/* CANCEL for INITIAL program */");
6447  output_prefix ();
6448  if (!prog->nested_level) {
6449  output ("%s_ (-1", prog->program_id);
6450  } else {
6451  output ("%s_%d_ (-1", prog->program_id,
6452  prog->toplev_count);
6453  }
6454  if (!prog->flag_chained) {
6455  for (l = parameter_list; l; l = CB_CHAIN (l)) {
6456  output (", NULL");
6457  }
6458  }
6459  output (");\n");
6460  output_newline ();
6461  }
6462 
6463  output_line ("/* Program return */");
6464 #if 1 /* RXWRXW - PROCRET */
6465  if (prog->returning) {
6466  output_move (prog->returning, prog->cb_return_code);
6467  }
6468 #endif
6469  output_prefix ();
6470  output ("return ");
6471  if (prog->prog_type == CB_FUNCTION_TYPE) {
6472  output_param (prog->returning, -1);
6473  } else {
6474  output_integer (prog->cb_return_code);
6475  }
6476  output (";\n");
6477 
6478  /* Error handlers */
6479  if (prog->file_list || prog->flag_gen_error) {
6480  output_error_handler (prog);
6481  }
6482 
6483  /* Frame stack jump table for compiler without computed goto */
6484  if (!cb_flag_computed_goto) {
6485  output_newline ();
6486  output_line ("/* Frame stack jump table */");
6487  output_line ("P_switch:");
6488  if (label_cache) {
6489  output_line (" switch (frame_ptr->return_address_num) {");
6490  for (pl = label_cache; pl; pl = pl->next) {
6491  output_line (" case %d:", pl->call_num);
6492  output_line (" goto %s%d;", CB_PREFIX_LABEL,
6493  pl->id);
6494  }
6495  output_line (" }");
6496  }
6497  output_line (" cob_fatal_error (COB_FERROR_CODEGEN);");
6498  output_newline ();
6499  }
6500 
6501  /* Program initialization */
6502 
6503 #if 0 /* RXWRXW WS */
6504  if (prog->working_storage) {
6505  for (f = prog->working_storage; f; f = f->sister) {
6506  if (f->flag_item_based || f->flag_local_alloced) {
6507  continue;
6508  }
6509  if (f->redefines || f->flag_external) {
6510  continue;
6511  }
6512 #if 0 /* RXWRXW - Check global */
6513  if (f->flag_is_global) {
6514  continue;
6515  }
6516 #endif
6517  if (f->flag_no_init && !f->count) {
6518  continue;
6519  }
6520  if (f->flag_item_78) {
6521  cobc_abort_pr (_("Unexpected CONSTANT item"));
6522  COBC_ABORT ();
6523  }
6524  if (f->flag_is_global) {
6525  f->mem_offset = working_mem;
6526  working_mem += ((f->memory_size + COB_MALLOC_ALIGN) &
6527  ~COB_MALLOC_ALIGN);
6528  } else {
6529  f->mem_offset = local_working_mem;
6530  local_working_mem += ((f->memory_size + COB_MALLOC_ALIGN) &
6531  ~COB_MALLOC_ALIGN);
6532  }
6533  }
6534  }
6535 #endif
6536 
6537  output_newline ();
6538  output_line ("/* Program initialization */");
6539  output_line ("P_initialize:");
6540  output_newline ();
6541 
6542  /* Check matching version */
6543  if (!prog->nested_level) {
6544  output_line ("cob_check_version (COB_SOURCE_FILE, COB_PACKAGE_VERSION, COB_PATCH_LEVEL);");
6545  output_newline ();
6546  }
6547 
6548  /* Resolve user functions */
6549  for (clp = func_call_cache; clp; clp = clp->next) {
6550  output_line ("func_%s.funcvoid = cob_resolve_func (\"%s\");",
6551  clp->callname, clp->callname);
6552  }
6553 
6554  if (cobc_flag_main && !prog->nested_level) {
6555  output_line ("cob_module_path = cob_glob_ptr->cob_main_argv0;");
6556  output_newline ();
6557  }
6558 
6559  /* Module initialization */
6560  if (!prog->flag_recursive) {
6561  output_module_init (prog);
6562  }
6563 
6564 
6565  /* Check runtime DEBUGGING MODE variable */
6566  if (prog->flag_debugging) {
6567  output_line ("if ((s = getenv (\"COB_SET_DEBUG\")) && (*s == 'Y' || *s == 'y' || *s == '1'))");
6568  output_line ("\tcob_debugging_mode = 1;");
6569  output_newline ();
6570  }
6571 
6572  /* Setup up CANCEL callback */
6573  if (!prog->nested_level && prog->prog_type == CB_PROGRAM_TYPE) {
6574  output_line ("/* Initialize cancel callback */");
6575 #if 0 /* RXWRXW CA */
6576  if (!cb_flag_implicit_init) {
6577  output_line ("if (module->next)");
6578  }
6579 #endif
6580  output_line ("cob_set_cancel (module);");
6581  output_newline ();
6582  }
6583 
6584  /* Initialize EXTERNAL files */
6585  for (l = prog->file_list; l; l = CB_CHAIN (l)) {
6586  f = CB_FILE (CB_VALUE (l))->record;
6587  if (f->flag_external) {
6588  strcpy (string_buffer, f->name);
6589  for (p = string_buffer; *p; p++) {
6590  if (*p == '-' || *p == ' ') {
6591  *p = '_';
6592  }
6593  }
6594  output_line ("%s%d = cob_external_addr (\"%s\", %d);",
6595  CB_PREFIX_BASE, f->id, string_buffer,
6596  CB_FILE (CB_VALUE (l))->record_max);
6597  }
6598  }
6599 
6600  /* Initialize WORKING-STORAGE EXTERNAL items */
6601  for (f = prog->working_storage; f; f = f->sister) {
6602  if (f->redefines) {
6603  continue;
6604  }
6605  if (!f->flag_external) {
6606  continue;
6607  }
6608  output_prefix ();
6609  output_base (f, 0);
6610  output (" = cob_external_addr (\"%s\", %d);\n",
6611  f->ename, f->size);
6612  }
6613 
6614  /* Initialize WORKING-STORAGE/files if not INITIAL program */
6615  if (!prog->flag_initial) {
6616  if (prog->working_storage) {
6617  output_line ("/* Initialize WORKING-STORAGE */");
6618  output_initial_values (prog->working_storage);
6619  output_newline ();
6620  }
6621  if (prog->file_list) {
6622  output_newline ();
6623  for (l = prog->file_list; l; l = CB_CHAIN (l)) {
6624  output_file_initialization (CB_FILE (CB_VALUE (l)));
6625  }
6626  output_newline ();
6627  }
6628  }
6629 
6630  if (prog->screen_storage) {
6631  output_line ("/* Initialize SCREEN items */");
6632  /* Initialize items with VALUE */
6633  output_initial_values (prog->screen_storage);
6634  output_screen_init (prog->screen_storage);
6635  output_newline ();
6636  }
6637 
6638  output_line ("initialized = 1;");
6639  output_line ("goto P_ret_initialize;");
6640 
6641  /* Set up CANCEL callback code */
6642 
6643  if (prog->prog_type != CB_PROGRAM_TYPE) {
6644  goto prog_cancel_end;
6645  }
6646 
6647  output_newline ();
6648  output_line ("/* CANCEL callback handling */");
6649  output_line ("P_cancel:");
6650  output_newline ();
6651  output_line ("if (!initialized) {");
6652  output_line ("\treturn 0;");
6653  output_line ("}");
6654  output_line ("if (module->module_active) {");
6655  output_line ("\tcob_fatal_error (COB_FERROR_CANCEL);");
6656  output_line ("}");
6657  output_newline ();
6658 
6659  if (prog->flag_main) {
6660  goto cancel_end;
6661  }
6662 
6663  next_prog = prog->next_program;
6664 
6665  /* Check for implicit cancel of contained programs */
6666  for (; next_prog; next_prog = next_prog->next_program) {
6667  if (next_prog->nested_level == prog->nested_level + 1) {
6668  output_prefix ();
6669  output ("(void)%s_%d_ (-1", next_prog->program_id,
6670  next_prog->toplev_count);
6671  for (i = 0; i < next_prog->num_proc_params; ++i) {
6672  output (", NULL");
6673  }
6674  output (");\n");
6675  }
6676  }
6677 
6678  /* Close files on cancel */
6679  for (l = prog->file_list; l; l = CB_CHAIN (l)) {
6680  fl = CB_FILE (CB_VALUE (l));
6681  if (fl->organization != COB_ORG_SORT) {
6682  output_line ("cob_close (%s%s, NULL, COB_CLOSE_NORMAL, 1);",
6683  CB_PREFIX_FILE, fl->cname);
6684  if (!fl->flag_external) {
6685  if (fl->linage) {
6686  output_line ("cob_cache_free (%s%s->linorkeyptr);",
6687  CB_PREFIX_FILE, fl->cname);
6688  }
6689  if (fl->organization == COB_ORG_RELATIVE ||
6690  fl->organization == COB_ORG_INDEXED) {
6691  output_line ("cob_cache_free (%s%s);",
6692  CB_PREFIX_KEYS, fl->cname);
6693  output_line ("%s%s = NULL;",
6694  CB_PREFIX_KEYS, fl->cname);
6695  }
6696  output_line ("cob_cache_free (%s%s);",
6697  CB_PREFIX_FILE, fl->cname);
6698  output_line ("%s%s = NULL;",
6699  CB_PREFIX_FILE, fl->cname);
6700  }
6701  } else {
6702  output_line ("cob_cache_free (%s%s);",
6703  CB_PREFIX_FILE, fl->cname);
6704  output_line ("%s%s = NULL;",
6705  CB_PREFIX_FILE, fl->cname);
6706  }
6707  }
6708 
6709  /* Clear alter indicators */
6710  for (cpl = prog->alter_gotos; cpl; cpl = cpl->next) {
6711  output_line ("label_%s%d = 0;",
6712  CB_PREFIX_LABEL, cpl->goto_id);
6713  if (prog->flag_segments) {
6714  output_line ("save_label_%s%d = 0;",
6715  CB_PREFIX_LABEL, cpl->goto_id);
6716  }
6717  }
6718 
6719  /* Release based storage */
6720  for (f = prog->working_storage; f; f = f->sister) {
6721  if (f->flag_item_based) {
6722  output_line ("if (%s%d) {", CB_PREFIX_BASE, f->id);
6723  output_line ("\tcob_free_alloc (&%s%d, NULL);",
6724  CB_PREFIX_BASE, f->id);
6725  output_line ("}");
6726  }
6727  }
6728 
6729  /* Reset DEBUGGING mode */
6730  if (prog->flag_debugging) {
6731  output_line ("cob_debugging_mode = 0;");
6732  }
6733 
6734  /* Clear CALL pointers */
6735  for (clp = call_cache; clp; clp = clp->next) {
6736  output_line ("call_%s.funcvoid = NULL;", clp->callname);
6737  }
6738  for (clp = func_call_cache; clp; clp = clp->next) {
6739  output_line ("func_%s.funcvoid = NULL;", clp->callname);
6740  }
6741 
6742  /* Clear sticky-linkage pointers */
6743  if (cb_sticky_linkage) {
6744  for (l = prog->parameter_list; l; l = CB_CHAIN (l)) {
6745  output_line ("cob_parm_%d = NULL;",
6746  cb_code_field (CB_VALUE (l))->id);
6747  }
6748  }
6749 
6750  /* Clear RETURN-CODE */
6751  if (!prog->nested_level) {
6752  output_prefix ();
6753  output_integer (current_prog->cb_return_code);
6754  output (" = 0;\n");
6755  }
6756 
6757 #if 1 /* RXWRXW Mod */
6758  output_line ("cob_cache_free (module);");
6759  output_line ("module = NULL;");
6760 #endif
6761  output_newline ();
6762 
6763 cancel_end:
6764  output_line ("initialized = 0;");
6765  output_line ("return 0;");
6766  output_newline ();
6767  /* End of CANCEL callback code */
6768 
6769 prog_cancel_end:
6770  output_indent ("}");
6771  output_newline ();
6772  if (prog->prog_type == CB_FUNCTION_TYPE) {
6773  s = "FUNCTION-ID";
6774  } else {
6775  s = "PROGRAM-ID";
6776  }
6777  output_line ("/* End %s '%s' */", s, prog->orig_program_id);
6778  output_newline ();
6779 }
static void output_label_info ( cb_tree  x,
struct cb_label *  lp 
)
static

References excp_current_paragraph, excp_current_section, cb_label::flag_dummy_exit, cb_label::flag_dummy_paragraph, cb_label::flag_dummy_section, cb_label::flag_entry, cb_label::flag_next_sentence, cb_label::flag_section, cb_label::name, NULL, cb_label::orig_name, output(), output_line(), output_newline(), output_prefix(), cb_tree_common::source_file, and cb_tree_common::source_line.

Referenced by output_stmt().

4541 {
4542  if (lp->flag_dummy_section || lp->flag_dummy_paragraph) {
4543  return;
4544  }
4545 
4546  output_newline ();
4547 
4548  if (lp->flag_dummy_exit) {
4549  output_line ("/* Implicit EXIT label */");
4550  return;
4551  } else if (lp->flag_next_sentence) {
4552  output_line ("/* Implicit NEXT SENTENCE label */");
4553  return;
4554  }
4555 
4556  output_prefix ();
4557  if (x->source_file) {
4558  output ("/* Line: %-10d: ", x->source_line);
4559  } else {
4560  output ("/* ");
4561  }
4562  if (lp->flag_section) {
4563  output ("Section %-24s", (const char *)lp->name);
4564  excp_current_section = (const char *)lp->name;
4565  excp_current_paragraph = NULL;
4566  } else {
4567  if (lp->flag_entry) {
4568  output ("Entry %-24s", lp->orig_name);
4569  excp_current_section = NULL;
4570  excp_current_paragraph = NULL;
4571  } else {
4572  output ("Paragraph %-24s", (const char *)lp->name);
4573  excp_current_paragraph = (const char *)lp->name;
4574  }
4575  }
4576  if (x->source_file) {
4577  output (": %s */\n", x->source_file);
4578  } else {
4579  output ("*/\n");
4580  }
4581 }
static void output_line ( const char *  fmt,
  ... 
)
static

References output_prefix(), and output_target.

Referenced by output_alter(), output_alter_check(), output_bin_field(), output_call(), output_class_name_definition(), output_error_handler(), output_ferror_stmt(), output_file_error(), output_file_initialization(), output_goto(), output_goto_1(), output_indent(), output_initialize(), output_initialize_compound(), output_initialize_literal(), output_initialize_one(), output_internal_function(), output_label_info(), output_main_function(), output_module_init(), output_perform_call(), output_perform_exit(), output_perform_until(), output_search_all(), output_search_whens(), output_section_info(), output_set_attribute(), and output_stmt().

454 {
455  va_list ap;
456 
457  if (output_target) {
458  output_prefix ();
459  va_start (ap, fmt);
460  vfprintf (output_target, fmt, ap);
461  va_end (ap);
462  fputc ('\n', output_target);
463  }
464 }
static void output_local ( const char *  fmt,
  ... 
)
static

References cb_local_file.

Referenced by codegen(), output_alphabet_name_definition(), output_alter_check(), output_base(), output_file_allocation(), output_internal_function(), and output_screen_definition().

528 {
529  va_list ap;
530 
531  if (cb_local_file) {
532  va_start (ap, fmt);
533  vfprintf (cb_local_file, fmt, ap);
534  va_end (ap);
535  }
536 }
static void output_long_integer ( cb_tree  x)
static

References _, cb_cast::cast_type, CB_BINARY_OP, CB_CAST, CB_CAST_ADDRESS, CB_CAST_PROGRAM_POINTER, CB_CONST, cb_fits_long_long(), CB_FMT_LLD_F, cb_get_long_long(), CB_INTEGER, cb_null, CB_PREFIX_BASE, CB_STORAGE_LINKAGE, CB_TAG_BINARY_OP, CB_TAG_CAST, CB_TAG_CONST, CB_TAG_INTEGER, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_TAG, CB_USAGE_BINARY, CB_USAGE_COMP_5, CB_USAGE_COMP_X, CB_USAGE_INDEX, CB_USAGE_LENGTH, CB_USAGE_POINTER, CB_USAGE_PROGRAM_POINTER, cb_zero, COBC_ABORT, cobc_abort_pr(), else, cb_binary_op::flag, cb_field::flag_binary_swap, gen_nested_tab, cb_picture::have_sign, hexval, cb_field::id, cb_field::indexes, cb_program::nested_prog_list, cb_field::offset, cb_binary_op::op, output(), output_base(), output_data(), output_func_1(), output_param(), p, cb_field::pic, cb_field::size, cb_field::special_index, cb_field::storage, cb_field::usage, cb_cast::val, cb_binary_op::x, and cb_binary_op::y.

Referenced by output_param().

1329 {
1330  struct cb_binary_op *p;
1331  struct cb_cast *cp;
1332  struct cb_field *f;
1333 
1334  switch (CB_TREE_TAG (x)) {
1335  case CB_TAG_CONST:
1336  if (x == cb_zero) {
1337  output ("0");
1338  } else if (x == cb_null) {
1339  output ("(cob_u8_ptr)NULL");
1340  } else {
1341  output ("%s", CB_CONST (x)->val);
1342  }
1343  break;
1344  case CB_TAG_INTEGER:
1345  if (CB_INTEGER (x)->hexval) {
1346  output ("0x%X", CB_INTEGER (x)->val);
1347  } else {
1348  output ("%d", CB_INTEGER (x)->val);
1349  }
1350  break;
1351  case CB_TAG_LITERAL:
1352  output (CB_FMT_LLD_F, cb_get_long_long (x));
1353  break;
1354  case CB_TAG_BINARY_OP:
1355  p = CB_BINARY_OP (x);
1356  if (p->flag) {
1357  if (!cb_fits_long_long (p->x) ||
1358  !cb_fits_long_long (p->y)) {
1359  output ("cob_get_llint (");
1360  output_param (x, -1);
1361  output (")");
1362  break;
1363  }
1364  }
1365  if (p->op == '^') {
1366  output ("(cob_s64_t) pow (");
1367  output_long_integer (p->x);
1368  output (", ");
1369  output_long_integer (p->y);
1370  output (")");
1371  } else {
1372  output ("(");
1373  output_long_integer (p->x);
1374  output (" %c ", p->op);
1375  output_long_integer (p->y);
1376  output (")");
1377  }
1378  break;
1379  case CB_TAG_CAST:
1380  cp = CB_CAST (x);
1381  switch (cp->cast_type) {
1382  case CB_CAST_ADDRESS:
1383  output ("(");
1384  output_data (cp->val);
1385  output (")");
1386  break;
1387  case CB_CAST_PROGRAM_POINTER:
1388  output ("cob_call_field (");
1389  output_param (x, -1);
1390  if (current_prog->nested_prog_list) {
1391  gen_nested_tab = 1;
1392  output (", cob_nest_tab, 0, %d)", cb_fold_call);
1393  } else {
1394  output (", NULL, 0, %d)", cb_fold_call);
1395  }
1396  break;
1397  default:
1398  cobc_abort_pr (_("Unexpected cast type %d"),
1399  (int)cp->cast_type);
1400  COBC_ABORT ();
1401  }
1402  break;
1403  case CB_TAG_REFERENCE:
1404  f = cb_code_field (x);
1405  switch (f->usage) {
1406  case CB_USAGE_INDEX:
1407  if (f->special_index) {
1408  output_base (f, 1U);
1409  output ("(cob_s64_t)%s%d", CB_PREFIX_BASE, f->id);
1410  return;
1411  }
1412  /* Fall through */
1413  case CB_USAGE_LENGTH:
1414  output ("(cob_s64_t)(*(int *) (");
1415  output_data (x);
1416  output ("))");
1417  return;
1418 
1419  case CB_USAGE_POINTER:
1420 #ifdef COB_NON_ALIGNED
1421  output ("(cob_get_pointer (");
1422  output_data (x);
1423  output ("))");
1424 #else
1425  output ("(*(unsigned char **) (");
1426  output_data (x);
1427  output ("))");
1428 #endif
1429  return;
1430 
1431  case CB_USAGE_PROGRAM_POINTER:
1432 #ifdef COB_NON_ALIGNED
1433  output ("(cob_get_prog_pointer (");
1434  output_data (x);
1435  output ("))");
1436 #else
1437  output ("(*(void **) (");
1438  output_data (x);
1439  output ("))");
1440 #endif
1441  return;
1442 
1443  case CB_USAGE_BINARY:
1444  case CB_USAGE_COMP_5:
1445  case CB_USAGE_COMP_X:
1446  if (f->size == 1) {
1447  output ("(*(");
1448  if (!f->pic->have_sign) {
1449  output ("cob_u8_ptr) (");
1450  } else {
1451  output ("cob_s8_ptr) (");
1452  }
1453  output_data (x);
1454  output ("))");
1455  return;
1456  }
1457 #ifdef COB_NON_ALIGNED
1458  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 && (
1459 #ifdef COB_SHORT_BORK
1460  (f->size == 2 && (f->offset % 4 == 0)) ||
1461 #else
1462  (f->size == 2 && (f->offset % 2 == 0)) ||
1463 #endif
1464  (f->size == 4 && (f->offset % 4 == 0)) ||
1465  (f->size == 8 && (f->offset % 8 == 0)))) {
1466 #else
1467  if (f->size == 2 || f->size == 4 || f->size == 8) {
1468 #endif
1469  if (f->flag_binary_swap) {
1470  output ("((");
1471  switch (f->size) {
1472  case 2:
1473  if (!f->pic->have_sign) {
1474  output ("unsigned short)COB_BSWAP_16(");
1475  } else {
1476  output ("short)COB_BSWAP_16(");
1477  }
1478  break;
1479  case 4:
1480  if (!f->pic->have_sign) {
1481  output ("unsigned int)COB_BSWAP_32(");
1482  } else {
1483  output ("int)COB_BSWAP_32(");
1484  }
1485  break;
1486  case 8:
1487  if (!f->pic->have_sign) {
1488  output ("cob_u64_t)COB_BSWAP_64(");
1489  } else {
1490  output ("cob_s64_t)COB_BSWAP_64(");
1491  }
1492  break;
1493  default:
1494  break;
1495  }
1496  output ("*(");
1497  switch (f->size) {
1498  case 2:
1499  output ("short *)(");
1500  break;
1501  case 4:
1502  output ("int *)(");
1503  break;
1504  case 8:
1505  output ("cob_s64_t *)(");
1506  break;
1507  default:
1508  break;
1509  }
1510  output_data (x);
1511  output (")))");
1512  return;
1513  } else {
1514  output ("(*(");
1515  switch (f->size) {
1516  case 2:
1517  if (!f->pic->have_sign) {
1518  output ("unsigned short *)(");
1519  } else {
1520  output ("short *)(");
1521  }
1522  break;
1523  case 4:
1524  if (!f->pic->have_sign) {
1525  output ("unsigned int *)(");
1526  } else {
1527  output ("int *)(");
1528  }
1529  break;
1530  case 8:
1531  if (!f->pic->have_sign) {
1532  output ("cob_u64_ptr)(");
1533  } else {
1534  output ("cob_s64_ptr)(");
1535  }
1536  break;
1537  default:
1538  break;
1539  }
1540  output_data (x);
1541  output ("))");
1542  return;
1543  }
1544  }
1545 #if 0 /* RXWRXW - unsigned */
1546  if (f->pic->have_sign == 0) {
1547  output ("(unsigned int)");
1548  }
1549 #endif
1550  break;
1551 
1552  default:
1553  break;
1554  }
1555 
1556  output_func_1 ("cob_get_llint", x);
1557  break;
1558  case CB_TAG_INTRINSIC:
1559  output ("cob_get_llint (");
1560  output_param (x, -1);
1561  output (")");
1562  break;
1563  default:
1564  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
1565  COBC_ABORT ();
1566  }
1567 }
static void output_main_function ( struct cb_program *  prog)
static

References output_indent(), output_line(), and cb_program::program_id.

Referenced by codegen().

7304 {
7305  output_line ("/* Main function */");
7306  output_line ("int");
7307  output_line ("main (int argc, char **argv)");
7308  output_indent ("{");
7309  output_line ("cob_init (argc, argv);");
7310  output_line ("cob_stop_run (%s ());", prog->program_id);
7311  output_indent ("}\n");
7312 }
static void output_module_init ( struct cb_program *  prog)
static

References CB_FUNCTION_TYPE, cb_ref(), cobc_flag_main, cb_program::collating_sequence, cb_program::crt_status, cb_program::currency_symbol, cb_program::cursor_pos, cb_program::decimal_point, cb_program::nested_level, no_physical_cancel, non_nested_count, cb_program::num_proc_params, cb_program::numeric_separator, cb_program::orig_program_id, output(), output_line(), output_newline(), output_param(), output_prefix(), cb_program::prog_type, and cb_program::program_id.

Referenced by output_internal_function().

5627 {
5628 #if 0 /* Module comments */
5629  output ("/* Next pointer, Parameter list pointer, Module name, */\n");
5630  output ("/* Module formatted date, Module source, */\n");
5631  output ("/* Module entry, Module cancel, */\n");
5632  output ("/* Collating, CRT status, CURSOR, */\n");
5633  output ("/* Module reference count, Module path, Module active, */\n");
5634  output ("/* Module date, Module time, */\n");
5635  output ("/* Module type, Number of USING parameters, Return type */\n");
5636  output ("/* Current parameter count */\n");
5637  output ("/* Display sign, Decimal point, Currency symbol, */\n");
5638  output ("/* Numeric separator, File name mapping, Binary truncate, */\n");
5639  output ("/* Alternate numeric display, Host sign, No physical cancel */\n");
5640  output ("/* Flag main program, Fold call, Exit after CALL */\n\n");
5641 #endif
5642 
5643  /* Do not initialize next pointer, parameter list pointer + count */
5644  output_line ("/* Initialize module structure */");
5645  output_line ("module->module_name = \"%s\";", prog->orig_program_id);
5646  output_line ("module->module_formatted_date = COB_MODULE_FORMATTED_DATE;");
5647  output_line ("module->module_source = COB_SOURCE_FILE;");
5648  if (!prog->nested_level) {
5649  output_line ("module->module_entry.funcptr = (void *(*)())%s;",
5650  prog->program_id);
5651  if (prog->prog_type == CB_FUNCTION_TYPE) {
5652  output_line ("module->module_cancel.funcptr = NULL;");
5653  } else {
5654  output_line ("module->module_cancel.funcptr = (void *(*)())%s_;",
5655  prog->program_id);
5656  }
5657  } else {
5658  output_line ("module->module_entry.funcvoid = NULL;");
5659  output_line ("module->module_cancel.funcvoid = NULL;");
5660  }
5661 
5662  if (prog->collating_sequence) {
5663  output_prefix ();
5664  output ("module->collating_sequence = ");
5665  output_param (cb_ref (prog->collating_sequence), -1);
5666  output (";\n");
5667  } else {
5668  output_line ("module->collating_sequence = NULL;");
5669  }
5670  if (prog->crt_status && cb_code_field (prog->crt_status)->count) {
5671  output_prefix ();
5672  output ("module->crt_status = ");
5673  output_param (cb_ref (prog->crt_status), -1);
5674  output (";\n");
5675  } else {
5676  output_line ("module->crt_status = NULL;");
5677  }
5678  if (prog->cursor_pos) {
5679  output_prefix ();
5680  output ("module->cursor_pos = ");
5681  output_param (cb_ref (prog->cursor_pos), -1);
5682  output (";\n");
5683  } else {
5684  output_line ("module->cursor_pos = NULL;");
5685  }
5686  if (!cobc_flag_main && non_nested_count > 1) {
5687  output_line ("module->module_ref_count = &cob_reference_count;");
5688  } else {
5689  output_line ("module->module_ref_count = NULL;");
5690  }
5691  output_line ("module->module_path = &cob_module_path;");
5692  output_line ("module->module_active = 0;");
5693  output_line ("module->module_date = COB_MODULE_DATE;");
5694  output_line ("module->module_time = COB_MODULE_TIME;");
5695  output_line ("module->module_type = %d;", (int)prog->prog_type);
5696  output_line ("module->module_param_cnt = %d;", prog->num_proc_params);
5697  output_line ("module->module_returning = 0;");
5698  output_line ("module->ebcdic_sign = %d;", cb_ebcdic_sign);
5699  output_line ("module->decimal_point = '%c';", prog->decimal_point);
5700  output_line ("module->currency_symbol = '%c';", prog->currency_symbol);
5701  output_line ("module->numeric_separator = '%c';", prog->numeric_separator);
5702  output_line ("module->flag_filename_mapping = %d;", cb_filename_mapping);
5703  output_line ("module->flag_binary_truncate = %d;", cb_binary_truncate);
5704  output_line ("module->flag_pretty_display = %d;", cb_pretty_display);
5705  output_line ("module->flag_host_sign = %d;", cb_host_sign);
5706  output_line ("module->flag_no_phys_canc = %d;", no_physical_cancel);
5707  output_line ("module->flag_main = %d;", cobc_flag_main);
5708  output_line ("module->flag_fold_call = %d;", cb_fold_call);
5709  output_line ("module->flag_exit_program = 0;");
5710  output_newline ();
5711 }
static void output_move ( cb_tree  src,
cb_tree  dst 
)
static

References cb_build_move(), cb_error_node, output_stmt(), suppress_warn, and cb_binary_op::x.

Referenced by output_call(), output_goto_1(), output_initialize_one(), output_internal_function(), output_perform(), output_perform_until(), output_search_whens(), and output_stmt().

2198 {
2199  cb_tree x;
2200 
2201  /* Suppress warnings */
2202  suppress_warn = 1;
2203  x = cb_build_move (src, dst);
2204  if (x != cb_error_node) {
2205  output_stmt (x);
2206  }
2207  suppress_warn = 0;
2208 }
static void output_newline ( void  )
static

References output_target.

Referenced by codegen(), output_alter_check(), output_call(), output_class_name_definition(), output_cond(), output_error_handler(), output_internal_function(), output_label_info(), output_module_init(), output_perform_exit(), output_screen_init(), output_search_all(), output_search_whens(), and output_stmt().

434 {
435  if (output_target) {
436  fputs ("\n", output_target);
437  }
438 }
static void output_occurs ( struct cb_field *  p)
static

References cb_field::depending, cb_field::occurs_max, output(), and output_integer().

Referenced by output_search_all(), and output_search_whens().

2859 {
2860  if (p->depending) {
2861  output_integer (p->depending);
2862  } else {
2863  output ("%d", p->occurs_max);
2864  }
2865 }
static void output_param ( cb_tree  x,
int  id 
)
static

References _, cb_alphabet_name::alphabet_type, cb_intrinsic::args, cb_cast::cast_type, CB_ALPHABET_ASCII, CB_ALPHABET_CUSTOM, CB_ALPHABET_EBCDIC, CB_ALPHABET_NAME, CB_ALPHABET_NAME_P, CB_ALPHABET_NATIVE, CB_BINARY_OP, cb_build_field_reference(), CB_CAST, CB_CAST_ADDR_OF_ADDR, CB_CAST_ADDRESS, CB_CAST_INTEGER, CB_CAST_LENGTH, CB_CAST_LONG_INT, CB_CAST_PROGRAM_POINTER, CB_CHAIN, CB_CONST, CB_DECIMAL, CB_FIELD, CB_FILE, CB_FILE_P, cb_int0, cb_int1, CB_INTRINSIC, cb_list_length(), CB_LOCALE_NAME, CB_LOCALE_NAME_P, cb_name(), CB_NEED_HIGH, CB_NEED_LOW, CB_NEED_QUOTE, CB_NEED_SPACE, CB_NEED_ZERO, cb_norm_high, cb_norm_low, CB_PREFIX_CONST, CB_PREFIX_FIELD, CB_PREFIX_FILE, CB_PREFIX_SEQUENCE, cb_quote, CB_REFERENCE, cb_space, CB_STORAGE_SCREEN, CB_STRING, CB_TAG_ALPHABET_NAME, CB_TAG_BINARY_OP, CB_TAG_CAST, CB_TAG_CONST, CB_TAG_DECIMAL, CB_TAG_FIELD, CB_TAG_FILE, CB_TAG_FUNCALL, CB_TAG_INTEGER, CB_TAG_INTRINSIC, CB_TAG_LITERAL, CB_TAG_LOCALE_NAME, CB_TAG_REFERENCE, CB_TAG_STRING, CB_TREE_TAG, CB_VALUE, cb_zero, cb_reference::check, chk_field_variable_address(), chk_field_variable_size(), cb_alphabet_name::cname, COB_INSIDE_SIZE, COBC_ABORT, cobc_abort_pr(), cobc_parse_malloc(), cb_program::collating_sequence, cb_field::count, field_list::curr_prog, excp_current_program_id, field_list::f, field_cache, cb_field::flag_any_length, cb_field::flag_anylen_done, cb_field::flag_external, cb_field::flag_field, cb_program::flag_file_global, cb_field::flag_is_global, cb_field::flag_item_based, cb_field::flag_local, gen_alt_ebcdic, gen_custom, gen_dynamic, gen_ebcdic_ascii, gen_figurative, gen_full_ebcdic, gen_native, cb_field::id, inside_check, inside_stack, cb_intrinsic::intr_field, cb_intrinsic_table::intr_routine, cb_intrinsic::intr_tab, cb_intrinsic::isuser, cb_intrinsic::length, local_field_cache, lookup_func_call(), lookup_literal(), cb_intrinsic::name, field_list::next, nolitcast, NULL, num_cob_fields, cb_reference::offset, cb_intrinsic::offset, cb_binary_op::op, output(), output_attr(), output_data(), output_field(), output_funcall(), output_indent_level, output_integer(), output_long_integer(), output_prefix(), output_size(), output_stmt(), output_string(), output_target, param_id, real_field_founder(), cb_intrinsic_table::refmod, screenptr, cb_field::special_index, stack_id, cb_field::storage, cb_reference::subs, user_func_upper(), cb_cast::val, cb_reference::value, field_list::x, cb_binary_op::x, and cb_binary_op::y.

Referenced by output_call(), output_call_by_value_args(), output_cancel(), output_data(), output_file_initialization(), output_func_1(), output_funcall(), output_funcall_debug(), output_goto(), output_integer(), output_internal_function(), output_long_integer(), output_module_init(), output_perform(), output_screen_init(), and output_stmt().

1591 {
1592  struct cb_reference *r;
1593  struct cb_field *f;
1594  struct cb_field *ff;
1595  struct cb_cast *cp;
1596  struct cb_binary_op *bp;
1597  struct field_list *fl;
1598  FILE *savetarget;
1599  struct cb_intrinsic *ip;
1600  struct cb_alphabet_name *abp;
1601  struct cb_alphabet_name *rbp;
1602  cb_tree l;
1603  char *func;
1604  int n;
1605  int sav_stack_id;
1606  char fname[12];
1607 
1608  param_id = id;
1609 
1610  if (x == NULL) {
1611  output ("NULL");
1612  return;
1613  }
1614 
1615  switch (CB_TREE_TAG (x)) {
1616  case CB_TAG_CONST:
1617  if (x == cb_quote) {
1618  gen_figurative |= CB_NEED_QUOTE;
1619  } else if (x == cb_norm_low) {
1620  gen_figurative |= CB_NEED_LOW;
1621  } else if (x == cb_norm_high) {
1622  gen_figurative |= CB_NEED_HIGH;
1623  } else if (x == cb_space) {
1624  gen_figurative |= CB_NEED_SPACE;
1625  } else if (x == cb_zero) {
1626  gen_figurative |= CB_NEED_ZERO;
1627  }
1628  output ("%s", CB_CONST (x)->val);
1629  break;
1630  case CB_TAG_INTEGER:
1631  output_integer (x);
1632  break;
1633  case CB_TAG_STRING:
1634  output_string (CB_STRING (x)->data, (int) CB_STRING (x)->size, 0);
1635  break;
1636  case CB_TAG_LOCALE_NAME:
1637  output_param (CB_LOCALE_NAME(x)->list, id);
1638  break;
1639  case CB_TAG_ALPHABET_NAME:
1640  abp = CB_ALPHABET_NAME (x);
1641  switch (abp->alphabet_type) {
1642  case CB_ALPHABET_ASCII:
1643 #ifdef COB_EBCDIC_MACHINE
1644  gen_ebcdic_ascii = 1;
1645  output ("cob_ebcdic_ascii");
1646  break;
1647 #endif
1648  /* Fall through for ASCII */
1649  case CB_ALPHABET_NATIVE:
1650  if (current_prog->collating_sequence) {
1651  gen_native = 1;
1652  output ("cob_native");
1653  } else {
1654  output ("NULL");
1655  }
1656  break;
1657  case CB_ALPHABET_EBCDIC:
1658 #ifdef COB_EBCDIC_MACHINE
1659  if (current_prog->collating_sequence) {
1660  gen_native = 1;
1661  output ("cob_native");
1662  } else {
1663  output ("NULL");
1664  }
1665 #else
1666  if (cb_flag_alt_ebcdic) {
1667  gen_alt_ebcdic = 1;
1668  output ("cob_a2e");
1669  } else {
1670  gen_full_ebcdic = 1;
1671  output ("cob_ascii_ebcdic");
1672  }
1673 #endif
1674  break;
1675  case CB_ALPHABET_CUSTOM:
1676  gen_custom = 1;
1677  output ("%s%s", CB_PREFIX_SEQUENCE, abp->cname);
1678  break;
1679  default:
1680  break;
1681  }
1682  break;
1683  case CB_TAG_CAST:
1684  cp = CB_CAST (x);
1685  switch (cp->cast_type) {
1686  case CB_CAST_INTEGER:
1687  output_integer (cp->val);
1688  break;
1689  case CB_CAST_LONG_INT:
1690  output_long_integer (cp->val);
1691  break;
1692  case CB_CAST_ADDRESS:
1693  output_data (cp->val);
1694  break;
1695  case CB_CAST_ADDR_OF_ADDR:
1696  output ("&");
1697  output_data (cp->val);
1698  break;
1699  case CB_CAST_LENGTH:
1700  output_size (cp->val);
1701  break;
1702  case CB_CAST_PROGRAM_POINTER:
1703  output_param (cp->val, id);
1704  break;
1705  default:
1706  break;
1707  }
1708  break;
1709  case CB_TAG_DECIMAL:
1710  output ("d%d", CB_DECIMAL (x)->id);
1711  break;
1712  case CB_TAG_FILE:
1713  output ("%s%s", CB_PREFIX_FILE, CB_FILE (x)->cname);
1714  break;
1715  case CB_TAG_LITERAL:
1716 #if 0 /* RXWRXW - Const */
1717  output ("&%s%d.vf", CB_PREFIX_CONST, lookup_literal (x));
1718 #else
1719  if (nolitcast) {
1720  output ("&%s%d", CB_PREFIX_CONST, lookup_literal (x));
1721  } else {
1722  output ("(cob_field *)&%s%d", CB_PREFIX_CONST,
1723  lookup_literal (x));
1724  }
1725 #endif
1726  break;
1727  case CB_TAG_FIELD:
1728  /* TODO: remove me */
1729  output_param (cb_build_field_reference (CB_FIELD (x), NULL), id);
1730  break;
1731  case CB_TAG_REFERENCE:
1732  r = CB_REFERENCE (x);
1733  if (CB_LOCALE_NAME_P (r->value)) {
1734  output_param (CB_LOCALE_NAME(r->value)->list, id);
1735  break;
1736  }
1737  if (r->check) {
1738  inside_stack[inside_check++] = 0;
1739  if (inside_check >= COB_INSIDE_SIZE) {
1740  cobc_abort_pr (_("Internal statement stack depth exceeded -> %d"),
1741  COB_INSIDE_SIZE);
1742  COBC_ABORT ();
1743  }
1744  output ("\n");
1745  output_prefix ();
1746  output ("(");
1747  n = output_indent_level;
1748  output_indent_level = 0;
1749  for (l = r->check; l; l = CB_CHAIN (l)) {
1750  sav_stack_id = stack_id;
1751  output_stmt (CB_VALUE (l));
1752  stack_id = sav_stack_id;
1753  if (l == r->check) {
1754  output_indent_level = n;
1755  }
1756  }
1757  }
1758 
1759  if (CB_FILE_P (r->value)) {
1760  output ("%s%s", CB_PREFIX_FILE, CB_FILE (r->value)->cname);
1761  if (r->check) {
1762  if (inside_check) {
1763  --inside_check;
1764  }
1765  output (" )");
1766  }
1767  break;
1768  }
1769  if (CB_ALPHABET_NAME_P (r->value)) {
1770  rbp = CB_ALPHABET_NAME (r->value);
1771  switch (rbp->alphabet_type) {
1772  case CB_ALPHABET_ASCII:
1773 #ifdef COB_EBCDIC_MACHINE
1774  gen_ebcdic_ascii = 2;
1775  output ("&f_ebcdic_ascii");
1776  break;
1777 #endif
1778  /* Fall through for ASCII */
1779  case CB_ALPHABET_NATIVE:
1780  gen_native = 2;
1781  output ("&f_native");
1782  break;
1783  case CB_ALPHABET_EBCDIC:
1784 #ifdef COB_EBCDIC_MACHINE
1785  gen_native = 2;
1786  output ("&f_native");
1787 #else
1788  gen_full_ebcdic = 2;
1789  output ("&f_ascii_ebcdic");
1790 #endif
1791  break;
1792  case CB_ALPHABET_CUSTOM:
1793  gen_custom = 1;
1794  output ("&%s%s", CB_PREFIX_FIELD, rbp->cname);
1795  break;
1796  default:
1797  break;
1798  }
1799  if (r->check) {
1800  if (inside_check) {
1801  --inside_check;
1802  }
1803  output (" )");
1804  }
1805  break;
1806  }
1807 
1808  f = CB_FIELD (r->value);
1809 
1810  ff = real_field_founder (f);
1811 
1812  if (ff->flag_external) {
1813  f->flag_external = 1;
1814  f->flag_local = 1;
1815  } else if (ff->flag_item_based) {
1816  f->flag_local = 1;
1817  }
1818 
1819  if (!r->subs && !r->offset && f->count > 0 &&
1820  !chk_field_variable_size (f) &&
1821  !chk_field_variable_address (f)) {
1822  if (!f->flag_field) {
1823  savetarget = output_target;
1824  output_target = NULL;
1825  output_field (x);
1826 
1827  fl = cobc_parse_malloc (sizeof (struct field_list));
1828  fl->x = x;
1829  fl->f = f;
1830  fl->curr_prog = excp_current_program_id;
1831  if (f->special_index != 2 && (f->flag_is_global ||
1832  current_prog->flag_file_global)) {
1833  fl->next = field_cache;
1834  field_cache = fl;
1835  } else {
1836  fl->next = local_field_cache;
1837  local_field_cache = fl;
1838  }
1839 
1840  f->flag_field = 1;
1841  output_target = savetarget;
1842  }
1843  if (f->flag_local) {
1844 #if 0 /* RXWRXW - Any data pointer */
1845  if (f->flag_any_length && f->flag_anylen_done) {
1846  output ("&%s%d",
1847  CB_PREFIX_FIELD, f->id);
1848  } else {
1849 #endif
1850  output ("COB_SET_DATA (%s%d, ",
1851  CB_PREFIX_FIELD, f->id);
1852  output_data (x);
1853  output (")");
1854 #if 0 /* RXWRXW - Any data pointer */
1855  f->flag_anylen_done = 1;
1856  }
1857 #endif
1858  } else {
1859  if (screenptr && f->storage == CB_STORAGE_SCREEN) {
1860  output ("&s_%d", f->id);
1861  } else {
1862  output ("&%s%d", CB_PREFIX_FIELD, f->id);
1863  }
1864  }
1865  } else {
1866  if (stack_id >= num_cob_fields) {
1867  num_cob_fields = stack_id + 1;
1868  }
1869  sprintf (fname, "f%d", stack_id++);
1870  if (inside_check != 0) {
1871  if (inside_stack[inside_check - 1] != 0) {
1872  inside_stack[inside_check - 1] = 0;
1873  output (",\n");
1874  output_prefix ();
1875  }
1876  }
1877  output ("COB_SET_FLD(%s, ", fname);
1878  output_size (x);
1879  output (", ");
1880  output_data (x);
1881  output (", ");
1882  output_attr (x);
1883  output (")");
1884  }
1885 
1886  if (r->check) {
1887  if (inside_check) {
1888  --inside_check;
1889  }
1890  output (" )");
1891  }
1892  break;
1893  case CB_TAG_BINARY_OP:
1894  bp = CB_BINARY_OP (x);
1895  output ("cob_intr_binop (");
1896  output_param (bp->x, id);
1897  output (", ");
1898  output ("%d", bp->op);
1899  output (", ");
1900  output_param (bp->y, id);
1901  output (")");
1902  break;
1903  case CB_TAG_INTRINSIC:
1904  ip = CB_INTRINSIC (x);
1905  if (ip->isuser) {
1906  func = user_func_upper (cb_name(ip->name));
1907  lookup_func_call (func);
1908 #if 0 /* RXWRXW Func */
1909  output ("cob_user_function (func_%s, &cob_dyn_%u, ",
1910  func, gen_dynamic);
1911 #else
1912  output ("func_%s.funcfld (&cob_dyn_%u",
1913  func, gen_dynamic);
1914 #endif
1915  gen_dynamic++;
1916  if (ip->intr_field || ip->args) {
1917  output (", ");
1918  }
1919 #if 0 /* RXWRXW Func */
1920  if (ip->intr_tab->refmod) {
1921  if (ip->offset) {
1922  output_integer (ip->offset);
1923  output (", ");
1924  } else {
1925  output ("0, ");
1926  }
1927  if (ip->length) {
1928  output_integer (ip->length);
1929  } else {
1930  output ("0");
1931  }
1932  if (ip->intr_field || ip->args) {
1933  output (", ");
1934  }
1935  }
1936 #endif
1937  } else {
1938  output ("%s (", ip->intr_tab->intr_routine);
1939  if (ip->intr_tab->refmod) {
1940  if (ip->offset) {
1941  output_integer (ip->offset);
1942  output (", ");
1943  } else {
1944  output ("0, ");
1945  }
1946  if (ip->length) {
1947  output_integer (ip->length);
1948  } else {
1949  output ("0");
1950  }
1951  if (ip->intr_field || ip->args) {
1952  output (", ");
1953  }
1954  }
1955  }
1956  if (ip->intr_field) {
1957  if (ip->intr_field == cb_int0) {
1958  output ("NULL");
1959  } else if (ip->intr_field == cb_int1) {
1960  output ("%d", cb_list_length (ip->args));
1961  } else {
1962  output_param (ip->intr_field, id);
1963  }
1964  if (ip->args) {
1965  output (", ");
1966  }
1967  }
1968  for (l = ip->args; l; l = CB_CHAIN (l)) {
1969  output_param (CB_VALUE (l), id);
1970  id++;
1971  param_id++;
1972  if (CB_CHAIN (l)) {
1973  output (", ");
1974  }
1975  }
1976  output (")");
1977  break;
1978  case CB_TAG_FUNCALL:
1979  output_funcall (x);
1980  break;
1981  default:
1982  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
1983  COBC_ABORT ();
1984  }
1985 }
static void output_perform ( struct cb_perform *  p)
static

References cb_build_cast_llint(), cb_build_debug(), cb_debug_contents, cb_debug_name, CB_FIELD, CB_LABEL, CB_PERFORM_EXIT, CB_PERFORM_FOREVER, CB_PERFORM_ONCE, CB_PERFORM_TIMES, CB_PERFORM_UNTIL, CB_PERFORM_VARYING, cb_ref(), CB_VALUE, cb_perform::data, cb_field::debug_section, cb_perform::exit_label, cb_field::flag_field_debug, cb_program::flag_gen_debug, cb_perform_varying::from, loop_counter, cb_field::name, cb_perform_varying::name, NULL, output(), output_indent(), output_move(), output_param(), output_perform_call(), output_perform_exit(), output_perform_once(), output_perform_until(), output_prefix(), output_stmt(), cb_perform::perform_type, and cb_perform::varying.

Referenced by output_stmt().

4215 {
4216  struct cb_perform_varying *v;
4217  struct cb_field *f;
4218 
4219  switch (p->perform_type) {
4220  case CB_PERFORM_EXIT:
4221  if (CB_LABEL (p->data)->flag_return) {
4222  output_perform_exit (CB_LABEL (p->data));
4223  }
4224  break;
4225  case CB_PERFORM_ONCE:
4226  output_perform_once (p);
4227  break;
4228  case CB_PERFORM_TIMES:
4229  output_prefix ();
4230  output ("for (n%d = ", loop_counter);
4231  output_param (cb_build_cast_llint (p->data), 0);
4232  output ("; n%d > 0; n%d--)\n", loop_counter, loop_counter);
4233  loop_counter++;
4234  output_indent ("{");
4235  output_perform_once (p);
4236  output_indent ("}");
4237  break;
4238  case CB_PERFORM_UNTIL:
4239  v = CB_PERFORM_VARYING (CB_VALUE (p->varying));
4240  if (v->name) {
4241  output_move (v->from, v->name);
4242  /* DEBUG */
4243  if (current_prog->flag_gen_debug) {
4244  f = CB_FIELD (cb_ref (v->name));
4245  if (f->flag_field_debug) {
4246  output_stmt (cb_build_debug (cb_debug_name,
4247  (const char *)f->name, NULL));
4248  output_stmt (cb_build_debug (cb_debug_contents,
4249  NULL, v->name));
4250  output_perform_call (f->debug_section,
4251  f->debug_section);
4252  }
4253  }
4254 
4255  }
4256  output_perform_until (p, p->varying);
4257  break;
4258  case CB_PERFORM_FOREVER:
4259  output_prefix ();
4260  output ("for (;;)\n");
4261  output_indent ("{");
4262  output_perform_once (p);
4263  output_indent ("}");
4264  break;
4265  default:
4266  break;
4267  }
4268  if (p->exit_label) {
4269  output_stmt (cb_ref (p->exit_label));
4270  }
4271 }
static void output_perform_call ( struct cb_label *  lb,
struct cb_label *  le 
)
static

References cb_program::all_procedure, label_list::call_num, cb_build_debug(), cb_debug_name, cb_id, CB_PREFIX_LABEL, cobc_parse_malloc(), cb_label::flag_alter, cb_label::flag_debugging_mode, cb_program::flag_gen_debug, cb_label::flag_is_debug_sect, cb_label::flag_real_label, cb_label::flag_section, cb_program::flag_segments, label_list::id, cb_label::id, label_cache, last_segment, cb_label::name, label_list::next, cb_para_label::next, NULL, output_line(), output_stmt(), p, cb_para_label::para, cb_label::para_label, cb_label::section, cb_label::section_id, and cb_label::segment.

Referenced by output_alter(), output_cond_debug(), output_error_handler(), output_file_error(), output_funcall_debug(), output_goto(), output_perform(), output_perform_once(), output_perform_until(), and output_stmt().

3854 {
3855  struct cb_para_label *p;
3856  struct label_list *l;
3857 
3858  if (lb == current_prog->all_procedure || lb->flag_is_debug_sect) {
3859  output_line ("/* DEBUGGING Callback PERFORM %s */",
3860  (const char *)lb->name);
3861  } else if (lb == le) {
3862  output_line ("/* PERFORM %s */", (const char *)lb->name);
3863  } else {
3864  output_line ("/* PERFORM %s THRU %s */", (const char *)lb->name,
3865  (const char *)le->name);
3866  }
3867 
3868  /* Save current independent segment pointers */
3869  if (current_prog->flag_segments && last_section &&
3870  last_section->section_id != lb->section_id) {
3871  p = last_section->para_label;
3872  for (; p; p = p->next) {
3873  if (p->para->segment > 49 &&
3874  p->para->flag_alter) {
3875  output_line ("save_label_%s%d = label_%s%d;",
3876  CB_PREFIX_LABEL, p->para->id,
3877  CB_PREFIX_LABEL, p->para->id);
3878  }
3879  }
3880  }
3881  /* Zap target independent labels */
3882  if (current_prog->flag_segments && last_segment != lb->segment) {
3883  if (lb->flag_section) {
3884  p = lb->para_label;
3885  } else if (lb->section) {
3886  p = lb->section->para_label;
3887  } else {
3888  p = NULL;
3889  }
3890  for (; p; p = p->next) {
3891  if (p->para->segment > 49 &&
3892  p->para->flag_alter) {
3893  output_line ("label_%s%d = 0;",
3894  CB_PREFIX_LABEL, p->para->id);
3895  }
3896  }
3897  }
3898 
3899  /* Update debugging name */
3900  if (current_prog->flag_gen_debug && lb->flag_real_label &&
3901  (current_prog->all_procedure || lb->flag_debugging_mode)) {
3902  output_stmt (cb_build_debug (cb_debug_name,
3903  (const char *)lb->name, NULL));
3904  }
3905 
3906  output_line ("frame_ptr++;");
3907  if (cb_flag_stack_check) {
3908  output_line ("if (unlikely(frame_ptr == frame_overflow))");
3909  output_line (" cob_fatal_error (COB_FERROR_STACK);");
3910  }
3911  output_line ("frame_ptr->perform_through = %d;", le->id);
3912  if (!cb_flag_computed_goto) {
3913  l = cobc_parse_malloc (sizeof (struct label_list));
3914  l->next = label_cache;
3915  l->id = cb_id;
3916  if (label_cache == NULL) {
3917  l->call_num = 0;
3918  } else {
3919  l->call_num = label_cache->call_num + 1;
3920  }
3921  label_cache = l;
3922  output_line ("frame_ptr->return_address_num = %d;", l->call_num);
3923  output_line ("goto %s%d;", CB_PREFIX_LABEL, lb->id);
3924  output_line ("%s%d:", CB_PREFIX_LABEL, cb_id);
3925  } else {
3926  output_line ("frame_ptr->return_address_ptr = &&%s%d;",
3927  CB_PREFIX_LABEL, cb_id);
3928  output_line ("goto %s%d;", CB_PREFIX_LABEL, lb->id);
3929  output_line ("%s%d:", CB_PREFIX_LABEL, cb_id);
3930  }
3931  output_line ("frame_ptr--;");
3932  cb_id++;
3933 
3934  if (current_prog->flag_segments && last_section &&
3935  last_section->section_id != lb->section_id) {
3936  /* Restore current independent segment pointers */
3937  p = last_section->para_label;
3938  for (; p; p = p->next) {
3939  if (p->para->segment > 49 &&
3940  p->para->flag_alter) {
3941  output_line ("label_%s%d = save_label_%s%d;",
3942  CB_PREFIX_LABEL, p->para->id,
3943  CB_PREFIX_LABEL, p->para->id);
3944  }
3945  }
3946  /* Zap target independent labels */
3947  if (lb->flag_section) {
3948  p = lb->para_label;
3949  } else if (lb->section) {
3950  p = lb->section->para_label;
3951  } else {
3952  p = NULL;
3953  }
3954  for (; p; p = p->next) {
3955  if (p->para->segment > 49 &&
3956  p->para->flag_alter) {
3957  output_line ("label_%s%d = 0;",
3958  CB_PREFIX_LABEL, p->para->id);
3959  }
3960  }
3961  }
3962 }
static void output_perform_exit ( struct cb_label *  l)
static

References CB_PROGRAM_TYPE, cb_label::flag_declarative_exit, cb_label::flag_default_handler, cb_label::flag_fatal_check, cb_label::flag_global, cb_program::flag_recursive, cb_label::id, output_line(), output_newline(), and cb_program::prog_type.

Referenced by output_error_handler(), and output_perform().

3966 {
3967  if (l->flag_global) {
3968  output_newline ();
3969  output_line ("/* Implicit GLOBAL DECLARATIVE return */");
3970  output_line ("if (entry == %d) {", l->id);
3971  output_line (" cob_module_leave (module);");
3972  if (cb_flag_stack_on_heap || current_prog->flag_recursive) {
3973  output_line (" cob_free (frame_stack);");
3974  output_line (" cob_free (cob_procedure_params);");
3975  output_line (" cob_cache_free (module);");
3976  }
3977  output_line (" return 0;");
3978  output_line ("}");
3979  }
3980  output_newline ();
3981 
3982  if (l->flag_declarative_exit) {
3983  output_line ("/* Implicit DECLARATIVE return */");
3984  } else if (l->flag_default_handler) {
3985  output_line ("/* Implicit Default Error Handler return */");
3986  } else {
3987  output_line ("/* Implicit PERFORM return */");
3988  }
3989 
3990  if (cb_perform_osvs && current_prog->prog_type == CB_PROGRAM_TYPE) {
3991  output_line
3992  ("for (temp_index = frame_ptr; temp_index->perform_through; temp_index--) {");
3993  output_line (" if (temp_index->perform_through == %d) {", l->id);
3994  output_line (" frame_ptr = temp_index;");
3995  if (!cb_flag_computed_goto) {
3996  output_line (" goto P_switch;");
3997  } else {
3998  output_line (" goto *frame_ptr->return_address_ptr;");
3999  }
4000  output_line (" }");
4001  output_line ("}");
4002  } else {
4003  output_line ("if (frame_ptr->perform_through == %d)", l->id);
4004  if (!cb_flag_computed_goto) {
4005  output_line (" goto P_switch;");
4006  } else {
4007  output_line (" goto *frame_ptr->return_address_ptr;");
4008  }
4009  }
4010 
4011  if (l->flag_fatal_check) {
4012  output_newline ();
4013  output_line ("/* Fatal error if reached */");
4014  output_line ("cob_fatal_error (COB_FERROR_GLOBAL);");
4015  }
4016 }
static void output_perform_once ( struct cb_perform *  p)
static

References cb_perform::body, CB_LABEL, CB_PAIR_P, CB_PAIR_X, CB_PAIR_Y, cb_ref(), cb_perform::cycle_label, output_perform_call(), and output_stmt().

Referenced by output_perform(), and output_perform_until().

4138 {
4139  if (p->body && CB_PAIR_P (p->body)) {
4140  output_perform_call (CB_LABEL (cb_ref (CB_PAIR_X (p->body))),
4141  CB_LABEL (cb_ref (CB_PAIR_Y (p->body))));
4142  } else {
4143  output_stmt (p->body);
4144  }
4145  if (p->cycle_label) {
4146  output_stmt (cb_ref (p->cycle_label));
4147  }
4148 }
static void output_perform_until ( struct cb_perform *  p,
cb_tree  l 
)
static

References CB_AFTER, CB_BEFORE, cb_build_debug(), CB_CHAIN, cb_debug_contents, cb_debug_name, CB_FIELD, CB_PERFORM_VARYING, cb_ref(), CB_VALUE, cb_field::debug_section, cb_field::flag_field_debug, cb_program::flag_gen_debug, cb_field::name, next, NULL, output(), output_cond(), output_cond_debug(), output_indent(), output_line(), output_move(), output_perform_call(), output_perform_once(), output_prefix(), output_stmt(), cb_perform_varying::step, cb_perform::test, and cb_perform_varying::until.

Referenced by output_perform().

4152 {
4153  struct cb_perform_varying *v;
4154  struct cb_field *f;
4155  cb_tree next;
4156 
4157  if (l == NULL) {
4158  /* Perform body at the end */
4159  output_perform_once (p);
4160  return;
4161  }
4162 
4163  v = CB_PERFORM_VARYING (CB_VALUE (l));
4164  next = CB_CHAIN (l);
4165 
4166  output_line ("for (;;)");
4167  output_indent ("{");
4168 
4169  if (next && CB_PERFORM_VARYING (CB_VALUE (next))->name) {
4170  output_move (CB_PERFORM_VARYING (CB_VALUE (next))->from,
4171  CB_PERFORM_VARYING (CB_VALUE (next))->name);
4172  /* DEBUG */
4173  if (current_prog->flag_gen_debug) {
4174  f = CB_FIELD (cb_ref (CB_PERFORM_VARYING (CB_VALUE (next))->name));
4175  if (f->flag_field_debug) {
4176  output_stmt (cb_build_debug (cb_debug_name,
4177  (const char *)f->name, NULL));
4178  output_stmt (cb_build_debug (cb_debug_contents,
4179  NULL, CB_PERFORM_VARYING (CB_VALUE (next))->name));
4180  output_perform_call (f->debug_section,
4181  f->debug_section);
4182  }
4183  }
4184 
4185  }
4186 
4187  if (p->test == CB_AFTER) {
4188  output_perform_until (p, next);
4189  }
4190 
4191  /* DEBUG */
4192  if (current_prog->flag_gen_debug) {
4193  output_cond_debug (v->until);
4194  }
4195 
4196  output_prefix ();
4197  output ("if (");
4198  output_cond (v->until, 0);
4199  output (")\n");
4200  output_line (" break;");
4201 
4202  if (p->test == CB_BEFORE) {
4203  output_perform_until (p, next);
4204  }
4205 
4206  if (v->step) {
4207  output_stmt (v->step);
4208  }
4209 
4210  output_indent ("}");
4211 }
static void output_prefix ( void  )
static

References output_indent_level, and output_target.

Referenced by output_call(), output_cancel(), output_cond(), output_error_handler(), output_figurative(), output_file_initialization(), output_goto(), output_initialize_fp(), output_initialize_fp_bindec(), output_initialize_literal(), output_initialize_one(), output_initialize_uniform(), output_internal_function(), output_label_info(), output_line(), output_module_init(), output_param(), output_perform(), output_perform_until(), output_screen_init(), output_search_all(), output_search_whens(), output_stmt(), and output_trace_info().

442 {
443  int i;
444 
445  if (output_target) {
446  for (i = 0; i < output_indent_level; i++) {
447  fputc (' ', output_target);
448  }
449  }
450 }
static void output_screen_definition ( struct cb_field *  p)
static

References cb_field::children, COB_SCREEN_TYPE_ATTRIBUTE, COB_SCREEN_TYPE_FIELD, COB_SCREEN_TYPE_GROUP, COB_SCREEN_TYPE_VALUE, cb_field::count, cb_field::id, output_local(), cb_field::sister, cb_field::size, and cb_field::values.

Referenced by output_internal_function().

5303 {
5304  int type;
5305 
5306  if (p->sister) {
5307  output_screen_definition (p->sister);
5308  }
5309  if (p->children) {
5310  output_screen_definition (p->children);
5311  }
5312 
5313  type = (p->children ? COB_SCREEN_TYPE_GROUP :
5314  p->values ? COB_SCREEN_TYPE_VALUE :
5315  (p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
5316  if (type == COB_SCREEN_TYPE_FIELD || type == COB_SCREEN_TYPE_VALUE) {
5317  p->count++;
5318  }
5319 
5320  output_local ("static cob_screen\ts_%d;\n", p->id);
5321 }
static void output_screen_init ( struct cb_field *  p)
static

References cb_build_field_reference(), cb_field::children, COB_SCREEN_TYPE_ATTRIBUTE, COB_SCREEN_TYPE_FIELD, COB_SCREEN_TYPE_GROUP, COB_SCREEN_TYPE_VALUE, cb_field::id, cb_field::level, NULL, cb_field::occurs_min, output(), output_newline(), output_param(), output_prefix(), cb_field::screen_backg, cb_field::screen_column, cb_field::screen_flag, cb_field::screen_foreg, cb_field::screen_line, cb_field::screen_prompt, cb_field::sister, cb_field::size, and cb_field::values.

Referenced by output_internal_function().

5325 {
5326  int type;
5327 
5328  type = (p->children ? COB_SCREEN_TYPE_GROUP :
5329  p->values ? COB_SCREEN_TYPE_VALUE :
5330  (p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
5331  output_prefix ();
5332  output ("cob_set_screen (&s_%d, ", p->id);
5333 
5334  if (p->sister && p->sister->level != 1) {
5335  output ("&s_%d, ", p->sister->id);
5336  } else {
5337  output ("NULL, ");
5338  }
5339  if (type == COB_SCREEN_TYPE_GROUP) {
5340  output ("&s_%d, ", p->children->id);
5341  } else {
5342  output ("NULL, ");
5343  }
5344  output_newline ();
5345  output_prefix ();
5346  output ("\t\t ");
5347  if (type == COB_SCREEN_TYPE_FIELD) {
5348  output_param (cb_build_field_reference (p, NULL), -1);
5349  output (", ");
5350  } else {
5351  output ("NULL, ");
5352  }
5353  if (type == COB_SCREEN_TYPE_VALUE) {
5354  /* Need a field reference here */
5355  output_param (cb_build_field_reference (p, NULL), -1);
5356  output (", ");
5357  } else {
5358  output ("NULL, ");
5359  }
5360 
5361  if (p->screen_line) {
5362  output_param (p->screen_line, 0);
5363  output (", ");
5364  } else {
5365  output ("NULL, ");
5366  }
5367  output_newline ();
5368  output_prefix ();
5369  output ("\t\t ");
5370  if (p->screen_column) {
5371  output_param (p->screen_column, 0);
5372  output (", ");
5373  } else {
5374  output ("NULL, ");
5375  }
5376  if (p->screen_foreg) {
5377  output_param (p->screen_foreg, 0);
5378  output (", ");
5379  } else {
5380  output ("NULL, ");
5381  }
5382  if (p->screen_backg) {
5383  output_param (p->screen_backg, 0);
5384  output (", ");
5385  } else {
5386  output ("NULL, ");
5387  }
5388  output_newline ();
5389  output_prefix ();
5390  output ("\t\t ");
5391  if (p->screen_prompt) {
5392  output_param (p->screen_prompt, 0);
5393  output (", ");
5394  } else {
5395  output ("NULL, ");
5396  }
5397  output ("%d, %d, 0x%x);\n", type, p->occurs_min, p->screen_flag);
5398 
5399  if (p->children) {
5400  output_screen_init (p->children);
5401  }
5402  if (p->sister) {
5403  output_screen_init (p->sister);
5404  }
5405 }
static void output_search ( struct cb_search *  p)
static

References CB_IF, cb_search::end_stmt, cb_search::flag_all, output_search_all(), output_search_whens(), cb_search::table, cb_search::var, and cb_search::whens.

Referenced by output_stmt().

2989 {
2990  if (p->flag_all) {
2991  output_search_all (p->table, p->end_stmt,
2992  CB_IF (p->whens)->test, CB_IF (p->whens)->stmt1);
2993  } else {
2994  output_search_whens (p->table, p->var, p->end_stmt, p->whens);
2995  }
2996 }
static void output_search_all ( cb_tree  table,
cb_tree  stmt,
cb_tree  cond,
cb_tree  when 
)
static

References CB_VALUE, cb_field::index_list, cb_field::occurs_min, output(), output_cond(), output_indent(), output_integer(), output_line(), output_newline(), output_occurs(), output_prefix(), output_stmt(), and p.

Referenced by output_search().

2927 {
2928  struct cb_field *p;
2929  cb_tree idx;
2930 
2931  p = cb_code_field (table);
2932  idx = CB_VALUE (p->index_list);
2933  /* Header */
2934  output_indent ("{");
2935  output_line ("int ret;");
2936  output_line ("int head = %d - 1;", p->occurs_min);
2937  output_prefix ();
2938  output ("int tail = ");
2939  output_occurs (p);
2940  output (" + 1;\n");
2941 
2942  /* Start loop */
2943  output_line ("for (;;)");
2944  output_indent ("{");
2945 
2946  /* End test */
2947  output_line ("if (head >= tail - 1)");
2948  output_indent ("{");
2949  output_line ("/* Table end */");
2950  if (stmt) {
2951  output_stmt (stmt);
2952  } else {
2953  output_line ("break;");
2954  }
2955  output_indent ("}");
2956 
2957  /* Next index */
2958  output_prefix ();
2959  output_integer (idx);
2960  output (" = (head + tail) / 2;\n");
2961  output_newline ();
2962 
2963  /* WHEN test */
2964  output_line ("/* WHEN */");
2965  output_prefix ();
2966  output ("if (");
2967  output_cond (cond, 1);
2968  output (")\n");
2969  output_indent ("{");
2970  output_stmt (when);
2971  output_indent ("}");
2972 
2973  output_line ("if (ret < 0)");
2974  output_prefix ();
2975  output (" head = ");
2976  output_integer (idx);
2977  output (";\n");
2978  output_line ("else");
2979  output_prefix ();
2980  output (" tail = ");
2981  output_integer (idx);
2982  output (";\n");
2983  output_indent ("}");
2984  output_indent ("}");
2985 }
static void output_search_whens ( cb_tree  table,
cb_tree  var,
cb_tree  stmt,
cb_tree  whens 
)
static

References CB_CHAIN, cb_ref(), CB_VALUE, cb_field::index_list, NULL, output(), output_indent(), output_indent_level, output_integer(), output_line(), output_move(), output_newline(), output_occurs(), output_prefix(), output_stmt(), and p.

Referenced by output_search().

2869 {
2870  cb_tree l;
2871  struct cb_field *p;
2872  cb_tree idx;
2873 
2874  idx = NULL;
2875  p = cb_code_field (table);
2876  /* Determine the index to use */
2877  if (var) {
2878  for (l = p->index_list; l; l = CB_CHAIN (l)) {
2879  if (cb_ref (CB_VALUE (l)) == cb_ref (var)) {
2880  idx = var;
2881  }
2882  }
2883  }
2884  if (!idx) {
2885  idx = CB_VALUE (p->index_list);
2886  }
2887 
2888  /* Start loop */
2889  output_line ("for (;;) {");
2890  output_indent_level += 2;
2891 
2892  /* End test */
2893  output_prefix ();
2894  output ("if (");
2895  output_integer (idx);
2896  output (" > ");
2897  output_occurs (p);
2898  output (")\n");
2899  output_indent ("{");
2900  output_line ("/* Table end */");
2901  if (stmt) {
2902  output_stmt (stmt);
2903  } else {
2904  output_line ("break;");
2905  }
2906  output_indent ("}");
2907 
2908  /* WHEN test */
2909  output_stmt (whens);
2910 
2911  /* Iteration */
2912  output_newline ();
2913  output_prefix ();
2914  output_integer (idx);
2915  output ("++;\n");
2916  if (var && var != idx) {
2917  output_move (idx, var);
2918  }
2919  output_line ("/* Iterate */");
2920  /* End loop */
2921  output_indent_level -= 2;
2922  output_line ("}");
2923 }
static void output_section_info ( struct cb_label *  lp)
static

References CB_PREFIX_STRING, cb_standard_error_handler, CB_TREE, cb_label::flag_dummy_exit, cb_label::flag_dummy_paragraph, cb_label::flag_dummy_section, cb_label::flag_entry, cb_label::flag_section, lookup_string(), cb_label::orig_name, output_line(), and string_buffer.

Referenced by output_stmt().

4474 {
4475  if (CB_TREE (lp) == cb_standard_error_handler) {
4476  return;
4477  }
4478  if (lp->flag_dummy_exit) {
4479  return;
4480  }
4481  if (lp->flag_section) {
4482  if (!lp->flag_dummy_section) {
4483  sprintf (string_buffer, "Section: %s", lp->orig_name);
4484  } else {
4485  sprintf (string_buffer, "Section: (None)");
4486  }
4487  } else if (lp->flag_entry) {
4488  sprintf (string_buffer, "Entry: %s", lp->orig_name);
4489  } else {
4490  if (!lp->flag_dummy_paragraph) {
4491  sprintf (string_buffer, "Paragraph: %s", lp->orig_name);
4492  } else {
4493  sprintf (string_buffer, "Paragraph: (None)");
4494  }
4495  }
4496  if (CB_TREE (lp)->source_file) {
4497  output_line ("cob_trace_section (%s%d, %s%d, %d);",
4498  CB_PREFIX_STRING,
4499  lookup_string (string_buffer),
4500  CB_PREFIX_STRING,
4501  lookup_string (CB_TREE (lp)->source_file),
4502  CB_TREE (lp)->source_line);
4503  } else {
4504  output_line ("cob_trace_section (%s%d, NULL, %d);",
4505  CB_PREFIX_STRING,
4506  lookup_string (string_buffer),
4507  CB_TREE (lp)->source_line);
4508  }
4509 }
static void output_set_attribute ( const struct cb_field *  f,
const int  val_on,
const int  val_off 
)
static

References cb_field::id, and output_line().

Referenced by output_stmt().

3794 {
3795  if (val_on) {
3796  output_line ("s_%d.attr |= 0x%x;", f->id, val_on);
3797  }
3798  if (val_off) {
3799  output_line ("s_%d.attr &= ~0x%x;", f->id, val_off);
3800  }
3801 }
static void output_size ( const cb_tree  x)
static

References _, CB_FIELD, cb_field_subordinate(), CB_LITERAL, CB_PREFIX_FIELD, CB_REFERENCE, CB_TAG_CONST, CB_TAG_FIELD, CB_TAG_LITERAL, CB_TAG_REFERENCE, CB_TREE_TAG, chk_field_variable_size(), COBC_ABORT, cobc_abort_pr(), cb_field::depending, cb_field::flag_any_length, cb_field::flag_no_field, cb_field::flag_odo_item, cb_reference::flag_receiving, cb_field::id, cb_reference::length, cb_field::occurs_max, cb_field::offset, cb_reference::offset, output(), output_index(), output_integer(), p, cb_field::parent, cb_field::redefines, cb_literal::sign, cb_field::sister, cb_literal::size, cb_field::size, and cb_reference::value.

Referenced by codegen(), output_call(), output_field(), output_figurative(), output_initialize_literal(), output_initialize_uniform(), output_internal_function(), and output_param().

772 {
773  struct cb_literal *l;
774  struct cb_reference *r;
775  struct cb_field *f;
776  struct cb_field *p;
777  struct cb_field *q;
778 
779  switch (CB_TREE_TAG (x)) {
780  case CB_TAG_CONST:
781  output ("1");
782  break;
783  case CB_TAG_LITERAL:
784  l = CB_LITERAL (x);
785  output ("%d", (int)(l->size + ((l->sign != 0) ? 1 : 0)));
786  break;
787  case CB_TAG_REFERENCE:
788  r = CB_REFERENCE (x);
789  f = CB_FIELD (r->value);
790  if (f->flag_no_field) {
791  output ("0");
792  break;
793  }
794  if (r->length) {
795  output_integer (r->length);
796  } else if (r->offset) {
797  if (f->flag_any_length) {
798  output ("%s%d.size - ", CB_PREFIX_FIELD, f->id);
799  } else {
800  output ("%d - ", f->size);
801  }
802  output_index (r->offset);
803  } else {
804  p = chk_field_variable_size (f);
805  q = f;
806 
807 again:
808  if (!cb_flag_odoslide && p && p->flag_odo_item) {
809  q = p;
810  output ("%d", p->size * p->occurs_max);
811  } else if (p && (!r->flag_receiving ||
812  !cb_field_subordinate (cb_code_field (p->depending),
813  q))) {
814  if (p->offset - q->offset > 0) {
815  output ("%d + ", p->offset - q->offset);
816  }
817  if (p->size != 1) {
818  output ("%d * ", p->size);
819  }
820  output_integer (p->depending);
821  q = p;
822  } else {
823  output ("%d", q->size);
824  }
825 
826  for (; q != f; q = q->parent) {
827  if (q->sister && !q->sister->redefines) {
828  q = q->sister;
829  p = q->depending ? q : chk_field_variable_size (q);
830  output (" + ");
831  goto again;
832  }
833  }
834  }
835  break;
836  case CB_TAG_FIELD:
837  output ("(int)%s%d.size", CB_PREFIX_FIELD, CB_FIELD (x)->id);
838  break;
839  default:
840  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
841  COBC_ABORT ();
842  }
843 }
static void output_stmt ( cb_tree  x)
static

References _, cb_program::all_procedure, cb_statement::body, cb_cast::cast_type, CB_ALTER, CB_ASSIGN, cb_build_debug(), CB_CALL, CB_CANCEL, CB_CAST, CB_CAST_ADDRESS, CB_CAST_PROGRAM_POINTER, CB_CHAIN, CB_CLASS_POINTER, CB_DEBUG, CB_DEBUG_CALL, cb_debug_contents, cb_debug_line, cb_debug_name, CB_DIRECT, cb_error_node, CB_EXCEPTION_CODE, CB_EXCEPTION_ENABLE, CB_FILE, CB_GOTO, cb_id, CB_IF, CB_INITIALIZE, CB_LABEL, cb_null, CB_PERFORM, CB_PREFIX_LABEL, CB_PREFIX_STRING, CB_REFERENCE, CB_SEARCH, CB_SET_ATTR, cb_space, CB_STATEMENT, CB_TAG_ALTER, CB_TAG_ASSIGN, CB_TAG_CALL, CB_TAG_CANCEL, CB_TAG_CAST, CB_TAG_CONTINUE, CB_TAG_DEBUG, CB_TAG_DEBUG_CALL, CB_TAG_DIRECT, CB_TAG_FUNCALL, CB_TAG_GOTO, CB_TAG_IF, CB_TAG_INITIALIZE, CB_TAG_LABEL, CB_TAG_LIST, CB_TAG_PERFORM, CB_TAG_REFERENCE, CB_TAG_SEARCH, CB_TAG_SET_ATTR, CB_TAG_STATEMENT, CB_TREE_CLASS, CB_TREE_TAG, CB_VALUE, cb_zero, COB_EC_I_O, COBC_ABORT, cobc_abort_pr(), cb_statement::debug_check, cb_label::debug_section, cb_label::exit_label, cb_statement::file, cb_label::flag_alter, cb_label::flag_begin, cb_statement::flag_callback, cb_program::flag_debugging, cb_label::flag_debugging_mode, cb_program::flag_gen_debug, cb_statement::flag_in_debug, cb_label::flag_is_debug_sect, cb_label::flag_real_label, cb_label::flag_section, cb_label::flag_skip_label, cb_set_attr::fld, gen_if_level, gen_nested_tab, cb_statement::handler1, cb_statement::handler2, cb_statement::handler_id, cb_label::id, inside_check, inside_stack, cb_if::is_if, last_line, last_segment, line, lookup_string(), cb_label::name, cb_statement::name, need_save_exception, cb_program::nested_prog_list, cb_para_label::next, NULL, cb_statement::null_check, output(), output_alter(), output_alter_check(), output_call(), output_cancel(), output_cond(), output_data(), output_ferror_stmt(), output_funcall(), output_goto(), output_indent(), output_indent_level, output_initialize(), output_integer(), output_label_info(), output_line(), output_move(), output_newline(), output_param(), output_perform(), output_perform_call(), output_prefix(), output_search(), output_section_info(), output_set_attribute(), output_trace_info(), p, cb_para_label::para, cb_label::para_label, cb_label::segment, cb_tree_common::source_file, cb_tree_common::source_line, stack_id, cb_if::stmt1, cb_if::stmt2, cb_if::test, unlikely, cb_cast::val, cb_assign::val, cb_set_attr::val_off, cb_set_attr::val_on, value, and cb_assign::var.

Referenced by output_alter(), output_call(), output_cond(), output_cond_debug(), output_error_handler(), output_ferror_stmt(), output_file_error(), output_funcall_debug(), output_goto(), output_goto_1(), output_initial_values(), output_internal_function(), output_move(), output_param(), output_perform(), output_perform_call(), output_perform_once(), output_perform_until(), output_search_all(), and output_search_whens().

4609 {
4610  struct cb_statement *p;
4611  struct cb_label *lp;
4612  struct cb_assign *ap;
4613  struct cb_if *ip;
4614  struct cb_para_label *pal;
4615  struct cb_set_attr *sap;
4616 #ifdef COB_NON_ALIGNED
4617  struct cb_cast *cp;
4618 #endif
4619  size_t size;
4620  int code;
4621 
4622  stack_id = 0;
4623  if (x == NULL) {
4624  output_line (";");
4625  return;
4626  }
4627  if (unlikely(x == cb_error_node)) {
4628  cobc_abort_pr (_("Unexpected error_node parameter"));
4629  COBC_ABORT ();
4630  }
4631 
4632  if (inside_check != 0) {
4633  if (inside_stack[inside_check - 1] != 0) {
4634  inside_stack[inside_check - 1] = 0;
4635  output (",\n");
4636  }
4637  }
4638 
4639  switch (CB_TREE_TAG (x)) {
4640  case CB_TAG_STATEMENT:
4641  p = CB_STATEMENT (x);
4642  /* Output source location as a comment */
4643  if (p->name) {
4644  output_newline ();
4645  output_line ("/* Line: %-10d: %-19.19s: %s */",
4646  x->source_line, p->name, x->source_file);
4647  }
4648  if (x->source_file) {
4649  if (cb_flag_source_location) {
4650  /* Output source location as code */
4651  output_trace_info (x, p);
4652  }
4653  if (current_prog->flag_gen_debug &&
4654  !p->flag_in_debug) {
4655  output_prefix ();
4656  output ("memcpy (");
4657  output_data (cb_debug_line);
4658  output (", \"%6d\", 6);\n", x->source_line);
4659  }
4660  last_line = x->source_line;
4661  }
4662 
4663 #if 0 /* RXWRXW - Exception */
4664  if (p->handler1 || p->handler2 ||
4665  (p->file && CB_EXCEPTION_ENABLE (COB_EC_I_O))) {
4666 #else
4667  if (!p->file && (p->handler1 || p->handler2)) {
4668 #endif
4669  output_line ("cob_glob_ptr->cob_exception_code = 0;");
4670  }
4671 
4672  if (p->null_check) {
4673  output_stmt (p->null_check);
4674  }
4675 
4676  if (p->body) {
4677  output_stmt (p->body);
4678  }
4679 
4680  /* Output field debugging statements */
4681  if (current_prog->flag_gen_debug && p->debug_check) {
4682  output_stmt (p->debug_check);
4683  }
4684 
4685  /* Special debugging callback for START / DELETE */
4686  /* Must be done immediately after I/O and before */
4687  /* status check */
4688  if (current_prog->flag_gen_debug && p->file && p->flag_callback) {
4689  output_line ("save_exception_code = cob_glob_ptr->cob_exception_code;");
4690  output_stmt (cb_build_debug (cb_debug_name,
4691  CB_FILE(p->file)->name, NULL));
4692  output_move (cb_space, cb_debug_contents);
4693  output_perform_call (CB_FILE(p->file)->debug_section,
4694  CB_FILE(p->file)->debug_section);
4695  output_line ("cob_glob_ptr->cob_exception_code = save_exception_code;");
4696  need_save_exception = 1;
4697  }
4698 
4699  if (p->handler1 || p->handler2 ||
4700  (p->file && CB_EXCEPTION_ENABLE (COB_EC_I_O))) {
4701  code = CB_EXCEPTION_CODE (p->handler_id);
4702  if (p->file) {
4703  output_ferror_stmt (p, code);
4704  } else {
4705  if (p->handler1) {
4706  if ((code & 0x00ff) == 0) {
4707  output_line ("if (unlikely((cob_glob_ptr->cob_exception_code & 0xff00) == 0x%04x))",
4708  code);
4709  } else {
4710  output_line ("if (unlikely(cob_glob_ptr->cob_exception_code == 0x%04x))", code);
4711  }
4712  output_indent ("{");
4713  output_stmt (p->handler1);
4714  output_indent ("}");
4715  if (p->handler2) {
4716  output_line ("else");
4717  }
4718  }
4719  if (p->handler2) {
4720  if (p->handler1 == NULL) {
4721  output_line ("if (!cob_glob_ptr->cob_exception_code)");
4722  }
4723  output_indent ("{");
4724  output_stmt (p->handler2);
4725  output_indent ("}");
4726  }
4727  }
4728  }
4729  break;
4730  case CB_TAG_LABEL:
4731  lp = CB_LABEL (x);
4732  if (lp->flag_skip_label) {
4733  break;
4734  }
4735  output_label_info (x, lp);
4736  if (lp->flag_section) {
4737  for (pal = lp->para_label; pal; pal = pal->next) {
4738  if (pal->para->segment > 49 &&
4739  pal->para->flag_alter) {
4740  output_line ("label_%s%d = 0;",
4741  CB_PREFIX_LABEL, pal->para->id);
4742  }
4743  }
4744  last_segment = lp->segment;
4745  last_section = lp;
4746  }
4747  if (lp->flag_begin) {
4748  output_line ("%s%d:;", CB_PREFIX_LABEL, lp->id);
4749  }
4750 
4751  /* Check for runtime debug flag */
4752  if (current_prog->flag_debugging && lp->flag_is_debug_sect) {
4753  output_line ("if (!cob_debugging_mode)");
4754  output_line ("\tgoto %s%d;",
4755  CB_PREFIX_LABEL, CB_LABEL (lp->exit_label)->id);
4756  }
4757 
4758  if (cb_flag_trace) {
4759  output_section_info (lp);
4760  }
4761 
4762  /* Check procedure debugging */
4763  if (current_prog->flag_gen_debug && lp->flag_real_label) {
4764  output_stmt (cb_build_debug (cb_debug_name,
4765  (const char *)lp->name, NULL));
4766  if (current_prog->all_procedure) {
4767  output_perform_call (current_prog->all_procedure,
4768  current_prog->all_procedure);
4769  } else if (lp->flag_debugging_mode) {
4770  output_perform_call (lp->debug_section,
4771  lp->debug_section);
4772  }
4773  }
4774 
4775  /* Check ALTER processing */
4776  if (lp->flag_alter) {
4777  output_alter_check (lp);
4778  }
4779 
4780  break;
4781  case CB_TAG_FUNCALL:
4782  output_prefix ();
4783  output_funcall (x);
4784  if (inside_check == 0) {
4785  output (";\n");
4786  } else {
4787  inside_stack[inside_check - 1] = 1;
4788  }
4789  break;
4790  case CB_TAG_ASSIGN:
4791  ap = CB_ASSIGN (x);
4792 #ifdef COB_NON_ALIGNED
4793  /* Nonaligned */
4794  if (CB_TREE_CLASS (ap->var) == CB_CLASS_POINTER ||
4795  CB_TREE_CLASS (ap->val) == CB_CLASS_POINTER) {
4796  /* Pointer assignment */
4797  output_indent ("{");
4798  output_line ("void *temp_ptr;");
4799 
4800  /* temp_ptr = source address; */
4801  output_prefix ();
4802  if (ap->val == cb_null || ap->val == cb_zero) {
4803  /* MOVE NULL ... */
4804  output ("temp_ptr = 0;\n");
4805  } else if (CB_TREE_TAG (ap->val) == CB_TAG_CAST) {
4806  /* MOVE ADDRESS OF val ... */
4807  cp = CB_CAST (ap->val);
4808  output ("temp_ptr = ");
4809  switch (cp->cast_type) {
4810  case CB_CAST_ADDRESS:
4811  output_data (cp->val);
4812  break;
4813  case CB_CAST_PROGRAM_POINTER:
4814  output ("cob_call_field (");
4815  output_param (ap->val, -1);
4816  if (current_prog->nested_prog_list) {
4817  gen_nested_tab = 1;
4818  output (", cob_nest_tab, 0, %d)",
4819  cb_fold_call);
4820  } else {
4821  output (", NULL, 0, %d)",
4822  cb_fold_call);
4823  }
4824  break;
4825  default:
4826  cobc_abort_pr (_("Unexpected cast type %d"),
4827  cp->cast_type);
4828  COBC_ABORT ();
4829  }
4830  output (";\n");
4831  } else {
4832  /* MOVE val ... */
4833  output ("memcpy(&temp_ptr, ");
4834  output_data (ap->val);
4835  output (", sizeof(temp_ptr));\n");
4836  }
4837 
4838  /* Destination address = temp_ptr; */
4839  output_prefix ();
4840  if (CB_TREE_TAG (ap->var) == CB_TAG_CAST) {
4841  /* SET ADDRESS OF var ... */
4842  cp = CB_CAST (ap->var);
4843  if (cp->cast_type != CB_CAST_ADDRESS) {
4844  cobc_abort_pr (_("Unexpected tree type %d"),
4845  cp->cast_type);
4846  COBC_ABORT ();
4847  }
4848  output_data (cp->val);
4849  output (" = temp_ptr;\n");
4850  } else {
4851  /* MOVE ... TO var */
4852  output ("memcpy(");
4853  output_data (ap->var);
4854  output (", &temp_ptr, sizeof(temp_ptr));\n");
4855  }
4856 
4857  output_indent ("}");
4858  } else {
4859  /* Numeric assignment */
4860  output_prefix ();
4861  output_integer (ap->var);
4862  output (" = ");
4863  output_integer (ap->val);
4864  if (inside_check == 0) {
4865  output (";\n");
4866  } else {
4867  inside_stack[inside_check - 1] = 1;
4868  }
4869  }
4870 #else /* Nonaligned */
4871  output_prefix ();
4872  output_integer (ap->var);
4873  output (" = ");
4874  output_integer (ap->val);
4875  if (inside_check == 0) {
4876  output (";\n");
4877  } else {
4878  inside_stack[inside_check - 1] = 1;
4879  }
4880 #endif /* Nonaligned */
4881  break;
4882  case CB_TAG_INITIALIZE:
4883  output_initialize (CB_INITIALIZE (x));
4884  break;
4885  case CB_TAG_SEARCH:
4886  output_search (CB_SEARCH (x));
4887  break;
4888  case CB_TAG_CALL:
4889  output_call (CB_CALL (x));
4890  break;
4891  case CB_TAG_GOTO:
4892  output_goto (CB_GOTO (x));
4893  break;
4894  case CB_TAG_CANCEL:
4895  output_cancel (CB_CANCEL (x));
4896  break;
4897  case CB_TAG_SET_ATTR:
4898  sap = CB_SET_ATTR (x);
4899  output_set_attribute (sap->fld, sap->val_on, sap->val_off);
4900  break;
4901  case CB_TAG_ALTER:
4902  output_alter (CB_ALTER (x));
4903  break;
4904  case CB_TAG_IF:
4905  ip = CB_IF (x);
4906  if (!ip->is_if) {
4907  output_newline ();
4908  output_line ("/* WHEN */");
4909  output_newline ();
4910  }
4911  gen_if_level++;
4912  code = 0;
4913  output_prefix ();
4914  output ("if (");
4915  output_cond (ip->test, 0);
4916  output (")\n");
4917  output_line ("{");
4918  output_indent_level += 2;
4919  if (ip->stmt1) {
4920  output_stmt (ip->stmt1);
4921  } else {
4922  output_line ("; /* Nothing */");
4923  }
4924  if (gen_if_level > cb_if_cutoff) {
4925  if (ip->stmt2) {
4926  code = cb_id++;
4927  output_line ("goto l_%d;", code);
4928  }
4929  }
4930  output_indent_level -= 2;
4931  output_line ("}");
4932  if (ip->stmt2) {
4933  if (gen_if_level <= cb_if_cutoff) {
4934  output_line ("else");
4935  output_line ("{");
4936  output_indent_level += 2;
4937  }
4938  if (ip->is_if) {
4939  output_line ("/* ELSE */");
4940  } else {
4941  output_line ("/* WHEN */");
4942  }
4943  output_stmt (ip->stmt2);
4944  if (gen_if_level <= cb_if_cutoff) {
4945  output_indent_level -= 2;
4946  output_line ("}");
4947  } else {
4948  output_line ("l_%d:;", code);
4949  }
4950  }
4951  gen_if_level--;
4952  break;
4953  case CB_TAG_PERFORM:
4954  output_perform (CB_PERFORM (x));
4955  break;
4956  case CB_TAG_CONTINUE:
4957  output_prefix ();
4958  output (";\n");
4959  break;
4960  case CB_TAG_LIST:
4961  if (cb_flag_extra_brace) {
4962  output_indent ("{");
4963  }
4964  for (; x; x = CB_CHAIN (x)) {
4965  output_stmt (CB_VALUE (x));
4966  }
4967  if (cb_flag_extra_brace) {
4968  output_indent ("}");
4969  }
4970  break;
4971  case CB_TAG_REFERENCE:
4972  output_stmt (CB_REFERENCE(x)->value);
4973  break;
4974  case CB_TAG_DIRECT:
4975  if (CB_DIRECT (x)->flag_is_direct) {
4976  if (CB_DIRECT (x)->flag_new_line) {
4977  output_newline ();
4978  }
4979  output_line ("%s", (const char *)(CB_DIRECT (x)->line));
4980  } else {
4981  output_newline ();
4982  output_line ("/* %s */", (const char *)(CB_DIRECT (x)->line));
4983  }
4984  break;
4985  case CB_TAG_DEBUG:
4986  if (!current_prog->flag_gen_debug) {
4987  break;
4988  }
4989  output_prefix ();
4990  size = cb_code_field (CB_DEBUG(x)->target)->size;
4991  if (CB_DEBUG(x)->value) {
4992  if (size <= CB_DEBUG(x)->size) {
4993  output ("memcpy (");
4994  output_data (CB_DEBUG(x)->target);
4995  output (", %s%d, %d);\n", CB_PREFIX_STRING,
4996  lookup_string (CB_DEBUG(x)->value),
4997  (int)size);
4998  } else {
4999  output ("memcpy (");
5000  output_data (CB_DEBUG(x)->target);
5001  output (", %s%d, %d);\n", CB_PREFIX_STRING,
5002  lookup_string (CB_DEBUG(x)->value),
5003  (int)CB_DEBUG(x)->size);
5004  output_prefix ();
5005  output ("memset (");
5006  output_data (CB_DEBUG(x)->target);
5007  code = (int)(size - CB_DEBUG(x)->size);
5008  output (" + %d, ' ', %d);\n",
5009  (int)CB_DEBUG(x)->size, code);
5010 
5011  }
5012  } else {
5013  if (size <= CB_DEBUG(x)->size) {
5014  output ("memcpy (");
5015  output_data (CB_DEBUG(x)->target);
5016  output (", ");
5017  output_data (CB_DEBUG(x)->fld);
5018  output (", %d);\n", (int)size);
5019  } else {
5020  output ("memcpy (");
5021  output_data (CB_DEBUG(x)->target);
5022  output (", ");
5023  output_data (CB_DEBUG(x)->fld);
5024  output (", %d);\n", (int)CB_DEBUG(x)->size);
5025  output_prefix ();
5026  output ("memset (");
5027  output_data (CB_DEBUG(x)->target);
5028  code = (int)(size - CB_DEBUG(x)->size);
5029  output (" + %d, ' ', %d);\n",
5030  (int)CB_DEBUG(x)->size, code);
5031  }
5032  }
5033  break;
5034  case CB_TAG_DEBUG_CALL:
5035  output_perform_call (CB_DEBUG_CALL(x)->target,
5036  CB_DEBUG_CALL(x)->target);
5037  break;
5038  default:
5039  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
5040  COBC_ABORT ();
5041  }
5042 }
static void output_storage ( const char *  fmt,
  ... 
)
static

References cb_storage_file.

Referenced by codegen(), and output_file_allocation().

516 {
517  va_list ap;
518 
519  if (cb_storage_file) {
520  va_start (ap, fmt);
521  vfprintf (cb_storage_file, fmt, ap);
522  va_end (ap);
523  }
524 }
static void output_string ( const unsigned char *  s,
const int  size,
const cob_u32_t  llit 
)
static

References output().

Referenced by codegen(), output_call(), output_cancel(), output_data(), output_initialize_literal(), output_initialize_one(), and output_param().

490 {
491  int i;
492  int c;
493 
494  if (!s) {
495  output ("NULL");
496  return;
497  }
498  output ("\"");
499  for (i = 0; i < size; i++) {
500  c = s[i];
501  if (!isprint (c)) {
502  output ("\\%03o", c);
503  } else if (c == '\"') {
504  output ("\\%c", c);
505  } else if ((c == '\\' || c == '?') && !llit) {
506  output ("\\%c", c);
507  } else {
508  output ("%c", c);
509  }
510  }
511  output ("\"");
512 }
static void output_trace_info ( cb_tree  x,
struct cb_statement *  p 
)
static

References CB_PREFIX_STRING, excp_current_paragraph, excp_current_section, lookup_string(), cb_statement::name, output(), output_prefix(), cb_tree_common::source_file, and cb_tree_common::source_line.

Referenced by output_stmt().

4513 {
4514  output_prefix ();
4515  output ("cob_set_location (%s%d, %d, ",
4516  CB_PREFIX_STRING,
4517  lookup_string (x->source_file),
4518  x->source_line);
4519  if (excp_current_section) {
4520  output ("%s%d, ",
4521  CB_PREFIX_STRING, lookup_string (excp_current_section));
4522  } else {
4523  output ("NULL, ");
4524  }
4525  if (excp_current_paragraph) {
4526  output ("%s%d, ",
4527  CB_PREFIX_STRING, lookup_string (excp_current_paragraph));
4528  } else {
4529  output ("NULL, ");
4530  }
4531  if (p->name) {
4532  output ("%s%d);\n",
4533  CB_PREFIX_STRING, lookup_string (p->name));
4534  } else {
4535  output ("NULL);\n");
4536  }
4537 }
static struct cb_field* real_field_founder ( const struct cb_field *  f)
staticread

References cb_field::parent, and cb_field::redefines.

Referenced by output_base(), and output_param().

542 {
543  const struct cb_field *ff;
544 
545  ff = f;
546  while (ff->parent) {
547  ff = ff->parent;
548  }
549  if (ff->redefines) {
550  return ff->redefines;
551  }
552  return (struct cb_field *)ff;
553 }
static struct string_list* string_list_reverse ( struct string_list *  p)
staticread

References string_list::next, next, NULL, and p.

Referenced by codegen().

285 {
286  struct string_list *next;
287  struct string_list *last;
288 
289  last = NULL;
290  for (; p; p = next) {
291  next = p->next;
292  p->next = last;
293  last = p;
294  }
295  return last;
296 }
static char* user_func_upper ( const char *  func)
static

References cb_encode_program_id(), and cob_u8_t.

Referenced by output_param().

881 {
882  unsigned char *s;
883  char *rets;
884 
885  rets = cb_encode_program_id (func);
886  for (s = (unsigned char *)rets; *s; s++) {
887  if (islower ((int)*s)) {
888  *s = (cob_u8_t)toupper ((int)*s);
889  }
890  }
891  return rets;
892 }

Variable Documentation

struct attr_list* attr_cache = NULL
static

Referenced by lookup_attr().

struct base_list* base_cache = NULL
static

Referenced by output_base().

struct call_list* call_cache = NULL
static

Referenced by lookup_call().

FILE* cb_local_file = NULL
static

Referenced by codegen(), and output_local().

struct cb_program* current_prog = NULL
static
const char* excp_current_paragraph = NULL
static

Referenced by codegen(), output_label_info(), and output_trace_info().

const char* excp_current_program_id = NULL
static

Referenced by codegen(), output_base(), output_internal_function(), and output_param().

const char* excp_current_section = NULL
static

Referenced by codegen(), output_label_info(), and output_trace_info().

struct field_list* field_cache = NULL
static

Referenced by output_param().

cob_u32_t field_iteration = 0
static

Referenced by output_call(), and output_data().

struct call_list* func_call_cache = NULL
static

Referenced by lookup_func_call().

unsigned int gen_alt_ebcdic = 0
static

Referenced by codegen(), and output_param().

unsigned int gen_custom = 0
static

Referenced by codegen(), output_file_allocation(), and output_param().

unsigned int gen_dynamic = 0
static

Referenced by codegen(), output_internal_function(), and output_param().

unsigned int gen_ebcdic_ascii = 0
static

Referenced by codegen(), output_file_allocation(), and output_param().

unsigned int gen_figurative = 0
static

Referenced by codegen(), and output_param().

unsigned int gen_full_ebcdic = 0
static

Referenced by codegen(), output_file_allocation(), and output_param().

int gen_if_level = 0
static

Referenced by codegen(), and output_stmt().

unsigned int gen_native = 0
static

Referenced by codegen(), output_file_allocation(), and output_param().

unsigned int gen_nested_tab = 0
static

Referenced by codegen(), output_call(), output_cancel(), output_integer(), output_long_integer(), and output_stmt().

struct base_list* globext_cache = NULL
static

Referenced by output_internal_function().

unsigned int i_counters[COB_MAX_SUBSCRIPTS]
static

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

unsigned int inside_check = 0
static

Referenced by codegen(), output_cond(), output_param(), and output_stmt().

unsigned int inside_stack[COB_INSIDE_SIZE]
static

Referenced by codegen(), output_cond(), output_param(), and output_stmt().

struct label_list* label_cache = NULL
static

Referenced by output_perform_call().

int last_line = 0
static

Referenced by codegen(), and output_stmt().

struct cb_label* last_section = NULL
static
int last_segment = 0
static

Referenced by codegen(), output_goto_1(), output_perform_call(), and output_stmt().

unsigned char* litbuff = NULL
static

Referenced by output_initialize_one().

struct literal_list* literal_cache = NULL
static

Referenced by lookup_literal().

int litsize = 0
static

Referenced by output_initialize_one().

struct base_list* local_base_cache = NULL
static

Referenced by output_base().

struct field_list* local_field_cache = NULL
static

Referenced by output_param().

int local_mem = 0
static

Referenced by codegen(), and output_internal_function().

int local_working_mem = 0
static

Referenced by codegen(), and output_internal_function().

int loop_counter = 0
static

Referenced by codegen(), and output_perform().

unsigned int need_save_exception = 0
static

Referenced by codegen(), and output_stmt().

unsigned int needs_exit_prog = 0
static

Referenced by codegen(), output_call(), output_goto(), and output_internal_function().

unsigned int needs_unifunc = 0
static

Referenced by codegen(), and output_call().

unsigned int nolitcast = 0
static

Referenced by output_funcall(), and output_param().

int non_nested_count = 0
static

Referenced by codegen(), output_internal_function(), and output_module_init().

int num_cob_fields = 0
static

Referenced by codegen(), and output_param().

int output_indent_level = 0
static

Referenced by codegen(), output_call(), output_goto(), output_indent(), output_param(), output_prefix(), output_search_whens(), and output_stmt().

FILE* output_target = NULL
static

Referenced by codegen(), lookup_literal(), output_internal_function(), output_line(), output_newline(), output_param(), and output_prefix().

int param_id = 0
static

Referenced by codegen(), output_func_1(), and output_param().

int progid = 0
static

Referenced by codegen(), and output_entry_function().

int screenptr = 0
static

Referenced by output_funcall(), and output_param().

int stack_id = 0
static

Referenced by codegen(), output_param(), and output_stmt().

char* string_buffer = NULL
static

Referenced by codegen(), output_internal_function(), and output_section_info().

struct string_list* string_cache = NULL
static

Referenced by lookup_string().

int string_id
static

Referenced by codegen(), and lookup_string().

struct system_table system_tab[]
static
int working_mem = 0
static

Referenced by codegen(), and output_internal_function().