GnuCOBOL  2.0
A free COBOL compiler
 All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Macros
Data Structures | Macros | Functions | Variables
common.c File Reference
#include "config.h"
#include "defaults.h"
#include "tarstamp.h"
#include <stdio.h>
#include <stdlib.h>
#include <stddef.h>
#include <stdarg.h>
#include <string.h>
#include <ctype.h>
#include <sys/types.h>
#include <math.h>
#include <time.h>
#include "libcob.h"
#include "coblocal.h"
#include "libcob/cobgetopt.h"
#include "exception.def"
Include dependency graph for common.c:

Data Structures

struct  cob_alloc_cache
 
struct  cob_external
 
struct  exit_handlerlist
 
struct  handlerlist
 

Macros

#define COB_LIB_EXPIMP
 
#define CB_IMSG_SIZE   24
 
#define CB_IVAL_SIZE   (80 - CB_IMSG_SIZE - 4)
 
#define CB_STRINGIFY(s)   #s
 
#define CB_XSTRINGIFY(s)   CB_STRINGIFY(s)
 
#define OC_C_VERSION_PRF   ""
 
#define OC_C_VERSION   "unknown"
 
#define COB_ERRBUF_SIZE   1024
 
#define COB_EXCEPTION(code, tag, name, critical)   name,
 
#define COB_EXCEPTION(code, tag, name, critical)   0x##code,
 
#define EXCEPTION_TAB_SIZE   sizeof(cob_exception_tab_code) / sizeof(int)
 
#define COB_SWITCH_MAX   16
 

Functions

static void cob_exit_common (void)
 
static void cob_terminate_routines (void)
 
static void cob_set_signal (void)
 
static int cob_get_sign_ascii (unsigned char *p)
 
static void cob_put_sign_ascii (unsigned char *p)
 
static int cob_get_sign_ebcdic (unsigned char *p)
 
static void cob_put_sign_ebcdic (unsigned char *p, const int sign)
 
static int common_cmpc (const unsigned char *s1, const unsigned int c, const size_t size, const unsigned char *col)
 
static int common_cmps (const unsigned char *s1, const unsigned char *s2, const size_t size, const unsigned char *col)
 
static int cob_cmp_all (cob_field *f1, cob_field *f2)
 
static int cob_cmp_alnum (cob_field *f1, cob_field *f2)
 
static int sort_compare (const void *data1, const void *data2)
 
static void cob_memcpy (cob_field *dst, const void *src, const size_t size)
 
static void cob_check_trace_file (void)
 
int cob_check_env_true (char *s)
 
int cob_check_env_false (char *s)
 
static void cob_rescan_env_vals (void)
 
int cob_get_exception_code (void)
 
const char * cob_get_exception_name (void)
 
void cob_set_exception (const int id)
 
void cob_accept_exception_status (cob_field *f)
 
void cob_accept_user_name (cob_field *f)
 
void * cob_malloc (const size_t size)
 
COB_INLINE void cob_free (void *mptr)
 
void * cob_fast_malloc (const size_t size)
 
char * cob_strdup (const char *p)
 
void * cob_cache_malloc (const size_t size)
 
void * cob_cache_realloc (void *ptr, const size_t size)
 
void cob_cache_free (void *ptr)
 
void cob_set_location (const char *sfile, const unsigned int sline, const char *csect, const char *cpara, const char *cstatement)
 
void cob_trace_section (const char *para, const char *source, const int line)
 
void cob_ready_trace (void)
 
void cob_reset_trace (void)
 
unsigned char * cob_get_pointer (const void *srcptr)
 
void * cob_get_prog_pointer (const void *srcptr)
 
void cob_field_to_string (const cob_field *f, void *str, const size_t maxsize)
 
void cob_stop_run (const int status)
 
void cob_runtime_error (const char *fmt,...)
 
void cob_fatal_error (const int fatal_error)
 
cob_global * cob_get_global_ptr (void)
 
void cob_module_enter (cob_module **module, cob_global **mglobal, const int auto_init)
 
void cob_module_leave (cob_module *module)
 
void * cob_save_func (cob_field **savefld, const int params, const int eparams,...)
 
void cob_restore_func (struct cob_func_loc *fl)
 
void cob_check_version (const char *prog, const char *packver, const int patchlev)
 
void cob_parameter_check (const char *funcname, const int numparms)
 
void cob_correct_numeric (cob_field *f)
 
static int cob_check_numdisp (const cob_field *f)
 
int cob_real_get_sign (cob_field *f)
 
void cob_real_put_sign (cob_field *f, const int sign)
 
void cob_reg_sighnd (void(*sighnd)(int))
 
int cob_get_switch (const int n)
 
void cob_set_switch (const int n, const int flag)
 
int cob_cmp (cob_field *f1, cob_field *f2)
 
int cob_is_omitted (const cob_field *f)
 
int cob_is_numeric (const cob_field *f)
 
int cob_is_alpha (const cob_field *f)
 
int cob_is_upper (const cob_field *f)
 
int cob_is_lower (const cob_field *f)
 
void cob_table_sort_init (const size_t nkeys, const unsigned char *collating_sequence)
 
void cob_table_sort_init_key (cob_field *field, const int flag, const unsigned int offset)
 
void cob_table_sort (cob_field *f, const int n)
 
void cob_check_based (const unsigned char *x, const char *name)
 
void cob_check_numeric (const cob_field *f, const char *name)
 
void cob_check_odo (const int i, const int min, const int max, const char *name)
 
void cob_check_subscript (const int i, const int min, const int max, const char *name)
 
void cob_check_ref_mod (const int offset, const int length, const int size, const char *name)
 
void * cob_external_addr (const char *exname, const int exlength)
 
void cob_accept_date (cob_field *f)
 
void cob_accept_date_yyyymmdd (cob_field *f)
 
void cob_accept_day (cob_field *f)
 
void cob_accept_day_yyyyddd (cob_field *f)
 
void cob_accept_day_of_week (cob_field *f)
 
void cob_accept_time (cob_field *f)
 
void cob_display_command_line (cob_field *f)
 
void cob_accept_command_line (cob_field *f)
 
void cob_display_arg_number (cob_field *f)
 
void cob_accept_arg_number (cob_field *f)
 
void cob_accept_arg_value (cob_field *f)
 
void cob_display_environment (const cob_field *f)
 
void cob_display_env_value (const cob_field *f)
 
void cob_set_environment (const cob_field *f1, const cob_field *f2)
 
void cob_get_environment (const cob_field *envname, cob_field *envval)
 
void cob_accept_environment (cob_field *f)
 
void cob_chain_setup (void *data, const size_t parm, const size_t size)
 
void cob_allocate (unsigned char **dataptr, cob_field *retptr, cob_field *sizefld, cob_field *initialize)
 
void cob_free_alloc (unsigned char **ptr1, unsigned char *ptr2)
 
char * cob_getenv (const char *name)
 
int cob_putenv (char *name)
 
static const char * cob_gettmpdir (void)
 
void cob_temp_name (char *filename, const char *ext)
 
void cob_incr_temp_iteration (void)
 
int cob_extern_init (void)
 
void * cob_command_line (int flags, int *pargc, char ***pargv, char ***penvp, char **pname)
 
int cob_tidy (void)
 
int cob_sys_exit_proc (const void *dispo, const void *pptr)
 
int cob_sys_error_proc (const void *dispo, const void *pptr)
 
int cob_sys_system (const void *cmdline)
 
int cob_sys_and (const void *p1, void *p2, const int length)
 
int cob_sys_or (const void *p1, void *p2, const int length)
 
int cob_sys_nor (const void *p1, void *p2, const int length)
 
int cob_sys_xor (const void *p1, void *p2, const int length)
 
int cob_sys_imp (const void *p1, void *p2, const int length)
 
int cob_sys_nimp (const void *p1, void *p2, const int length)
 
int cob_sys_eq (const void *p1, void *p2, const int length)
 
int cob_sys_not (void *p1, const int length)
 
int cob_sys_xf4 (void *p1, const void *p2)
 
int cob_sys_xf5 (const void *p1, void *p2)
 
int cob_sys_x91 (void *p1, const void *p2, void *p3)
 
int cob_sys_toupper (void *p1, const int length)
 
int cob_sys_tolower (void *p1, const int length)
 
int cob_sys_oc_nanosleep (const void *data)
 
int cob_sys_getpid (void)
 
int cob_sys_return_args (void *data)
 
int cob_sys_calledby (void *data)
 
int cob_sys_parameter_size (void *data)
 
int cob_sys_getopt_long_long (void *so, void *lo, void *idx, const int long_only, void *return_char, void *opt_val)
 
int cob_sys_sleep (const void *data)
 
int cob_sys_printable (void *p1,...)
 
int cob_sys_justify (void *p1,...)
 
void cob_set_locale (cob_field *locale, const int category)
 
char * cob_int_to_string (int i, char *number)
 
char * cob_int_to_formatted_bytestring (int i, char *number)
 
char * cob_strcat (char *str1, char *str2)
 
char * cob_strjoin (char **strarray, int size, char *separator)
 
char * cob_save_env_value (char *env_var, char *env_val)
 
static void var_print (const char *msg, const char *val, const char *default_val, const unsigned int format)
 
void print_runtime_env (void)
 
void print_version (void)
 
void print_info (void)
 
void cob_init (const int argc, char **argv)
 

Variables

static int cob_initialized = 0
 
static int cob_argc
 
static char ** cob_argv
 
static struct cob_alloc_cache * cob_alloc_base
 
static const char * cob_last_sfile
 
static cob_global * cobglobptr
 
static runtime_env * runtimeptr
 
static char * runtime_err_str
 
static const cob_field_attr const_alpha_attr
 
static char * cob_local_env
 
static char * cob_user_name
 
static int current_arg
 
static unsigned char * commlnptr
 
static size_t commlncnt
 
static size_t cob_local_env_size
 
static struct cob_external * basext
 
static size_t sort_nkeys
 
static cob_file_key * sort_keys
 
static const unsigned char * sort_collate
 
static const char * cob_current_program_id
 
static const char * cob_current_section
 
static const char * cob_current_paragraph
 
static const char * cob_source_file
 
static const char * cob_source_statement
 
static const char * cob_trace_env
 
static FILE * cob_trace_file
 
static unsigned int cob_source_line
 
static unsigned int cob_line_trace
 
static char * strbuff = NULL
 
static int cob_process_id = 0
 
static int cob_temp_iteration = 0
 
static void(* cob_ext_sighdl )(int) = NULL
 
static const char *const cob_exception_tab_name []
 
static const int cob_exception_tab_code []
 
static int cob_switch [COB_SWITCH_MAX]
 
static struct exit_handlerlist * exit_hdlrs
 
static struct handlerlist * hdlrs
 

Macro Definition Documentation

#define CB_IMSG_SIZE   24

Referenced by var_print().

#define CB_IVAL_SIZE   (80 - CB_IMSG_SIZE - 4)

Referenced by var_print().

#define CB_STRINGIFY (   s)    #s
#define CB_XSTRINGIFY (   s)    CB_STRINGIFY(s)
#define COB_ERRBUF_SIZE   1024

Referenced by cob_init().

#define COB_EXCEPTION (   code,
  tag,
  name,
  critical 
)    name,
#define COB_EXCEPTION (   code,
  tag,
  name,
  critical 
)    0x##code,
#define COB_LIB_EXPIMP
#define COB_SWITCH_MAX   16

Referenced by cob_get_switch(), cob_init(), and cob_set_switch().

#define EXCEPTION_TAB_SIZE   sizeof(cob_exception_tab_code) / sizeof(int)

Referenced by cob_get_exception_name().

#define OC_C_VERSION   "unknown"

Referenced by print_info().

#define OC_C_VERSION_PRF   ""

Referenced by print_info().

Function Documentation

void cob_accept_arg_number ( cob_field *  f)

References cob_field::attr, cob_argc, COB_ATTR_INIT, cob_move(), COB_TYPE_NUMERIC_BINARY, cob_field::data, NULL, and cob_field::size.

2590 {
2591  int n;
2592  cob_field_attr attr;
2593  cob_field temp;
2594 
2595  n = cob_argc - 1;
2596  temp.size = 4;
2597  temp.data = (unsigned char *)&n;
2598  temp.attr = &attr;
2599  COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL);
2600  cob_move (&temp, f);
2601 }
void cob_accept_arg_value ( cob_field *  f)

References cob_argc, cob_argv, COB_EC_IMP_ACCEPT, cob_memcpy(), cob_set_exception(), and current_arg.

2605 {
2606  if (current_arg >= cob_argc) {
2607  cob_set_exception (COB_EC_IMP_ACCEPT);
2608  return;
2609  }
2610  cob_memcpy (f, cob_argv[current_arg],
2611  strlen (cob_argv[current_arg]));
2612  current_arg++;
2613 }
void cob_accept_command_line ( cob_field *  f)

References cob_argc, cob_argv, cob_free(), cob_malloc(), cob_memcpy(), commlncnt, commlnptr, and cob_field::size.

2526 {
2527  char *buff;
2528  size_t i;
2529  size_t size;
2530  size_t len;
2531 
2532  if (commlncnt) {
2533  cob_memcpy (f, commlnptr, commlncnt);
2534  return;
2535  }
2536 
2537  if (cob_argc <= 1) {
2538  cob_memcpy (f, " ", (size_t)1);
2539  return;
2540  }
2541 
2542  size = 0;
2543  for (i = 1; i < (size_t)cob_argc; ++i) {
2544  size += (strlen (cob_argv[i]) + 1);
2545  if (size > f->size) {
2546  break;
2547  }
2548  }
2549  buff = cob_malloc (size);
2550  buff[0] = ' ';
2551  size = 0;
2552  for (i = 1; i < (size_t)cob_argc; ++i) {
2553  len = strlen (cob_argv[i]);
2554  memcpy (buff + size, cob_argv[i], len);
2555  size += len;
2556  if (i != (size_t)cob_argc - 1U) {
2557  buff[size++] = ' ';
2558  }
2559  if (size > f->size) {
2560  break;
2561  }
2562  }
2563  cob_memcpy (f, buff, size);
2564  cob_free (buff);
2565 }
void cob_accept_date ( cob_field *  f)

References cob_memcpy(), and NULL.

2414 {
2415  time_t t;
2416  char s[8];
2417 
2418  t = time (NULL);
2419  strftime (s, (size_t)7, "%y%m%d", localtime (&t));
2420  cob_memcpy (f, s, (size_t)6);
2421 }
void cob_accept_date_yyyymmdd ( cob_field *  f)

References cob_memcpy(), and NULL.

2425 {
2426  time_t t;
2427  char s[12];
2428 
2429  t = time (NULL);
2430  strftime (s, (size_t)9, "%Y%m%d", localtime (&t));
2431  cob_memcpy (f, s, (size_t)8);
2432 }
void cob_accept_day ( cob_field *  f)

References cob_memcpy(), and NULL.

2436 {
2437  time_t t;
2438  char s[8];
2439 
2440  t = time (NULL);
2441  strftime (s, (size_t)6, "%y%j", localtime (&t));
2442  cob_memcpy (f, s, (size_t)5);
2443 }
void cob_accept_day_of_week ( cob_field *  f)

References cob_memcpy(), and NULL.

2458 {
2459  struct tm *tm;
2460  time_t t;
2461  unsigned char s[4];
2462 
2463  t = time (NULL);
2464  tm = localtime (&t);
2465  if (tm->tm_wday == 0) {
2466  s[0] = (unsigned char)'7';
2467  } else {
2468  s[0] = (unsigned char)(tm->tm_wday + '0');
2469  }
2470  cob_memcpy (f, s, (size_t)1);
2471 }
void cob_accept_day_yyyyddd ( cob_field *  f)

References cob_memcpy(), and NULL.

2447 {
2448  time_t t;
2449  char s[12];
2450 
2451  t = time (NULL);
2452  strftime (s, (size_t)8, "%Y%j", localtime (&t));
2453  cob_memcpy (f, s, (size_t)7);
2454 }
void cob_accept_environment ( cob_field *  f)

References COB_EC_IMP_ACCEPT, cob_local_env, cob_memcpy(), cob_set_exception(), NULL, and p.

2715 {
2716  const char *p = NULL;
2717 
2718  if (cob_local_env) {
2719  p = getenv (cob_local_env);
2720  }
2721  if (!p) {
2722  cob_set_exception (COB_EC_IMP_ACCEPT);
2723  p = " ";
2724  }
2725  cob_memcpy (f, p, strlen (p));
2726 }
void cob_accept_exception_status ( cob_field *  f)

References __cob_global::cob_exception_code, and cob_set_int().

1106 {
1107  cob_set_int (f, cobglobptr->cob_exception_code);
1108 }
void cob_accept_time ( cob_field *  f)

References cob_memcpy(), and NULL.

2475 {
2476 #ifdef _WIN32
2477  SYSTEMTIME syst;
2478 #else
2479  struct tm *tlt;
2480  time_t t;
2481 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
2482  struct timeval tmv;
2483  char buff2[8];
2484 #endif
2485 #endif
2486  char s[12];
2487 
2488 #ifdef _WIN32
2489  GetLocalTime (&syst);
2490  sprintf (s, "%2.2d%2.2d%2.2d%2.2d", syst.wHour, syst.wMinute,
2491  syst.wSecond, syst.wMilliseconds / 10);
2492 #else
2493 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
2494  gettimeofday (&tmv, NULL);
2495  t = tmv.tv_sec;
2496 #else
2497  t = time (NULL);
2498 #endif
2499  tlt = localtime (&t);
2500  /* Leap seconds ? */
2501  if (tlt->tm_sec >= 60) {
2502  tlt->tm_sec = 59;
2503  }
2504  strftime (s, (size_t)9, "%H%M%S00", tlt);
2505 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
2506  sprintf(buff2, "%2.2ld", (long int)(tmv.tv_usec / 10000));
2507  memcpy (&s[6], buff2, (size_t)2);
2508 #endif
2509 #endif
2510  cob_memcpy (f, s, (size_t)8);
2511 }
void cob_accept_user_name ( cob_field *  f)

References cob_memcpy(), and cob_user_name.

1112 {
1113  if (cob_user_name) {
1114  cob_memcpy (f, cob_user_name,
1115  strlen (cob_user_name));
1116  } else {
1117  cob_memcpy (f, " ", (size_t)1);
1118  }
1119 }
void cob_allocate ( unsigned char **  dataptr,
cob_field *  retptr,
cob_field *  sizefld,
cob_field *  initialize 
)

References cob_field::attr, cob_alloc_base, __cob_global::cob_exception_code, cob_free(), cob_get_int(), cob_malloc(), cob_move(), cob_alloc_cache::cob_pointer, cob_set_exception(), const_alpha_attr, cob_field::data, cob_alloc_cache::next, NULL, cob_alloc_cache::size, and cob_field::size.

2750 {
2751  void *mptr;
2752  struct cob_alloc_cache *cache_ptr;
2753  int fsize;
2754  cob_field temp;
2755 
2756  /* ALLOCATE */
2757  cobglobptr->cob_exception_code = 0;
2758  mptr = NULL;
2759  fsize = cob_get_int (sizefld);
2760  if (fsize > 0) {
2761  cache_ptr = cob_malloc (sizeof (struct cob_alloc_cache));
2762  mptr = malloc ((size_t)fsize);
2763  if (!mptr) {
2764  cob_set_exception (COB_EC_STORAGE_NOT_AVAIL);
2765  cob_free (cache_ptr);
2766  } else {
2767  if (initialize) {
2768  temp.size = (size_t)fsize;
2769  temp.data = mptr;
2770  temp.attr = &const_alpha_attr;
2771  cob_move (initialize, &temp);
2772  } else {
2773  memset (mptr, 0, (size_t)fsize);
2774  }
2775  cache_ptr->cob_pointer = mptr;
2776  cache_ptr->size = (size_t)fsize;
2777  cache_ptr->next = cob_alloc_base;
2778  cob_alloc_base = cache_ptr;
2779  }
2780  }
2781  if (dataptr) {
2782  *dataptr = mptr;
2783  }
2784  if (retptr) {
2785  *(void **)(retptr->data) = mptr;
2786  }
2787 }
void cob_cache_free ( void *  ptr)

References cob_alloc_base, cob_free(), cob_alloc_cache::cob_pointer, and cob_alloc_cache::next.

1213 {
1214  struct cob_alloc_cache *cache_ptr;
1215  struct cob_alloc_cache *prev_ptr;
1216 
1217  if (!ptr) {
1218  return;
1219  }
1220  cache_ptr = cob_alloc_base;
1221  prev_ptr = cob_alloc_base;
1222  for (; cache_ptr; cache_ptr = cache_ptr->next) {
1223  if (ptr == cache_ptr->cob_pointer) {
1224  cob_free (cache_ptr->cob_pointer);
1225  if (cache_ptr == cob_alloc_base) {
1226  cob_alloc_base = cache_ptr->next;
1227  } else {
1228  prev_ptr->next = cache_ptr->next;
1229  }
1230  cob_free (cache_ptr);
1231  return;
1232  }
1233  prev_ptr = cache_ptr;
1234  }
1235 }
void* cob_cache_malloc ( const size_t  size)

References cob_alloc_base, cob_malloc(), cob_alloc_cache::cob_pointer, cob_alloc_cache::next, and cob_alloc_cache::size.

Referenced by cob_cache_realloc(), and cob_module_enter().

1172 {
1173  struct cob_alloc_cache *cache_ptr;
1174  void *mptr;
1175 
1176  cache_ptr = cob_malloc (sizeof (struct cob_alloc_cache));
1177  mptr = cob_malloc (size);
1178  cache_ptr->cob_pointer = mptr;
1179  cache_ptr->size = size;
1180  cache_ptr->next = cob_alloc_base;
1181  cob_alloc_base = cache_ptr;
1182  return mptr;
1183 }
void* cob_cache_realloc ( void *  ptr,
const size_t  size 
)

References cob_alloc_base, cob_cache_malloc(), cob_free(), cob_malloc(), cob_alloc_cache::cob_pointer, cob_alloc_cache::next, and cob_alloc_cache::size.

1187 {
1188  struct cob_alloc_cache *cache_ptr;
1189  void *mptr;
1190 
1191  if (!ptr) {
1192  return cob_cache_malloc (size);
1193  }
1194  cache_ptr = cob_alloc_base;
1195  for (; cache_ptr; cache_ptr = cache_ptr->next) {
1196  if (ptr == cache_ptr->cob_pointer) {
1197  if (size <= cache_ptr->size) {
1198  return ptr;
1199  }
1200  mptr = cob_malloc (size);
1201  memcpy (mptr, cache_ptr->cob_pointer, cache_ptr->size);
1202  cob_free (cache_ptr->cob_pointer);
1203  cache_ptr->cob_pointer = mptr;
1204  cache_ptr->size = size;
1205  return mptr;
1206  }
1207  }
1208  return ptr;
1209 }
void cob_chain_setup ( void *  data,
const size_t  parm,
const size_t  size 
)

References cob_argc, cob_argv, and __cob_global::cob_call_params.

2730 {
2731  size_t len;
2732 
2733  memset (data, ' ', size);
2734  if (parm <= (size_t)cob_argc - 1) {
2735  len = strlen (cob_argv[parm]);
2736  if (len <= size) {
2737  memcpy (data, cob_argv[parm], len);
2738  } else {
2739  memcpy (data, cob_argv[parm], size);
2740  }
2741  } else {
2742  memset (data, ' ', size);
2743  }
2744  cobglobptr->cob_call_params = cob_argc - 1;
2745 }
void cob_check_based ( const unsigned char *  x,
const char *  name 
)

References _, cob_runtime_error(), and cob_stop_run().

2306 {
2307  if (!x) {
2308  cob_runtime_error (_("BASED/LINKAGE item '%s' has NULL address"), name);
2309  cob_stop_run (1);
2310  }
2311 }
int cob_check_env_false ( char *  s)

Referenced by cob_rescan_env_vals().

974 {
975  if (s) {
976  if (strlen(s) == 1 && (*s == 'N' || *s == 'n' || *s == '0')) return 1;
977  if (strcasecmp(s, "NO") == 0 || strcasecmp(s, "NONE") == 0 ||
978  strcasecmp(s, "OFF") == 0 || strcasecmp(s, "FALSE") == 0) {
979  return 1;
980  }
981  }
982  return 0;
983 }
int cob_check_env_true ( char *  s)

Referenced by cob_init(), cob_init_fileio(), cob_init_move(), cob_init_screenio(), and cob_rescan_env_vals().

961 {
962  if (s) {
963  if (strlen(s) == 1 && (*s == 'Y' || *s == 'y' || *s == '1')) return 1;
964  if (strcasecmp(s, "YES") == 0 || strcasecmp(s, "ON") == 0 ||
965  strcasecmp(s, "TRUE") == 0) {
966  return 1;
967  }
968  }
969  return 0;
970 }
static int cob_check_numdisp ( const cob_field *  f)
static

References COB_FIELD_HAVE_SIGN, COB_FIELD_SIGN_LEADING, COB_FIELD_SIGN_SEPARATE, COB_MODULE_PTR, cob_field::data, cob_func_loc::data, p, cob_field::size, and unlikely.

Referenced by cob_is_numeric().

1889 {
1890  unsigned char *p;
1891  unsigned char *data;
1892  size_t size;
1893  size_t i;
1894 
1895  size = f->size;
1896  data = f->data;
1897  if (COB_FIELD_HAVE_SIGN (f)) {
1898  /* Adjust for sign byte */
1899  size--;
1900  if (unlikely(COB_FIELD_SIGN_LEADING (f))) {
1901  p = f->data;
1902  data = p + 1;
1903  } else {
1904  p = f->data + f->size - 1;
1905  }
1906  if (unlikely(COB_FIELD_SIGN_SEPARATE (f))) {
1907  if (*p != '+' && *p != '-') {
1908  return 0;
1909  }
1910  } else if (unlikely(COB_MODULE_PTR->ebcdic_sign)) {
1911  switch (*p) {
1912  case '0':
1913  case '1':
1914  case '2':
1915  case '3':
1916  case '4':
1917  case '5':
1918  case '6':
1919  case '7':
1920  case '8':
1921  case '9':
1922  case '{':
1923  case 'A':
1924  case 'B':
1925  case 'C':
1926  case 'D':
1927  case 'E':
1928  case 'F':
1929  case 'G':
1930  case 'H':
1931  case 'I':
1932  case '}':
1933  case 'J':
1934  case 'K':
1935  case 'L':
1936  case 'M':
1937  case 'N':
1938  case 'O':
1939  case 'P':
1940  case 'Q':
1941  case 'R':
1942  break;
1943  default:
1944  return 0;
1945  }
1946  } else {
1947  switch (*p) {
1948  case '0':
1949  case '1':
1950  case '2':
1951  case '3':
1952  case '4':
1953  case '5':
1954  case '6':
1955  case '7':
1956  case '8':
1957  case '9':
1958  case 'p':
1959  case 'q':
1960  case 'r':
1961  case 's':
1962  case 't':
1963  case 'u':
1964  case 'v':
1965  case 'w':
1966  case 'x':
1967  case 'y':
1968  break;
1969  default:
1970  return 0;
1971  }
1972  }
1973  }
1974  for (i = 0; i < size; ++i) {
1975  if (!isdigit (data[i])) {
1976  return 0;
1977  }
1978  }
1979  return 1;
1980 }
void cob_check_numeric ( const cob_field *  f,
const char *  name 
)

References _, cob_fast_malloc(), cob_free(), cob_is_numeric(), cob_runtime_error(), COB_SMALL_BUFF, cob_stop_run(), cob_field::data, p, and cob_field::size.

2315 {
2316  unsigned char *data;
2317  char *p;
2318  char *buff;
2319  size_t i;
2320 
2321  if (!cob_is_numeric (f)) {
2322  buff = cob_fast_malloc ((size_t)COB_SMALL_BUFF);
2323  p = buff;
2324  data = f->data;
2325  for (i = 0; i < f->size; ++i) {
2326  if (isprint (data[i])) {
2327  *p++ = data[i];
2328  } else {
2329  p += sprintf (p, "\\%03o", data[i]);
2330  }
2331  }
2332  *p = '\0';
2333  cob_runtime_error (_("'%s' not numeric: '%s'"), name, buff);
2334  cob_free (buff);
2335  cob_stop_run (1);
2336  }
2337 }
void cob_check_odo ( const int  i,
const int  min,
const int  max,
const char *  name 
)

References _, COB_EC_BOUND_ODO, cob_runtime_error(), cob_set_exception(), and cob_stop_run().

2342 {
2343  /* Check OCCURS DEPENDING ON item */
2344  if (i < min || max < i) {
2345  cob_set_exception (COB_EC_BOUND_ODO);
2346  cob_runtime_error (_("OCCURS DEPENDING ON '%s' out of bounds: %d"), name, i);
2347  cob_stop_run (1);
2348  }
2349 }
void cob_check_ref_mod ( const int  offset,
const int  length,
const int  size,
const char *  name 
)

References _, cob_runtime_error(), cob_set_exception(), and cob_stop_run().

2366 {
2367  /* Check offset */
2368  if (offset < 1 || offset > size) {
2369  cob_set_exception (COB_EC_BOUND_REF_MOD);
2370  cob_runtime_error (_("Offset of '%s' out of bounds: %d"), name, offset);
2371  cob_stop_run (1);
2372  }
2373 
2374  /* Check length */
2375  if (length < 1 || offset + length - 1 > size) {
2376  cob_set_exception (COB_EC_BOUND_REF_MOD);
2377  cob_runtime_error (_("Length of '%s' out of bounds: %d"), name, length);
2378  cob_stop_run (1);
2379  }
2380 }
void cob_check_subscript ( const int  i,
const int  min,
const int  max,
const char *  name 
)

References _, cob_runtime_error(), cob_set_exception(), and cob_stop_run().

2354 {
2355  /* Check subscript */
2356  if (i < min || max < i) {
2357  cob_set_exception (COB_EC_BOUND_SUBSCRIPT);
2358  cob_runtime_error (_("Subscript of '%s' out of bounds: %d"), name, i);
2359  cob_stop_run (1);
2360  }
2361 }
static void cob_check_trace_file ( void  )
static

References cob_trace_env, cob_trace_file, and __cob_global::cob_unix_lf.

Referenced by cob_set_location(), cob_trace_section(), and print_runtime_env().

944 {
945  if (!cob_trace_env) {
946  cob_trace_file = stderr;
947  return;
948  }
949  if (!cobglobptr->cob_unix_lf) {
950  cob_trace_file = fopen (cob_trace_env, "w");
951  } else {
952  cob_trace_file = fopen (cob_trace_env, "wb");
953  }
954  if (!cob_trace_file) {
955  cob_trace_file = stderr;
956  }
957 }
void cob_check_version ( const char *  prog,
const char *  packver,
const int  patchlev 
)

References _, cob_runtime_error(), cob_stop_run(), PACKAGE_VERSION, and PATCH_LEVEL.

1675 {
1676  if (strcmp (packver, PACKAGE_VERSION) || patchlev != PATCH_LEVEL) {
1677  cob_runtime_error (_("Error - Version mismatch"));
1678  cob_runtime_error (_("%s has version/patch level %s/%d"), prog,
1679  packver, patchlev);
1680  cob_runtime_error (_("Library has version/patch level %s/%d"),
1681  PACKAGE_VERSION, PATCH_LEVEL);
1682  cob_stop_run (1);
1683  }
1684 }
int cob_cmp ( cob_field *  f1,
cob_field *  f2 
)

References cob_field::attr, cob_cmp_all(), cob_cmp_alnum(), cob_cmp_int(), COB_FIELD_DIGITS, COB_FIELD_IS_NUMERIC, COB_FIELD_TYPE, COB_FLAG_HAVE_SIGN, cob_move(), cob_numeric_cmp(), COB_TYPE_ALPHANUMERIC_ALL, COB_TYPE_NUMERIC_DISPLAY, cob_field::data, cob_field_attr::flags, cob_field::size, and cob_field_attr::type.

Referenced by cob_intr_max(), cob_intr_midrange(), cob_intr_min(), cob_intr_ord_max(), cob_intr_ord_min(), cob_intr_range(), and comp_field().

2099 {
2100  cob_field temp;
2101  cob_field_attr attr;
2102  unsigned char buff[256];
2103 
2104  if (COB_FIELD_IS_NUMERIC (f1) && COB_FIELD_IS_NUMERIC (f2)) {
2105  return cob_numeric_cmp (f1, f2);
2106  }
2107  if (COB_FIELD_TYPE (f2) == COB_TYPE_ALPHANUMERIC_ALL) {
2108  if (f2->size == 1 && f2->data[0] == '0' &&
2109  COB_FIELD_IS_NUMERIC (f1)) {
2110  return cob_cmp_int (f1, 0);
2111  }
2112  return cob_cmp_all (f1, f2);
2113  }
2114  if (COB_FIELD_TYPE (f1) == COB_TYPE_ALPHANUMERIC_ALL) {
2115  if (f1->size == 1 && f1->data[0] == '0' &&
2116  COB_FIELD_IS_NUMERIC (f2)) {
2117  return -cob_cmp_int (f2, 0);
2118  }
2119  return -cob_cmp_all (f2, f1);
2120  }
2121  if (COB_FIELD_IS_NUMERIC (f1) &&
2122  COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_DISPLAY) {
2123  temp.size = COB_FIELD_DIGITS(f1);
2124  temp.data = buff;
2125  temp.attr = &attr;
2126  attr = *f1->attr;
2127  attr.type = COB_TYPE_NUMERIC_DISPLAY;
2128  attr.flags &= ~COB_FLAG_HAVE_SIGN;
2129  cob_move (f1, &temp);
2130  f1 = &temp;
2131  }
2132  if (COB_FIELD_IS_NUMERIC (f2) &&
2133  COB_FIELD_TYPE (f2) != COB_TYPE_NUMERIC_DISPLAY) {
2134  temp.size = COB_FIELD_DIGITS(f2);
2135  temp.data = buff;
2136  temp.attr = &attr;
2137  attr = *f2->attr;
2138  attr.type = COB_TYPE_NUMERIC_DISPLAY;
2139  attr.flags &= ~COB_FLAG_HAVE_SIGN;
2140  cob_move (f2, &temp);
2141  f2 = &temp;
2142  }
2143  return cob_cmp_alnum (f1, f2);
2144 }
static int cob_cmp_all ( cob_field *  f1,
cob_field *  f2 
)
static

References COB_FIELD_TYPE, COB_GET_SIGN, COB_MODULE_PTR, COB_PUT_SIGN, COB_TYPE_NUMERIC_PACKED, common_cmpc(), common_cmps(), cob_field::data, sign, and cob_field::size.

Referenced by cob_cmp().

834 {
835  unsigned char *data;
836  const unsigned char *s;
837  size_t size;
838  int ret;
839  int sign;
840 
841  size = f1->size;
842  data = f1->data;
843  sign = COB_GET_SIGN (f1);
844  s = COB_MODULE_PTR->collating_sequence;
845  if (f2->size == 1) {
846  ret = common_cmpc (data, f2->data[0], size, s);
847  goto end;
848  }
849  ret = 0;
850  while (size >= f2->size) {
851  if ((ret = common_cmps (data, f2->data, f2->size, s)) != 0) {
852  goto end;
853  }
854  size -= f2->size;
855  data += f2->size;
856  }
857  if (size > 0) {
858  ret = common_cmps (data, f2->data, size, s);
859  }
860 
861 end:
862  if (COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_PACKED) {
863  COB_PUT_SIGN (f1, sign);
864  }
865  return ret;
866 }
static int cob_cmp_alnum ( cob_field *  f1,
cob_field *  f2 
)
static

References COB_FIELD_TYPE, COB_GET_SIGN, COB_MODULE_PTR, COB_PUT_SIGN, COB_TYPE_NUMERIC_PACKED, common_cmpc(), common_cmps(), cob_field::data, if(), and cob_field::size.

Referenced by cob_cmp().

870 {
871  const unsigned char *s;
872  size_t min;
873  int ret;
874  int sign1;
875  int sign2;
876 
877  sign1 = COB_GET_SIGN (f1);
878  sign2 = COB_GET_SIGN (f2);
879  min = (f1->size < f2->size) ? f1->size : f2->size;
880  s = COB_MODULE_PTR->collating_sequence;
881 
882  /* Compare common substring */
883  if ((ret = common_cmps (f1->data, f2->data, min, s)) != 0) {
884  goto end;
885  }
886 
887  /* Compare the rest (if any) with spaces */
888  if (f1->size > f2->size) {
889  ret = common_cmpc (f1->data + min, ' ', f1->size - min, s);
890  } else if (f1->size < f2->size) {
891  ret = -common_cmpc (f2->data + min, ' ', f2->size - min, s);
892  }
893 
894 end:
895  if (COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_PACKED) {
896  COB_PUT_SIGN (f1, sign1);
897  }
898  if (COB_FIELD_TYPE (f2) != COB_TYPE_NUMERIC_PACKED) {
899  COB_PUT_SIGN (f2, sign2);
900  }
901  return ret;
902 }
void* cob_command_line ( int  flags,
int *  pargc,
char ***  pargv,
char ***  penvp,
char **  pname 
)

References _, cob_argc, cob_argv, cob_initialized, cob_runtime_error(), cob_stop_run(), COB_UNUSED, and NULL.

2940 {
2941 #if 0 /* RXWRXW cob_command_line */
2942  char **spenvp;
2943  char *spname;
2944 #else
2945  COB_UNUSED (penvp);
2946  COB_UNUSED (pname);
2947 #endif
2948 
2949  COB_UNUSED (flags);
2950 
2951  if (!cob_initialized) {
2952  cob_runtime_error (_("'cobcommandline' - Runtime has not been initialized"));
2953  cob_stop_run (1);
2954  }
2955  if (pargc && pargv) {
2956  cob_argc = *pargc;
2957  cob_argv = *pargv;
2958  }
2959 
2960 #if 0 /* RXWRXW cob_command_line */
2961  if (penvp) {
2962  spenvp = *penvp;
2963  }
2964  if (pname) {
2965  spname = *pname;
2966  }
2967 #endif
2968 
2969  /* What are we supposed to return here? */
2970  return NULL;
2971 }
void cob_correct_numeric ( cob_field *  f)

References COB_FIELD_HAVE_SIGN, COB_FIELD_IS_NUMDISP, COB_FIELD_SIGN_LEADING, COB_FIELD_SIGN_SEPARATE, COB_MODULE_PTR, cob_field::data, cob_func_loc::data, p, cob_field::size, and unlikely.

1698 {
1699  unsigned char *p;
1700  unsigned char *data;
1701  size_t size;
1702  size_t i;
1703 
1704  if (!COB_FIELD_IS_NUMDISP(f)) {
1705  return;
1706  }
1707  size = f->size;
1708  data = f->data;
1709  if (COB_FIELD_HAVE_SIGN (f)) {
1710  /* Adjust for sign byte */
1711  size--;
1712  if (unlikely(COB_FIELD_SIGN_LEADING (f))) {
1713  p = f->data;
1714  data = p + 1;
1715  } else {
1716  p = f->data + f->size - 1;
1717  }
1718  if (unlikely(COB_FIELD_SIGN_SEPARATE (f))) {
1719  if (*p != '+' && *p != '-') {
1720  *p = '+';
1721  }
1722  } else if (unlikely(COB_MODULE_PTR->ebcdic_sign)) {
1723  switch (*p) {
1724  case '{':
1725  case 'A':
1726  case 'B':
1727  case 'C':
1728  case 'D':
1729  case 'E':
1730  case 'F':
1731  case 'G':
1732  case 'H':
1733  case 'I':
1734  case '}':
1735  case 'J':
1736  case 'K':
1737  case 'L':
1738  case 'M':
1739  case 'N':
1740  case 'O':
1741  case 'P':
1742  case 'Q':
1743  case 'R':
1744  break;
1745  case '0':
1746  *p = '{';
1747  break;
1748  case '1':
1749  *p = 'A';
1750  break;
1751  case '2':
1752  *p = 'B';
1753  break;
1754  case '3':
1755  *p = 'C';
1756  break;
1757  case '4':
1758  *p = 'D';
1759  break;
1760  case '5':
1761  *p = 'E';
1762  break;
1763  case '6':
1764  *p = 'F';
1765  break;
1766  case '7':
1767  *p = 'G';
1768  break;
1769  case '8':
1770  *p = 'H';
1771  break;
1772  case '9':
1773  *p = 'I';
1774  break;
1775  case 0:
1776  case ' ':
1777  *p = '{';
1778  break;
1779  default:
1780  break;
1781  }
1782  } else {
1783  if(!*p || *p == ' ') {
1784  *p = '0';
1785  }
1786  }
1787  } else {
1788  p = f->data + f->size - 1;
1789  if (unlikely(COB_MODULE_PTR->ebcdic_sign)) {
1790  switch (*p) {
1791  case 0:
1792  case ' ':
1793  case '{':
1794  case '}':
1795  *p = '0';
1796  break;
1797  case 'A':
1798  case 'B':
1799  case 'C':
1800  case 'D':
1801  case 'E':
1802  case 'F':
1803  case 'G':
1804  case 'H':
1805  case 'I':
1806  *p = '1' + (*p - 'A');
1807  break;
1808  case 'J':
1809  case 'K':
1810  case 'L':
1811  case 'M':
1812  case 'N':
1813  case 'O':
1814  case 'P':
1815  case 'Q':
1816  case 'R':
1817  *p = '1' + (*p - 'J');
1818  break;
1819  default:
1820  break;
1821  }
1822  } else {
1823  switch (*p) {
1824  case 0:
1825  case ' ':
1826  case 'p':
1827  *p = '0';
1828  break;
1829  case 'q':
1830  *p = '1';
1831  break;
1832  case 'r':
1833  *p = '2';
1834  break;
1835  case 's':
1836  *p = '3';
1837  break;
1838  case 't':
1839  *p = '4';
1840  break;
1841  case 'u':
1842  *p = '5';
1843  break;
1844  case 'v':
1845  *p = '6';
1846  break;
1847  case 'w':
1848  *p = '7';
1849  break;
1850  case 'x':
1851  *p = '8';
1852  break;
1853  case 'y':
1854  *p = '9';
1855  break;
1856  default:
1857  break;
1858  }
1859  }
1860  }
1861  for (i = 0, p = data; i < size; ++i, ++p) {
1862  switch (*p) {
1863  case '0':
1864  case '1':
1865  case '2':
1866  case '3':
1867  case '4':
1868  case '5':
1869  case '6':
1870  case '7':
1871  case '8':
1872  case '9':
1873  break;
1874  case 0:
1875  case ' ':
1876  *p = '0';
1877  break;
1878  default:
1879  if ((*p & 0x0F) <= 9) {
1880  *p = (*p & 0x0F) + '0';
1881  }
1882  break;
1883  }
1884  }
1885 }
void cob_display_arg_number ( cob_field *  f)

References cob_field::attr, cob_argc, COB_ATTR_INIT, cob_move(), cob_set_exception(), COB_TYPE_NUMERIC_BINARY, current_arg, cob_field::data, NULL, and cob_field::size.

2571 {
2572  int n;
2573  cob_field_attr attr;
2574  cob_field temp;
2575 
2576  temp.size = 4;
2577  temp.data = (unsigned char *)&n;
2578  temp.attr = &attr;
2579  COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL);
2580  cob_move (f, &temp);
2581  if (n < 0 || n >= cob_argc) {
2582  cob_set_exception (COB_EC_IMP_DISPLAY);
2583  return;
2584  }
2585  current_arg = n;
2586 }
void cob_display_command_line ( cob_field *  f)

References cob_free(), cob_malloc(), commlncnt, commlnptr, cob_field::data, and cob_field::size.

2515 {
2516  if (commlnptr) {
2517  cob_free (commlnptr);
2518  }
2519  commlnptr = cob_malloc (f->size + 1U);
2520  commlncnt = f->size;
2521  memcpy (commlnptr, f->data, commlncnt);
2522 }
void cob_display_env_value ( const cob_field *  f)

References cob_fast_malloc(), cob_field_to_string(), cob_free(), cob_local_env, cob_malloc(), cob_rescan_env_vals(), cob_set_exception(), p, and cob_field::size.

Referenced by cob_set_environment().

2641 {
2642  char *env2;
2643 #if !HAVE_SETENV
2644  char *p;
2645  size_t len;
2646 #endif
2647  int ret;
2648 
2649  if (!cob_local_env) {
2650  cob_set_exception (COB_EC_IMP_DISPLAY);
2651  return;
2652  }
2653  if (!*cob_local_env) {
2654  cob_set_exception (COB_EC_IMP_DISPLAY);
2655  return;
2656  }
2657  env2 = cob_malloc (f->size + 1U);
2658  cob_field_to_string (f, env2, f->size);
2659 #if HAVE_SETENV
2660  ret = setenv(cob_local_env, env2, 1);
2661 #else
2662  len = strlen (cob_local_env) + strlen (env2) + 3U;
2663  p = cob_fast_malloc (len);
2664  sprintf (p, "%s=%s", cob_local_env, env2);
2665  ret = putenv (p);
2666 #endif
2667  cob_free (env2);
2668  if (ret != 0) {
2669  cob_set_exception (COB_EC_IMP_DISPLAY);
2670  return;
2671  }
2672  /* Rescan term/screen variables */
2673  cob_rescan_env_vals ();
2674 }
void cob_display_environment ( const cob_field *  f)

References __cob_global::cob_env_mangle, cob_field_to_string(), cob_free(), cob_local_env, cob_local_env_size, cob_malloc(), cob_field::size, and unlikely.

Referenced by cob_set_environment().

2619 {
2620  size_t i;
2621 
2622  if (cob_local_env_size < f->size) {
2623  cob_local_env_size = f->size;
2624  if (cob_local_env) {
2625  cob_free (cob_local_env);
2626  }
2627  cob_local_env = cob_malloc (cob_local_env_size + 1U);
2628  }
2629  cob_field_to_string (f, cob_local_env, cob_local_env_size);
2630  if (unlikely(cobglobptr->cob_env_mangle)) {
2631  for (i = 0; i < strlen (cob_local_env); ++i) {
2632  if (!isalnum ((int)cob_local_env[i])) {
2633  cob_local_env[i] = '_';
2634  }
2635  }
2636  }
2637 }
static void cob_exit_common ( void  )
static

References cob_free(), cob_initialized, cob_local_env, __cob_global::cob_locale, __cob_global::cob_locale_collate, __cob_global::cob_locale_ctype, __cob_global::cob_locale_messages, __cob_global::cob_locale_monetary, __cob_global::cob_locale_numeric, __cob_global::cob_locale_orig, __cob_global::cob_locale_time, __cob_global::cob_main_argv0, cob_alloc_cache::cob_pointer, __cob_global::cob_term_buff, cob_user_name, commlnptr, cob_external::ename, cob_external::ext_alloc, cob_alloc_cache::next, cob_external::next, NULL, p, and runtime_err_str.

Referenced by cob_terminate_routines().

211 {
212  struct cob_external *p;
213  struct cob_external *q;
214  struct cob_alloc_cache *x;
215  struct cob_alloc_cache *y;
216 
217 #ifdef HAVE_SETLOCALE
218  if (cobglobptr->cob_locale_orig) {
219  (void) setlocale (LC_ALL, cobglobptr->cob_locale_orig);
220  cob_free (cobglobptr->cob_locale_orig);
221  }
222  if (cobglobptr->cob_locale) {
223  cob_free (cobglobptr->cob_locale);
224  }
225  if (cobglobptr->cob_locale_ctype) {
226  cob_free (cobglobptr->cob_locale_ctype);
227  }
228  if (cobglobptr->cob_locale_collate) {
229  cob_free (cobglobptr->cob_locale_collate);
230  }
231  if (cobglobptr->cob_locale_messages) {
232  cob_free (cobglobptr->cob_locale_messages);
233  }
234  if (cobglobptr->cob_locale_monetary) {
235  cob_free (cobglobptr->cob_locale_monetary);
236  }
237  if (cobglobptr->cob_locale_numeric) {
238  cob_free (cobglobptr->cob_locale_numeric);
239  }
240  if (cobglobptr->cob_locale_time) {
241  cob_free (cobglobptr->cob_locale_time);
242  }
243 #endif
244 
245  if (cob_user_name) {
246  cob_free (cob_user_name);
247  }
248  if (commlnptr) {
249  cob_free (commlnptr);
250  }
251  if (cob_local_env) {
252  cob_free (cob_local_env);
253  }
254 
255  /* Free library routine stuff */
256 
257  if (cobglobptr->cob_term_buff) {
258  cob_free (cobglobptr->cob_term_buff);
259  }
260 
261  /* Free cached externals */
262  for (p = basext; p;) {
263  q = p;
264  p = p->next;
265  if (q->ename) {
266  cob_free (q->ename);
267  }
268  if (q->ext_alloc) {
269  cob_free (q->ext_alloc);
270  }
271  cob_free (q);
272  }
273 
274  /* Free cached mallocs */
275  for (x = cob_alloc_base; x;) {
276  y = x;
277  x = x->next;
278  cob_free (y->cob_pointer);
279  cob_free (y);
280  }
281 
282  /* Free last stuff */
283  if (runtime_err_str) {
284  cob_free (runtime_err_str);
285  }
286  if (cobglobptr) {
287  if (cobglobptr->cob_main_argv0) {
288  cob_free ((void *)(cobglobptr->cob_main_argv0));
289  }
290  cob_free (cobglobptr);
291  }
292  cobglobptr = NULL;
293  cob_initialized = 0;
294 }
int cob_extern_init ( void  )

References cob_init(), and NULL.

2932 {
2933  cob_init (0, NULL);
2934  return 0;
2935 }
void* cob_external_addr ( const char *  exname,
const int  exlength 
)

References _, basext, __cob_global::cob_initial_external, cob_malloc(), cob_runtime_error(), cob_stop_run(), cob_external::ename, cob_external::esize, cob_external::ext_alloc, and cob_external::next.

2384 {
2385  struct cob_external *eptr;
2386 
2387  /* Locate or allocate EXTERNAL item */
2388  for (eptr = basext; eptr; eptr = eptr->next) {
2389  if (!strcmp (exname, eptr->ename)) {
2390  if (exlength > eptr->esize) {
2391  cob_runtime_error (_("EXTERNAL item '%s' previously allocated with size %d, requested size is %d"),
2392  exname, eptr->esize, exlength);
2393  cob_stop_run (1);
2394  }
2395  cobglobptr->cob_initial_external = 0;
2396  return eptr->ext_alloc;
2397  }
2398  }
2399  eptr = cob_malloc (sizeof (struct cob_external));
2400  eptr->next = basext;
2401  eptr->esize = exlength;
2402  eptr->ename = cob_malloc (strlen (exname) + 1U);
2403  strcpy (eptr->ename, exname);
2404  eptr->ext_alloc = cob_malloc ((size_t)exlength);
2405  basext = eptr;
2406  cobglobptr->cob_initial_external = 1;
2407  return eptr->ext_alloc;
2408 }
void* cob_fast_malloc ( const size_t  size)

References cob_fatal_error(), COB_FERROR_MEMORY, and unlikely.

Referenced by cob_check_numeric(), cob_decimal_set_display(), cob_display_env_value(), cob_file_sort_init(), cob_get_buff(), cob_gettmpdir(), cob_init(), cob_init_call(), cob_init_fileio(), cob_inspect_init(), cob_int_to_formatted_bytestring(), cob_new_item(), cob_save_env_value(), cob_strcat(), print_runtime_env(), and print_version().

1147 {
1148  void *mptr;
1149 
1150  mptr = malloc (size);
1151  if (unlikely(!mptr)) {
1152  cob_fatal_error (COB_FERROR_MEMORY);
1153  }
1154  return mptr;
1155 }
void cob_fatal_error ( const int  fatal_error)

References _, cob_file::assign, COB_D2I, __cob_global::cob_error_file, COB_FERROR_CANCEL, COB_FERROR_CHAINING, COB_FERROR_CODEGEN, COB_FERROR_FILE, COB_FERROR_FREE, COB_FERROR_FUNCTION, COB_FERROR_GLOBAL, COB_FERROR_INITIALIZED, COB_FERROR_MEMORY, COB_FERROR_MODULE, COB_FERROR_NONE, COB_FERROR_RECURSIVE, COB_FERROR_STACK, cob_field_to_string(), COB_FILE_BUFF, COB_FILE_MAX, cob_free(), cob_malloc(), cob_runtime_error(), COB_STATUS_10_END_OF_FILE, COB_STATUS_14_OUT_OF_KEY_RANGE, COB_STATUS_21_KEY_INVALID, COB_STATUS_22_KEY_EXISTS, COB_STATUS_23_KEY_NOT_EXISTS, COB_STATUS_30_PERMANENT_ERROR, COB_STATUS_35_NOT_EXISTS, COB_STATUS_37_PERMISSION_DENIED, COB_STATUS_41_ALREADY_OPEN, COB_STATUS_42_NOT_OPEN, COB_STATUS_43_READ_NOT_DONE, COB_STATUS_44_RECORD_OVERFLOW, COB_STATUS_46_READ_ERROR, COB_STATUS_47_INPUT_DENIED, COB_STATUS_48_OUTPUT_DENIED, COB_STATUS_49_I_O_DENIED, COB_STATUS_51_RECORD_LOCKED, COB_STATUS_57_I_O_LINAGE, COB_STATUS_61_FILE_SHARING, COB_STATUS_91_NOT_AVAILABLE, cob_stop_run(), and cob_file::file_status.

Referenced by cob_call(), cob_call_field(), cob_cancel(), cob_cancel_field(), cob_fast_malloc(), cob_free(), cob_get_global_ptr(), cob_intr_boolean_of_integer(), cob_intr_char_national(), cob_intr_display_of(), cob_intr_exception_file_n(), cob_intr_exception_location_n(), cob_intr_formatted_current_date(), cob_intr_integer_of_boolean(), cob_intr_integer_of_formatted_date(), cob_intr_national_of(), cob_intr_standard_compare(), cob_intr_test_formatted_datetime(), cob_longjmp(), cob_malloc(), cob_module_enter(), cob_resolve_internal(), and cob_savenv().

1441 {
1442  const char *msg;
1443  unsigned char *file_status;
1444  char *filename;
1445  int status;
1446 
1447  switch (fatal_error) {
1448  case COB_FERROR_NONE:
1449  cob_runtime_error (_("cob_init() has not been called"));
1450  break;
1451  case COB_FERROR_CANCEL:
1452  cob_runtime_error (_("Attempt to CANCEL active program"));
1453  break;
1454  case COB_FERROR_INITIALIZED:
1455  cob_runtime_error (_("cob_init() has not been called"));
1456  break;
1457  case COB_FERROR_CODEGEN:
1458  cob_runtime_error (_("Codegen error - Please report this"));
1459  break;
1460  case COB_FERROR_CHAINING:
1461  cob_runtime_error (_("Recursive call of chained program"));
1462  break;
1463  case COB_FERROR_STACK:
1464  cob_runtime_error (_("Stack overflow, possible PERFORM depth exceeded"));
1465  break;
1466  case COB_FERROR_GLOBAL:
1467  cob_runtime_error (_("Invalid entry/exit in GLOBAL USE procedure"));
1468  break;
1469  case COB_FERROR_MEMORY:
1470  cob_runtime_error (_("Unable to allocate memory"));
1471  break;
1472  case COB_FERROR_MODULE:
1473  cob_runtime_error (_("Invalid entry into module"));
1474  break;
1475  case COB_FERROR_RECURSIVE:
1476  cob_runtime_error (_("Invalid recursive COBOL CALL"));
1477  break;
1478  case COB_FERROR_FREE:
1479  cob_runtime_error (_("Call to cob_free with NULL pointer"));
1480  break;
1481  case COB_FERROR_FILE:
1482  file_status = cobglobptr->cob_error_file->file_status;
1483  status = COB_D2I(file_status[0]) * 10 + COB_D2I(file_status[1]);
1484  switch (status) {
1485  case COB_STATUS_10_END_OF_FILE:
1486  msg = _("End of file");
1487  break;
1488  case COB_STATUS_14_OUT_OF_KEY_RANGE:
1489  msg = _("Key out of range");
1490  break;
1491  case COB_STATUS_21_KEY_INVALID:
1492  msg = _("Key order not ascending");
1493  break;
1494  case COB_STATUS_22_KEY_EXISTS:
1495  msg = _("Record key already exists");
1496  break;
1497  case COB_STATUS_23_KEY_NOT_EXISTS:
1498  msg = _("Record key does not exist");
1499  break;
1500  case COB_STATUS_30_PERMANENT_ERROR:
1501  msg = _("Permanent file error");
1502  break;
1503  case COB_STATUS_35_NOT_EXISTS:
1504  msg = _("File does not exist");
1505  break;
1506  case COB_STATUS_37_PERMISSION_DENIED:
1507  msg = _("Permission denied");
1508  break;
1509  case COB_STATUS_41_ALREADY_OPEN:
1510  msg = _("File already open");
1511  break;
1512  case COB_STATUS_42_NOT_OPEN:
1513  msg = _("File not open");
1514  break;
1515  case COB_STATUS_43_READ_NOT_DONE:
1516  msg = _("READ must be executed first");
1517  break;
1518  case COB_STATUS_44_RECORD_OVERFLOW:
1519  msg = _("Record overflow");
1520  break;
1521  case COB_STATUS_46_READ_ERROR:
1522  msg = _("Failed to read");
1523  break;
1524  case COB_STATUS_47_INPUT_DENIED:
1525  msg = _("READ/START not allowed");
1526  break;
1527  case COB_STATUS_48_OUTPUT_DENIED:
1528  msg = _("WRITE not allowed");
1529  break;
1530  case COB_STATUS_49_I_O_DENIED:
1531  msg = _("DELETE/REWRITE not allowed");
1532  break;
1533  case COB_STATUS_51_RECORD_LOCKED:
1534  msg = _("Record locked by another file connector");
1535  break;
1536  case COB_STATUS_57_I_O_LINAGE:
1537  msg = _("LINAGE values invalid");
1538  break;
1539  case COB_STATUS_61_FILE_SHARING:
1540  msg = _("File sharing conflict");
1541  break;
1542  case COB_STATUS_91_NOT_AVAILABLE:
1543  msg = _("Runtime library is not configured for this operation");
1544  break;
1545  default:
1546  msg = _("Unknown file error");
1547  break;
1548  }
1549  filename = cob_malloc ((size_t)COB_FILE_BUFF);
1550  cob_field_to_string (cobglobptr->cob_error_file->assign,
1551  filename, (size_t)COB_FILE_MAX);
1552  cob_runtime_error (_("%s (Status = %02d) File : '%s'"),
1553  msg, status, filename);
1554  cob_free (filename);
1555  break;
1556  case COB_FERROR_FUNCTION:
1557  cob_runtime_error (_("Attempt to use non-implemented function"));
1558  break;
1559  default:
1560  cob_runtime_error (_("Unknown failure : %d"), fatal_error);
1561  break;
1562  }
1563  cob_stop_run (1);
1564 }
void cob_field_to_string ( const cob_field *  f,
void *  str,
const size_t  maxsize 
)

References cob_field::data, cob_field::size, and unlikely.

Referenced by cob_call_field(), cob_cancel_field(), cob_delete_file(), cob_display_env_value(), cob_display_environment(), cob_exit_fileio(), cob_fatal_error(), cob_get_environment(), cob_intr_lcl_time_from_secs(), cob_intr_locale_compare(), cob_intr_locale_date(), cob_intr_locale_time(), cob_open(), cob_set_locale(), and cob_sys_getopt_long_long().

1335 {
1336  unsigned char *s;
1337  size_t count;
1338  size_t i;
1339 
1340  count = 0;
1341  if (unlikely(f->size == 0)) {
1342  return;
1343  }
1344  i = f->size - 1;
1345  for (; ;) {
1346  if (f->data[i] && f->data[i] != (unsigned char)' ') {
1347  count = i + 1;
1348  break;
1349  }
1350  if (!i) {
1351  break;
1352  }
1353  --i;
1354  }
1355  if (count > maxsize) {
1356  count = maxsize;
1357  }
1358  s = (unsigned char *)str;
1359  for (i = 0; i < count; ++i) {
1360  s[i] = f->data[i];
1361  }
1362  s[i] = 0;
1363 }
COB_INLINE void cob_free ( void *  mptr)

References cob_fatal_error(), COB_FERROR_FREE, and unlikely.

Referenced by alloc_figurative(), cob_accept_command_line(), cob_allocate(), cob_cache_free(), cob_cache_realloc(), cob_call(), cob_call_field(), cob_check_numeric(), cob_chk_file_env(), cob_chk_file_mapping(), cob_close(), cob_decimal_get_field(), cob_decimal_pop(), cob_decimal_set_display(), cob_display_command_line(), cob_display_env_value(), cob_display_environment(), cob_exit_call(), cob_exit_common(), cob_exit_fileio(), cob_exit_intrinsic(), cob_exit_numeric(), cob_exit_strings(), cob_fatal_error(), cob_file_sort_close(), cob_file_sort_giving(), cob_free_alloc(), cob_free_list(), cob_get_buff(), cob_get_environment(), cob_gettmpdir(), cob_init(), cob_init_call(), cob_init_fileio(), cob_inspect_init(), cob_intr_concatenate(), cob_intr_exception_location(), cob_intr_locale_compare(), cob_intr_median(), cob_intr_numval(), cob_intr_numval_c(), cob_intr_numval_f(), cob_intr_substitute(), cob_intr_substitute_case(), cob_move_all(), cob_move_edited_to_display(), cob_resolve(), cob_resolve_cobol(), cob_restore_func(), cob_runtime_error(), cob_save_env_value(), cob_set_library_path(), cob_set_locale(), cob_srttmpfile(), cob_strcat(), cob_sys_change_dir(), cob_sys_check_file_exist(), cob_sys_copy_file(), cob_sys_create_dir(), cob_sys_delete_dir(), cob_sys_delete_file(), cob_sys_error_proc(), cob_sys_exit_proc(), cob_sys_file_info(), cob_sys_get_current_dir(), cob_sys_getopt_long_long(), cob_sys_rename_file(), cob_sys_system(), cob_table_sort(), cob_unstring_init(), do_cancel_module(), indexed_close(), indexed_open(), indirect_move(), insert(), make_field_entry(), open_cbl_file(), and var_print().

1135 {
1136 #ifdef _DEBUG
1137  if (unlikely(!mptr)) {
1138  cob_fatal_error (COB_FERROR_FREE);
1139  }
1140 #endif
1141  free (mptr);
1142 
1143 }
void cob_free_alloc ( unsigned char **  ptr1,
unsigned char *  ptr2 
)

References cob_alloc_base, COB_EC_STORAGE_NOT_ALLOC, __cob_global::cob_exception_code, cob_free(), cob_alloc_cache::cob_pointer, cob_set_exception(), cob_alloc_cache::next, and NULL.

2791 {
2792  struct cob_alloc_cache *cache_ptr;
2793  struct cob_alloc_cache *prev_ptr;
2794  void *vptr1;
2795 
2796  /* FREE */
2797  cobglobptr->cob_exception_code = 0;
2798  cache_ptr = cob_alloc_base;
2799  prev_ptr = cob_alloc_base;
2800  if (ptr1 && *ptr1) {
2801  vptr1 = *ptr1;
2802  for (; cache_ptr; cache_ptr = cache_ptr->next) {
2803  if (vptr1 == cache_ptr->cob_pointer) {
2804  cob_free (cache_ptr->cob_pointer);
2805  if (cache_ptr == cob_alloc_base) {
2806  cob_alloc_base = cache_ptr->next;
2807  } else {
2808  prev_ptr->next = cache_ptr->next;
2809  }
2810  cob_free (cache_ptr);
2811  *ptr1 = NULL;
2812  return;
2813  }
2814  prev_ptr = cache_ptr;
2815  }
2816  cob_set_exception (COB_EC_STORAGE_NOT_ALLOC);
2817  return;
2818  }
2819  if (ptr2 && *(void **)ptr2) {
2820  for (; cache_ptr; cache_ptr = cache_ptr->next) {
2821  if (*(void **)ptr2 == cache_ptr->cob_pointer) {
2822  cob_free (cache_ptr->cob_pointer);
2823  if (cache_ptr == cob_alloc_base) {
2824  cob_alloc_base = cache_ptr->next;
2825  } else {
2826  prev_ptr->next = cache_ptr->next;
2827  }
2828  cob_free (cache_ptr);
2829  *(void **)ptr2 = NULL;
2830  return;
2831  }
2832  prev_ptr = cache_ptr;
2833  }
2834  cob_set_exception (COB_EC_STORAGE_NOT_ALLOC);
2835  return;
2836  }
2837 }
void cob_get_environment ( const cob_field *  envname,
cob_field *  envval 
)

References COB_EC_IMP_ACCEPT, __cob_global::cob_env_mangle, cob_field_to_string(), cob_free(), cob_malloc(), cob_memcpy(), cob_set_exception(), p, cob_field::size, and unlikely.

2685 {
2686  const char *p;
2687  char *buff;
2688  size_t size;
2689 
2690  if (envname->size == 0 || envval->size == 0) {
2691  cob_set_exception (COB_EC_IMP_ACCEPT);
2692  return;
2693  }
2694 
2695  buff = cob_malloc (envname->size + 1U);
2696  cob_field_to_string (envname, buff, envname->size);
2697  if (unlikely(cobglobptr->cob_env_mangle)) {
2698  for (size = 0; size < strlen (buff); ++size) {
2699  if (!isalnum ((int)buff[size])) {
2700  buff[size] = '_';
2701  }
2702  }
2703  }
2704  p = getenv (buff);
2705  if (!p) {
2706  cob_set_exception (COB_EC_IMP_ACCEPT);
2707  p = " ";
2708  }
2709  cob_memcpy (envval, p, strlen (p));
2710  cob_free (buff);
2711 }
int cob_get_exception_code ( void  )

References __cob_global::cob_exception_code.

Referenced by cob_string_append(), and cob_unstring_into().

1073 {
1074  return cobglobptr->cob_exception_code;
1075 }
const char* cob_get_exception_name ( void  )

References __cob_global::cob_exception_code, cob_exception_tab_code, cob_exception_tab_name, EXCEPTION_TAB_SIZE, and NULL.

Referenced by cob_intr_exception_status().

1079 {
1080  size_t n;
1081 
1082  for (n = 0; n < EXCEPTION_TAB_SIZE; ++n) {
1083  if (cobglobptr->cob_exception_code == cob_exception_tab_code[n]) {
1084  return cob_exception_tab_name[n];
1085  }
1086  }
1087  return NULL;
1088 }
cob_global* cob_get_global_ptr ( void  )

References cob_fatal_error(), COB_FERROR_INITIALIZED, cob_initialized, cobglobptr, and unlikely.

1568 {
1569  if (unlikely(!cob_initialized)) {
1570  cob_fatal_error (COB_FERROR_INITIALIZED);
1571  }
1572  return cobglobptr;
1573 }
unsigned char* cob_get_pointer ( const void *  srcptr)

References cob_u8_ptr.

1317 {
1318  void *tmptr;
1319 
1320  memcpy (&tmptr, srcptr, sizeof (void *));
1321  return (cob_u8_ptr)tmptr;
1322 }
void* cob_get_prog_pointer ( const void *  srcptr)
1326 {
1327  void *tmptr;
1328 
1329  memcpy (&tmptr, srcptr, sizeof (void *));
1330  return tmptr;
1331 }
static int cob_get_sign_ascii ( unsigned char *  p)
static

Referenced by cob_real_get_sign().

539 {
540 #ifdef COB_EBCDIC_MACHINE
541  switch (*p) {
542  case 'p':
543  *p = (unsigned char)'0';
544  return -1;
545  case 'q':
546  *p = (unsigned char)'1';
547  return -1;
548  case 'r':
549  *p = (unsigned char)'2';
550  return -1;
551  case 's':
552  *p = (unsigned char)'3';
553  return -1;
554  case 't':
555  *p = (unsigned char)'4';
556  return -1;
557  case 'u':
558  *p = (unsigned char)'5';
559  return -1;
560  case 'v':
561  *p = (unsigned char)'6';
562  return -1;
563  case 'w':
564  *p = (unsigned char)'7';
565  return -1;
566  case 'x':
567  *p = (unsigned char)'8';
568  return -1;
569  case 'y':
570  *p = (unsigned char)'9';
571  return -1;
572  }
573  *p = (unsigned char)'0';
574  return 1;
575 #else
576  if (*p >= (unsigned char)'p' && *p <= (unsigned char)'y') {
577  *p &= ~64U;
578  return -1;
579  }
580  *p = (unsigned char)'0';
581  return 1;
582 #endif
583 }
static int cob_get_sign_ebcdic ( unsigned char *  p)
static

Referenced by cob_real_get_sign().

635 {
636  switch (*p) {
637  case '{':
638  *p = (unsigned char)'0';
639  return 1;
640  case 'A':
641  *p = (unsigned char)'1';
642  return 1;
643  case 'B':
644  *p = (unsigned char)'2';
645  return 1;
646  case 'C':
647  *p = (unsigned char)'3';
648  return 1;
649  case 'D':
650  *p = (unsigned char)'4';
651  return 1;
652  case 'E':
653  *p = (unsigned char)'5';
654  return 1;
655  case 'F':
656  *p = (unsigned char)'6';
657  return 1;
658  case 'G':
659  *p = (unsigned char)'7';
660  return 1;
661  case 'H':
662  *p = (unsigned char)'8';
663  return 1;
664  case 'I':
665  *p = (unsigned char)'9';
666  return 1;
667  case '}':
668  *p = (unsigned char)'0';
669  return -1;
670  case 'J':
671  *p = (unsigned char)'1';
672  return -1;
673  case 'K':
674  *p = (unsigned char)'2';
675  return -1;
676  case 'L':
677  *p = (unsigned char)'3';
678  return -1;
679  case 'M':
680  *p = (unsigned char)'4';
681  return -1;
682  case 'N':
683  *p = (unsigned char)'5';
684  return -1;
685  case 'O':
686  *p = (unsigned char)'6';
687  return -1;
688  case 'P':
689  *p = (unsigned char)'7';
690  return -1;
691  case 'Q':
692  *p = (unsigned char)'8';
693  return -1;
694  case 'R':
695  *p = (unsigned char)'9';
696  return -1;
697  default:
698  /* What to do here */
699  *p = (unsigned char)('0' + (*p & 0x0F));
700  if (*p > (unsigned char)'9') {
701  *p = (unsigned char)'0';
702  }
703  return 1;
704  }
705 }
int cob_get_switch ( const int  n)

References cob_switch, and COB_SWITCH_MAX.

Referenced by cob_switch_value().

2077 {
2078  if (n < 0 || n > (COB_SWITCH_MAX - 1)) {
2079  return 0;
2080  }
2081  return cob_switch[n];
2082 }
char* cob_getenv ( const char *  name)

References cob_strdup(), NULL, and p.

2841 {
2842  char *p;
2843 
2844  if (name) {
2845  p = getenv (name);
2846  if (p) {
2847  return cob_strdup (p);
2848  }
2849  }
2850  return NULL;
2851 }
static const char* cob_gettmpdir ( void  )
static

References cob_fast_malloc(), cob_free(), cob_strdup(), and NULL.

Referenced by cob_temp_name().

2870 {
2871  char *tmpdir;
2872  char *tmp;
2873 #if !HAVE_SETENV
2874  char *put;
2875 #endif
2876 
2877  if ((tmpdir = getenv ("TMPDIR")) == NULL) {
2878  tmp = NULL;
2879 #ifdef _WIN32
2880  if ((tmpdir = getenv ("TEMP")) == NULL &&
2881  (tmpdir = getenv ("TMP")) == NULL &&
2882  (tmpdir = getenv ("USERPROFILE")) == NULL) {
2883  tmp = cob_fast_malloc (2U);
2884  strcpy (tmp, ".");
2885  tmpdir = tmp;
2886  }
2887 #else
2888  if ((tmpdir = getenv ("TMP")) == NULL &&
2889  (tmpdir = getenv ("TEMP")) == NULL) {
2890  tmp = cob_fast_malloc (5U);
2891  strcpy (tmp, "/tmp");
2892  tmpdir = tmp;
2893  }
2894 #endif
2895 #if HAVE_SETENV
2896  setenv("TMPDIR", tmpdir, 1);
2897 #else
2898  put = cob_fast_malloc (strlen (tmpdir) + 10);
2899  sprintf (put, "TMPDIR=%s", tmpdir);
2900  putenv (cob_strdup(put));
2901  cob_free ((void *)put);
2902 #endif
2903  if (tmp) {
2904  cob_free ((void *)tmp);
2905  tmpdir = getenv ("TMPDIR");
2906  }
2907  }
2908  return tmpdir;
2909 }
void cob_incr_temp_iteration ( void  )

References cob_temp_iteration.

Referenced by cob_srttmpfile(), and process_filename().

2926 {
2927  cob_temp_iteration++;
2928 }
void cob_init ( const int  argc,
char **  argv 
)

References _, cob_argc, cob_argv, cob_check_env_true(), cob_current_paragraph, cob_current_program_id, cob_current_section, __cob_global::cob_display_warn, runtime_env::cob_display_warn_env, __cob_global::cob_env_mangle, runtime_env::cob_env_mangle_env, COB_ERRBUF_SIZE, cob_fast_malloc(), __cob_global::cob_first_init, cob_free(), cob_init_call(), cob_init_fileio(), cob_init_intrinsic(), cob_init_move(), cob_init_numeric(), cob_init_screenio(), cob_init_strings(), cob_init_termio(), cob_initialized, COB_LARGE_BUFF, COB_LARGE_MAX, cob_last_sfile, cob_line_trace, runtime_env::cob_line_trace_env, cob_local_env, cob_local_env_size, __cob_global::cob_locale, __cob_global::cob_locale_collate, __cob_global::cob_locale_ctype, __cob_global::cob_locale_messages, __cob_global::cob_locale_monetary, __cob_global::cob_locale_numeric, __cob_global::cob_locale_orig, __cob_global::cob_locale_time, __cob_global::cob_main_argv0, cob_malloc(), COB_MEDIUM_BUFF, cob_rescan_env_vals(), cob_save_env_value(), cob_set_signal(), cob_source_file, cob_source_line, cob_source_statement, cob_strdup(), cob_switch, COB_SWITCH_MAX, __cob_global::cob_term_buff, cob_trace_env, cob_trace_file, __cob_global::cob_unix_lf, runtime_env::cob_unix_lf_env, cob_user_name, commlncnt, commlnptr, current_arg, exit_hdlrs, hdlrs, NULL, R_OK, runtime_err_str, sort_collate, and sort_nkeys.

Referenced by cob_extern_init(), cob_module_enter(), main(), and print_runtime_env().

4252 {
4253  char *s;
4254 #if defined(HAVE_READLINK) || defined(HAVE_GETEXECNAME)
4255  const char *path;
4256 #endif
4257  int i;
4258 
4259  if (cob_initialized) {
4260  return;
4261  }
4262 
4263  cobglobptr = NULL;
4264  runtimeptr = (struct runtime_env*) cob_malloc(sizeof(struct runtime_env));
4265 
4266  cob_set_signal ();
4267 
4268  cob_alloc_base = NULL;
4269  cob_local_env = NULL;
4270  cob_last_sfile = NULL;
4271  commlnptr = NULL;
4272  basext = NULL;
4273  sort_keys = NULL;
4274  sort_collate = NULL;
4275  cob_current_program_id = NULL;
4276  cob_current_section = NULL;
4277  cob_current_paragraph = NULL;
4278  cob_source_file = NULL;
4279  cob_source_statement = NULL;
4280  cob_user_name = NULL;
4281  exit_hdlrs = NULL;
4282  hdlrs = NULL;
4283  commlncnt = 0;
4284  sort_nkeys = 0;
4285  cob_source_line = 0;
4286  cob_line_trace = 0;
4287  cob_local_env_size = 0;
4288 
4289  current_arg = 1;
4290 
4291  cob_argc = argc;
4292  cob_argv = argv;
4293 
4294  /* Get emergency buffer */
4295  runtime_err_str = cob_fast_malloc ((size_t)COB_ERRBUF_SIZE);
4296 
4297  /* Get global structure */
4298  cobglobptr = cob_malloc (sizeof(cob_global));
4299 
4300  cob_initialized = 1;
4301 
4302  if (argc) {
4303  cobglobptr->cob_first_init = 1;
4304  }
4305 
4306 #ifdef HAVE_SETLOCALE
4307  /* Prime the locale from user settings */
4308  s = setlocale (LC_ALL, "");
4309  if (s) {
4310  /* Save initial values */
4311  cobglobptr->cob_locale_orig = cob_strdup (s);
4312  s = setlocale (LC_CTYPE, NULL);
4313  if (s) {
4314  cobglobptr->cob_locale_ctype = cob_strdup (s);
4315  }
4316  s = setlocale (LC_COLLATE, NULL);
4317  if (s) {
4318  cobglobptr->cob_locale_collate = cob_strdup (s);
4319  }
4320 #ifdef LC_MESSAGES
4321  s = setlocale (LC_MESSAGES, NULL);
4322  if (s) {
4323  cobglobptr->cob_locale_messages = cob_strdup (s);
4324  }
4325 #endif
4326  s = setlocale (LC_MONETARY, NULL);
4327  if (s) {
4328  cobglobptr->cob_locale_monetary = cob_strdup (s);
4329  }
4330  s = setlocale (LC_NUMERIC, NULL);
4331  if (s) {
4332  cobglobptr->cob_locale_numeric = cob_strdup (s);
4333  }
4334  s = setlocale (LC_TIME, NULL);
4335  if (s) {
4336  cobglobptr->cob_locale_time = cob_strdup (s);
4337  }
4338  /* Set to standard "C" locale for COBOL */
4339  setlocale (LC_NUMERIC, "C");
4340  setlocale (LC_CTYPE, "C");
4341  /* Save changed locale */
4342  s = setlocale (LC_ALL, NULL);
4343  if (s) {
4344  cobglobptr->cob_locale = cob_strdup (s);
4345  }
4346  }
4347 #endif
4348 
4349 #ifdef _WIN32
4350  /* Allows running of tests under Win */
4351  s = getenv ("COB_UNIX_LF");
4352  if (s) {
4353  runtimeptr->cob_unix_lf_env = cob_save_env_value(runtimeptr->cob_unix_lf_env, s);
4354 
4355  if (cob_check_env_true(s)) {
4356 
4357  cobglobptr->cob_unix_lf = 1;
4358  _setmode (_fileno (stdin), _O_BINARY);
4359  _setmode (_fileno (stdout), _O_BINARY);
4360  _setmode (_fileno (stderr), _O_BINARY);
4361  }
4362  }
4363 #endif
4364 
4365  /* Call inits with runtimeptr to get the adresses of all */
4366  cob_init_numeric(cobglobptr);
4367  cob_init_strings();
4368  cob_init_move(cobglobptr, runtimeptr);
4369  cob_init_intrinsic(cobglobptr);
4370  /* Screen-IO might be needed for error outputs */
4371  cob_init_screenio(cobglobptr, runtimeptr);
4372  cob_init_fileio(cobglobptr, runtimeptr);
4373  cob_init_call(cobglobptr, runtimeptr);
4374  cob_init_termio(cobglobptr);
4375 
4376  /* Set up library routine stuff */
4377  cobglobptr->cob_term_buff = cob_malloc ((size_t)COB_MEDIUM_BUFF);
4378  cob_rescan_env_vals ();
4379 
4380  /* Set switches */
4381  for (i = 0; i < COB_SWITCH_MAX; ++i) {
4382  sprintf (runtime_err_str, "COB_SWITCH_%d", i);
4383  s = getenv (runtime_err_str);
4384  if (s && (*s == '1' || strcasecmp (s, "ON") == 0)) {
4385  cob_switch[i] = 1;
4386  } else {
4387  cob_switch[i] = 0;
4388  }
4389  }
4390 
4391  /* Trace enable */
4392  s = getenv ("COB_SET_TRACE");
4393  if (s) {
4394  runtimeptr->cob_line_trace_env = cob_save_env_value(runtimeptr->cob_line_trace_env, s);
4395 
4396  if (cob_check_env_true(s)) {
4397  cob_line_trace = 1;
4398  }
4399  }
4400 
4401  /* Trace file */
4402  s = getenv ("COB_TRACE_FILE");
4403  if (s) {
4404  cob_trace_env = (const char*) cob_save_env_value((char*) cob_trace_env, s);
4405  cob_trace_file = NULL;
4406  } else {
4407  cob_trace_env = NULL;
4408  cob_trace_file = stderr;
4409  }
4410 
4411  /* Disable runtime warnings */
4412  cobglobptr->cob_display_warn = 1;
4413  s = getenv ("COB_DISABLE_WARNINGS");
4414  if (s) {
4415  runtimeptr->cob_display_warn_env = cob_save_env_value(runtimeptr->cob_display_warn_env, s);
4416 
4417  if (cob_check_env_true(s)) {
4418  cobglobptr->cob_display_warn = 0;
4419  }
4420  }
4421 
4422  /* Mangle environment names */
4423  s = getenv ("COB_ENV_MANGLE");
4424  if (s) {
4425  runtimeptr->cob_env_mangle_env = cob_save_env_value(runtimeptr->cob_env_mangle_env, s);
4426 
4427  if (cob_check_env_true(s)) {
4428  cobglobptr->cob_env_mangle = 1;
4429  }
4430  }
4431 
4432  /* Get user name */
4433  s = getenv ("USERNAME");
4434  if (s) {
4435  cob_user_name = cob_strdup (s);
4436  } else {
4437  s = getenv ("LOGNAME");
4438  if (s) {
4439  cob_user_name = cob_strdup (s);
4440  } else {
4441 #ifdef _WIN32
4442  unsigned long bsiz = COB_ERRBUF_SIZE;
4443  if (GetUserName (runtime_err_str, &bsiz)) {
4444  cob_user_name = cob_strdup (runtime_err_str);
4445  }
4446 #elif !defined(__OS400__)
4447  s = getlogin ();
4448  if (s) {
4449  cob_user_name = cob_strdup (s);
4450  }
4451 #endif
4452  }
4453  }
4454  if (!cob_user_name) {
4455  cob_user_name = cob_strdup (_("Unknown"));
4456  }
4457 
4458  /* This must be last in this function as we do early return */
4459  /* from certain ifdef's */
4460 
4461 #ifdef _WIN32
4462  s = cob_malloc ((size_t)COB_LARGE_BUFF);
4463  i = GetModuleFileNameA (NULL, s, COB_LARGE_MAX);
4464  if (i > 0 && i < COB_LARGE_BUFF) {
4465  cobglobptr->cob_main_argv0 = cob_strdup (s);
4466  cob_free (s);
4467  return;
4468  }
4469  cob_free (s);
4470 #elif defined(HAVE_READLINK)
4471  path = NULL;
4472  if (!access ("/proc/self/exe", R_OK)) {
4473  path = "/proc/self/exe";
4474  } else if (!access ("/proc/curproc/file", R_OK)) {
4475  path = "/proc/curproc/file";
4476  } else if (!access ("/proc/self/path/a.out", R_OK)) {
4477  path = "/proc/self/path/a.out";
4478  }
4479  if (path) {
4480  s = cob_malloc ((size_t)COB_LARGE_BUFF);
4481  i = (int)readlink (path, s, (size_t)COB_LARGE_MAX);
4482  if (i > 0 && i < COB_LARGE_BUFF) {
4483  cobglobptr->cob_main_argv0 = cob_strdup (s);
4484  cob_free (s);
4485  return;
4486  }
4487  cob_free (s);
4488  }
4489 #endif
4490 
4491 #ifdef HAVE_GETEXECNAME
4492  path = getexecname ();
4493  if (path) {
4494 #ifdef HAVE_REALPATH
4495  s = cob_malloc ((size_t)COB_LARGE_BUFF);
4496  if (realpath (path, s) != NULL) {
4497  cobglobptr->cob_main_argv0 = cob_strdup (s);
4498  } else {
4499  cobglobptr->cob_main_argv0 = cob_strdup (path);
4500  }
4501  cob_free (s);
4502 #else
4503  cobglobptr->cob_main_argv0 = cob_strdup (path);
4504 #endif
4505  return;
4506  }
4507 #endif
4508 
4509  if (argc && argv && argv[0]) {
4510 #ifdef _WIN32
4511  /* Returns malloced path or NULL */
4512  cobglobptr->cob_main_argv0 = _fullpath (NULL, argv[0], 1);
4513 #elif defined(HAVE_CANONICALIZE_FILE_NAME)
4514  /* Returns malloced path or NULL */
4515  cobglobptr->cob_main_argv0 = canonicalize_file_name (argv[0]);
4516 #elif defined(HAVE_REALPATH)
4517  s = cob_malloc ((size_t)COB_LARGE_BUFF);
4518  if (realpath (argv[0], s) != NULL) {
4519  cobglobptr->cob_main_argv0 = cob_strdup (s);
4520  }
4521  cob_free (s);
4522 #endif
4523  if (!cobglobptr->cob_main_argv0) {
4524  cobglobptr->cob_main_argv0 = cob_strdup (argv[0]);
4525  }
4526  } else {
4527  cobglobptr->cob_main_argv0 = cob_strdup (_("Unknown"));
4528  }
4529  /* The above must be last in this function as we do early return */
4530  /* from certain ifdef's */
4531 }
char* cob_int_to_formatted_bytestring ( int  i,
char *  number 
)

References cob_fast_malloc(), and NULL.

Referenced by print_runtime_env().

3845  {
3846 
3847  double d;
3848  char* strB;
3849 
3850  if(!number) return NULL;
3851 
3852  strB = (char*) cob_fast_malloc(3);
3853 
3854  if (i > (1024 * 1024)) {
3855  d = i / 1024.0 / 1024.0;
3856  strB = (char*) "MB";
3857  } else if (i > 1024) {
3858  d = i / 1024.0;
3859  strB = (char*) "kB";
3860  } else {
3861  d = 0;
3862  strB = (char*) "B";
3863  }
3864  sprintf(number, "%3.2f %s", d, strB);
3865  return number;
3866 }
char* cob_int_to_string ( int  i,
char *  number 
)

References NULL.

Referenced by print_runtime_env().

3838  {
3839  if(!number) return NULL;
3840  sprintf(number, "%i", i);
3841  return number;
3842 }
int cob_is_alpha ( const cob_field *  f)

References cob_field::data, and cob_field::size.

2234 {
2235  size_t i;
2236 
2237  for (i = 0; i < f->size; ++i) {
2238  if (!isalpha (f->data[i]) && f->data[i] != (unsigned char)' ') {
2239  return 0;
2240  }
2241  }
2242  return 1;
2243 }
int cob_is_lower ( const cob_field *  f)

References cob_field::data, and cob_field::size.

2260 {
2261  size_t i;
2262 
2263  for (i = 0; i < f->size; ++i) {
2264  if (!islower (f->data[i]) && f->data[i] != (unsigned char)' ') {
2265  return 0;
2266  }
2267  }
2268  return 1;
2269 }
int cob_is_numeric ( const cob_field *  f)

References cob_check_numdisp(), COB_FIELD_HAVE_SIGN, COB_FIELD_NO_SIGN_NIBBLE, COB_FIELD_TYPE, COB_MODULE_PTR, COB_TYPE_NUMERIC_BINARY, COB_TYPE_NUMERIC_DISPLAY, COB_TYPE_NUMERIC_DOUBLE, COB_TYPE_NUMERIC_FLOAT, COB_TYPE_NUMERIC_FP_DEC128, COB_TYPE_NUMERIC_FP_DEC64, COB_TYPE_NUMERIC_PACKED, cob_field::data, sign, and cob_field::size.

Referenced by cob_check_numeric().

2156 {
2157  size_t i;
2158  union {
2159  float fpf;
2160  double fpd;
2161  } fval;
2162  int sign;
2163 
2164  switch (COB_FIELD_TYPE (f)) {
2165  case COB_TYPE_NUMERIC_BINARY:
2166  return 1;
2167  case COB_TYPE_NUMERIC_FLOAT:
2168  memcpy (&fval.fpf, f->data, sizeof(float));
2169  return !finite ((double)fval.fpf);
2170  case COB_TYPE_NUMERIC_DOUBLE:
2171  memcpy (&fval.fpd, f->data, sizeof(double));
2172  return !finite (fval.fpd);
2173  case COB_TYPE_NUMERIC_PACKED:
2174  /* Check digits */
2175  for (i = 0; i < f->size - 1; ++i) {
2176  if ((f->data[i] & 0xF0) > 0x90 ||
2177  (f->data[i] & 0x0F) > 0x09) {
2178  return 0;
2179  }
2180  }
2181  /* Check high nibble of last byte */
2182  if ((f->data[i] & 0xF0) > 0x90) {
2183  return 0;
2184  }
2185 
2186  if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
2187  /* COMP-6 - Check last nibble */
2188  if ((f->data[i] & 0x0F) > 0x09) {
2189  return 0;
2190  }
2191  return 1;
2192  }
2193 
2194  /* Check sign */
2195  sign = f->data[i] & 0x0F;
2196  if (COB_FIELD_HAVE_SIGN (f)) {
2197  if (sign == 0x0C || sign == 0x0D) {
2198  return 1;
2199  }
2200  if (COB_MODULE_PTR->flag_host_sign &&
2201  sign == 0x0F) {
2202  return 1;
2203  }
2204  } else if (sign == 0x0F) {
2205  return 1;
2206  }
2207  return 0;
2208  case COB_TYPE_NUMERIC_DISPLAY:
2209  return cob_check_numdisp (f);
2210  case COB_TYPE_NUMERIC_FP_DEC64:
2211 #ifdef WORDS_BIGENDIAN
2212  return (f->data[0] & 0x78U) != 0x78U;
2213 #else
2214  return (f->data[7] & 0x78U) != 0x78U;
2215 #endif
2216  case COB_TYPE_NUMERIC_FP_DEC128:
2217 #ifdef WORDS_BIGENDIAN
2218  return (f->data[0] & 0x78U) != 0x78U;
2219 #else
2220  return (f->data[15] & 0x78U) != 0x78U;
2221 #endif
2222  default:
2223  for (i = 0; i < f->size; ++i) {
2224  if (!isdigit (f->data[i])) {
2225  return 0;
2226  }
2227  }
2228  return 1;
2229  }
2230 }
int cob_is_omitted ( const cob_field *  f)

References cob_field::data, and NULL.

2150 {
2151  return f->data == NULL;
2152 }
int cob_is_upper ( const cob_field *  f)

References cob_field::data, and cob_field::size.

2247 {
2248  size_t i;
2249 
2250  for (i = 0; i < f->size; ++i) {
2251  if (!isupper (f->data[i]) && f->data[i] != (unsigned char)' ') {
2252  return 0;
2253  }
2254  }
2255  return 1;
2256 }
void* cob_malloc ( const size_t  size)

References cob_fatal_error(), COB_FERROR_MEMORY, and unlikely.

Referenced by alloc_figurative(), cache_dynload(), cache_preload(), cob_accept_command_line(), cob_allocate(), cob_cache_file(), cob_cache_malloc(), cob_cache_realloc(), cob_call(), cob_decimal_get_field(), cob_decimal_push(), cob_display_command_line(), cob_display_env_value(), cob_display_environment(), cob_external_addr(), cob_fatal_error(), cob_file_sort_giving(), cob_file_sort_init(), cob_get_environment(), cob_init(), cob_init_call(), cob_init_fileio(), cob_init_intrinsic(), cob_init_numeric(), cob_init_strings(), cob_intr_concatenate(), cob_intr_exception_location(), cob_intr_locale_compare(), cob_intr_median(), cob_intr_numval(), cob_intr_numval_c(), cob_intr_numval_f(), cob_intr_substitute(), cob_intr_substitute_case(), cob_move_all(), cob_move_edited_to_display(), cob_resolve_internal(), cob_save_func(), cob_set_library_path(), cob_set_locale(), cob_srttmpfile(), cob_str_from_fld(), cob_strdup(), cob_sys_error_proc(), cob_sys_exit_proc(), cob_sys_getopt_long_long(), cob_sys_system(), cob_table_sort_init(), cob_unstring_init(), indexed_open(), indexed_write(), indirect_move(), insert(), and make_field_entry().

1123 {
1124  void *mptr;
1125 
1126  mptr = calloc ((size_t)1, size);
1127  if (unlikely(!mptr)) {
1128  cob_fatal_error (COB_FERROR_MEMORY);
1129  }
1130  return mptr;
1131 }
static void cob_memcpy ( cob_field *  dst,
const void *  src,
const size_t  size 
)
static

References cob_field::attr, cob_move(), cob_u8_ptr, const_alpha_attr, cob_field::data, and cob_field::size.

Referenced by cob_accept_arg_value(), cob_accept_command_line(), cob_accept_date(), cob_accept_date_yyyymmdd(), cob_accept_day(), cob_accept_day_of_week(), cob_accept_day_yyyyddd(), cob_accept_environment(), cob_accept_time(), cob_accept_user_name(), and cob_get_environment().

930 {
931  cob_field temp;
932 
933  if (!dst->size) {
934  return;
935  }
936  temp.size = size;
937  temp.data = (cob_u8_ptr)src;
938  temp.attr = &const_alpha_attr;
939  cob_move (&temp, dst);
940 }
void cob_module_enter ( cob_module **  module,
cob_global **  mglobal,
const int  auto_init 
)

References cob_cache_malloc(), __cob_global::cob_call_params, cob_fatal_error(), COB_FERROR_INITIALIZED, cob_init(), cob_initialized, COB_MODULE_PTR, cobglobptr, NULL, and unlikely.

1578 {
1579  /* Check initialized */
1580  if (unlikely(!cob_initialized)) {
1581  if (auto_init) {
1582  cob_init (0, NULL);
1583  } else {
1584  cob_fatal_error (COB_FERROR_INITIALIZED);
1585  }
1586  }
1587 
1588  /* Set global pointer */
1589  *mglobal = cobglobptr;
1590 
1591  /* Check module pointer */
1592  if (!*module) {
1593  *module = cob_cache_malloc (sizeof(cob_module));
1594  }
1595 
1596 #if 0 /* RXWRXW - Params */
1597  /* Save parameter count */
1598  (*module)->module_num_params = cobglobptr->cob_call_params;
1599 #endif
1600 
1601  /* Push module pointer */
1602  (*module)->next = COB_MODULE_PTR;
1603  COB_MODULE_PTR = *module;
1604 }
void cob_module_leave ( cob_module *  module)

References COB_MODULE_PTR, and COB_UNUSED.

1608 {
1609  COB_UNUSED (module);
1610  /* Pop module pointer */
1611  COB_MODULE_PTR = COB_MODULE_PTR->next;
1612 }
void cob_parameter_check ( const char *  funcname,
const int  numparms 
)

References _, __cob_global::cob_call_params, cob_runtime_error(), and cob_stop_run().

1688 {
1689  if (cobglobptr->cob_call_params < numparms) {
1690  cob_runtime_error (_("CALL to %s requires %d parameters"),
1691  funcname, numparms);
1692  cob_stop_run (1);
1693  }
1694 }
static void cob_put_sign_ascii ( unsigned char *  p)
static

Referenced by cb_build_move_literal(), and cob_real_put_sign().

587 {
588 #ifdef COB_EBCDIC_MACHINE
589  switch (*p) {
590  case '0':
591  *p = (unsigned char)'p';
592  return;
593  case '1':
594  *p = (unsigned char)'q';
595  return;
596  case '2':
597  *p = (unsigned char)'r';
598  return;
599  case '3':
600  *p = (unsigned char)'s';
601  return;
602  case '4':
603  *p = (unsigned char)'t';
604  return;
605  case '5':
606  *p = (unsigned char)'u';
607  return;
608  case '6':
609  *p = (unsigned char)'v';
610  return;
611  case '7':
612  *p = (unsigned char)'w';
613  return;
614  case '8':
615  *p = (unsigned char)'x';
616  return;
617  case '9':
618  *p = (unsigned char)'y';
619  return;
620  default:
621  *p = (unsigned char)'0';
622  }
623 #else
624  *p |= 64U;
625 #endif
626 }
static void cob_put_sign_ebcdic ( unsigned char *  p,
const int  sign 
)
static

Referenced by cob_real_put_sign().

709 {
710  if (sign < 0) {
711  switch (*p) {
712  case '0':
713  *p = (unsigned char)'}';
714  return;
715  case '1':
716  *p = (unsigned char)'J';
717  return;
718  case '2':
719  *p = (unsigned char)'K';
720  return;
721  case '3':
722  *p = (unsigned char)'L';
723  return;
724  case '4':
725  *p = (unsigned char)'M';
726  return;
727  case '5':
728  *p = (unsigned char)'N';
729  return;
730  case '6':
731  *p = (unsigned char)'O';
732  return;
733  case '7':
734  *p = (unsigned char)'P';
735  return;
736  case '8':
737  *p = (unsigned char)'Q';
738  return;
739  case '9':
740  *p = (unsigned char)'R';
741  return;
742  default:
743  /* What to do here */
744  *p = (unsigned char)'{';
745  return;
746  }
747  }
748  switch (*p) {
749  case '0':
750  *p = (unsigned char)'{';
751  return;
752  case '1':
753  *p = (unsigned char)'A';
754  return;
755  case '2':
756  *p = (unsigned char)'B';
757  return;
758  case '3':
759  *p = (unsigned char)'C';
760  return;
761  case '4':
762  *p = (unsigned char)'D';
763  return;
764  case '5':
765  *p = (unsigned char)'E';
766  return;
767  case '6':
768  *p = (unsigned char)'F';
769  return;
770  case '7':
771  *p = (unsigned char)'G';
772  return;
773  case '8':
774  *p = (unsigned char)'H';
775  return;
776  case '9':
777  *p = (unsigned char)'I';
778  return;
779  default:
780  /* What to do here */
781  *p = (unsigned char)'{';
782  return;
783  }
784 }
int cob_putenv ( char *  name)

References cob_rescan_env_vals(), and cob_strdup().

2855 {
2856  int ret;
2857 
2858  if (name && strchr (name, '=')) {
2859  ret = putenv (cob_strdup(name));
2860  if (!ret) {
2861  cob_rescan_env_vals ();
2862  }
2863  return ret;
2864  }
2865  return -1;
2866 }
void cob_ready_trace ( void  )

References cob_line_trace.

1305 {
1306  cob_line_trace = 1;
1307 }
int cob_real_get_sign ( cob_field *  f)

References COB_FIELD_NO_SIGN_NIBBLE, COB_FIELD_SIGN_LEADING, COB_FIELD_SIGN_SEPARATE, COB_FIELD_TYPE, cob_get_sign_ascii(), cob_get_sign_ebcdic(), COB_MODULE_PTR, COB_TYPE_NUMERIC_DISPLAY, COB_TYPE_NUMERIC_PACKED, cob_field::data, p, cob_field::size, and unlikely.

1986 {
1987  unsigned char *p;
1988 
1989  switch (COB_FIELD_TYPE (f)) {
1990  case COB_TYPE_NUMERIC_DISPLAY:
1991  /* Locate sign */
1992  if (unlikely(COB_FIELD_SIGN_LEADING (f))) {
1993  p = f->data;
1994  } else {
1995  p = f->data + f->size - 1;
1996  }
1997 
1998  /* Get sign */
1999  if (unlikely(COB_FIELD_SIGN_SEPARATE (f))) {
2000  return (*p == '-') ? -1 : 1;
2001  }
2002  if (*p >= (unsigned char)'0' && *p <= (unsigned char)'9') {
2003  return 1;
2004  }
2005  if (*p == ' ') {
2006 #if 0 /* RXWRXW - Space sign */
2007  *p = (unsigned char)'0';
2008 #endif
2009  return 1;
2010  }
2011  if (unlikely(COB_MODULE_PTR->ebcdic_sign)) {
2012  return cob_get_sign_ebcdic (p);
2013  }
2014  return cob_get_sign_ascii (p);
2015  case COB_TYPE_NUMERIC_PACKED:
2016  if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
2017  return 1;
2018  }
2019  p = f->data + f->size - 1;
2020  return ((*p & 0x0F) == 0x0D) ? -1 : 1;
2021  }
2022  return 0;
2023 }
void cob_real_put_sign ( cob_field *  f,
const int  sign 
)

References COB_FIELD_NO_SIGN_NIBBLE, COB_FIELD_SIGN_LEADING, COB_FIELD_SIGN_SEPARATE, COB_FIELD_TYPE, COB_MODULE_PTR, cob_put_sign_ascii(), cob_put_sign_ebcdic(), COB_TYPE_NUMERIC_DISPLAY, COB_TYPE_NUMERIC_PACKED, cob_u8_t, cob_field::data, p, cob_field::size, and unlikely.

2027 {
2028  unsigned char *p;
2029  unsigned char c;
2030 
2031  switch (COB_FIELD_TYPE (f)) {
2032  case COB_TYPE_NUMERIC_DISPLAY:
2033  /* Locate sign */
2034  if (unlikely(COB_FIELD_SIGN_LEADING (f))) {
2035  p = f->data;
2036  } else {
2037  p = f->data + f->size - 1;
2038  }
2039 
2040  /* Put sign */
2041  if (unlikely(COB_FIELD_SIGN_SEPARATE (f))) {
2042  c = (sign < 0) ? (cob_u8_t)'-' : (cob_u8_t)'+';
2043  if (*p != c) {
2044  *p = c;
2045  }
2046  } else if (unlikely(COB_MODULE_PTR->ebcdic_sign)) {
2047  cob_put_sign_ebcdic (p, sign);
2048  } else if (sign < 0) {
2049  cob_put_sign_ascii (p);
2050  }
2051  return;
2052  case COB_TYPE_NUMERIC_PACKED:
2053  if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
2054  return;
2055  }
2056  p = f->data + f->size - 1;
2057  if (sign < 0) {
2058  *p = (*p & 0xF0) | 0x0D;
2059  } else {
2060  *p = (*p & 0xF0) | 0x0C;
2061  }
2062  return;
2063  }
2064 }
void cob_reg_sighnd ( void(*)(int)  sighnd)

References cob_ext_sighdl.

2069 {
2070  cob_ext_sighdl = sighnd;
2071 }
static void cob_rescan_env_vals ( void  )
static

References runtime_env::cob_beep_str_env, __cob_global::cob_beep_value, cob_check_env_false(), cob_check_env_true(), __cob_global::cob_disp_to_stderr, runtime_env::cob_disp_to_stderr_env, __cob_global::cob_extended_status, runtime_env::cob_extended_status_env, cob_save_env_value(), __cob_global::cob_timeout_scale, runtime_env::cob_timeout_scale_env, __cob_global::cob_use_esc, and runtime_env::cob_use_esc_env.

Referenced by cob_display_env_value(), cob_init(), and cob_putenv().

987 {
988  char *s, *tail;
989  int timeout_scale;
990 
991  /* termio */
992  s = getenv("COB_REDIRECT_DISPLAY");
993  if (s) {
994  runtimeptr->cob_disp_to_stderr_env = cob_save_env_value(runtimeptr->cob_disp_to_stderr_env, s);
995 
996  if (cob_check_env_true(s)) {
997  cobglobptr->cob_disp_to_stderr = 1;
998  } else {
999  cobglobptr->cob_disp_to_stderr = 0;
1000  }
1001  }
1002 
1003  /* screenio */
1004 
1005  /* BELL disposition */
1006  /* Default to BEEP */
1007  cobglobptr->cob_beep_value = 0;
1008  s = getenv("COB_BELL");
1009  if (s) {
1010  runtimeptr->cob_beep_str_env = cob_save_env_value(
1011  runtimeptr->cob_beep_str_env, s);
1012  if (!strcasecmp(s, "FLASH")) {
1013  cobglobptr->cob_beep_value = 1;
1014  } else if (!strcasecmp(s, "SPEAKER")) {
1015  cobglobptr->cob_beep_value = 2;
1016  } else if (cob_check_env_false (s)) {
1017  cobglobptr->cob_beep_value = 9;
1018  }
1019  }
1020 
1021  /* TIMEOUT scaling */
1022  cobglobptr->cob_timeout_scale = 1000;
1023  s = getenv ("COB_TIMEOUT_SCALE");
1024  if (s) {
1025  runtimeptr->cob_timeout_scale_env = cob_save_env_value(
1026  runtimeptr->cob_timeout_scale_env, s);
1027 
1028  if (strlen(s) == 1) {
1029  switch(s[0]) {
1030  case '1':
1031  cobglobptr->cob_timeout_scale = 100; break;
1032  case '2':
1033  cobglobptr->cob_timeout_scale = 10; break;
1034  case '3':
1035  cobglobptr->cob_timeout_scale = 1; break;
1036  }
1037  }
1038  else {
1039  timeout_scale = (int) strtol(s, &tail, 10);
1040  if((!tail || strlen(tail) == 0) && timeout_scale >= 0) {
1041  cobglobptr->cob_timeout_scale = timeout_scale;
1042  }
1043  }
1044  }
1045 
1046  /* Extended ACCEPT status returns */
1047  cobglobptr->cob_extended_status = 0;
1048  cobglobptr->cob_use_esc = 0;
1049  s = getenv ("COB_SCREEN_EXCEPTIONS");
1050  if (s) {
1051  runtimeptr->cob_extended_status_env = cob_save_env_value(
1052  runtimeptr->cob_extended_status_env, s);
1053 
1054  if (cob_check_env_true(s)) {
1055  cobglobptr->cob_extended_status = 1;
1056  s = getenv ("COB_SCREEN_ESC");
1057  if (s) {
1058  runtimeptr->cob_use_esc_env = cob_save_env_value(
1059  runtimeptr->cob_use_esc_env, s);
1060 
1061  if (cob_check_env_true(s)) {
1062  cobglobptr->cob_use_esc = 1;
1063  }
1064  }
1065  }
1066  }
1067 }
void cob_reset_trace ( void  )

References cob_line_trace.

1311 {
1312  cob_line_trace = 0;
1313 }
void cob_restore_func ( struct cob_func_loc *  fl)

References __cob_global::cob_call_params, cob_free(), COB_MODULE_PTR, cob_func_loc::data, cob_func_loc::func_params, cob_func_loc::save_call_params, cob_func_loc::save_module, cob_func_loc::save_num_params, and cob_func_loc::save_proc_parms.

1660 {
1661  /* Restore calling environment */
1662  cobglobptr->cob_call_params = fl->save_call_params;
1663 #if 0 /* RXWRXW - MODNEXT */
1664  COB_MODULE_PTR->next = fl->save_module;
1665 #endif
1666  COB_MODULE_PTR->cob_procedure_params = fl->save_proc_parms;
1667  COB_MODULE_PTR->module_num_params = fl->save_num_params;
1668  cob_free (fl->data);
1669  cob_free (fl->func_params);
1670  cob_free (fl);
1671 }
void cob_runtime_error ( const char *  fmt,
  ... 
)

References _, cob_exit_screen(), cob_free(), cob_source_file, cob_source_line, hdlrs, handlerlist::next, NULL, p, handlerlist::proc, and runtime_err_str.

Referenced by cob_call(), cob_call_error(), cob_cancel(), cob_check_based(), cob_check_numeric(), cob_check_odo(), cob_check_ref_mod(), cob_check_subscript(), cob_check_version(), cob_command_line(), cob_external_addr(), cob_fatal_error(), cob_get_sort_tempfile(), cob_longjmp(), cob_parameter_check(), cob_resolve_func(), cob_savenv(), cob_sys_check_file_exist(), cob_sys_file_info(), cob_sys_getopt_long_long(), and cob_sys_system().

1386 {
1387  struct handlerlist *h;
1388  struct handlerlist *hp;
1389  char *p;
1390  va_list ap;
1391 
1392 #if 1 /* RXWRXW - Exit screen */
1393  /* Exit screen mode early */
1394  cob_exit_screen ();
1395 #endif
1396 
1397  if (hdlrs != NULL) {
1398  if (runtime_err_str) {
1399  p = runtime_err_str;
1400  if (cob_source_file) {
1401  sprintf (runtime_err_str, "%s: %u: ",
1402  cob_source_file, cob_source_line);
1403  p = runtime_err_str + strlen (runtime_err_str);
1404  }
1405  va_start (ap, fmt);
1406  vsprintf (p, fmt, ap);
1407  va_end (ap);
1408  }
1409  h = hdlrs;
1410  while (h != NULL) {
1411  if (runtime_err_str) {
1412  h->proc (runtime_err_str);
1413  } else {
1414  h->proc ((char *)_("Malloc error"));
1415  }
1416  hp = h;
1417  h = h->next;
1418  cob_free (hp);
1419  }
1420  hdlrs = NULL;
1421  }
1422 
1423  /* Prefix */
1424  if (cob_source_file) {
1425  fprintf (stderr, "%s: %u: ", cob_source_file, cob_source_line);
1426  }
1427  fputs ("libcob: ", stderr);
1428 
1429  /* Body */
1430  va_start (ap, fmt);
1431  vfprintf (stderr, fmt, ap);
1432  va_end (ap);
1433 
1434  /* Postfix */
1435  putc ('\n', stderr);
1436  fflush (stderr);
1437 }
char* cob_save_env_value ( char *  env_var,
char *  env_val 
)

References cob_fast_malloc(), cob_free(), and NULL.

Referenced by cob_init(), cob_init_call(), cob_init_fileio(), cob_init_screenio(), and cob_rescan_env_vals().

3914  {
3915  if (!env_val) return NULL;
3916 
3917  if (env_var) cob_free(env_var);
3918  env_var = (char*) cob_fast_malloc(strlen(env_val) + 1);
3919  strcpy(env_var, env_val);
3920 
3921  return env_var;
3922 }
void* cob_save_func ( cob_field **  savefld,
const int  params,
const int  eparams,
  ... 
)

References __cob_global::cob_call_params, cob_malloc(), COB_MODULE_PTR, cob_field::data, cob_func_loc::data, cob_func_loc::func_params, params, cob_func_loc::save_call_params, cob_func_loc::save_module, cob_func_loc::save_num_params, cob_func_loc::save_proc_parms, and unlikely.

1617 {
1618  struct cob_func_loc *fl;
1619  va_list args;
1620  int numparams;
1621  int n;
1622 
1623  if (unlikely(params > eparams)) {
1624  numparams = eparams;
1625  } else {
1626  numparams = params;
1627  }
1628 
1629  /* Allocate return field */
1630  *savefld = cob_malloc (sizeof (cob_field));
1631  /* Allocate save area */
1632  fl = cob_malloc (sizeof(struct cob_func_loc));
1633  fl->func_params = cob_malloc (sizeof(void *) * ((size_t)numparams + 1U));
1634  fl->data = cob_malloc (sizeof(void *) * ((size_t)numparams + 1U));
1635 
1636  /* Save values */
1637  fl->save_module = COB_MODULE_PTR->next;
1638  fl->save_call_params = cobglobptr->cob_call_params;
1639  fl->save_proc_parms = COB_MODULE_PTR->cob_procedure_params;
1640  fl->save_num_params = COB_MODULE_PTR->module_num_params;
1641 
1642  /* Set current values */
1643  COB_MODULE_PTR->cob_procedure_params = fl->func_params;
1644  cobglobptr->cob_call_params = numparams;
1645  if (numparams) {
1646  va_start (args, eparams);
1647  for (n = 0; n < numparams; ++n) {
1648  fl->func_params[n] = va_arg (args, cob_field *);
1649  if (fl->func_params[n]) {
1650  fl->data[n] = fl->func_params[n]->data;
1651  }
1652  }
1653  va_end (args);
1654  }
1655  return fl;
1656 }
void cob_set_environment ( const cob_field *  f1,
const cob_field *  f2 
)

References cob_display_env_value(), and cob_display_environment().

2678 {
2679  cob_display_environment (f1);
2680  cob_display_env_value (f2);
2681 }
void cob_set_exception ( const int  id)

References cob_current_paragraph, cob_current_program_id, cob_current_section, __cob_global::cob_exception_code, cob_exception_tab_code, __cob_global::cob_got_exception, __cob_global::cob_orig_line, __cob_global::cob_orig_paragraph, __cob_global::cob_orig_program_id, __cob_global::cob_orig_section, __cob_global::cob_orig_statement, cob_source_line, and cob_source_statement.

Referenced by cob_accept(), cob_accept_arg_value(), cob_accept_environment(), cob_alloc_field(), cob_allocate(), cob_call_field(), cob_check_odo(), cob_check_ref_mod(), cob_check_subscript(), cob_decimal_div(), cob_decimal_do_round(), cob_decimal_get_binary(), cob_decimal_get_display(), cob_decimal_get_field(), cob_decimal_get_ieee128dec(), cob_decimal_get_ieee64dec(), cob_decimal_get_packed(), cob_decimal_pow(), cob_display_arg_number(), cob_display_env_value(), cob_free_alloc(), cob_get_environment(), cob_inspect_converting(), cob_inspect_init(), cob_intr_acos(), cob_intr_annuity(), cob_intr_asin(), cob_intr_atan(), cob_intr_binop(), cob_intr_combined_datetime(), cob_intr_cos(), cob_intr_currency_symbol(), cob_intr_date_of_integer(), cob_intr_date_to_yyyymmdd(), cob_intr_day_of_integer(), cob_intr_day_to_yyyyddd(), cob_intr_exp(), cob_intr_exp10(), cob_intr_factorial(), cob_intr_formatted_date(), cob_intr_formatted_datetime(), cob_intr_formatted_time(), cob_intr_highest_algebraic(), cob_intr_integer_of_date(), cob_intr_integer_of_day(), cob_intr_lcl_time_from_secs(), cob_intr_locale_compare(), cob_intr_locale_date(), cob_intr_locale_time(), cob_intr_log(), cob_intr_log10(), cob_intr_lowest_algebraic(), cob_intr_mon_decimal_point(), cob_intr_mon_thousands_sep(), cob_intr_num_decimal_point(), cob_intr_num_thousands_sep(), cob_intr_numval(), cob_intr_numval_c(), cob_intr_numval_f(), cob_intr_seconds_from_formatted_time(), cob_intr_sin(), cob_intr_sqrt(), cob_intr_standard_deviation(), cob_intr_tan(), cob_intr_year_to_yyyy(), cob_mod_or_rem(), cob_resolve_cobol(), cob_resolve_internal(), cob_set_locale(), cob_string_append(), cob_string_init(), cob_unstring_finish(), cob_unstring_init(), inspect_common(), save_status(), and set_resolve_error().

1092 {
1093  cobglobptr->cob_exception_code = cob_exception_tab_code[id];
1094  if (cobglobptr->cob_exception_code) {
1095  cobglobptr->cob_got_exception = 1;
1096  cobglobptr->cob_orig_statement = cob_source_statement;
1097  cobglobptr->cob_orig_line = cob_source_line;
1098  cobglobptr->cob_orig_program_id = cob_current_program_id;
1099  cobglobptr->cob_orig_section = cob_current_section;
1100  cobglobptr->cob_orig_paragraph = cob_current_paragraph;
1101  }
1102 }
void cob_set_locale ( cob_field *  locale,
const int  category 
)

References cob_field_to_string(), cob_free(), COB_LC_ALL, COB_LC_CLASS, COB_LC_COLLATE, COB_LC_CTYPE, COB_LC_MESSAGES, COB_LC_MONETARY, COB_LC_NUMERIC, COB_LC_TIME, COB_LC_USER, __cob_global::cob_locale, __cob_global::cob_locale_ctype, __cob_global::cob_locale_orig, cob_malloc(), cob_set_exception(), cob_strdup(), NULL, p, and cob_field::size.

3766 {
3767 #ifdef HAVE_SETLOCALE
3768  char *p;
3769  char *buff;
3770 
3771  p = NULL;
3772  if (locale) {
3773  if (locale->size == 0) {
3774  return;
3775  }
3776  buff = cob_malloc (locale->size + 1U);
3777  cob_field_to_string (locale, buff, locale->size);
3778  } else {
3779  buff = NULL;
3780  }
3781 
3782  switch (category) {
3783  case COB_LC_COLLATE:
3784  p = setlocale (LC_COLLATE, buff);
3785  break;
3786  case COB_LC_CTYPE:
3787  p = setlocale (LC_CTYPE, buff);
3788  break;
3789 #ifdef LC_MESSAGES
3790  case COB_LC_MESSAGES:
3791  p = setlocale (LC_MESSAGES, buff);
3792  break;
3793 #endif
3794  case COB_LC_MONETARY:
3795  p = setlocale (LC_MONETARY, buff);
3796  break;
3797  case COB_LC_NUMERIC:
3798  p = setlocale (LC_NUMERIC, buff);
3799  break;
3800  case COB_LC_TIME:
3801  p = setlocale (LC_TIME, buff);
3802  break;
3803  case COB_LC_ALL:
3804  p = setlocale (LC_ALL, buff);
3805  break;
3806  case COB_LC_USER:
3807  if (cobglobptr->cob_locale_orig) {
3808  p = setlocale (LC_ALL, cobglobptr->cob_locale_orig);
3809  (void)setlocale (LC_NUMERIC, "C");
3810  }
3811  break;
3812  case COB_LC_CLASS:
3813  if (cobglobptr->cob_locale_ctype) {
3814  p = setlocale (LC_CTYPE, cobglobptr->cob_locale_ctype);
3815  }
3816  break;
3817  }
3818  if (buff) {
3819  cob_free (buff);
3820  }
3821  if (!p) {
3822  cob_set_exception (COB_EC_LOCALE_MISSING);
3823  return;
3824  }
3825  p = setlocale (LC_ALL, NULL);
3826  if (p) {
3827  if (cobglobptr->cob_locale) {
3828  cob_free (cobglobptr->cob_locale);
3829  }
3830  cobglobptr->cob_locale = cob_strdup (p);
3831  }
3832 #else
3833  cob_set_exception (COB_EC_LOCALE_MISSING);
3834 #endif
3835 }
void cob_set_location ( const char *  sfile,
const unsigned int  sline,
const char *  csect,
const char *  cpara,
const char *  cstatement 
)

References cob_check_trace_file(), cob_current_paragraph, cob_current_program_id, cob_current_section, cob_last_sfile, cob_line_trace, COB_MODULE_PTR, cob_source_file, cob_source_line, cob_source_statement, and cob_trace_file.

1241 {
1242  const char *s;
1243 
1244  cob_current_program_id = COB_MODULE_PTR->module_name;
1245  cob_source_file = sfile;
1246  cob_source_line = sline;
1247  cob_current_section = csect;
1248  cob_current_paragraph = cpara;
1249  if (cstatement) {
1250  cob_source_statement = cstatement;
1251  }
1252  if (cob_line_trace) {
1253  if (!cob_trace_file) {
1254  cob_check_trace_file ();
1255  }
1256  if (!cob_last_sfile || strcmp (cob_last_sfile, sfile)) {
1257  cob_last_sfile = sfile;
1258  fprintf (cob_trace_file, "Source : '%s'\n", sfile);
1259  }
1260  if (COB_MODULE_PTR->module_name) {
1261  s = COB_MODULE_PTR->module_name;
1262  } else {
1263  s = "Unknown";
1264  }
1265  fprintf (cob_trace_file,
1266  "Program-Id: %-16s Statement: %-21.21s Line: %u\n",
1267  s, cstatement ? (char *)cstatement : "Unknown",
1268  sline);
1269  fflush (cob_trace_file);
1270  }
1271 }
static void cob_set_signal ( void  )
static

References NULL.

Referenced by cob_init().

437 {
438 #ifdef HAVE_SIGNAL_H
439 
440 #ifdef HAVE_SIGACTION
441  struct sigaction sa;
442  struct sigaction osa;
443 
444  memset (&sa, 0, sizeof(sa));
445  sa.sa_handler = cob_sig_handler;
446 #ifdef SA_RESETHAND
447  sa.sa_flags = SA_RESETHAND;
448 #else
449  sa.sa_flags = 0;
450 #endif
451 #ifdef SA_NOCLDSTOP
452  sa.sa_flags |= SA_NOCLDSTOP;
453 #endif
454 
455 #ifdef SIGINT
456  (void)sigaction (SIGINT, NULL, &osa);
457  if (osa.sa_handler != SIG_IGN) {
458  (void)sigemptyset (&sa.sa_mask);
459  (void)sigaction (SIGINT, &sa, NULL);
460  }
461 #endif
462 #ifdef SIGHUP
463  (void)sigaction (SIGHUP, NULL, &osa);
464  if (osa.sa_handler != SIG_IGN) {
465  (void)sigemptyset (&sa.sa_mask);
466  (void)sigaction (SIGHUP, &sa, NULL);
467  }
468 #endif
469 #ifdef SIGQUIT
470  (void)sigaction (SIGQUIT, NULL, &osa);
471  if (osa.sa_handler != SIG_IGN) {
472  (void)sigemptyset (&sa.sa_mask);
473  (void)sigaction (SIGQUIT, &sa, NULL);
474  }
475 #endif
476 #ifdef SIGTERM
477  (void)sigaction (SIGTERM, NULL, &osa);
478  if (osa.sa_handler != SIG_IGN) {
479  (void)sigemptyset (&sa.sa_mask);
480  (void)sigaction (SIGTERM, &sa, NULL);
481  }
482 #endif
483 #ifdef SIGPIPE
484  (void)sigaction (SIGPIPE, NULL, &osa);
485  if (osa.sa_handler != SIG_IGN) {
486  (void)sigemptyset (&sa.sa_mask);
487  (void)sigaction (SIGPIPE, &sa, NULL);
488  }
489 #endif
490 #ifdef SIGSEGV
491  /* Take direct control of segmentation violation */
492  (void)sigemptyset (&sa.sa_mask);
493  (void)sigaction (SIGSEGV, &sa, NULL);
494 #endif
495 
496 #else
497 
498 #ifdef SIGINT
499  if (signal (SIGINT, SIG_IGN) != SIG_IGN) {
500  (void)signal (SIGINT, cob_sig_handler);
501  }
502 #endif
503 #ifdef SIGHUP
504  if (signal (SIGHUP, SIG_IGN) != SIG_IGN) {
505  (void)signal (SIGHUP, cob_sig_handler);
506  }
507 #endif
508 #ifdef SIGQUIT
509  if (signal (SIGQUIT, SIG_IGN) != SIG_IGN) {
510  (void)signal (SIGQUIT, cob_sig_handler);
511  }
512 #endif
513 #ifdef SIGTERM
514  if (signal (SIGTERM, SIG_IGN) != SIG_IGN) {
515  (void)signal (SIGTERM, cob_sig_handler);
516  }
517 #endif
518 #ifdef SIGPIPE
519  if (signal (SIGPIPE, SIG_IGN) != SIG_IGN) {
520  (void)signal (SIGPIPE, cob_sig_handler);
521  }
522 #endif
523 #ifdef SIGSEGV
524  /* Take direct control of segmentation violation */
525  (void)signal (SIGSEGV, cob_sig_handler);
526 #endif
527 
528 #endif
529 #endif
530 }
void cob_set_switch ( const int  n,
const int  flag 
)

References cob_switch, and COB_SWITCH_MAX.

2086 {
2087  if (n < 0 || n > (COB_SWITCH_MAX - 1)) {
2088  return;
2089  }
2090  if (flag == 0) {
2091  cob_switch[n] = 0;
2092  } else if (flag == 1) {
2093  cob_switch[n] = 1;
2094  }
2095 }
void cob_stop_run ( const int  status)

References cob_initialized, cob_terminate_routines(), exit_hdlrs, exit_handlerlist::next, NULL, and exit_handlerlist::proc.

Referenced by cob_call(), cob_call_error(), cob_cancel(), cob_check_based(), cob_check_numeric(), cob_check_odo(), cob_check_ref_mod(), cob_check_subscript(), cob_check_version(), cob_command_line(), cob_external_addr(), cob_fatal_error(), cob_get_sort_tempfile(), cob_longjmp(), cob_parameter_check(), cob_resolve_func(), cob_savenv(), cob_sys_check_file_exist(), cob_sys_file_info(), cob_sys_getopt_long_long(), cob_sys_system(), and main().

1367 {
1368  struct exit_handlerlist *h;
1369 
1370  if (!cob_initialized) {
1371  exit (1);
1372  }
1373  if (exit_hdlrs != NULL) {
1374  h = exit_hdlrs;
1375  while (h != NULL) {
1376  h->proc ();
1377  h = h->next;
1378  }
1379  }
1380  cob_terminate_routines ();
1381  exit (status);
1382 }
char* cob_strcat ( char *  str1,
char *  str2 
)

References cob_fast_malloc(), cob_free(), cob_strdup(), and strbuff.

Referenced by cache_preload(), cob_strjoin(), and var_print().

3869  {
3870  size_t l;
3871  char *temp1, *temp2;
3872 
3873  l = strlen(str1) + strlen(str2) + 1;
3874 
3875  /*
3876  * If one of the parameter is the buffer itself,
3877  * we copy the buffer before continuing.
3878  */
3879  if (str1 == strbuff) {
3880  temp1 = cob_strdup(str1);
3881  } else {
3882  temp1 = str1;
3883  }
3884  if (str2 == strbuff) {
3885  temp2 = cob_strdup(str2);
3886  } else {
3887  temp2 = str2;
3888  }
3889 
3890  cob_free(strbuff);
3891  strbuff = (char*) cob_fast_malloc(l);
3892 
3893  sprintf(strbuff, "%s%s", temp1, temp2);
3894  return strbuff;
3895 }
char* cob_strdup ( const char *  p)

References cob_malloc().

Referenced by cache_dynload(), cache_preload(), cob_chk_call_path(), cob_chk_file_env(), cob_chk_file_mapping(), cob_fileio_getenv(), cob_getenv(), cob_gettmpdir(), cob_init(), cob_init_call(), cob_putenv(), cob_set_locale(), cob_strcat(), indexed_open(), and insert().

1159 {
1160  char *mptr;
1161  size_t len;
1162 
1163  len = strlen (p);
1164  mptr = (char *) cob_malloc (len + 1U);
1165  memcpy (mptr, p, len);
1166  return mptr;
1167 }
char* cob_strjoin ( char **  strarray,
int  size,
char *  separator 
)

References cob_strcat(), and NULL.

Referenced by print_runtime_env().

3898  {
3899 
3900  char* result;
3901  int i;
3902 
3903  if(!strarray || size <= 0 || !separator) return NULL;
3904 
3905  result = strarray[0];
3906  for (i = 1; i < size; i++) {
3907  result = cob_strcat(result, separator);
3908  result = cob_strcat(result, strarray[i]);
3909  }
3910 
3911  return result;
3912 }
int cob_sys_and ( const void *  p1,
void *  p2,
const int  length 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3125 {
3126  const cob_u8_ptr data_1 = p1;
3127  cob_u8_ptr data_2 = p2;
3128  size_t n;
3129 
3130  COB_CHK_PARMS (CBL_AND, 3);
3131 
3132  if (length <= 0) {
3133  return 0;
3134  }
3135  for (n = 0; n < (size_t)length; ++n) {
3136  data_2[n] &= data_1[n];
3137  }
3138  return 0;
3139 }
int cob_sys_calledby ( void *  data)

References COB_CHK_PARMS, and COB_MODULE_PTR.

3444 {
3445  size_t size;
3446  size_t msize;
3447 
3448  COB_CHK_PARMS (C$CALLEDBY, 1);
3449 
3450  if (!COB_MODULE_PTR->cob_procedure_params[0]) {
3451  return -1;
3452  }
3453  size = COB_MODULE_PTR->cob_procedure_params[0]->size;
3454  memset (data, ' ', size);
3455  if (!COB_MODULE_PTR->next) {
3456  return 0;
3457  }
3458  msize = strlen (COB_MODULE_PTR->next->module_name);
3459  if (msize > size) {
3460  msize = size;
3461  }
3462  memcpy (data, COB_MODULE_PTR->next->module_name, msize);
3463  return 1;
3464 }
int cob_sys_eq ( const void *  p1,
void *  p2,
const int  length 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3233 {
3234  const cob_u8_ptr data_1 = p1;
3235  cob_u8_ptr data_2 = p2;
3236  size_t n;
3237 
3238  COB_CHK_PARMS (CBL_EQ, 3);
3239 
3240  if (length <= 0) {
3241  return 0;
3242  }
3243  for (n = 0; n < (size_t)length; ++n) {
3244  data_2[n] = ~(data_1[n] ^ data_2[n]);
3245  }
3246  return 0;
3247 }
int cob_sys_error_proc ( const void *  dispo,
const void *  pptr 
)

References COB_CHK_PARMS, cob_free(), cob_malloc(), hdlrs, handlerlist::next, NULL, p, and handlerlist::proc.

3041 {
3042  struct handlerlist *hp = NULL;
3043  struct handlerlist *h = hdlrs;
3044  const unsigned char *x;
3045  int (**p)(char *s);
3046 
3047  COB_CHK_PARMS (CBL_ERROR_PROC, 2);
3048 
3049  memcpy (&p, &pptr, sizeof (void *));
3050  if (!p || !*p) {
3051  return -1;
3052  }
3053 
3054  hp = NULL;
3055  h = hdlrs;
3056  /* Remove handler anyway */
3057  while (h != NULL) {
3058  if (h->proc == *p) {
3059  if (hp != NULL) {
3060  hp->next = h->next;
3061  } else {
3062  hdlrs = h->next;
3063  }
3064  if (hp) {
3065  cob_free (hp);
3066  }
3067  break;
3068  }
3069  hp = h;
3070  h = h->next;
3071  }
3072  x = dispo;
3073  if (*x != 0) {
3074  /* Remove handler */
3075  return 0;
3076  }
3077  h = cob_malloc (sizeof(struct handlerlist));
3078  h->next = hdlrs;
3079  h->proc = *p;
3080  hdlrs = h;
3081  return 0;
3082 }
int cob_sys_exit_proc ( const void *  dispo,
const void *  pptr 
)

References COB_CHK_PARMS, cob_free(), cob_malloc(), exit_hdlrs, exit_handlerlist::next, NULL, p, and exit_handlerlist::proc.

2996 {
2997  struct exit_handlerlist *hp;
2998  struct exit_handlerlist *h;
2999  const unsigned char *x;
3000  int (**p)(void);
3001 
3002  COB_CHK_PARMS (CBL_EXIT_PROC, 2);
3003 
3004  memcpy (&p, &pptr, sizeof (void *));
3005  if (!p || !*p) {
3006  return -1;
3007  }
3008 
3009  hp = NULL;
3010  h = exit_hdlrs;
3011  /* Remove handler anyway */
3012  while (h != NULL) {
3013  if (h->proc == *p) {
3014  if (hp != NULL) {
3015  hp->next = h->next;
3016  } else {
3017  exit_hdlrs = h->next;
3018  }
3019  if (hp) {
3020  cob_free (hp);
3021  }
3022  break;
3023  }
3024  hp = h;
3025  h = h->next;
3026  }
3027  x = dispo;
3028  if (*x != 0 && *x != 2 && *x != 3) {
3029  /* Remove handler */
3030  return 0;
3031  }
3032  h = cob_malloc (sizeof(struct exit_handlerlist));
3033  h->next = exit_hdlrs;
3034  h->proc = *p;
3035  exit_hdlrs = h;
3036  return 0;
3037 }
int cob_sys_getopt_long_long ( void *  so,
void *  lo,
void *  idx,
const int  long_only,
void *  return_char,
void *  opt_val 
)

References _, cob_argc, cob_argv, COB_CHK_PARMS, cob_field_to_string(), cob_free(), cob_get_int(), cob_getopt_long_long(), cob_malloc(), COB_MODULE_PTR, cob_optarg, cob_runtime_error(), cob_set_int(), cob_stop_run(), COB_UNUSED, option::flag, option::has_arg, longoption_def::has_option, option::name, longoption_def::name, NULL, longoption_def::return_value, longoption_def::return_value_pointer, and option::val.

3489  {
3490  /*
3491  * cob_argc is a static int containing argc from runtime
3492  * cob_argv is a static char** containing argv from runtime
3493  */
3494 
3495  size_t opt_val_size = 0;
3496  size_t so_size = 0;
3497  size_t lo_size = 0;
3498 
3499  unsigned int lo_amount;
3500 
3501  int exit_status;
3502 
3503  char* shortoptions;
3504  char* temp;
3505 
3506  struct option* longoptions;
3507  longoption_def* l = NULL;
3508 
3509  int longind = 0;
3510  unsigned int i;
3511  int j;
3512 
3513  unsigned int optlen;
3514  int return_value;
3515 
3516  COB_UNUSED (idx);
3517  COB_UNUSED (lo);
3518  COB_UNUSED (so);
3519 
3520  COB_CHK_PARMS (CBL_OC_GETOPT, 6);
3521 
3522  /*
3523  * Read in sizes of some parameters
3524  */
3525  if (COB_MODULE_PTR->cob_procedure_params[1]) {
3526  lo_size = COB_MODULE_PTR->cob_procedure_params[1]->size;
3527  }
3528  if (COB_MODULE_PTR->cob_procedure_params[0]) {
3529  so_size = COB_MODULE_PTR->cob_procedure_params[0]->size;
3530  }
3531  if (COB_MODULE_PTR->cob_procedure_params[5]) {
3532  opt_val_size = COB_MODULE_PTR->cob_procedure_params[5]->size;
3533  }
3534 
3535  /*
3536  * Buffering longoptions (cobol), target format (struct option)
3537  */
3538  if (lo_size % sizeof(longoption_def) == 0) {
3539  lo_amount = (int)lo_size / sizeof(longoption_def);
3540  longoptions = (struct option*) cob_malloc(sizeof(struct option) * (lo_amount + 1U));
3541  }
3542  else {
3543  cob_runtime_error (_("Call to CBL_OC_GETOPT with wrong longoption size."));
3544  cob_stop_run (1);
3545  }
3546 
3547  if (!COB_MODULE_PTR->cob_procedure_params[2]) {
3548  cob_runtime_error (_("Call to CBL_OC_GETOPT with missing longind."));
3549  cob_stop_run (1);
3550  }
3551  longind = cob_get_int (COB_MODULE_PTR->cob_procedure_params[2]);
3552 
3553  /*
3554  * Add 0-termination to strings.
3555  */
3556  shortoptions = cob_malloc(so_size + 1U);
3557  if (COB_MODULE_PTR->cob_procedure_params[0]) {
3558  cob_field_to_string (COB_MODULE_PTR->cob_procedure_params[0], shortoptions, so_size);
3559  }
3560 
3561  if (COB_MODULE_PTR->cob_procedure_params[1]) {
3562  l = (struct longoption_def*) (COB_MODULE_PTR->cob_procedure_params[1]->data);
3563  }
3564 
3565  for (i = 0; i < lo_amount; i++) {
3566  j = sizeof(l->name) - 1;
3567  while (j >= 0 && l->name[j] == 0x20) {
3568  l->name[j] = 0x00;
3569  j--;
3570  }
3571  longoptions->name = l->name;
3572  longoptions->has_arg = (int) l->has_option - '0';
3573  memcpy (&longoptions->flag, l->return_value_pointer, sizeof(l->return_value_pointer));
3574  memcpy(&longoptions->val, &l->return_value, 4);
3575 
3576  l = l + 1; /* +1 means pointer + 1*sizeof(longoption_def) */
3577  longoptions = longoptions + 1;
3578  }
3579 
3580  /*
3581  * Appending final record, so getopt can spot the end of longoptions
3582  */
3583  longoptions->name = NULL;
3584  longoptions->has_arg = 0;
3585  longoptions->flag = NULL;
3586  longoptions->val = 0;
3587 
3588 
3589  l -= lo_amount; /* Set pointer back to begin of longoptions */
3590  longoptions -= lo_amount;
3591 
3592  return_value = cob_getopt_long_long(cob_argc, cob_argv, shortoptions, longoptions, &longind, long_only);
3593  temp = (char*) &return_value;
3594 
3595  /*
3596  * Write data back to Cobol
3597  */
3598  if (temp[0] == '?' || temp[0] == ':' || temp[0] == 'W'
3599  || temp[0] == -1 || temp[0] == 0) exit_status = return_value;
3600  else exit_status = 3;
3601 
3602  for(i = 3; i > 0; i--) {
3603  if(temp[i] == 0x00) temp[i] = 0x20;
3604  else break;
3605  }
3606 
3607  cob_set_int (COB_MODULE_PTR->cob_procedure_params[2], longind);
3608  memcpy (return_char, &return_value, 4);
3609 
3610  if(cob_optarg != NULL) {
3611  memset (opt_val, 0x00, opt_val_size);
3612 
3613  optlen = strlen (cob_optarg);
3614  if (optlen > opt_val_size) {
3615  /* Returncode 2 for "Optionvalue too long => cut" */
3616  optlen = opt_val_size;
3617  exit_status = 2;
3618  }
3619  memcpy (opt_val, cob_optarg, optlen);
3620  }
3621 
3622 
3623  cob_free (shortoptions);
3624  cob_free (longoptions);
3625 
3626  return exit_status;
3627 
3628 }
int cob_sys_getpid ( void  )

References cob_process_id.

Referenced by cob_temp_name().

3421 {
3422  if (!cob_process_id) {
3423  cob_process_id = (int)getpid ();
3424  }
3425  return cob_process_id;
3426 }
int cob_sys_imp ( const void *  p1,
void *  p2,
const int  length 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3197 {
3198  const cob_u8_ptr data_1 = p1;
3199  cob_u8_ptr data_2 = p2;
3200  size_t n;
3201 
3202  COB_CHK_PARMS (CBL_IMP, 3);
3203 
3204  if (length <= 0) {
3205  return 0;
3206  }
3207  for (n = 0; n < (size_t)length; ++n) {
3208  data_2[n] = (~data_1[n]) | data_2[n];
3209  }
3210  return 0;
3211 }
int cob_sys_justify ( void *  p1,
  ... 
)

References __cob_global::cob_call_params, COB_CHK_PARMS, COB_MODULE_PTR, and cob_u8_ptr.

3687 {
3688  cob_u8_ptr data;
3689  unsigned char *direction;
3690  size_t datalen;
3691  size_t left;
3692  size_t right;
3693  size_t movelen;
3694  size_t centrelen;
3695  size_t n;
3696  size_t shifting;
3697  va_list args;
3698 
3699  COB_CHK_PARMS (C$JUSTIFY, 1);
3700 
3701  if (!COB_MODULE_PTR->cob_procedure_params[0]) {
3702  return 0;
3703  }
3704  data = p1;
3705  datalen = COB_MODULE_PTR->cob_procedure_params[0]->size;
3706  if (datalen < 2) {
3707  return 0;
3708  }
3709  if (data[0] != ' ' && data[datalen - 1] != ' ') {
3710  return 0;
3711  }
3712  for (left = 0; left < datalen; ++left) {
3713  if (data[left] != ' ') {
3714  break;
3715  }
3716  }
3717  if (left == datalen) {
3718  return 0;
3719  }
3720  right = 0;
3721  for (n = datalen - 1; ; --n, ++right) {
3722  if (data[n] != ' ') {
3723  break;
3724  }
3725  if (n == 0) {
3726  break;
3727  }
3728  }
3729  movelen = datalen - left - right;
3730  shifting = 0;
3731  if (cobglobptr->cob_call_params > 1) {
3732  va_start (args, p1);
3733  direction = va_arg (args, unsigned char *);
3734  va_end (args);
3735  if (*direction == 'L') {
3736  shifting = 1;
3737  } else if (*direction == 'C') {
3738  shifting = 2;
3739  }
3740  }
3741  switch (shifting) {
3742  case 1:
3743  memmove (data, &data[left], movelen);
3744  memset (&data[movelen], ' ', datalen - movelen);
3745  break;
3746  case 2:
3747  centrelen = (left + right) / 2;
3748  memmove (&data[centrelen], &data[left], movelen);
3749  memset (data, ' ', centrelen);
3750  if ((left + right) % 2) {
3751  memset (&data[centrelen + movelen], ' ', centrelen + 1);
3752  } else {
3753  memset (&data[centrelen + movelen], ' ', centrelen);
3754  }
3755  break;
3756  default:
3757  memmove (&data[left + right], &data[left], movelen);
3758  memset (data, ' ', datalen - movelen);
3759  break;
3760  }
3761  return 0;
3762 }
int cob_sys_nimp ( const void *  p1,
void *  p2,
const int  length 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3215 {
3216  const cob_u8_ptr data_1 = p1;
3217  cob_u8_ptr data_2 = p2;
3218  size_t n;
3219 
3220  COB_CHK_PARMS (CBL_NIMP, 3);
3221 
3222  if (length <= 0) {
3223  return 0;
3224  }
3225  for (n = 0; n < (size_t)length; ++n) {
3226  data_2[n] = data_1[n] & (~data_2[n]);
3227  }
3228  return 0;
3229 }
int cob_sys_nor ( const void *  p1,
void *  p2,
const int  length 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3161 {
3162  const cob_u8_ptr data_1 = p1;
3163  cob_u8_ptr data_2 = p2;
3164  size_t n;
3165 
3166  COB_CHK_PARMS (CBL_NOR, 3);
3167 
3168  if (length <= 0) {
3169  return 0;
3170  }
3171  for (n = 0; n < (size_t)length; ++n) {
3172  data_2[n] = ~(data_1[n] | data_2[n]);
3173  }
3174  return 0;
3175 }
int cob_sys_not ( void *  p1,
const int  length 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3251 {
3252  cob_u8_ptr data_1 = p1;
3253  size_t n;
3254 
3255  COB_CHK_PARMS (CBL_NOT, 2);
3256 
3257  if (length <= 0) {
3258  return 0;
3259  }
3260  for (n = 0; n < (size_t)length; ++n) {
3261  data_1[n] = ~data_1[n];
3262  }
3263  return 0;
3264 }
int cob_sys_oc_nanosleep ( const void *  data)

References COB_CHK_PARMS, cob_get_llint(), COB_MODULE_PTR, cob_s64_t, COB_UNUSED, and NULL.

3377 {
3378  cob_s64_t nsecs;
3379 #if defined(_WIN32) || defined(__370__) || defined(__OS400__)
3380  unsigned int msecs;
3381 #elif defined(HAVE_NANO_SLEEP)
3382  struct timespec tsec;
3383 #else
3384  unsigned int msecs;
3385 #endif
3386 
3387  COB_UNUSED (data);
3388 
3389  COB_CHK_PARMS (CBL_OC_NANOSLEEP, 1);
3390 
3391  if (COB_MODULE_PTR->cob_procedure_params[0]) {
3392  nsecs = cob_get_llint (COB_MODULE_PTR->cob_procedure_params[0]);
3393  if (nsecs > 0) {
3394 #ifdef _WIN32
3395  msecs = (unsigned int)(nsecs / 1000000);
3396  if (msecs > 0) {
3397  Sleep (msecs);
3398  }
3399 #elif defined(__370__) || defined(__OS400__)
3400  msecs = (unsigned int)(nsecs / 1000000000);
3401  if (msecs > 0) {
3402  sleep (msecs);
3403  }
3404 #elif defined(HAVE_NANO_SLEEP)
3405  tsec.tv_sec = nsecs / 1000000000;
3406  tsec.tv_nsec = nsecs % 1000000000;
3407  nanosleep (&tsec, NULL);
3408 #else
3409  msecs = (unsigned int)(nsecs / 1000000000);
3410  if (msecs > 0) {
3411  sleep (msecs);
3412  }
3413 #endif
3414  }
3415  }
3416  return 0;
3417 }
int cob_sys_or ( const void *  p1,
void *  p2,
const int  length 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3143 {
3144  const cob_u8_ptr data_1 = p1;
3145  cob_u8_ptr data_2 = p2;
3146  size_t n;
3147 
3148  COB_CHK_PARMS (CBL_OR, 3);
3149 
3150  if (length <= 0) {
3151  return 0;
3152  }
3153  for (n = 0; n < (size_t)length; ++n) {
3154  data_2[n] |= data_1[n];
3155  }
3156  return 0;
3157 }
int cob_sys_parameter_size ( void *  data)

References COB_CHK_PARMS, cob_get_int(), COB_MODULE_PTR, and COB_UNUSED.

3468 {
3469  int n;
3470 
3471  COB_UNUSED (data);
3472 
3473  COB_CHK_PARMS (C$PARAMSIZE, 1);
3474 
3475  if (COB_MODULE_PTR->cob_procedure_params[0]) {
3476  n = cob_get_int (COB_MODULE_PTR->cob_procedure_params[0]);
3477  if (n > 0 && n <= COB_MODULE_PTR->module_num_params) {
3478  n--;
3479  if (COB_MODULE_PTR->next &&
3480  COB_MODULE_PTR->next->cob_procedure_params[n]) {
3481  return (int)COB_MODULE_PTR->next->cob_procedure_params[n]->size;
3482  }
3483  }
3484  }
3485  return 0;
3486 }
int cob_sys_printable ( void *  p1,
  ... 
)

References __cob_global::cob_call_params, COB_CHK_PARMS, COB_MODULE_PTR, and cob_u8_ptr.

3654 {
3655  cob_u8_ptr data;
3656  unsigned char *dotptr;
3657  size_t datalen;
3658  size_t n;
3659  unsigned char dotrep;
3660  va_list args;
3661 
3662  COB_CHK_PARMS (C$PRINTABLE, 1);
3663 
3664  if (!COB_MODULE_PTR->cob_procedure_params[0]) {
3665  return 0;
3666  }
3667  data = p1;
3668  datalen = COB_MODULE_PTR->cob_procedure_params[0]->size;
3669  if (cobglobptr->cob_call_params > 1) {
3670  va_start (args, p1);
3671  dotptr = va_arg (args, unsigned char *);
3672  va_end (args);
3673  dotrep = *dotptr;
3674  } else {
3675  dotrep = (unsigned char)'.';
3676  }
3677  for (n = 0; n < datalen; ++n) {
3678  if (!isprint (data[n])) {
3679  data[n] = dotrep;
3680  }
3681  }
3682  return 0;
3683 }
int cob_sys_return_args ( void *  data)

References COB_CHK_PARMS, COB_MODULE_PTR, cob_set_int(), and COB_UNUSED.

3430 {
3431  COB_UNUSED (data);
3432 
3433  COB_CHK_PARMS (C$NARG, 1);
3434 
3435  if (COB_MODULE_PTR->cob_procedure_params[0]) {
3436  cob_set_int (COB_MODULE_PTR->cob_procedure_params[0],
3437  COB_MODULE_PTR->module_num_params);
3438  }
3439  return 0;
3440 }
int cob_sys_sleep ( const void *  data)

References COB_CHK_PARMS, cob_get_int(), COB_MODULE_PTR, and COB_UNUSED.

3632 {
3633  int n;
3634 
3635  COB_UNUSED (data);
3636 
3637  COB_CHK_PARMS (C$SLEEP, 1);
3638 
3639  if (COB_MODULE_PTR->cob_procedure_params[0]) {
3640  n = cob_get_int (COB_MODULE_PTR->cob_procedure_params[0]);
3641  if (n > 0 && n < 3600*24*7) {
3642 #ifdef _WIN32
3643  Sleep (n*1000);
3644 #else
3645  sleep ((unsigned int)n);
3646 #endif
3647  }
3648  }
3649  return 0;
3650 }
int cob_sys_system ( const void *  cmdline)

References _, COB_CHK_PARMS, cob_free(), cob_malloc(), COB_MEDIUM_MAX, COB_MODULE_PTR, cob_runtime_error(), __cob_global::cob_screen_initialized, cob_screen_set_mode(), cob_stop_run(), if(), and unlikely.

3086 {
3087  const char *cmd;
3088  char *buff;
3089  int i;
3090 
3091  COB_CHK_PARMS (SYSTEM, 1);
3092 
3093  if (COB_MODULE_PTR->cob_procedure_params[0]) {
3094  cmd = cmdline;
3095  i = (int)COB_MODULE_PTR->cob_procedure_params[0]->size;
3096  if (unlikely(i > COB_MEDIUM_MAX)) {
3097  cob_runtime_error (_("Parameter to SYSTEM call is larger than 8192 characters"));
3098  cob_stop_run (1);
3099  }
3100  i--;
3101  for (; i >= 0; --i) {
3102  if (cmd[i] != ' ' && cmd[i] != 0) {
3103  break;
3104  }
3105  }
3106  if (i >= 0) {
3107  buff = cob_malloc ((size_t)(i + 2));
3108  memcpy (buff, cmd, (size_t)(i + 1));
3109  if (cobglobptr->cob_screen_initialized) {
3110  cob_screen_set_mode (0);
3111  }
3112  i = system (buff);
3113  cob_free (buff);
3114  if (cobglobptr->cob_screen_initialized) {
3115  cob_screen_set_mode (1U);
3116  }
3117  return i;
3118  }
3119  }
3120  return 1;
3121 }
int cob_sys_tolower ( void *  p1,
const int  length 
)

References COB_CHK_PARMS, cob_u8_ptr, and cob_u8_t.

3359 {
3360  cob_u8_ptr data = p1;
3361  size_t n;
3362 
3363  COB_CHK_PARMS (CBL_TOLOWER, 2);
3364 
3365  if (length > 0) {
3366  for (n = 0; n < (size_t)length; ++n) {
3367  if (isupper (data[n])) {
3368  data[n] = (cob_u8_t)tolower (data[n]);
3369  }
3370  }
3371  }
3372  return 0;
3373 }
int cob_sys_toupper ( void *  p1,
const int  length 
)

References COB_CHK_PARMS, cob_u8_ptr, and cob_u8_t.

3341 {
3342  cob_u8_ptr data = p1;
3343  size_t n;
3344 
3345  COB_CHK_PARMS (CBL_TOUPPER, 2);
3346 
3347  if (length > 0) {
3348  for (n = 0; n < (size_t)length; ++n) {
3349  if (islower (data[n])) {
3350  data[n] = (cob_u8_t)toupper (data[n]);
3351  }
3352  }
3353  }
3354  return 0;
3355 }
int cob_sys_x91 ( void *  p1,
const void *  p2,
void *  p3 
)

References COB_MODULE_PTR, cob_switch, cob_u8_ptr, and p.

3299 {
3300  cob_u8_ptr result = p1;
3301  const cob_u8_ptr func = p2;
3302  cob_u8_ptr parm = p3;
3303  unsigned char *p;
3304  size_t i;
3305 
3306  switch (*func) {
3307  case 11:
3308  /* Set switches */
3309  p = parm;
3310  for (i = 0; i < 8; ++i, ++p) {
3311  if (*p == 0) {
3312  cob_switch[i] = 0;
3313  } else if (*p == 1) {
3314  cob_switch[i] = 1;
3315  }
3316  }
3317  *result = 0;
3318  break;
3319  case 12:
3320  /* Get switches */
3321  p = parm;
3322  for (i = 0; i < 8; ++i, ++p) {
3323  *p = (unsigned char)cob_switch[i];
3324  }
3325  *result = 0;
3326  break;
3327  case 16:
3328  /* Return number of call parameters */
3329  *parm = (unsigned char)COB_MODULE_PTR->module_num_params;
3330  *result = 0;
3331  break;
3332  default:
3333  *result = 1;
3334  break;
3335  }
3336  return 0;
3337 }
int cob_sys_xf4 ( void *  p1,
const void *  p2 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3268 {
3269  cob_u8_ptr data_1 = p1;
3270  const cob_u8_ptr data_2 = p2;
3271  size_t n;
3272 
3273  COB_CHK_PARMS (CBL_XF4, 2);
3274 
3275  *data_1 = 0;
3276  for (n = 0; n < 8; ++n) {
3277  *data_1 |= (data_2[n] & 1) << (7 - n);
3278  }
3279  return 0;
3280 }
int cob_sys_xf5 ( const void *  p1,
void *  p2 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3284 {
3285  const cob_u8_ptr data_1 = p1;
3286  cob_u8_ptr data_2 = p2;
3287  size_t n;
3288 
3289  COB_CHK_PARMS (CBL_XF5, 2);
3290 
3291  for (n = 0; n < 8; ++n) {
3292  data_2[n] = (*data_1 & (1 << (7 - n))) ? 1 : 0;
3293  }
3294  return 0;
3295 }
int cob_sys_xor ( const void *  p1,
void *  p2,
const int  length 
)

References COB_CHK_PARMS, and cob_u8_ptr.

3179 {
3180  const cob_u8_ptr data_1 = p1;
3181  cob_u8_ptr data_2 = p2;
3182  size_t n;
3183 
3184  COB_CHK_PARMS (CBL_XOR, 3);
3185 
3186  if (length <= 0) {
3187  return 0;
3188  }
3189  for (n = 0; n < (size_t)length; ++n) {
3190  data_2[n] ^= data_1[n];
3191  }
3192  return 0;
3193 }
void cob_table_sort ( cob_field *  f,
const int  n 
)

References cob_free(), cob_field::data, cob_field::size, and sort_compare().

2297 {
2298  qsort (f->data, (size_t) n, f->size, sort_compare);
2299  cob_free (sort_keys);
2300 }
void cob_table_sort_init ( const size_t  nkeys,
const unsigned char *  collating_sequence 
)

References cob_malloc(), COB_MODULE_PTR, sort_collate, and sort_nkeys.

2275 {
2276  sort_nkeys = 0;
2277  sort_keys = cob_malloc (nkeys * sizeof (cob_file_key));
2278  if (collating_sequence) {
2279  sort_collate = collating_sequence;
2280  } else {
2281  sort_collate = COB_MODULE_PTR->collating_sequence;
2282  }
2283 }
void cob_table_sort_init_key ( cob_field *  field,
const int  flag,
const unsigned int  offset 
)

References cob_file_key::field, cob_file_key::flag, cob_file_key::offset, and sort_nkeys.

2288 {
2289  sort_keys[sort_nkeys].field = field;
2290  sort_keys[sort_nkeys].flag = flag;
2291  sort_keys[sort_nkeys].offset = offset;
2292  sort_nkeys++;
2293 }
void cob_temp_name ( char *  filename,
const char *  ext 
)

References COB_FILE_MAX, cob_gettmpdir(), cob_sys_getpid(), cob_temp_iteration, and SLASH_INT.

Referenced by cob_srttmpfile(), and process_filename().

2913 {
2914  /* Set temporary file name */
2915  if (ext) {
2916  snprintf (filename, (size_t)COB_FILE_MAX, "%s%ccob%d_%d%s",
2917  cob_gettmpdir(), SLASH_INT, cob_sys_getpid(), cob_temp_iteration, ext);
2918  } else {
2919  snprintf (filename, (size_t)COB_FILE_MAX, "%s%ccobsort%d_%d",
2920  cob_gettmpdir(), SLASH_INT, cob_sys_getpid(), cob_temp_iteration);
2921  }
2922 }
static void cob_terminate_routines ( void  )
static

References cob_exit_call(), cob_exit_common(), cob_exit_fileio(), cob_exit_intrinsic(), cob_exit_numeric(), cob_exit_screen(), cob_exit_strings(), cob_initialized, cob_trace_file, and NULL.

Referenced by cob_stop_run(), and cob_tidy().

298 {
299  if (!cob_initialized) {
300  return;
301  }
302  if (!cobglobptr) {
303  return;
304  }
305 
306  if (cob_trace_file && cob_trace_file != stderr) {
307  fclose (cob_trace_file);
308  cob_trace_file = NULL;
309  }
310 
311  cob_exit_screen ();
312  cob_exit_fileio ();
313  cob_exit_intrinsic ();
314  cob_exit_strings ();
315  cob_exit_numeric ();
316  cob_exit_call ();
317  cob_exit_common ();
318 }
int cob_tidy ( void  )

References cob_initialized, cob_terminate_routines(), exit_hdlrs, exit_handlerlist::next, NULL, and exit_handlerlist::proc.

2975 {
2976  struct exit_handlerlist *h;
2977 
2978  if (!cob_initialized) {
2979  exit (1);
2980  }
2981  if (exit_hdlrs != NULL) {
2982  h = exit_hdlrs;
2983  while (h != NULL) {
2984  h->proc ();
2985  h = h->next;
2986  }
2987  }
2988  cob_terminate_routines ();
2989  return 0;
2990 }
void cob_trace_section ( const char *  para,
const char *  source,
const int  line 
)

References cob_check_trace_file(), cob_last_sfile, cob_line_trace, COB_MODULE_PTR, and cob_trace_file.

1276 {
1277  const char *s;
1278 
1279  if (cob_line_trace) {
1280  if (!cob_trace_file) {
1281  cob_check_trace_file ();
1282  }
1283  if (source &&
1284  (!cob_last_sfile || strcmp (cob_last_sfile, source))) {
1285  cob_last_sfile = source;
1286  fprintf (cob_trace_file, "Source: '%s'\n", source);
1287  }
1288  if (COB_MODULE_PTR->module_name) {
1289  s = COB_MODULE_PTR->module_name;
1290  } else {
1291  s = "Unknown";
1292  }
1293  fprintf (cob_trace_file, "Program-Id: %-16s ", s);
1294  if (line) {
1295  fprintf (cob_trace_file, "%-34.34sLine: %d\n", para, line);
1296  } else {
1297  fprintf (cob_trace_file, "%s\n", para);
1298  }
1299  fflush (cob_trace_file);
1300  }
1301 }
static int common_cmpc ( const unsigned char *  s1,
const unsigned int  c,
const size_t  size,
const unsigned char *  col 
)
static

References unlikely.

Referenced by cob_cmp_all(), and cob_cmp_alnum().

789 {
790  size_t i;
791  int ret;
792 
793  if (unlikely(col)) {
794  for (i = 0; i < size; ++i) {
795  if ((ret = col[s1[i]] - col[c]) != 0) {
796  return ret;
797  }
798  }
799  } else {
800  for (i = 0; i < size; ++i) {
801  if ((ret = s1[i] - c) != 0) {
802  return ret;
803  }
804  }
805  }
806  return 0;
807 }
static int common_cmps ( const unsigned char *  s1,
const unsigned char *  s2,
const size_t  size,
const unsigned char *  col 
)
static

References unlikely.

Referenced by cob_cmp_all(), cob_cmp_alnum(), and sort_compare().

812 {
813  size_t i;
814  int ret;
815 
816  if (unlikely(col)) {
817  for (i = 0; i < size; ++i) {
818  if ((ret = col[s1[i]] - col[s2[i]]) != 0) {
819  return ret;
820  }
821  }
822  } else {
823  for (i = 0; i < size; ++i) {
824  if ((ret = s1[i] - s2[i]) != 0) {
825  return ret;
826  }
827  }
828  }
829  return 0;
830 }
void print_info ( void  )

References _, COB_BLD_BUILD, COB_BLD_CC, COB_BLD_CFLAGS, COB_BLD_CPPFLAGS, COB_BLD_LD, COB_BLD_LDFLAGS, COB_EXEEXT, COB_MODULE_EXT, COB_OBJECT_EXT, NULL, OC_C_VERSION, OC_C_VERSION_PRF, print_version(), var_print(), and WITH_VARSEQ.

Referenced by process_command_line().

4178  {
4179  char buff[16];
4180  char *s;
4181 
4182  print_version ();
4183  putchar ('\n');
4184  puts (_("Build information"));
4185  var_print (_("Build environment"), COB_BLD_BUILD, "", 0);
4186  var_print ("CC", COB_BLD_CC, "", 0);
4187  var_print ("CPPFLAGS", COB_BLD_CPPFLAGS, "", 0);
4188  var_print ("CFLAGS", COB_BLD_CFLAGS, "", 0);
4189  var_print ("LD", COB_BLD_LD, "", 0);
4190  var_print ("LDFLAGS", COB_BLD_LDFLAGS, "", 0);
4191  putchar ('\n');
4192  printf (_("C version %s%s"), OC_C_VERSION_PRF, OC_C_VERSION);
4193  putchar ('\n');
4194  puts (_("GNU Cobol information"));
4195 
4196 // if ((s = getenv ("COB_LIBRARY_PATH")) != NULL) {
4197 // var_print ("COB_LIBRARY_PATH", s, "", 1);
4198 // }
4199  var_print ("COB_MODULE_EXT", COB_MODULE_EXT, "", 0);
4200  var_print ("COB_OBJECT_EXT", COB_OBJECT_EXT, "", 0);
4201  var_print ("COB_EXEEXT", COB_EXEEXT, "", 0);
4202 
4203 #if defined(USE_LIBDL) || defined(_WIN32)
4204  var_print (_("Dynamic loading"), _("System"), "", 0);
4205 #else
4206  var_print (_("Dynamic loading"), _("Libtool"), "", 0);
4207 #endif
4208 
4209 #ifdef COB_PARAM_CHECK
4210  var_print ("\"CBL_\" param check", _("Enabled"), "", 0);
4211 #else
4212  var_print ("\"CBL_\" param check", _("Disabled"), "", 0);
4213 #endif
4214 
4215  snprintf (buff, sizeof(buff), "%d", WITH_VARSEQ);
4216  var_print (_("Variable format"), buff, "", 0);
4217  if ((s = getenv ("COB_VARSEQ_FORMAT")) != NULL) {
4218  var_print ("COB_VARSEQ_FORMAT", s, "", 1);
4219  }
4220 
4221 #ifdef COB_LI_IS_LL
4222  var_print ("BINARY-C-LONG", _("8 bytes"), "", 0);
4223 #else
4224  var_print ("BINARY-C-LONG", _("4 bytes"), "", 0);
4225 #endif
4226 
4227 #ifdef WITH_SEQRA_EXTFH
4228  var_print (_("Sequential handler"), _("External"), "", 0);
4229 #else
4230  var_print (_("Sequential handler"), _("Internal"), "", 0);
4231 #endif
4232 #ifdef WITH_INDEX_EXTFH
4233  var_print (_("ISAM handler"), _("External"), "", 0);
4234 #endif
4235 #ifdef WITH_DB
4236  var_print (_("ISAM handler"), _("BDB"), "", 0);
4237 #endif
4238 #ifdef WITH_CISAM
4239  var_print (_("ISAM handler"), _("C-ISAM (Experimental)"), "", 0);
4240 #endif
4241 #ifdef WITH_DISAM
4242  var_print (_("ISAM handler"), _("D-ISAM (Experimental)"), "", 0);
4243 #endif
4244 #ifdef WITH_VBISAM
4245  var_print (_("ISAM handler"), _("VBISAM (Experimental)"), "", 0);
4246 #endif
4247 }
void print_runtime_env ( void  )

References _, cob_argc, cob_argv, runtime_env::cob_beep_str_env, __cob_global::cob_beep_value, cob_check_trace_file(), __cob_global::cob_disp_to_stderr, runtime_env::cob_disp_to_stderr_env, __cob_global::cob_display_warn, runtime_env::cob_display_warn_env, runtime_env::cob_do_sync, runtime_env::cob_do_sync_env, __cob_global::cob_env_mangle, runtime_env::cob_env_mangle_env, __cob_global::cob_extended_status, runtime_env::cob_extended_status_env, cob_fast_malloc(), runtime_env::cob_file_path, runtime_env::cob_file_path_env, cob_init(), cob_initialized, cob_int_to_formatted_bytestring(), cob_int_to_string(), runtime_env::cob_legacy, runtime_env::cob_legacy_env, runtime_env::cob_library_path_env, cob_line_trace, runtime_env::cob_line_trace_env, runtime_env::cob_local_edit, runtime_env::cob_local_edit_env, runtime_env::cob_ls_fixed, runtime_env::cob_ls_fixed_env, runtime_env::cob_ls_nulls, runtime_env::cob_ls_nulls_env, runtime_env::cob_ls_uses_cr, runtime_env::cob_ls_uses_cr_env, runtime_env::cob_preload_env, runtime_env::cob_preload_resolved, runtime_env::cob_sort_chunk, COB_SORT_CHUNK, runtime_env::cob_sort_chunk_env, runtime_env::cob_sort_memory, COB_SORT_MEMORY, runtime_env::cob_sort_memory_env, cob_strjoin(), __cob_global::cob_timeout_scale, runtime_env::cob_timeout_scale_env, cob_trace_env, cob_trace_file, __cob_global::cob_unix_lf, runtime_env::cob_unix_lf_env, __cob_global::cob_use_esc, runtime_env::cob_use_esc_env, runtime_env::cob_varseq_type, runtime_env::cob_varseq_type_env, runtime_env::name_convert, runtime_env::name_convert_env, NULL, PATHSEPS, runtime_env::physical_cancel, runtime_env::physical_cancel_env, runtime_env::resolve_path, runtime_env::resolve_size, and var_print().

Referenced by process_command_line().

3999  {
4000  char* no_default;
4001  char* not_set;
4002  char* intstring;
4003  char* intstring2;
4004 
4005  printf("GNU Cobol runtime environment\n\n");
4006  printf("All values were resolved from current environment. \n\n");
4007  /* Alles aus common.c --> cob_init und cob_init_... - einigermaßen sinnvoll sortiert (ggf. Zwischenüberschriften ...*/
4008 
4009  if(!cob_initialized) {
4010  cob_init(cob_argc, cob_argv);
4011  }
4012 
4013  no_default = (char*) _("No");
4014  not_set = (char*) _("not set");
4015  intstring = (char*) cob_fast_malloc(10);
4016  intstring2 = (char*) cob_fast_malloc(10);
4017 
4018  printf(_("Call environment\n"));
4019 
4020  var_print("COB_LIBRARY_PATH", runtimeptr->cob_library_path_env, not_set,
4021  2);
4022  var_print("resolve_path",
4023  cob_strjoin(runtimeptr->resolve_path, *(runtimeptr->resolve_size),
4024  (char*) PATHSEPS), not_set, 3);
4025  var_print("COB_PRE_LOAD", runtimeptr->cob_preload_env, not_set, 2);
4026  var_print("base_preload_ptr",
4027  runtimeptr->cob_preload_resolved, not_set, 3);
4028  var_print("COB_LOAD_CASE", runtimeptr->name_convert_env, not_set, 2);
4029  var_print("name_convert",
4030  cob_int_to_string(*(runtimeptr->name_convert), intstring),
4031  no_default, 3);
4032  var_print("COB_PHYSICAL_CANCEL", runtimeptr->physical_cancel_env,
4033  not_set, 2);
4034  var_print("physical_cancel",
4035  cob_int_to_string(*(runtimeptr->physical_cancel), intstring),
4036  no_default, 3);
4037 
4038  printf(_("\n\nFile I/O\n"));
4039  var_print("COB_SYNC", runtimeptr->cob_do_sync_env, not_set, 2);
4040  var_print("cob_do_sync",
4041  cob_int_to_string(*(runtimeptr->cob_do_sync), intstring),
4042  no_default, 3);
4043  var_print("COB_LS_USES_CR", runtimeptr->cob_ls_uses_cr_env, not_set, 2);
4044  var_print("cob_ls_uses_cr",
4045  cob_int_to_string(*(runtimeptr->cob_ls_uses_cr), intstring),
4046  no_default, 3);
4047 
4048  var_print("COB_SORT_MEMORY", runtimeptr->cob_sort_memory_env, not_set,
4049  2);
4050  var_print("cob_sort_memory",
4051  cob_int_to_formatted_bytestring(*(runtimeptr->cob_sort_memory),
4052  intstring),
4053  cob_int_to_formatted_bytestring(COB_SORT_MEMORY, intstring2), 3);
4054  var_print("COB_SORT_CHUNK", runtimeptr->cob_sort_chunk_env, not_set, 2);
4055  var_print("cob_sort_chunk",
4056  cob_int_to_formatted_bytestring(*(runtimeptr->cob_sort_chunk),
4057  intstring),
4058  cob_int_to_formatted_bytestring(COB_SORT_CHUNK, intstring2), 3);
4059  var_print("COB_FILE_PATH", runtimeptr->cob_file_path_env, not_set, 2);
4060  var_print("cob_file_path", runtimeptr->cob_file_path, not_set, 3);
4061  var_print("COB_LS_NULLS", runtimeptr->cob_ls_nulls_env, not_set, 2);
4062  var_print("cob_ls_nulls",
4063  cob_int_to_string(*(runtimeptr->cob_ls_nulls), intstring),
4064  no_default, 3);
4065  var_print("COB_LS_FIXED", runtimeptr->cob_ls_fixed_env, not_set, 2);
4066  var_print("cob_ls_fixed",
4067  cob_int_to_string(*(runtimeptr->cob_ls_fixed), intstring),
4068  no_default, 3);
4069  var_print("COB_VARSEQ_FORMAT", runtimeptr->cob_varseq_type_env,
4070  _("0 (default), [2-byte record-length] [0000] [record-data]"), 2);
4071  var_print("cob_varseq_type",
4072  cob_int_to_string(*(runtimeptr->cob_varseq_type), intstring),
4073  _("0 (default), [2-byte record-length] [0000] [record-data]"), 3);
4074  var_print("COB_UNIX_LF", runtimeptr->cob_unix_lf_env, not_set,
4075  2);
4076  var_print("cob_unix_lf",
4077  cob_int_to_string(cobglobptr->cob_unix_lf, intstring),
4078  no_default, 3);
4079 
4080  if (runtimeptr->cob_local_edit) {
4081  printf(_("\n\nLocale Properties\n"));
4082  var_print("COB_LOCALE_NUMERIC_EDITED", runtimeptr->cob_local_edit_env,
4083  not_set, 2);
4084  var_print("cob_local_edit",
4085  cob_int_to_string(*(runtimeptr->cob_local_edit), intstring),
4086  no_default, 3);
4087  }
4088 
4089  printf(_("\n\nScreen I/O\n"));
4090  var_print("COB_REDIRECT_DISPLAY",
4091  runtimeptr->cob_disp_to_stderr_env, not_set, 2);
4092  var_print("cob_disp_to_stderr",
4093  cob_int_to_string(cobglobptr->cob_disp_to_stderr,
4094  intstring), no_default, 3);
4095  var_print("COB_BELL", runtimeptr->cob_beep_str_env, not_set, 2);
4096  var_print("cob_beep_value", cob_int_to_string(cobglobptr->cob_beep_value, intstring), (char*) "0", 3);
4097  var_print("COB_TIMEOUT_SCALE", runtimeptr->cob_timeout_scale_env,
4098  not_set, 2);
4099  var_print("cob_timeout_scale",
4100  cob_int_to_string(cobglobptr->cob_timeout_scale,
4101  intstring), "1000", 3);
4102  var_print("COB_SCREEN_EXCEPTIONS",
4103  runtimeptr->cob_extended_status_env, not_set, 2);
4104  var_print("cob_extended_status",
4105  cob_int_to_string(cobglobptr->cob_extended_status,
4106  intstring), no_default, 3);
4107  var_print("COB_SCREEN_ESC", runtimeptr->cob_use_esc_env,
4108  not_set, 2);
4109  var_print("cob_screen_esc",
4110  cob_int_to_string(cobglobptr->cob_use_esc, intstring),
4111  no_default, 3);
4112  var_print("COB_LEGACY", runtimeptr->cob_legacy_env,
4113  not_set, 2);
4114  var_print("cob_legacy",
4115  cob_int_to_string(*(runtimeptr->cob_legacy), intstring),
4116  no_default, 3);
4117 
4118  printf(_("\n\nMiscellaneous\n"));
4119  var_print("COB_SET_TRACE", runtimeptr->cob_line_trace_env, not_set, 2);
4120  var_print("cob_line_trace", cob_int_to_string(cob_line_trace, intstring), no_default, 3);
4121  cob_check_trace_file();
4122  var_print("COB_TRACE_FILE", cob_trace_env, not_set, 2);
4123  if(cob_trace_file != stderr) {
4124  var_print("cob_trace_file", cob_trace_env, NULL, 3);
4125  }
4126  else {
4127  var_print("cob_trace_file", _("stderr (default)"), NULL, 3);
4128  }
4129  var_print("COB_DISABLE_WARNINGS",
4130  runtimeptr->cob_display_warn_env, not_set, 2);
4131  var_print("cob_display_warn",
4132  cob_int_to_string(cobglobptr->cob_display_warn,
4133  intstring), no_default, 3);
4134  var_print("COB_ENV_MANGLE", runtimeptr->cob_env_mangle_env,
4135  not_set, 2);
4136  var_print("cob_env_mangle",
4137  cob_int_to_string(cobglobptr->cob_env_mangle, intstring),
4138  no_default, 3);
4139 }
void print_version ( void  )

References _, cob_fast_malloc(), COB_MINI_MAX, COB_TAR_DATE, cobc_buffer, PACKAGE_NAME, PACKAGE_VERSION, and PATCH_LEVEL.

Referenced by print_info(), and process_command_line().

4142  {
4143  char* cobc_buffer;
4144  char month[32];
4145  int day, year;
4146 
4147  cobc_buffer = cob_fast_malloc((size_t) COB_MINI_MAX);
4148 
4149  /* Set up build time stamp */
4150  memset (month, 0, sizeof(month));
4151  day = 0;
4152  year = 0;
4153  sscanf (__DATE__, "%s %d %d", month, &day, &year);
4154 
4155  if (day && year) {
4156  snprintf (cobc_buffer, (size_t)COB_MINI_MAX,
4157  "%s %2.2d %4.4d %s", month, day, year, __TIME__);
4158  } else {
4159  snprintf (cobc_buffer, (size_t)COB_MINI_MAX,
4160  "%s %s", __DATE__, __TIME__);
4161  }
4162 
4163  printf ("libcob (%s) %s.%d\n",
4164  PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL);
4165  puts ("Copyright (C) 2001,2002,2003,2004,2005,2006,2007 Keisuke Nishida");
4166  puts ("Copyright (C) 2006-2012 Roger While");
4167  puts ("Copyright (C) 2009,2010,2012,2014 Simon Sobisch");
4168  puts (_("This is free software; see the source for copying conditions. There is NO\n\
4169 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."));
4170  printf (_("Built %s"), cobc_buffer);
4171  putchar ('\n');
4172  printf (_("Packaged %s"), COB_TAR_DATE);
4173  putchar ('\n');
4174 
4175 }
static int sort_compare ( const void *  data1,
const void *  data2 
)
static

References COB_ASCENDING, COB_FIELD_IS_NUMERIC, cob_numeric_cmp(), common_cmps(), cob_field::data, cob_file_key::field, cob_field::size, sort_collate, and sort_nkeys.

Referenced by cob_table_sort().

906 {
907  size_t i;
908  int cmp;
909  cob_field f1;
910  cob_field f2;
911 
912  for (i = 0; i < sort_nkeys; ++i) {
913  f1 = f2 = *sort_keys[i].field;
914  f1.data = (unsigned char *)data1 + sort_keys[i].offset;
915  f2.data = (unsigned char *)data2 + sort_keys[i].offset;
916  if (COB_FIELD_IS_NUMERIC(&f1)) {
917  cmp = cob_numeric_cmp (&f1, &f2);
918  } else {
919  cmp = common_cmps (f1.data, f2.data, f1.size, sort_collate);
920  }
921  if (cmp != 0) {
922  return (sort_keys[i].flag == COB_ASCENDING) ? cmp : -cmp;
923  }
924  }
925  return 0;
926 }
static void var_print ( const char *  msg,
const char *  val,
const char *  default_val,
const unsigned int  format 
)
static

References _, CB_IMSG_SIZE, CB_IVAL_SIZE, cob_free(), cob_strcat(), NULL, and p.

Referenced by print_info(), and print_runtime_env().

3925  {
3926  char *p;
3927  char *token;
3928  size_t n;
3929  int lablen;
3930  int toklen;
3931 
3932  switch (format) {
3933  case 0:
3934  printf("%-*.*s : ", CB_IMSG_SIZE, CB_IMSG_SIZE, msg);
3935  break;
3936  case 1: {
3937  printf(" %s: ", _("env"));
3938  lablen = CB_IMSG_SIZE - 2 - strlen(_("env")) - 2;
3939  printf("%-*.*s : ", lablen, lablen, msg);
3940  break;
3941  }
3942  case 2:
3943  printf(" %-*.*s : ", CB_IMSG_SIZE, CB_IMSG_SIZE, msg);
3944  break;
3945  case 3:
3946  printf(" %-*.*s : ", CB_IMSG_SIZE, CB_IMSG_SIZE, msg);
3947  break;
3948  default:
3949  printf("%-*.*s : ", CB_IMSG_SIZE, CB_IMSG_SIZE, msg);
3950  break;
3951  }
3952 
3953  if (!val && !default_val) {
3954  putchar('\n');
3955  return;
3956  } else if (val && default_val && ((format != 2 && val[0] == 0x30) || strcmp(val, default_val) == 0)) {
3957  val = cob_strcat((char*) default_val, (char*) _(" (default)"));
3958  } else if (!val && default_val) {
3959  val = default_val;
3960  }
3961 
3962  if (val && strlen(val) <= CB_IVAL_SIZE) {
3963  printf("%s", val);
3964  putchar ('\n');
3965 
3966  return;
3967  }
3968 
3969  p = strdup (val);
3970  if (!p) {
3971  fputs (_("Memory allocation failure"), stderr);
3972  putc ('\n', stderr);
3973  return;
3974  }
3975  n = 0;
3976  token = strtok (p, " ");
3977  for (; token; token = strtok (NULL, " ")) {
3978  toklen = strlen (token) + 1;
3979  if ((n + toklen) > CB_IVAL_SIZE) {
3980  if (n) {
3981  if (format == 2 || format == 3)
3982  printf("\n %*.*s", CB_IMSG_SIZE + 3,
3983  CB_IMSG_SIZE + 3, " ");
3984  else
3985  printf("\n%*.*s", CB_IMSG_SIZE + 3, CB_IMSG_SIZE + 3, " ");
3986  }
3987  n = 0;
3988  }
3989  printf ("%s%s", (n ? " " : ""), token);
3990  n += toklen;
3991  }
3992  putchar ('\n');
3993  cob_free (p);
3994 
3995 }

Variable Documentation

struct cob_external* basext
static

Referenced by cob_external_addr().

struct cob_alloc_cache* cob_alloc_base
static

Referenced by cob_allocate(), cob_cache_free(), cob_cache_malloc(), cob_cache_realloc(), and cob_free_alloc().

int cob_argc
static

Referenced by cob_accept_arg_number(), cob_accept_arg_value(), cob_accept_command_line(), cob_chain_setup(), cob_command_line(), cob_display_arg_number(), cob_init(), cob_sys_getopt_long_long(), and print_runtime_env().

char** cob_argv
static

Referenced by cob_accept_arg_value(), cob_accept_command_line(), cob_chain_setup(), cob_command_line(), cob_init(), cob_sys_getopt_long_long(), and print_runtime_env().

const char* cob_current_paragraph
static

Referenced by cob_init(), cob_set_exception(), and cob_set_location().

const char* cob_current_program_id
static

Referenced by cob_init(), cob_set_exception(), and cob_set_location().

const char* cob_current_section
static

Referenced by cob_init(), cob_set_exception(), and cob_set_location().

const int cob_exception_tab_code[]
static

Referenced by cob_get_exception_name(), and cob_set_exception().

const char* const cob_exception_tab_name[]
static

Referenced by cob_get_exception_name().

void(* cob_ext_sighdl)(int) = NULL
static

Referenced by cob_reg_sighnd().

int cob_initialized = 0
static

Referenced by cob_command_line(), cob_exit_common(), cob_get_global_ptr(), cob_init(), cob_module_enter(), cob_stop_run(), cob_terminate_routines(), cob_tidy(), and print_runtime_env().

const char* cob_last_sfile
static

Referenced by cob_init(), cob_set_location(), and cob_trace_section().

unsigned int cob_line_trace
static

Referenced by cob_init(), cob_ready_trace(), cob_reset_trace(), cob_set_location(), cob_trace_section(), and print_runtime_env().

char* cob_local_env
static

Referenced by cob_accept_environment(), cob_display_env_value(), cob_display_environment(), cob_exit_common(), and cob_init().

size_t cob_local_env_size
static

Referenced by cob_display_environment(), and cob_init().

int cob_process_id = 0
static

Referenced by cob_sys_getpid().

const char* cob_source_file
static

Referenced by cob_init(), cob_runtime_error(), and cob_set_location().

unsigned int cob_source_line
static

Referenced by cob_init(), cob_runtime_error(), cob_set_exception(), and cob_set_location().

const char* cob_source_statement
static

Referenced by cob_init(), cob_set_exception(), and cob_set_location().

int cob_switch[COB_SWITCH_MAX]
static

Referenced by cob_get_switch(), cob_init(), cob_set_switch(), and cob_sys_x91().

int cob_temp_iteration = 0
static

Referenced by cob_incr_temp_iteration(), and cob_temp_name().

const char* cob_trace_env
static

Referenced by cob_check_trace_file(), cob_init(), and print_runtime_env().

FILE* cob_trace_file
static

Referenced by cob_check_trace_file(), cob_init(), cob_set_location(), cob_terminate_routines(), cob_trace_section(), and print_runtime_env().

char* cob_user_name
static

Referenced by cob_accept_user_name(), cob_exit_common(), and cob_init().

cob_global* cobglobptr
static

Referenced by cob_get_global_ptr(), and cob_module_enter().

size_t commlncnt
static

Referenced by cob_accept_command_line(), cob_display_command_line(), and cob_init().

unsigned char* commlnptr
static

Referenced by cob_accept_command_line(), cob_display_command_line(), cob_exit_common(), and cob_init().

const cob_field_attr const_alpha_attr
static
Initial value:
=
{COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL}

Referenced by cob_allocate(), and cob_memcpy().

int current_arg
static

Referenced by cob_accept_arg_value(), cob_display_arg_number(), and cob_init().

struct exit_handlerlist * exit_hdlrs
static

Referenced by cob_init(), cob_stop_run(), cob_sys_exit_proc(), and cob_tidy().

struct handlerlist * hdlrs
static

Referenced by cob_init(), cob_runtime_error(), and cob_sys_error_proc().

char* runtime_err_str
static

Referenced by cob_exit_common(), cob_init(), and cob_runtime_error().

runtime_env* runtimeptr
static
const unsigned char* sort_collate
static

Referenced by cob_init(), cob_table_sort_init(), and sort_compare().

cob_file_key* sort_keys
static
size_t sort_nkeys
static

Referenced by cob_init(), cob_table_sort_init(), cob_table_sort_init_key(), and sort_compare().

char* strbuff = NULL
static

Referenced by cob_strcat().