OpenCOBOL 1.1pre-rel
common.c
Go to the documentation of this file.
00001 /*
00002  * Copyright (C) 2001-2009 Keisuke Nishida
00003  * Copyright (C) 2007-2009 Roger While
00004  *
00005  * This library is free software; you can redistribute it and/or
00006  * modify it under the terms of the GNU Lesser General Public License
00007  * as published by the Free Software Foundation; either version 2.1,
00008  * or (at your option) any later version.
00009  *
00010  * This library is distributed in the hope that it will be useful,
00011  * but WITHOUT ANY WARRANTY; without even the implied warranty of
00012  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00013  * GNU Lesser General Public License for more details.
00014  *
00015  * You should have received a copy of the GNU Lesser General Public
00016  * License along with this library; see the file COPYING.LIB.  If
00017  * not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor
00018  * Boston, MA 02110-1301 USA
00019  */
00020 
00021 #include "config.h"
00022 #include "defaults.h"
00023 
00024 #include <stdio.h>
00025 #include <stdlib.h>
00026 #include <stdarg.h>
00027 #include <string.h>
00028 #include <ctype.h>
00029 #ifdef  HAVE_UNISTD_H
00030 #include <unistd.h>
00031 #endif
00032 #include <time.h>
00033 #ifdef HAVE_SYS_TIME_H
00034 #include <sys/time.h>
00035 #endif
00036 #ifdef  _WIN32
00037 #define WINDOWS_LEAN_AND_MEAN
00038 #include <windows.h>
00039 #include <io.h>
00040 #include <fcntl.h>
00041 #undef  HAVE_SIGNAL_H
00042 #endif
00043 
00044 #ifdef  HAVE_SIGNAL_H
00045 #include <signal.h>
00046 #endif
00047 
00048 #ifdef  HAVE_LOCALE_H
00049 #include <locale.h>
00050 #endif
00051 
00052 #include "common.h"
00053 #include "coblocal.h"
00054 #include "move.h"
00055 #include "numeric.h"
00056 #include "termio.h"
00057 #include "fileio.h"
00058 #include "call.h"
00059 #include "screenio.h"
00060 #include "intrinsic.h"
00061 #include "lib/gettext.h"
00062 
00063 struct cob_exception {
00064         const char      *name;
00065         const int       code;
00066         const int       critical;
00067 };
00068 
00069 struct cob_alloc_cache {
00070         struct cob_alloc_cache  *next;
00071         void                    *cob_pointer;
00072         size_t                  size;
00073 };
00074 
00075 #define COB_ERRBUF_SIZE 256
00076 
00077 /* Local variables */
00078 
00079 static int                      cob_argc = 0;
00080 static char                     **cob_argv = NULL;
00081 static struct cob_alloc_cache   *cob_alloc_base = NULL;
00082 
00083 static char                     *cob_local_env = NULL;
00084 static int                      current_arg = 1;
00085 static unsigned char            *commlnptr = NULL;
00086 static size_t                   commlncnt = 0;
00087 
00088 static char                     *locale_save = NULL;
00089 
00090 static size_t                   sort_nkeys;
00091 static struct cob_file_key      *sort_keys;
00092 static const unsigned char      *sort_collate;
00093 
00094 static const char               *cob_current_program_id = NULL;
00095 static const char               *cob_current_section = NULL;
00096 static const char               *cob_current_paragraph = NULL;
00097 static const char               *cob_source_file = NULL;
00098 static const char               *cob_source_statement = NULL;
00099 static unsigned int             cob_source_line = 0;
00100 static size_t                   cob_line_trace = 0;
00101 
00102 #ifdef  HAVE_SIGNAL_H
00103 typedef void (*cob_sighandler_t) (int);
00104 static cob_sighandler_t         hupsig = NULL;
00105 static cob_sighandler_t         intsig = NULL;
00106 static cob_sighandler_t         qutsig = NULL;
00107 #endif
00108 
00109 #ifdef  COB_PARAM_CHECK
00110 static const char       parm_msg[] = "CALL to %s requires %d parameters";
00111 #endif
00112 
00113 #undef  COB_EXCEPTION
00114 #define COB_EXCEPTION(code,tag,name,critical)   name,
00115 static const char               * const cob_exception_tab_name[] = {
00116         NULL,           /* COB_EC_ZERO */
00117 #include "exception.def"
00118         NULL            /* COB_EC_MAX */
00119 };
00120 
00121 #undef  COB_EXCEPTION
00122 #define COB_EXCEPTION(code,tag,name,critical)   0x##code,
00123 static const int                cob_exception_tab_code[] = {
00124         0,              /* COB_EC_ZERO */
00125 #include "exception.def"
00126         0               /* COB_EC_MAX */
00127 };
00128 
00129 #undef  COB_EXCEPTION
00130 
00131 #define EXCEPTION_TAB_SIZE      sizeof(cob_exception_tab_code) / sizeof(int)
00132 
00133 /*
00134 #define EXCEPTION_TAB_SIZE      sizeof(cob_exception_table) / sizeof(struct cob_exception)
00135 */
00136 
00137 static int              cob_switch[8];
00138 
00139 /* Runtime exit handling */
00140 static struct exit_handlerlist {
00141         struct exit_handlerlist *next;
00142         int                     (*proc)(void);
00143 } *exit_hdlrs = NULL;
00144 
00145 /* Runtime error handling */
00146 static struct handlerlist {
00147         struct handlerlist      *next;
00148         int                     (*proc)(char *s);
00149 } *hdlrs = NULL;
00150 
00151 static char                     *runtime_err_str;
00152 
00153 static cob_field_attr   all_attr = { COB_TYPE_ALPHANUMERIC_ALL, 0, 0, 0, NULL };
00154 static cob_field_attr   one_attr = { COB_TYPE_NUMERIC, 1, 0, 0, NULL };
00155 
00156 /* Global variables */
00157 
00158 struct cob_module       *cob_current_module = NULL;
00159 
00160 int                     cob_initialized = 0;
00161 int                     cob_exception_code = 0;
00162 
00163 int                     cob_call_params = 0;
00164 int                     cob_save_call_params = 0;
00165 int                     cob_initial_external = 0;
00166 int                     cob_got_exception = 0;
00167 
00168 const char              *cob_orig_statement = NULL;
00169 const char              *cob_orig_program_id = NULL;
00170 const char              *cob_orig_section = NULL;
00171 const char              *cob_orig_paragraph = NULL;
00172 unsigned int            cob_orig_line = 0;
00173 
00174 cob_field               cob_zero = { 1, (ucharptr)"0", &all_attr };
00175 cob_field               cob_space = { 1, (ucharptr)" ", &all_attr };
00176 cob_field               cob_high = { 1, (ucharptr)"\xff", &all_attr };
00177 cob_field               cob_low = { 1, (ucharptr)"\0", &all_attr };
00178 cob_field               cob_quote = { 1, (ucharptr)"\"", &all_attr };
00179 cob_field               cob_one = { 1, (ucharptr)"1", &one_attr };
00180 
00181 /* Local functions */
00182 
00183 #ifdef  HAVE_SIGNAL_H
00184 static void COB_NOINLINE
00185 cob_sig_handler (int sig)
00186 {
00187 #ifdef  SIGSEGV
00188         if (sig == SIGSEGV) {
00189                 if (cob_source_file) {
00190                         fprintf (stderr, "%s:%d: ", cob_source_file, cob_source_line);
00191                 }
00192                 fprintf (stderr, "Attempt to reference unallocated memory (Signal SIGSEGV)\n");
00193                 fprintf (stderr, "Abnormal termination - File contents may be incorrect\n");
00194                 fflush (stderr);
00195                 exit (SIGSEGV);
00196         }
00197 #endif
00198         if (cob_initialized) {
00199                 cob_screen_terminate ();
00200                 cob_exit_fileio ();
00201                 fprintf (stderr, "Abnormal termination - File contents may not be correct\n");
00202                 fflush (stderr);
00203         }
00204         switch (sig) {
00205 #ifdef  SIGHUP
00206         case SIGHUP:
00207                 if ((hupsig != SIG_IGN) && (hupsig != SIG_DFL)) {
00208                         (*hupsig) (SIGHUP);
00209                 }
00210                 break;
00211 #endif
00212 #ifdef  SIGINT
00213         case SIGINT:
00214                 if ((intsig != SIG_IGN) && (intsig != SIG_DFL)) {
00215                         (*intsig) (SIGINT);
00216                 }
00217                 break;
00218 #endif
00219 #ifdef  SIGQUIT
00220         case SIGQUIT:
00221                 if ((qutsig != SIG_IGN) && (qutsig != SIG_DFL)) {
00222                         (*qutsig) (SIGQUIT);
00223                 }
00224                 break;
00225         }
00226 #endif
00227         exit (sig);
00228 }
00229 #endif
00230 
00231 static void
00232 cob_set_signal (void)
00233 {
00234 #ifdef  HAVE_SIGNAL_H
00235 #ifdef  SIGINT
00236         if ((intsig = signal (SIGINT, cob_sig_handler)) == SIG_IGN) {
00237                 (void)signal (SIGINT, SIG_IGN);
00238         }
00239 #endif
00240 #ifdef  SIGHUP
00241         if ((hupsig = signal (SIGHUP, cob_sig_handler)) == SIG_IGN) {
00242                 (void)signal (SIGHUP, SIG_IGN);
00243         }
00244 #endif
00245 #ifdef  SIGQUIT
00246         if ((qutsig = signal (SIGQUIT, cob_sig_handler)) == SIG_IGN) {
00247                 (void)signal (SIGQUIT, SIG_IGN);
00248         }
00249 #endif
00250         /* Take direct control of segementation violation */
00251 #ifdef  SIGSEGV
00252         (void)signal (SIGSEGV, cob_sig_handler);
00253 #endif
00254 #endif
00255 }
00256 
00257 #ifdef  COB_EBCDIC_MACHINE
00258 static void
00259 cob_get_sign_ascii (unsigned char *p)
00260 {
00261         switch (*p) {
00262         case 'p':
00263                 *p = (unsigned char)'0';
00264                 return;
00265         case 'q':
00266                 *p = (unsigned char)'1';
00267                 return;
00268         case 'r':
00269                 *p = (unsigned char)'2';
00270                 return;
00271         case 's':
00272                 *p = (unsigned char)'3';
00273                 return;
00274         case 't':
00275                 *p = (unsigned char)'4';
00276                 return;
00277         case 'u':
00278                 *p = (unsigned char)'5';
00279                 return;
00280         case 'v':
00281                 *p = (unsigned char)'6';
00282                 return;
00283         case 'w':
00284                 *p = (unsigned char)'7';
00285                 return;
00286         case 'x':
00287                 *p = (unsigned char)'8';
00288                 return;
00289         case 'y':
00290                 *p = (unsigned char)'9';
00291                 return;
00292         }
00293 }
00294 #endif
00295 
00296 static int COB_NOINLINE
00297 cob_get_sign_ebcdic (unsigned char *p)
00298 {
00299         switch (*p) {
00300         case '{':
00301                 *p = (unsigned char)'0';
00302                 return 1;
00303         case 'A':
00304                 *p = (unsigned char)'1';
00305                 return 1;
00306         case 'B':
00307                 *p = (unsigned char)'2';
00308                 return 1;
00309         case 'C':
00310                 *p = (unsigned char)'3';
00311                 return 1;
00312         case 'D':
00313                 *p = (unsigned char)'4';
00314                 return 1;
00315         case 'E':
00316                 *p = (unsigned char)'5';
00317                 return 1;
00318         case 'F':
00319                 *p = (unsigned char)'6';
00320                 return 1;
00321         case 'G':
00322                 *p = (unsigned char)'7';
00323                 return 1;
00324         case 'H':
00325                 *p = (unsigned char)'8';
00326                 return 1;
00327         case 'I':
00328                 *p = (unsigned char)'9';
00329                 return 1;
00330         case '}':
00331                 *p = (unsigned char)'0';
00332                 return -1;
00333         case 'J':
00334                 *p = (unsigned char)'1';
00335                 return -1;
00336         case 'K':
00337                 *p = (unsigned char)'2';
00338                 return -1;
00339         case 'L':
00340                 *p = (unsigned char)'3';
00341                 return -1;
00342         case 'M':
00343                 *p = (unsigned char)'4';
00344                 return -1;
00345         case 'N':
00346                 *p = (unsigned char)'5';
00347                 return -1;
00348         case 'O':
00349                 *p = (unsigned char)'6';
00350                 return -1;
00351         case 'P':
00352                 *p = (unsigned char)'7';
00353                 return -1;
00354         case 'Q':
00355                 *p = (unsigned char)'8';
00356                 return -1;
00357         case 'R':
00358                 *p = (unsigned char)'9';
00359                 return -1;
00360         default:
00361                 /* What to do here */
00362                 *p = (unsigned char)'0';
00363                 return 1;
00364         }
00365 /* NOT REACHED */
00366         return 1;
00367 }
00368 
00369 static void COB_NOINLINE
00370 cob_put_sign_ebcdic (unsigned char *p, const int sign)
00371 {
00372         if (sign < 0) {
00373                 switch (*p) {
00374                 case '0':
00375                         *p = (unsigned char)'}';
00376                         return;
00377                 case '1':
00378                         *p = (unsigned char)'J';
00379                         return;
00380                 case '2':
00381                         *p = (unsigned char)'K';
00382                         return;
00383                 case '3':
00384                         *p = (unsigned char)'L';
00385                         return;
00386                 case '4':
00387                         *p = (unsigned char)'M';
00388                         return;
00389                 case '5':
00390                         *p = (unsigned char)'N';
00391                         return;
00392                 case '6':
00393                         *p = (unsigned char)'O';
00394                         return;
00395                 case '7':
00396                         *p = (unsigned char)'P';
00397                         return;
00398                 case '8':
00399                         *p = (unsigned char)'Q';
00400                         return;
00401                 case '9':
00402                         *p = (unsigned char)'R';
00403                         return;
00404                 default:
00405                         /* What to do here */
00406                         *p = (unsigned char)'}';
00407                         return;
00408                 }
00409         }
00410         switch (*p) {
00411         case '0':
00412                 *p = (unsigned char)'{';
00413                 return;
00414         case '1':
00415                 *p = (unsigned char)'A';
00416                 return;
00417         case '2':
00418                 *p = (unsigned char)'B';
00419                 return;
00420         case '3':
00421                 *p = (unsigned char)'C';
00422                 return;
00423         case '4':
00424                 *p = (unsigned char)'D';
00425                 return;
00426         case '5':
00427                 *p = (unsigned char)'E';
00428                 return;
00429         case '6':
00430                 *p = (unsigned char)'F';
00431                 return;
00432         case '7':
00433                 *p = (unsigned char)'G';
00434                 return;
00435         case '8':
00436                 *p = (unsigned char)'H';
00437                 return;
00438         case '9':
00439                 *p = (unsigned char)'I';
00440                 return;
00441         default:
00442                 /* What to do here */
00443                 *p = (unsigned char)'{';
00444                 return;
00445         }
00446 /* NOT REACHED */
00447 }
00448 
00449 static int
00450 common_cmpc (const unsigned char *s1, const unsigned int c, const size_t size)
00451 {
00452         const unsigned char     *s;
00453         size_t                  i;
00454         int                     ret;
00455 
00456         s = cob_current_module->collating_sequence;
00457         if (unlikely(s)) {
00458                 for (i = 0; i < size; ++i) {
00459                         if ((ret = s[s1[i]] - s[c]) != 0) {
00460                                 return ret;
00461                         }
00462                 }
00463         } else {
00464                 for (i = 0; i < size; ++i) {
00465                         if ((ret = s1[i] - c) != 0) {
00466                                 return ret;
00467                         }
00468                 }
00469         }
00470         return 0;
00471 }
00472 
00473 static int
00474 common_cmps (const unsigned char *s1, const unsigned char *s2, const size_t size,
00475              const unsigned char *col)
00476 {
00477         size_t                  i;
00478         int                     ret;
00479 
00480         if (unlikely(col)) {
00481                 for (i = 0; i < size; ++i) {
00482                         if ((ret = col[s1[i]] - col[s2[i]]) != 0) {
00483                                 return ret;
00484                         }
00485                 }
00486         } else {
00487                 for (i = 0; i < size; ++i) {
00488                         if ((ret = s1[i] - s2[i]) != 0) {
00489                                 return ret;
00490                         }
00491                 }
00492         }
00493         return 0;
00494 }
00495 
00496 static int
00497 cob_cmp_char (cob_field *f, const unsigned int c)
00498 {
00499         int     sign;
00500         int     ret;
00501 
00502         sign = cob_get_sign (f);
00503         ret = common_cmpc (f->data, c, f->size);
00504         if (COB_FIELD_TYPE (f) != COB_TYPE_NUMERIC_PACKED) {
00505                 cob_put_sign (f, sign);
00506         }
00507         return ret;
00508 }
00509 
00510 static int
00511 cob_cmp_all (cob_field *f1, cob_field *f2)
00512 {
00513         unsigned char           *data;
00514         const unsigned char     *s;
00515         size_t                  size;
00516         int                     ret;
00517         int                     sign;
00518 
00519         size = f1->size;
00520         data = f1->data;
00521         sign = cob_get_sign (f1);
00522         ret = 0;
00523         s = cob_current_module->collating_sequence;
00524         while (size >= f2->size) {
00525                 if ((ret = common_cmps (data, f2->data, f2->size, s)) != 0) {
00526                         goto end;
00527                 }
00528                 size -= f2->size;
00529                 data += f2->size;
00530         }
00531         if (size > 0) {
00532                 ret = common_cmps (data, f2->data, size, s);
00533         }
00534 
00535 end:
00536         if (COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_PACKED) {
00537                 cob_put_sign (f1, sign);
00538         }
00539         return ret;
00540 }
00541 
00542 static int
00543 cob_cmp_alnum (cob_field *f1, cob_field *f2)
00544 {
00545         const unsigned char     *s;
00546         size_t                  min;
00547         int                     ret;
00548         int                     sign1;
00549         int                     sign2;
00550 
00551         sign1 = cob_get_sign (f1);
00552         sign2 = cob_get_sign (f2);
00553         min = (f1->size < f2->size) ? f1->size : f2->size;
00554         s = cob_current_module->collating_sequence;
00555         /* compare common substring */
00556         if ((ret = common_cmps (f1->data, f2->data, min, s)) != 0) {
00557                 goto end;
00558         }
00559 
00560         /* compare the rest (if any) with spaces */
00561         if (f1->size > f2->size) {
00562                 ret = common_cmpc (f1->data + min, ' ', f1->size - min);
00563         } else if (f1->size < f2->size) {
00564                 ret = -common_cmpc (f2->data + min, ' ', f2->size - min);
00565         }
00566 
00567 end:
00568         if (COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_PACKED) {
00569                 cob_put_sign (f1, sign1);
00570         }
00571         if (COB_FIELD_TYPE (f2) != COB_TYPE_NUMERIC_PACKED) {
00572                 cob_put_sign (f2, sign2);
00573         }
00574         return ret;
00575 }
00576 
00577 static int
00578 sort_compare (const void *data1, const void *data2)
00579 {
00580         size_t          i;
00581         int             cmp;
00582         cob_field       f1;
00583         cob_field       f2;
00584 
00585         for (i = 0; i < sort_nkeys; ++i) {
00586                 f1 = f2 = *sort_keys[i].field;
00587                 f1.data = (unsigned char *)data1 + sort_keys[i].offset;
00588                 f2.data = (unsigned char *)data2 + sort_keys[i].offset;
00589                 if (COB_FIELD_IS_NUMERIC(&f1)) {
00590                         cmp = cob_numeric_cmp (&f1, &f2);
00591                 } else {
00592                         cmp = common_cmps (f1.data, f2.data, f1.size, sort_collate);
00593                 }
00594                 if (cmp != 0) {
00595                         return (sort_keys[i].flag == COB_ASCENDING) ? cmp : -cmp;
00596                 }
00597         }
00598         return 0;
00599 }
00600 
00601 /*
00602  * Global functions
00603  */
00604 
00605 void *
00606 cob_malloc (const size_t size)
00607 {
00608         void *mptr;
00609 
00610         mptr = calloc (1, size);
00611         if (unlikely(!mptr)) {
00612                 cob_runtime_error ("Cannot acquire %d bytes of memory - Aborting", size);
00613                 cob_stop_run (1);
00614         }
00615         return mptr;
00616 }
00617 
00618 void
00619 cob_set_location (const char *progid, const char *sfile, const unsigned int sline,
00620                   const char *csect, const char *cpara, const char *cstatement)
00621 {
00622         cob_current_program_id = progid;
00623         cob_source_file = sfile;
00624         cob_source_line = sline;
00625         cob_current_section = csect;
00626         cob_current_paragraph = cpara;
00627         if (cstatement) {
00628                 cob_source_statement = cstatement;
00629         }
00630         if (cob_line_trace) {
00631                 fprintf (stderr, "PROGRAM-ID: %s \tLine: %d \tStatement: %s\n",
00632                         (char *)progid, sline, cstatement ? (char *)cstatement : "Unknown");
00633                 fflush (stderr);
00634         }
00635 }
00636 
00637 void
00638 cob_ready_trace (void)
00639 {
00640         cob_line_trace = 1;
00641 }
00642 
00643 void
00644 cob_reset_trace (void)
00645 {
00646         cob_line_trace = 0;
00647 }
00648 
00649 unsigned char *
00650 cob_get_pointer (const unsigned char *srcptr)
00651 {
00652         unsigned char   *tmptr;
00653 
00654         memcpy (&tmptr, srcptr, sizeof (void *));
00655         return tmptr;
00656 }
00657 
00658 void *
00659 cob_get_prog_pointer (const unsigned char *srcptr)
00660 {
00661         void    *tmptr;
00662 
00663         memcpy (&tmptr, srcptr, sizeof (void *));
00664         return tmptr;
00665 }
00666 
00667 void
00668 cob_memcpy (cob_field *dst, unsigned char *src, const int size)
00669 {
00670         cob_field       temp;
00671         cob_field_attr  attr;
00672 
00673         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
00674         temp.size = size;
00675         temp.data = src;
00676         temp.attr = &attr;
00677         cob_move (&temp, dst);
00678 }
00679 
00680 const char *
00681 cob_get_exception_name (const int exception_code)
00682 {
00683         size_t  n;
00684 
00685         for (n = 0; n < EXCEPTION_TAB_SIZE; ++n) {
00686                 if (exception_code == cob_exception_tab_code[n]) {
00687                         return cob_exception_tab_name[n];
00688                 }
00689         }
00690         return NULL;
00691 }
00692 
00693 void
00694 cob_set_exception (const int id)
00695 {
00696         cob_exception_code = cob_exception_tab_code[id];
00697         if (cob_exception_code) {
00698                 cob_got_exception = 1;
00699                 cob_orig_statement = cob_source_statement;
00700                 cob_orig_line = cob_source_line;
00701                 cob_orig_program_id = cob_current_program_id;
00702                 cob_orig_section = cob_current_section;
00703                 cob_orig_paragraph = cob_current_paragraph;
00704         }
00705 }
00706 
00707 void
00708 cob_init (int argc, char **argv)
00709 {
00710         char    *s;
00711         size_t  i;
00712         char    buff[32];
00713 
00714         if (!cob_initialized) {
00715                 cob_set_signal ();
00716 
00717                 cob_argc = argc;
00718                 cob_argv = argv;
00719 
00720                 /* Get emergency buffer */
00721                 runtime_err_str = cob_malloc (COB_ERRBUF_SIZE);
00722 
00723 #ifdef  HAVE_SETLOCALE
00724                 setlocale (LC_ALL, "");
00725                 setlocale (LC_NUMERIC, "C");
00726                 s = setlocale (LC_ALL, NULL);
00727                 if (s) {
00728                         locale_save = strdup (s);
00729                 }
00730 #endif
00731 #ifdef  ENABLE_NLS
00732                 bindtextdomain (PACKAGE, LOCALEDIR);
00733                 textdomain (PACKAGE);
00734 #endif
00735 
00736 /* Dirty hack until we implement something better */
00737 #if defined(_WIN32) && !defined(_MSC_VER)
00738                 _setmode (_fileno (stdin), _O_BINARY);
00739                 _setmode (_fileno (stdout), _O_BINARY);
00740                 _setmode (_fileno (stderr), _O_BINARY);
00741 #endif
00742 
00743                 cob_init_numeric ();
00744                 cob_init_strings ();
00745                 cob_init_move ();
00746                 cob_init_intrinsic ();
00747                 cob_init_fileio ();
00748                 cob_init_termio ();
00749                 cob_init_call ();
00750 
00751                 for (i = 0; i < 8; ++i) {
00752                         memset (buff, 0, sizeof (buff));
00753                         snprintf (buff, 31, "COB_SWITCH_%d", (int)(i + 1));
00754                         s = getenv (buff);
00755                         if (s && strcasecmp (s, "ON") == 0) {
00756                                 cob_switch[i] = 1;
00757                         } else {
00758                                 cob_switch[i] = 0;
00759                         }
00760                 }
00761 
00762                 s = getenv ("COB_LINE_TRACE");
00763                 if (s && (*s == 'Y' || *s == 'y')) {
00764                         cob_line_trace = 1;
00765                 }
00766 
00767                 cob_initialized = 1;
00768         }
00769 }
00770 
00771 void
00772 cob_module_enter (struct cob_module *module)
00773 {
00774         if (unlikely(!cob_initialized)) {
00775                 fputs ("Warning: cob_init expected in the main program\n", stderr);
00776                 cob_init (0, NULL);
00777         }
00778 
00779         module->next = cob_current_module;
00780         cob_current_module = module;
00781 }
00782 
00783 void
00784 cob_module_leave (struct cob_module *module)
00785 {
00786         cob_current_module = cob_current_module->next;
00787 }
00788 
00789 void
00790 cob_stop_run (const int status)
00791 {
00792         struct exit_handlerlist *h;
00793 
00794         if (exit_hdlrs != NULL) {
00795                 h = exit_hdlrs;
00796                 while (h != NULL) {
00797                         h->proc ();
00798                         h = h->next;
00799                 }
00800         }
00801         cob_screen_terminate ();
00802         cob_exit_fileio ();
00803         exit (status);
00804 }
00805 
00806 void COB_NOINLINE
00807 cob_runtime_error (const char *fmt, ...)
00808 {
00809         struct handlerlist      *h;
00810         char                    *p;
00811         va_list                 ap;
00812 
00813         if (hdlrs != NULL) {
00814                 h = hdlrs;
00815                 if (runtime_err_str) {
00816                         p = runtime_err_str;
00817                         if (cob_source_file) {
00818                                 sprintf (runtime_err_str, "%s:%d: ",
00819                                          cob_source_file, cob_source_line);
00820                                 p = runtime_err_str + strlen (runtime_err_str);
00821                         }
00822                         va_start (ap, fmt);
00823                         vsprintf (p, fmt, ap);
00824                         va_end (ap);
00825                 }
00826                 while (h != NULL) {
00827                         if (runtime_err_str) {
00828                                 h->proc (runtime_err_str);
00829                         } else {
00830                                 h->proc ((char *)"Malloc error");
00831                         }
00832                         h = h->next;
00833                 }
00834                 hdlrs = NULL;
00835         }
00836 
00837         /* prefix */
00838         if (cob_source_file) {
00839                 fprintf (stderr, "%s:%d: ", cob_source_file, cob_source_line);
00840         }
00841         fputs ("libcob: ", stderr);
00842 
00843         /* body */
00844         va_start (ap, fmt);
00845         vfprintf (stderr, fmt, ap);
00846         va_end (ap);
00847 
00848         /* postfix */
00849         fputs ("\n", stderr);
00850         fflush (stderr);
00851 }
00852 
00853 void
00854 cob_fatal_error (const unsigned int fatal_error)
00855 {
00856         switch (fatal_error) {
00857         case COB_FERROR_INITIALIZED:
00858                 cob_runtime_error ("cob_init() has not been called");
00859                 break;
00860         case COB_FERROR_CODEGEN:
00861                 cob_runtime_error ("Codegen error - Please report this");
00862                 break;
00863         case COB_FERROR_CHAINING:
00864                 cob_runtime_error ("ERROR - Recursive call of chained program");
00865                 break;
00866         case COB_FERROR_STACK:
00867                 cob_runtime_error ("Stack overflow, possible PERFORM depth exceeded");
00868                 break;
00869         default:
00870                 cob_runtime_error ("Unknown failure : %d", (int)fatal_error);
00871                 break;
00872         }
00873         cob_stop_run (1);
00874 }
00875 
00876 void
00877 cob_check_version (const char *prog, const char *packver, const int patchlev)
00878 {
00879         if (strcmp (packver, PACKAGE_VERSION) || patchlev > PATCH_LEVEL) {
00880                 cob_runtime_error ("Error - Version mismatch");
00881                 cob_runtime_error ("%s has version/patch level %s/%d", prog, packver,
00882                                    patchlev);
00883                 cob_runtime_error ("Library has version/patch level %s/%d", PACKAGE_VERSION,
00884                                    PATCH_LEVEL);
00885                 cob_stop_run (1);
00886         }
00887 }
00888 
00889 /*
00890  * Sign
00891  */
00892 
00893 int
00894 cob_real_get_sign (cob_field *f)
00895 {
00896         unsigned char   *p;
00897 
00898         switch (COB_FIELD_TYPE (f)) {
00899         case COB_TYPE_NUMERIC_DISPLAY:
00900                 /* locate sign */
00901                 if (unlikely(COB_FIELD_SIGN_LEADING (f))) {
00902                         p = f->data;
00903                 } else {
00904                         p = f->data + f->size - 1;
00905                 }
00906 
00907                 /* get sign */
00908                 if (unlikely(COB_FIELD_SIGN_SEPARATE (f))) {
00909                         return (*p == '+') ? 1 : -1;
00910                 } else {
00911                         if (*p >= '0' && *p <= '9') {
00912                                 return 1;
00913                         }
00914                         if (*p == ' ') {
00915                                 *p = (unsigned char)'0';
00916                                 return 1;
00917                         }
00918                         if (unlikely(cob_current_module->display_sign)) {
00919                                 return cob_get_sign_ebcdic (p);
00920                         } else {
00921 #ifdef  COB_EBCDIC_MACHINE
00922                                 cob_get_sign_ascii (p);
00923 #else
00924                                 GET_SIGN_ASCII (*p);
00925 #endif
00926                                 return -1;
00927                         }
00928                 }
00929         case COB_TYPE_NUMERIC_PACKED:
00930                 p = f->data + f->size - 1;
00931                 return ((*p & 0x0f) == 0x0d) ? -1 : 1;
00932         default:
00933                 return 0;
00934         }
00935 }
00936 
00937 void
00938 cob_real_put_sign (cob_field *f, const int sign)
00939 {
00940         unsigned char   *p;
00941         int             c;
00942 
00943         switch (COB_FIELD_TYPE (f)) {
00944         case COB_TYPE_NUMERIC_DISPLAY:
00945                 /* locate sign */
00946                 if (unlikely(COB_FIELD_SIGN_LEADING (f))) {
00947                         p = f->data;
00948                 } else {
00949                         p = f->data + f->size - 1;
00950                 }
00951 
00952                 /* put sign */
00953                 if (unlikely(COB_FIELD_SIGN_SEPARATE (f))) {
00954                         c = (sign < 0) ? '-' : '+';
00955                         if (*p != c) {
00956                                 *p = c;
00957                         }
00958                 } else if (unlikely(cob_current_module->display_sign)) {
00959                         cob_put_sign_ebcdic (p, sign);
00960                 } else if (sign < 0) {
00961 #ifdef  COB_EBCDIC_MACHINE
00962                         cob_put_sign_ascii (p);
00963 #else
00964                         PUT_SIGN_ASCII (*p);
00965 #endif
00966                 }
00967                 return;
00968         case COB_TYPE_NUMERIC_PACKED:
00969                 p = f->data + f->size - 1;
00970                 if (sign < 0) {
00971                         *p = (*p & 0xf0) | 0x0d;
00972                 } else {
00973                         *p = (*p & 0xf0) | 0x0c;
00974                 }
00975                 return;
00976         default:
00977                 return;
00978         }
00979 }
00980 
00981 void
00982 cob_field_to_string (const cob_field *f, char *s)
00983 {
00984         int     i;
00985 
00986         memcpy (s, f->data, f->size);
00987         for (i = (int) f->size - 1; i >= 0; i--) {
00988                 if (s[i] != ' ' && s[i] != 0) {
00989                         break;
00990                 }
00991         }
00992         s[i + 1] = '\0';
00993 }
00994 
00995 /*
00996  * Switch
00997  */
00998 
00999 int
01000 cob_get_switch (const int n)
01001 {
01002         return cob_switch[n];
01003 }
01004 
01005 void
01006 cob_set_switch (const int n, const int flag)
01007 {
01008         if (flag == 0) {
01009                 cob_switch[n] = 0;
01010         } else if (flag == 1) {
01011                 cob_switch[n] = 1;
01012         }
01013 }
01014 
01015 int
01016 cob_cmp (cob_field *f1, cob_field *f2)
01017 {
01018         cob_field       temp;
01019         cob_field_attr  attr;
01020         unsigned char   buff[48];
01021 
01022         if (COB_FIELD_IS_NUMERIC (f1) && COB_FIELD_IS_NUMERIC (f2)) {
01023                 return cob_numeric_cmp (f1, f2);
01024         }
01025         if (COB_FIELD_TYPE (f2) == COB_TYPE_ALPHANUMERIC_ALL) {
01026                 if (f2 == &cob_zero && COB_FIELD_IS_NUMERIC (f1)) {
01027                         return cob_cmp_int (f1, 0);
01028                 } else if (f2->size == 1) {
01029                         return cob_cmp_char (f1, f2->data[0]);
01030                 } else {
01031                         return cob_cmp_all (f1, f2);
01032                 }
01033         } else if (COB_FIELD_TYPE (f1) == COB_TYPE_ALPHANUMERIC_ALL) {
01034                 if (f1 == &cob_zero && COB_FIELD_IS_NUMERIC (f2)) {
01035                         return -cob_cmp_int (f2, 0);
01036                 } else if (f1->size == 1) {
01037                         return -cob_cmp_char (f2, f1->data[0]);
01038                 } else {
01039                         return -cob_cmp_all (f2, f1);
01040                 }
01041         } else {
01042                 if (COB_FIELD_IS_NUMERIC (f1)
01043                     && COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_DISPLAY) {
01044                         temp.size = COB_FIELD_DIGITS(f1);
01045                         temp.data = buff;
01046                         temp.attr = &attr;
01047                         attr = *f1->attr;
01048                         attr.type = COB_TYPE_NUMERIC_DISPLAY;
01049                         attr.flags &= ~COB_FLAG_HAVE_SIGN;
01050                         cob_move (f1, &temp);
01051                         f1 = &temp;
01052                 }
01053                 if (COB_FIELD_IS_NUMERIC (f2)
01054                     && COB_FIELD_TYPE (f2) != COB_TYPE_NUMERIC_DISPLAY) {
01055                         temp.size = COB_FIELD_DIGITS(f2);
01056                         temp.data = buff;
01057                         temp.attr = &attr;
01058                         attr = *f2->attr;
01059                         attr.type = COB_TYPE_NUMERIC_DISPLAY;
01060                         attr.flags &= ~COB_FLAG_HAVE_SIGN;
01061                         cob_move (f2, &temp);
01062                         f2 = &temp;
01063                 }
01064                 return cob_cmp_alnum (f1, f2);
01065         }
01066 }
01067 
01068 /*
01069  * Class check
01070  */
01071 
01072 int
01073 cob_is_omitted (const cob_field *f)
01074 {
01075         return f->data == NULL;
01076 }
01077 
01078 int
01079 cob_is_numeric (cob_field *f)
01080 {
01081         unsigned char   *data;
01082         size_t          size;
01083         size_t          i;
01084         int             sign;
01085 
01086         switch (COB_FIELD_TYPE (f)) {
01087         case COB_TYPE_NUMERIC_BINARY:
01088         case COB_TYPE_NUMERIC_FLOAT:
01089         case COB_TYPE_NUMERIC_DOUBLE:
01090                 return 1;
01091         case COB_TYPE_NUMERIC_PACKED:
01092                 /* check digits */
01093                 for (i = 0; i < f->size - 1; ++i) {
01094                         if ((f->data[i] & 0xf0) > 0x90 || (f->data[i] & 0x0f) > 0x09) {
01095                                 return 0;
01096                         }
01097                 }
01098                 if ((f->data[i] & 0xf0) > 0x90) {
01099                         return 0;
01100                 }
01101                 /* check sign */
01102                 sign = f->data[i] & 0x0f;
01103                 if (sign == 0x0f) {
01104                         return 1;
01105                 }
01106                 if (COB_FIELD_HAVE_SIGN (f)) {
01107                         if (sign == 0x0c || sign == 0x0d) {
01108                                 return 1;
01109                         }
01110                 }
01111                 return 0;
01112         case COB_TYPE_NUMERIC_DISPLAY:
01113                 data = COB_FIELD_DATA (f);
01114                 size = COB_FIELD_SIZE (f);
01115                 sign = cob_get_sign (f);
01116                 for (i = 0; i < size; ++i) {
01117                         if (!isdigit (data[i])) {
01118                                 cob_put_sign (f, sign);
01119                                 return 0;
01120                         }
01121                 }
01122                 cob_put_sign (f, sign);
01123                 return 1;
01124         default:
01125                 for (i = 0; i < f->size; ++i) {
01126                         if (!isdigit (f->data[i])) {
01127                                 return 0;
01128                         }
01129                 }
01130                 return 1;
01131         }
01132 }
01133 
01134 int
01135 cob_is_alpha (const cob_field *f)
01136 {
01137         size_t  i;
01138 
01139         for (i = 0; i < f->size; ++i) {
01140                 if (!isspace (f->data[i]) && !isalpha (f->data[i])) {
01141                         return 0;
01142                 }
01143         }
01144         return 1;
01145 }
01146 
01147 int
01148 cob_is_upper (const cob_field *f)
01149 {
01150         size_t  i;
01151 
01152         for (i = 0; i < f->size; ++i) {
01153                 if (!isspace (f->data[i]) && !isupper (f->data[i])) {
01154                         return 0;
01155                 }
01156         }
01157         return 1;
01158 }
01159 
01160 int
01161 cob_is_lower (const cob_field *f)
01162 {
01163         size_t  i;
01164 
01165         for (i = 0; i < f->size; ++i) {
01166                 if (!isspace (f->data[i]) && !islower (f->data[i])) {
01167                         return 0;
01168                 }
01169         }
01170         return 1;
01171 }
01172 
01173 /*
01174  * Table sort
01175  */
01176 
01177 void
01178 cob_table_sort_init (const int nkeys, const unsigned char *collating_sequence)
01179 {
01180         sort_nkeys = 0;
01181         sort_keys = cob_malloc (nkeys * sizeof (struct cob_file_key));
01182         if (collating_sequence) {
01183                 sort_collate = collating_sequence;
01184         } else {
01185                 sort_collate = cob_current_module->collating_sequence;
01186         }
01187 }
01188 
01189 void
01190 cob_table_sort_init_key (const int flag, cob_field *field, size_t offset)
01191 {
01192         sort_keys[sort_nkeys].flag = flag;
01193         sort_keys[sort_nkeys].field = field;
01194         sort_keys[sort_nkeys].offset = offset;
01195         sort_nkeys++;
01196 }
01197 
01198 void
01199 cob_table_sort (cob_field *f, const int n)
01200 {
01201         qsort (f->data, (size_t) n, f->size, sort_compare);
01202         free (sort_keys);
01203 }
01204 
01205 /*
01206  * Run-time error checking
01207  */
01208 
01209 void
01210 cob_check_based (const unsigned char *x, const char *name)
01211 {
01212         if (!x) {
01213                 cob_runtime_error ("BASED/LINKAGE item '%s' has NULL address", name);
01214                 cob_stop_run (1);
01215         }
01216 }
01217 
01218 void
01219 cob_check_numeric (cob_field *f, const char *name)
01220 {
01221         unsigned char   *data;
01222         char            *p;
01223         char            *buff;
01224         size_t          i;
01225 
01226         if (!cob_is_numeric (f)) {
01227                 buff = cob_malloc (COB_SMALL_BUFF);
01228                 p = buff;
01229                 data = f->data;
01230                 for (i = 0; i < f->size; ++i) {
01231                         if (isprint (data[i])) {
01232                                 *p++ = data[i];
01233                         } else {
01234                                 p += sprintf (p, "\\%03o", data[i]);
01235                         }
01236                 }
01237                 *p = '\0';
01238                 cob_runtime_error ("'%s' not numeric: '%s'", name, buff);
01239                 cob_stop_run (1);
01240         }
01241 }
01242 
01243 void
01244 cob_check_odo (const int i, const int min, const int max, const char *name)
01245 {
01246         /* check the OCCURS DEPENDING ON item */
01247         if (i < min || max < i) {
01248                 cob_set_exception (COB_EC_BOUND_ODO);
01249                 cob_runtime_error ("OCCURS DEPENDING ON '%s' out of bounds: %d", name, i);
01250                 cob_stop_run (1);
01251         }
01252 }
01253 
01254 void
01255 cob_check_subscript (const int i, const int min, const int max, const char *name)
01256 {
01257         /* check the subscript */
01258         if (i < min || max < i) {
01259                 cob_set_exception (COB_EC_BOUND_SUBSCRIPT);
01260                 cob_runtime_error ("Subscript of '%s' out of bounds: %d", name, i);
01261                 cob_stop_run (1);
01262         }
01263 }
01264 
01265 void
01266 cob_check_ref_mod (const int offset, const int length, const int size, const char *name)
01267 {
01268         /* check the offset */
01269         if (offset < 1 || offset > size) {
01270                 cob_set_exception (COB_EC_BOUND_REF_MOD);
01271                 cob_runtime_error ("Offset of '%s' out of bounds: %d", name, offset);
01272                 cob_stop_run (1);
01273         }
01274 
01275         /* check the length */
01276         if (length < 1 || offset + length - 1 > size) {
01277                 cob_set_exception (COB_EC_BOUND_REF_MOD);
01278                 cob_runtime_error ("Length of '%s' out of bounds: %d", name, length);
01279                 cob_stop_run (1);
01280         }
01281 }
01282 
01283 unsigned char *
01284 cob_external_addr (const char *exname, const int exlength)
01285 {
01286         static struct cob_external *basext = NULL;
01287 
01288         struct cob_external *eptr;
01289 
01290         for (eptr = basext; eptr; eptr = eptr->next) {
01291                 if (!strcmp (exname, eptr->ename)) {
01292                         if (exlength > eptr->esize) {
01293                                 cob_runtime_error ("EXTERNAL item '%s' has size > %d",
01294                                                    exname, exlength);
01295                                 cob_stop_run (1);
01296                         }
01297                         cob_initial_external = 0;
01298                         return (ucharptr)eptr->ext_alloc;
01299                 }
01300         }
01301         eptr = cob_malloc (sizeof (struct cob_external));
01302         eptr->next = basext;
01303         eptr->esize = exlength;
01304         eptr->ename = cob_malloc (strlen (exname) + 1);
01305         strcpy (eptr->ename, exname);
01306         eptr->ext_alloc = cob_malloc ((size_t)exlength);
01307         basext = eptr;
01308         cob_initial_external = 1;
01309         return (ucharptr)eptr->ext_alloc;
01310 }
01311 
01312 /* Extended ACCEPT/DISPLAY */
01313 
01314 void
01315 cob_accept_date (cob_field *f)
01316 {
01317         time_t  t;
01318         char    s[8];
01319 
01320         t = time (NULL);
01321         strftime (s, 7, "%y%m%d", localtime (&t));
01322         cob_memcpy (f, (ucharptr)s, 6);
01323 }
01324 
01325 void
01326 cob_accept_date_yyyymmdd (cob_field *f)
01327 {
01328         time_t  t;
01329         char    s[12];
01330 
01331         t = time (NULL);
01332         strftime (s, 9, "%Y%m%d", localtime (&t));
01333         cob_memcpy (f, (ucharptr)s, 8);
01334 }
01335 
01336 void
01337 cob_accept_day (cob_field *f)
01338 {
01339         time_t  t;
01340         char    s[8];
01341 
01342         t = time (NULL);
01343         strftime (s, 6, "%y%j", localtime (&t));
01344         cob_memcpy (f, (ucharptr)s, 5);
01345 }
01346 
01347 void
01348 cob_accept_day_yyyyddd (cob_field *f)
01349 {
01350         time_t  t;
01351         char    s[12];
01352 
01353         t = time (NULL);
01354         strftime (s, 8, "%Y%j", localtime (&t));
01355         cob_memcpy (f, (ucharptr)s, 7);
01356 }
01357 
01358 void
01359 cob_accept_day_of_week (cob_field *f)
01360 {
01361         time_t  t;
01362         char    s[4];
01363 
01364         t = time (NULL);
01365 #if defined(_MSC_VER)
01366         sprintf(s, "%d", localtime(&t)->tm_wday + 1);
01367 #else
01368         strftime (s, 2, "%u", localtime (&t));
01369 #endif
01370         cob_memcpy (f, (ucharptr)s, 1);
01371 }
01372 
01373 void
01374 cob_accept_time (cob_field *f)
01375 {
01376 #ifdef _WIN32
01377         SYSTEMTIME      syst;
01378 #else
01379         time_t          t;
01380 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
01381         struct timeval  tmv;
01382         char            buff2[8];
01383 #endif
01384 #endif
01385         char            s[12];
01386 
01387 #ifdef _WIN32
01388         GetLocalTime (&syst);
01389         sprintf (s, "%2.2d%2.2d%2.2d%2.2d", syst.wHour, syst.wMinute,
01390                 syst.wSecond, syst.wMilliseconds / 10);
01391 #else
01392 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
01393         gettimeofday (&tmv, NULL);
01394         t = tmv.tv_sec;
01395 #else
01396         t = time (NULL);
01397 #endif
01398         strftime (s, 9, "%H%M%S00", localtime (&t));
01399 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
01400         sprintf(buff2, "%2.2ld", tmv.tv_usec / 10000);
01401         memcpy (&s[6], buff2, 2);
01402 #endif
01403 #endif
01404         cob_memcpy (f, (ucharptr)s, 8);
01405 }
01406 
01407 void
01408 cob_display_command_line (cob_field *f)
01409 {
01410         if (commlnptr) {
01411                 free (commlnptr);
01412         }
01413         commlnptr = cob_malloc (f->size);
01414         commlncnt = f->size;
01415         memcpy (commlnptr, f->data, commlncnt);
01416 }
01417 
01418 void
01419 cob_accept_command_line (cob_field *f)
01420 {
01421         char    *buff;
01422         size_t  i;
01423         size_t  size;
01424         size_t  len;
01425 
01426         if (commlncnt) {
01427                 cob_memcpy (f, commlnptr, (int)commlncnt);
01428                 return;
01429         }
01430         buff = cob_malloc (COB_MEDIUM_BUFF);
01431         size = 0;
01432         for (i = 1; i < (size_t)cob_argc; ++i) {
01433                 len = strlen (cob_argv[i]);
01434                 if (size + len >= COB_MEDIUM_BUFF) {
01435                         /* overflow */
01436                         break;
01437                 }
01438                 memcpy (buff + size, cob_argv[i], len);
01439                 size += len;
01440                 buff[size++] = ' ';
01441         }
01442         cob_memcpy (f, (ucharptr)buff, (int)size);
01443         free (buff);
01444 }
01445 
01446 /*
01447  * Argument number
01448  */
01449 
01450 void
01451 cob_display_arg_number (cob_field *f)
01452 {
01453         int             n;
01454         cob_field_attr  attr;
01455         cob_field       temp;
01456 
01457         temp.size = 4;
01458         temp.data = (unsigned char *)&n;
01459         temp.attr = &attr;
01460         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL);
01461         cob_move (f, &temp);
01462         if (n < 0 || n >= cob_argc) {
01463                 cob_set_exception (COB_EC_IMP_DISPLAY);
01464                 return;
01465         }
01466         current_arg = n;
01467 }
01468 
01469 void
01470 cob_accept_arg_number (cob_field *f)
01471 {
01472         int             n = cob_argc - 1;
01473         cob_field_attr  attr;
01474         cob_field       temp;
01475 
01476         temp.size = 4;
01477         temp.data = (unsigned char *)&n;
01478         temp.attr = &attr;
01479         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL);
01480         cob_move (&temp, f);
01481 }
01482 
01483 void
01484 cob_accept_arg_value (cob_field *f)
01485 {
01486         if (current_arg >= cob_argc) {
01487                 cob_set_exception (COB_EC_IMP_ACCEPT);
01488                 return;
01489         }
01490         cob_memcpy (f, (ucharptr)cob_argv[current_arg], (int) strlen (cob_argv[current_arg]));
01491         current_arg++;
01492 }
01493 
01494 /*
01495  * Environment variable
01496  */
01497 
01498 void
01499 cob_display_environment (cob_field *f)
01500 {
01501         if (!cob_local_env) {
01502                 cob_local_env = cob_malloc (COB_SMALL_BUFF);
01503         }
01504         if (f->size > COB_SMALL_MAX) {
01505                 cob_set_exception (COB_EC_IMP_DISPLAY);
01506                 return;
01507         }
01508         cob_field_to_string (f, cob_local_env);
01509 }
01510 
01511 void
01512 cob_display_env_value (cob_field *f)
01513 {
01514         char    *p;
01515         char    *env2;
01516         size_t  len;
01517 
01518         if (!cob_local_env) {
01519                 cob_set_exception (COB_EC_IMP_DISPLAY);
01520                 return;
01521         }
01522         if (!*cob_local_env) {
01523                 cob_set_exception (COB_EC_IMP_DISPLAY);
01524                 return;
01525         }
01526         env2 = cob_malloc (f->size + 1);
01527         cob_field_to_string (f, env2);
01528         len = strlen (cob_local_env) + strlen (env2) + 3;
01529         p = cob_malloc (len);
01530         sprintf (p, "%s=%s", cob_local_env, env2);
01531         if (putenv (p) != 0) {
01532                 cob_set_exception (COB_EC_IMP_DISPLAY);
01533         }
01534         free (env2);
01535 }
01536 
01537 void
01538 cob_set_environment (cob_field *f1, cob_field *f2)
01539 {
01540         cob_display_environment (f1);
01541         cob_display_env_value (f2);
01542 }
01543 
01544 void
01545 cob_get_environment (cob_field *envname, cob_field *envval)
01546 {
01547         const char      *p;
01548         char            *buff;
01549 
01550         if (envname->size < COB_SMALL_BUFF) {
01551                 buff = cob_malloc (COB_SMALL_BUFF);
01552                 cob_field_to_string (envname, buff);
01553                 p = getenv (buff);
01554                 if (!p) {
01555                         cob_set_exception (COB_EC_IMP_ACCEPT);
01556                         p = " ";
01557                 }
01558                 cob_memcpy (envval, (ucharptr)p, (int) strlen (p));
01559                 free (buff);
01560         } else {
01561                 cob_set_exception (COB_EC_IMP_ACCEPT);
01562                 p = " ";
01563                 cob_memcpy (envval, (ucharptr)p, (int) strlen (p));
01564         }
01565 }
01566 
01567 void
01568 cob_accept_environment (cob_field *f)
01569 {
01570         const char *p = NULL;
01571 
01572         if (cob_local_env) {
01573                 p = getenv (cob_local_env);
01574         }
01575         if (!p) {
01576                 cob_set_exception (COB_EC_IMP_ACCEPT);
01577                 p = " ";
01578         }
01579         cob_memcpy (f, (ucharptr)p, (int) strlen (p));
01580 }
01581 
01582 void
01583 cob_chain_setup (void *data, const size_t parm, const size_t size)
01584 {
01585         size_t  len;
01586 
01587         memset (data, ' ', size);
01588         if (parm <= (size_t)cob_argc - 1) {
01589                 len = strlen (cob_argv[parm]);
01590                 if (len <= size) {
01591                         memcpy (data, cob_argv[parm], len);
01592                 } else {
01593                         memcpy (data, cob_argv[parm], size);
01594                 }
01595         } else {
01596                 memset (data, ' ', size);
01597         }
01598         cob_call_params = cob_argc - 1;
01599 }
01600 
01601 void
01602 cob_allocate (unsigned char **dataptr, cob_field *retptr, cob_field *sizefld)
01603 {
01604         void                    *mptr = NULL;
01605         struct cob_alloc_cache  *cache_ptr;
01606         int                     fsize;
01607 
01608         cob_exception_code = 0;
01609         fsize = cob_get_int (sizefld);
01610         if (fsize > 0) {
01611                 cache_ptr = cob_malloc (sizeof (struct cob_alloc_cache));
01612                 mptr = malloc ((size_t)fsize);
01613                 if (!mptr) {
01614                         cob_set_exception (COB_EC_STORAGE_NOT_AVAIL);
01615                         free (cache_ptr);
01616                 } else {
01617                         memset (mptr, 0, (size_t)fsize);
01618                         cache_ptr->cob_pointer = mptr;
01619                         cache_ptr->size = (size_t)fsize;
01620                         cache_ptr->next = cob_alloc_base;
01621                         cob_alloc_base = cache_ptr;
01622                 }
01623         }
01624         if (dataptr) {
01625                 *dataptr = (unsigned char *)mptr;
01626         }
01627         if (retptr) {
01628                 *(void **)(retptr->data) = mptr;
01629         }
01630 }
01631 
01632 void
01633 cob_free_alloc (unsigned char **ptr1, unsigned char *ptr2)
01634 {
01635         struct cob_alloc_cache  *cache_ptr;
01636 
01637         cob_exception_code = 0;
01638         if (ptr1 && *ptr1) {
01639                 for (cache_ptr = cob_alloc_base; cache_ptr; cache_ptr = cache_ptr->next) {
01640                         if (*(void **)ptr1 == cache_ptr->cob_pointer) {
01641                                 cache_ptr->cob_pointer = NULL;
01642                                 free (*ptr1);
01643                                 *ptr1 = NULL;
01644                                 return;
01645                         }
01646                 }
01647                 cob_set_exception (COB_EC_STORAGE_NOT_ALLOC);
01648                 return;
01649         }
01650         if (ptr2 && *(void **)ptr2) {
01651                 for (cache_ptr = cob_alloc_base; cache_ptr; cache_ptr = cache_ptr->next) {
01652                         if (*(void **)ptr2 == cache_ptr->cob_pointer) {
01653                                 cache_ptr->cob_pointer = NULL;
01654                                 free (*(void **)ptr2);
01655                                 *(void **)ptr2 = NULL;
01656                                 return;
01657                         }
01658                 }
01659                 cob_set_exception (COB_EC_STORAGE_NOT_ALLOC);
01660                 return;
01661         }
01662 }
01663 
01664 char *
01665 cobgetenv (const char *name)
01666 {
01667         if (name) {
01668                 return getenv (name);
01669         }
01670         return NULL;
01671 }
01672 
01673 int
01674 cobputenv (char *name)
01675 {
01676         if (name) {
01677                 return putenv (name);
01678         }
01679         return -1;
01680 }
01681 
01682 int
01683 cobinit (void)
01684 {
01685         cob_init (0, NULL);
01686         return 0;
01687 }
01688 
01689 void *
01690 cobcommandline (int flags, int *pargc, char ***pargv, char ***penvp, char **pname)
01691 {
01692         char            **spenvp;
01693         char            *spname;
01694         int             sflags;
01695 
01696         if (!cob_initialized) {
01697                 cob_runtime_error ("'cobcommandline' - Runtime has not been initialized");
01698                 cob_stop_run (1);
01699         }
01700         if (pargc && pargv) {
01701                 cob_argc = *pargc;
01702                 cob_argv = *pargv;
01703         }
01704         /* Shut up the compiler */
01705         sflags = flags;
01706         if (penvp) {
01707                 spenvp = *penvp;
01708         }
01709         if (pname) {
01710                 spname = *pname;
01711         }
01712         /* What are we supposed to return here? */
01713         return NULL;
01714 }
01715 
01716 void
01717 cobexit (const int status)
01718 {
01719         cob_stop_run (status);
01720 }
01721 
01722 int
01723 cobtidy (void)
01724 {
01725         struct exit_handlerlist *h;
01726 
01727         if (exit_hdlrs != NULL) {
01728                 h = exit_hdlrs;
01729                 while (h != NULL) {
01730                         h->proc ();
01731                         h = h->next;
01732                 }
01733         }
01734         cob_screen_terminate ();
01735         cob_exit_fileio ();
01736         return 0;
01737 }
01738 
01739 /* System routines */
01740 
01741 int
01742 CBL_EXIT_PROC (unsigned char *x, unsigned char *pptr)
01743 {
01744         struct exit_handlerlist *hp = NULL;
01745         struct exit_handlerlist *h = exit_hdlrs;
01746         int                     (**p)(void) = NULL;
01747 
01748         COB_CHK_PARMS (CBL_EXIT_PROC, 2);
01749 
01750         memcpy (&p, &pptr, sizeof (void *));
01751         if (!p || !*p) {
01752                 return -1;
01753         }
01754         /* remove handler anyway */
01755         while (h != NULL) {
01756                 if (h->proc == *p) {
01757                         if (hp != NULL) {
01758                                 hp->next = h->next;
01759                         } else {
01760                                 exit_hdlrs = h->next;
01761                         }
01762                         if (hp) {
01763                                 free (hp);
01764                         }
01765                         break;
01766                 }
01767                 hp = h;
01768                 h = h->next;
01769         }
01770         if   (*x != 0 && *x != 2 && *x != 3) {  /* remove handler */
01771                 return 0;
01772         }
01773         h = cob_malloc (sizeof(struct exit_handlerlist));
01774         h->next = exit_hdlrs;
01775         h->proc = *p;
01776         exit_hdlrs = h;
01777         return 0;
01778 }
01779 
01780 int
01781 CBL_ERROR_PROC (unsigned char *x, unsigned char *pptr)
01782 {
01783         struct handlerlist      *hp = NULL;
01784         struct handlerlist      *h = hdlrs;
01785         int                     (**p)(char *s) = NULL;
01786 
01787         COB_CHK_PARMS (CBL_ERROR_PROC, 2);
01788 
01789         memcpy (&p, &pptr, sizeof (void *));
01790         if (!p || !*p) {
01791                 return -1;
01792         }
01793         /* remove handler anyway */
01794         while (h != NULL) {
01795                 if (h->proc == *p) {
01796                         if (hp != NULL) {
01797                                 hp->next = h->next;
01798                         } else {
01799                                 hdlrs = h->next;
01800                         }
01801                         if (hp) {
01802                                 free (hp);
01803                         }
01804                         break;
01805                 }
01806                 hp = h;
01807                 h = h->next;
01808         }
01809         if (*x != 0) {  /* remove handler */
01810                 return 0;
01811         }
01812         h = cob_malloc (sizeof(struct handlerlist));
01813         h->next = hdlrs;
01814         h->proc = *p;
01815         hdlrs = h;
01816         return 0;
01817 }
01818 
01819 int
01820 SYSTEM (const unsigned char *cmd)
01821 {
01822         char    *buff;
01823         int     i;
01824 
01825         COB_CHK_PARMS (SYSTEM, 1);
01826 
01827         if (cob_current_module->cob_procedure_parameters[0]) {
01828                 i = (int)cob_current_module->cob_procedure_parameters[0]->size;
01829                 if (i > COB_MEDIUM_MAX) {
01830                         cob_runtime_error ("Parameter to SYSTEM call is larger than 8192 characters");
01831                         cob_stop_run (1);
01832                 }
01833                 i--;
01834                 for (; i >= 0; i--) {
01835                         if (cmd[i] != ' ' && cmd[i] != 0) {
01836                                 break;
01837                         }
01838                 }
01839                 if (i >= 0) {
01840                         buff = cob_malloc ((size_t)(i + 2));
01841                         memcpy (buff, cmd, (size_t)(i + 1));
01842                         if (cob_screen_initialized) {
01843                                 cob_screen_set_mode (0);
01844                         }
01845                         i = system (buff);
01846                         free (buff);
01847                         if (cob_screen_initialized) {
01848                                 cob_screen_set_mode (1);
01849                         }
01850                         return i;
01851                 }
01852         }
01853         return 1;
01854 }
01855 
01856 int
01857 CBL_AND (unsigned char *data_1, unsigned char *data_2, const int length)
01858 {
01859         size_t  n;
01860 
01861         COB_CHK_PARMS (CBL_AND, 3);
01862 
01863         if (length <= 0) {
01864                 return 0;
01865         }
01866         for (n = 0; n < (size_t)length; ++n) {
01867                 data_2[n] &= data_1[n];
01868         }
01869         return 0;
01870 }
01871 
01872 int
01873 CBL_OR (unsigned char *data_1, unsigned char *data_2, const int length)
01874 {
01875         size_t  n;
01876 
01877         COB_CHK_PARMS (CBL_OR, 3);
01878 
01879         if (length <= 0) {
01880                 return 0;
01881         }
01882         for (n = 0; n < (size_t)length; ++n) {
01883                 data_2[n] |= data_1[n];
01884         }
01885         return 0;
01886 }
01887 
01888 int
01889 CBL_NOR (unsigned char *data_1, unsigned char *data_2, const int length)
01890 {
01891         size_t  n;
01892 
01893         COB_CHK_PARMS (CBL_NOR, 3);
01894 
01895         if (length <= 0) {
01896                 return 0;
01897         }
01898         for (n = 0; n < (size_t)length; ++n) {
01899                 data_2[n] = ~(data_1[n] | data_2[n]);
01900         }
01901         return 0;
01902 }
01903 
01904 int
01905 CBL_XOR (unsigned char *data_1, unsigned char *data_2, const int length)
01906 {
01907         size_t  n;
01908 
01909         COB_CHK_PARMS (CBL_XOR, 3);
01910 
01911         if (length <= 0) {
01912                 return 0;
01913         }
01914         for (n = 0; n < (size_t)length; ++n) {
01915                 data_2[n] ^= data_1[n];
01916         }
01917         return 0;
01918 }
01919 
01920 int
01921 CBL_IMP (unsigned char *data_1, unsigned char *data_2, const int length)
01922 {
01923         size_t  n;
01924 
01925         COB_CHK_PARMS (CBL_IMP, 3);
01926 
01927         if (length <= 0) {
01928                 return 0;
01929         }
01930         for (n = 0; n < (size_t)length; ++n) {
01931                 data_2[n] = (~data_1[n]) | data_2[n];
01932         }
01933         return 0;
01934 }
01935 
01936 int
01937 CBL_NIMP (unsigned char *data_1, unsigned char *data_2, const int length)
01938 {
01939         size_t  n;
01940 
01941         COB_CHK_PARMS (CBL_NIMP, 3);
01942 
01943         if (length <= 0) {
01944                 return 0;
01945         }
01946         for (n = 0; n < (size_t)length; ++n) {
01947                 data_2[n] = data_1[n] & (~data_2[n]);
01948         }
01949         return 0;
01950 }
01951 
01952 int
01953 CBL_EQ (unsigned char *data_1, unsigned char *data_2, const int length)
01954 {
01955         size_t  n;
01956 
01957         COB_CHK_PARMS (CBL_EQ, 3);
01958 
01959         if (length <= 0) {
01960                 return 0;
01961         }
01962         for (n = 0; n < (size_t)length; ++n) {
01963                 data_2[n] = ~(data_1[n] ^ data_2[n]);
01964         }
01965         return 0;
01966 }
01967 
01968 int
01969 CBL_NOT (unsigned char *data_1, const int length)
01970 {
01971         size_t  n;
01972 
01973         COB_CHK_PARMS (CBL_NOT, 2);
01974 
01975         if (length <= 0) {
01976                 return 0;
01977         }
01978         for (n = 0; n < (size_t)length; ++n) {
01979                 data_1[n] = ~data_1[n];
01980         }
01981         return 0;
01982 }
01983 
01984 int
01985 CBL_XF4 (unsigned char *data_1, unsigned char *data_2)
01986 {
01987         size_t  n;
01988 
01989         COB_CHK_PARMS (CBL_XF4, 2);
01990 
01991         *data_1 = 0;
01992         for (n = 0; n < 8; ++n) {
01993                 *data_1 |= (data_2[n] & 1) << (7 - n);
01994         }
01995         return 0;
01996 }
01997 
01998 int
01999 CBL_XF5 (unsigned char *data_1, unsigned char *data_2)
02000 {
02001         size_t  n;
02002 
02003         COB_CHK_PARMS (CBL_XF5, 2);
02004 
02005         for (n = 0; n < 8; ++n) {
02006                 data_2[n] = (*data_1 & (1 << (7 - n))) ? 1 : 0;
02007         }
02008         return 0;
02009 }
02010 
02011 int
02012 CBL_X91 (unsigned char *result, const unsigned char *func, unsigned char *parm)
02013 {
02014         unsigned char   *p;
02015         size_t          i;
02016 
02017         switch (*func) {
02018         case 11:
02019                 /* Set switches */
02020                 p = parm;
02021                 for (i = 0; i < 8; ++i, ++p) {
02022                         if (*p == 0) {
02023                                 cob_switch[i] = 0;
02024                         } else if (*p == 1) {
02025                                 cob_switch[i] = 1;
02026                         }
02027                 }
02028                 *result = 0;
02029                 break;
02030         case 12:
02031                 /* Get switches */
02032                 p = parm;
02033                 for (i = 0; i < 8; ++i, ++p) {
02034                         *p = cob_switch[i];
02035                 }
02036                 *result = 0;
02037                 break;
02038         case 16:
02039                 /* Return number of call parameters */
02040                 *parm = cob_save_call_params;
02041                 *result = 0;
02042                 break;
02043         default:
02044                 *result = 1;
02045                 break;
02046         }
02047         return 0;
02048 }
02049 
02050 int
02051 CBL_TOUPPER (unsigned char *data, const int length)
02052 {
02053         size_t  n;
02054 
02055         COB_CHK_PARMS (CBL_TOUPPER, 2);
02056 
02057         if (length > 0) {
02058                 for (n = 0; n < (size_t)length; ++n) {
02059                         if (islower (data[n])) {
02060                                 data[n] = toupper (data[n]);
02061                         }
02062                 }
02063         }
02064         return 0;
02065 }
02066 
02067 int
02068 CBL_TOLOWER (unsigned char *data, const int length)
02069 {
02070         size_t  n;
02071 
02072         COB_CHK_PARMS (CBL_TOLOWER, 2);
02073 
02074         if (length > 0) {
02075                 for (n = 0; n < (size_t)length; ++n) {
02076                         if (isupper (data[n])) {
02077                                 data[n] = tolower (data[n]);
02078                         }
02079                 }
02080         }
02081         return 0;
02082 }
02083 
02084 int
02085 CBL_OC_NANOSLEEP (unsigned char *data)
02086 {
02087         long long       nsecs;
02088 #ifdef  _WIN32
02089 #if 0
02090         struct timeval  tv;
02091 #else
02092         unsigned int    msecs;
02093 #endif
02094 #else
02095         struct timespec tsec;
02096 #endif
02097 
02098         COB_CHK_PARMS (CBL_OC_NANOSLEEP, 1);
02099 
02100         if (cob_current_module->cob_procedure_parameters[0]) {
02101                 nsecs = cob_get_long_long (cob_current_module->cob_procedure_parameters[0]);
02102                 if (nsecs > 0) {
02103 #ifdef  _WIN32
02104 #if 0
02105                         nsecs /= 1000;
02106                         if (nsecs > 0) {
02107                                 tv.tv_sec = (long)(nsecs / 1000000);
02108                                 tv.tv_usec = (long)(nsecs % 1000000);
02109                                 select (0, (void *)0, (void *)0, (void *)0, &tv);
02110                         }
02111 #else
02112                         msecs = (unsigned int)(nsecs / 1000000);
02113                         if (msecs > 0) {
02114                                 Sleep (msecs);
02115                         }
02116 #endif
02117 #else
02118                         tsec.tv_sec = nsecs / 1000000000;
02119                         tsec.tv_nsec = nsecs % 1000000000;
02120                         nanosleep (&tsec, NULL);
02121 #endif
02122                 }
02123         }
02124         return 0;
02125 }
02126 
02127 int
02128 cob_return_args (unsigned char *data)
02129 {
02130         COB_CHK_PARMS (C$NARG, 1);
02131 
02132         if (cob_current_module->cob_procedure_parameters[0]) {
02133                 cob_set_int (cob_current_module->cob_procedure_parameters[0], cob_save_call_params);
02134         }
02135         return 0;
02136 }
02137 
02138 int
02139 cob_parameter_size (unsigned char *data)
02140 {
02141         int     n;
02142 
02143         COB_CHK_PARMS (C$PARAMSIZE, 1);
02144 
02145         if (cob_current_module->cob_procedure_parameters[0]) {
02146                 n = cob_get_int (cob_current_module->cob_procedure_parameters[0]);
02147                 if (n > 0 && n <= cob_save_call_params) {
02148                         n--;
02149                         if (cob_current_module->next &&
02150                             cob_current_module->next->cob_procedure_parameters[n]) {
02151                                 return cob_current_module->next->cob_procedure_parameters[n]->size;
02152                         }
02153                 }
02154         }
02155         return 0;
02156 }
02157 
02158 int
02159 cob_acuw_sleep (unsigned char *data)
02160 {
02161         int     n;
02162 
02163         COB_CHK_PARMS (C$SLEEP, 1);
02164 
02165         if (cob_current_module->cob_procedure_parameters[0]) {
02166                 n = cob_get_int (cob_current_module->cob_procedure_parameters[0]);
02167                 if (n > 0 && n < 3600*24*7) {
02168 #ifdef  _WIN32
02169                         Sleep (n*1000);
02170 #else
02171                         sleep ((unsigned int)n);
02172 #endif
02173                 }
02174         }
02175         return 0;
02176 }
02177 
02178 int
02179 cob_acuw_justify (unsigned char *data, ...)
02180 {
02181         unsigned char   *direction;
02182         size_t          datalen;
02183         int             n;
02184         int             shifting = 0;
02185         size_t          left = 0;
02186         size_t          right = 0;
02187         size_t          movelen;
02188         size_t          centrelen;
02189         va_list         args;
02190 
02191         COB_CHK_PARMS (C$JUSTIFY, 1);
02192 
02193         datalen = cob_current_module->cob_procedure_parameters[0]->size;
02194         if (datalen < 2) {
02195                 return 0;
02196         }
02197         if (data[0] != ' ' && data[datalen - 1] != ' ') {
02198                 return 0;
02199         }
02200         for (n = 0; n < (int)datalen; ++n, ++left) {
02201                 if (data[n] != ' ') {
02202                         break;
02203                 }
02204         }
02205         if (n == (int)datalen) {
02206                 return 0;
02207         }
02208         left = n;
02209         for (n = (int)datalen - 1; n >= 0; --n, ++right) {
02210                 if (data[n] != ' ') {
02211                         break;
02212                 }
02213         }
02214         movelen = datalen - left - right;
02215         if (cob_call_params > 1) {
02216                 va_start (args, data);
02217                 direction = va_arg (args, unsigned char *);
02218                 va_end (args);
02219                 if (*direction == 'L') {
02220                         shifting = 1;
02221                 } else if (*direction == 'C') {
02222                         shifting = 2;
02223                 }
02224         }
02225         switch (shifting) {
02226         case 1:
02227                 memmove (data, &data[left], movelen);
02228                 memset (&data[movelen], ' ', datalen - movelen);
02229                 break;
02230         case 2:
02231                 centrelen = (left + right) / 2;
02232                 memmove (&data[centrelen], &data[left], movelen);
02233                 memset (data, ' ', centrelen);
02234                 if ((left + right) % 2) {
02235                         memset (&data[centrelen + movelen], ' ', centrelen + 1);
02236                 } else {
02237                         memset (&data[centrelen + movelen], ' ', centrelen);
02238                 }
02239                 break;
02240         default:
02241                 memmove (&data[left + right], &data[left], movelen);
02242                 memset (data, ' ', datalen - movelen);
02243                 break;
02244         }
02245         return 0;
02246 }
 All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Defines