unsigned char *
cob_external_addr (const char *exname, const int exlength)
{
static struct cob_external *basext = NULL;
struct cob_external *eptr;
for (eptr = basext; eptr; eptr = eptr->next) {
if (!strcmp (exname, eptr->ename)) {
if (exlength > eptr->esize) {
cob_runtime_error ("EXTERNAL item '%s' has size > %d",
exname, exlength);
cob_stop_run (1);
}
cob_initial_external = 0;
return (ucharptr)eptr->ext_alloc;
}
}
eptr = cob_malloc (sizeof (struct cob_external));
eptr->next = basext;
eptr->esize = exlength;
eptr->ename = cob_malloc (strlen (exname) + 1);
strcpy (eptr->ename, exname);
eptr->ext_alloc = cob_malloc ((size_t)exlength);
basext = eptr;
cob_initial_external = 1;
return (ucharptr)eptr->ext_alloc;
}
void *
cobcommandline (int flags, int *pargc, char ***pargv, char ***penvp, char **pname)
{
char **spenvp;
char *spname;
int sflags;
if (!cob_initialized) {
cob_runtime_error ("'cobcommandline' - Runtime has not been initialized");
cob_stop_run (1);
}
if (pargc && pargv) {
cob_argc = *pargc;
cob_argv = *pargv;
}
/* Shut up the compiler */
sflags = flags;
if (penvp) {
spenvp = *penvp;
}
if (pname) {
spname = *pname;
}
/* What are we supposed to return here? */
return NULL;
}
int
main (int argc, char **argv)
{
int pcl_return;
union {
int (*func)();
void *func_void;
} unifunc;
#ifdef HAVE_SETLOCALE
setlocale (LC_ALL, "");
#endif
pcl_return = process_command_line (argc, argv);
if (pcl_return != 99) {
return pcl_return;
}
if (strlen (argv[1]) > 31) {
fprintf (stderr, "Invalid PROGRAM name\n");
return 1;
}
cob_init (argc - 1, &argv[1]);
unifunc.func_void = cob_resolve (argv[1]);
if (unifunc.func_void == NULL) {
cob_call_error ();
}
cob_stop_run ( unifunc.func() );
}
void
cob_check_ref_mod (const int offset, const int length, const int size, const char *name)
{
/* check the offset */
if (offset < 1 || offset > size) {
cob_set_exception (COB_EC_BOUND_REF_MOD);
cob_runtime_error ("Offset of '%s' out of bounds: %d", name, offset);
cob_stop_run (1);
}
/* check the length */
if (length < 1 || offset + length - 1 > size) {
cob_set_exception (COB_EC_BOUND_REF_MOD);
cob_runtime_error ("Length of '%s' out of bounds: %d", name, length);
cob_stop_run (1);
}
}
void
cob_check_based (const unsigned char *x, const char *name)
{
if (!x) {
cob_runtime_error ("BASED/LINKAGE item '%s' has NULL address", name);
cob_stop_run (1);
}
}
void
cob_check_subscript (const int i, const int min, const int max, const char *name)
{
/* check the subscript */
if (i < min || max < i) {
cob_set_exception (COB_EC_BOUND_SUBSCRIPT);
cob_runtime_error ("Subscript of '%s' out of bounds: %d", name, i);
cob_stop_run (1);
}
}
void
cob_check_odo (const int i, const int min, const int max, const char *name)
{
/* check the OCCURS DEPENDING ON item */
if (i < min || max < i) {
cob_set_exception (COB_EC_BOUND_ODO);
cob_runtime_error ("OCCURS DEPENDING ON '%s' out of bounds: %d", name, i);
cob_stop_run (1);
}
}
static void COB_NOINLINE
cob_screen_init (void)
{
char *s;
if (!cob_screen_initialized) {
s = getenv ("COB_SCREEN_EXCEPTIONS");
if (s) {
if (*s == 'Y' || *s == 'y') {
cob_extended_status = 1;
s = getenv ("COB_SCREEN_ESC");
if (s) {
if (*s == 'Y' || *s == 'y') {
cob_use_esc = 1;
}
}
}
}
/* Get default insert mode, if 'Y' set to on */
s = getenv ("COB_INSERT_MODE");
if (s) {
if (*s == 'Y' || *s == 'y') {
insert_mode = 1;
}
}
fflush (stdout);
fflush (stderr);
if (!initscr ()) {
cob_runtime_error ("Failed to initialize curses");
cob_stop_run (1);
}
cbreak ();
keypad (stdscr, 1);
nl ();
noecho ();
if (has_colors ()) {
start_color ();
pair_content ((short)0, &fore_color, &back_color);
if (COLOR_PAIRS) {
#ifdef HAVE_LIBPDCURSES
size_t i;
/* pdcurses sets ALL pairs to default fg/bg */
/* IMHO a bug. */
for (i = 1; i < (size_t)COLOR_PAIRS; ++i) {
init_pair ((short)i, 0, 0);
}
#endif
cob_has_color = 1;
}
}
attrset (A_NORMAL);
getmaxyx (stdscr, cob_max_y, cob_max_x);
cob_screen_initialized = 1;
}
}
void
cob_check_version (const char *prog, const char *packver, const int patchlev)
{
if (strcmp (packver, PACKAGE_VERSION) || patchlev > PATCH_LEVEL) {
cob_runtime_error ("Error - Version mismatch");
cob_runtime_error ("%s has version/patch level %s/%d", prog, packver,
patchlev);
cob_runtime_error ("Library has version/patch level %s/%d", PACKAGE_VERSION,
PATCH_LEVEL);
cob_stop_run (1);
}
}
void *
cob_malloc (const size_t size)
{
void *mptr;
mptr = calloc (1, size);
if (unlikely(!mptr)) {
cob_runtime_error ("Cannot acquire %d bytes of memory - Aborting", size);
cob_stop_run (1);
}
return mptr;
}
void
cob_fatal_error (const unsigned int fatal_error)
{
switch (fatal_error) {
case COB_FERROR_INITIALIZED:
cob_runtime_error ("cob_init() has not been called");
break;
case COB_FERROR_CODEGEN:
cob_runtime_error ("Codegen error - Please report this");
break;
case COB_FERROR_CHAINING:
cob_runtime_error ("ERROR - Recursive call of chained program");
break;
case COB_FERROR_STACK:
cob_runtime_error ("Stack overflow, possible PERFORM depth exceeded");
break;
default:
cob_runtime_error ("Unknown failure : %d", (int)fatal_error);
break;
}
cob_stop_run (1);
}
int
SYSTEM (const unsigned char *cmd)
{
char *buff;
int i;
COB_CHK_PARMS (SYSTEM, 1);
if (cob_current_module->cob_procedure_parameters[0]) {
i = (int)cob_current_module->cob_procedure_parameters[0]->size;
if (i > COB_MEDIUM_MAX) {
cob_runtime_error ("Parameter to SYSTEM call is larger than 8192 characters");
cob_stop_run (1);
}
i--;
for (; i >= 0; i--) {
if (cmd[i] != ' ' && cmd[i] != 0) {
break;
}
}
if (i >= 0) {
buff = cob_malloc ((size_t)(i + 2));
memcpy (buff, cmd, (size_t)(i + 1));
if (cob_screen_initialized) {
cob_screen_set_mode (0);
}
i = system (buff);
free (buff);
if (cob_screen_initialized) {
cob_screen_set_mode (1);
}
return i;
}
}
return 1;
}
void
cob_check_numeric (cob_field *f, const char *name)
{
unsigned char *data;
char *p;
char *buff;
size_t i;
if (!cob_is_numeric (f)) {
buff = cob_malloc (COB_SMALL_BUFF);
p = buff;
data = f->data;
for (i = 0; i < f->size; ++i) {
if (isprint (data[i])) {
*p++ = data[i];
} else {
p += sprintf (p, "\\%03o", data[i]);
}
}
*p = '\0';
cob_runtime_error ("'%s' not numeric: '%s'", name, buff);
cob_stop_run (1);
}
}
int
main (int argc, char **argv)
{
cob_init (argc, argv);
cob_stop_run (fizzbuzz ());
}
void
cobexit (const int status)
{
cob_stop_run (status);
}
void
cob_inspect_converting (const cob_field *f1, const cob_field *f2)
{
size_t i;
size_t j;
size_t len;
#ifdef I18N_UTF8
const int mark_wait[6] = {-1, -1, -1, -1, -1, -1};
const int mark_done[6] = { 1, 1, 1, 1, 1, 1};
size_t nc1;
size_t nc2;
size_t nc3;
const cob_field *fig_const = NULL;
const cob_field *fig_constw = NULL;
unsigned char *pdata;
char buf1[8]; /* for error message */
char buf2[8]; /* for error message */
#endif /*!I18N_UTF8*/
len = (size_t)(inspect_end - inspect_start);
#ifdef I18N_UTF8
if (f2 == &cob_quote) {
fig_const = &cob_quote;
fig_constw = &cob_zen_quote;
} else if (f2 == &cob_space) {
fig_const = &cob_space;
fig_constw = &cob_zen_space;
} else if (f2 == &cob_zero) {
fig_const = &cob_zero;
fig_constw = &cob_zen_zero;
}
for (j = 0; j < f1->size; j += nc1) {
if (!(nc1 = COB_U8BYTE_1 (f1->data[j]))) {
cob_runtime_error (
"Unexpected char X(%02X) in INSPECT CONVERTING (value before)",
f1->data[j]);
cob_stop_run (1);
} else if (fig_const) {
/* iteratively map to figurative */
} else if (!(nc2 = COB_U8BYTE_1 (f2->data[j]))) {
cob_runtime_error (
"Unexpected char X(%02X) in INSPECT CONVERTING (value after)",
f2->data[j]);
cob_stop_run (1);
} else if (nc1 != nc2) {
memset (buf1, 0, sizeof (buf1));
memset (buf2, 0, sizeof (buf2));
memcpy (buf1, &(f1->data[j]), nc1);
memcpy (buf2, &(f2->data[j]), nc2);
cob_runtime_error (
"'%s' char width (%d) to '%s' char width (%d) mismatch",
buf1, nc1, buf2, nc2);
cob_stop_run (1);
}
for (i = 0; i < len; i += nc3) {
if (!(nc3 = COB_U8BYTE_1 (inspect_start[i]))) {
cob_runtime_error (
"Unexpected char X(%02X) in INSPECT field",
inspect_start[i]);
cob_stop_run (1);
}
if (nc1 == nc3
&& !memcmp (&(inspect_mark[i]), mark_wait, nc1)
&& !memcmp (&(inspect_start[i]), &(f1->data[j]), nc1)) {
if (!fig_const) {
pdata = &(f2->data[j]);
} else if (nc1 == 1) {
pdata = fig_const->data;
} else if (nc1 == COB_U8CSIZ) {
pdata = fig_constw->data;
} else {
memset (buf1, 0, sizeof (buf1));
memcpy (buf1, &(f1->data[j]), nc1);
cob_runtime_error (
"'%s' char width (%d) mismatch",
buf1, nc1);
cob_stop_run (1);
}
memcpy (&(inspect_start[i]), pdata, nc1);
memcpy (&(inspect_mark[i]), mark_done, nc1);
}
}
}
#else /*!I18N_UTF8*/
if (COB_FIELD_TYPE (f1) == COB_TYPE_NATIONAL ||
COB_FIELD_TYPE (f1) == COB_TYPE_NATIONAL_EDITED) {
if (f2 == &cob_quote) {
f2 = &cob_zen_quote;
} else if (f2 == &cob_space) {
f2 = &cob_zen_space;
} else if (f2 == &cob_zero) {
f2 = &cob_zen_zero;
}
for (j = 0; j < f1->size; j += 2) {
for (i = 0; i < len; i += 2) {
if (inspect_mark[i] == -1 && inspect_mark[i+1] == -1 && memcmp (&inspect_start[i], &(f1->data[j]), 2) == 0) {
if (f2 == &cob_zen_quote || f2 == &cob_zen_space || f2 == &cob_zen_zero) {
inspect_start[i] = f2->data[0];
inspect_start[i+1] = f2->data[1];
} else {
inspect_start[i] = f2->data[j];
inspect_start[i+1] = f2->data[j+1];
}
inspect_mark[i] = 1;
inspect_mark[i+1] = 1;
}
}
}
} else {
for (j = 0; j < f1->size; j++) {
for (i = 0; i < len; i++) {
if (inspect_mark[i] == -1 && inspect_start[i] == f1->data[j]) {
if (f2 == &cob_quote || f2 == &cob_space || f2 == &cob_zero) {
inspect_start[i] = f2->data[0];
} else {
inspect_start[i] = f2->data[j];
}
inspect_mark[i] = 1;
}
}
}
}
#endif /*I18N_UTF8*/
}
static int
fizzbuzz_ (const int entry)
{
#include "fizzbuzz.c.h" /* local variables */
static int initialized = 0;
static cob_field *cob_user_parameters[COB_MAX_FIELD_PARAMS];
static cob_module module = { NULL, NULL, &f_8, NULL, cob_user_parameters, 0, '.', '$', ',', 1, 1, 1, 0};
/* perform frame stack */
int frame_index;
struct frame {
int perform_through;
void *return_address;
} frame_stack[255];
/* Start of function code */
if (unlikely(entry < 0)) {
if (!initialized) {
return 0;
}
initialized = 0;
return 0;
}
module.next = cob_current_module;
cob_current_module = &module;
if (unlikely(initialized == 0))
{
if (!cob_initialized) {
cob_fatal_error (COB_FERROR_INITIALIZED);
}
cob_check_version (COB_SOURCE_FILE, COB_PACKAGE_VERSION, COB_PATCH_LEVEL);
(*(int *) (b_1)) = 0;
(*(int *) (b_2)) = 0;
(*(int *) (b_3)) = 0;
memcpy (b_5, "001", 3);
memset (b_6, 48, 3);
memset (b_7, 48, 3);
memset (b_8, 48, 4);
initialized = 1;
}
/* initialize frame stack */
frame_index = 0;
frame_stack[0].perform_through = -1;
/* initialize number of call params */
(*(int *) (b_3)) = cob_call_params;
cob_save_call_params = cob_call_params;
goto l_2;
/* PROCEDURE DIVISION */
/* fizzbuzz: */
l_2:;
/* MAIN SECTION: */
/* MAIN PARAGRAPH: */
/* fizzbuzz.cob:13: PERFORM */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 13, "MAIN SECTION", "MAIN PARAGRAPH", "PERFORM");
{
while (1)
{
if (((int)cob_cmp_numdisp (b_5, 3, 100) > 0))
break;
{
/* fizzbuzz.cob:14: DIVIDE */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 14, "MAIN SECTION", "MAIN PARAGRAPH", "DIVIDE");
{
cob_div_quotient (&f_5, &c_1, &f_7, 2);
cob_div_remainder (&f_6, 2);
}
/* fizzbuzz.cob:15: IF */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 15, "MAIN SECTION", "MAIN PARAGRAPH", "IF");
{
if (((int)cob_cmp_numdisp (b_6, 3, 0) == 0))
{
/* fizzbuzz.cob:17: DISPLAY */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 17, "MAIN SECTION", "MAIN PARAGRAPH", "DISPLAY");
{
cob_new_display (0, 0, 1, &c_2);
}
}
else
{
/* fizzbuzz.cob:19: DIVIDE */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 19, "MAIN SECTION", "MAIN PARAGRAPH", "DIVIDE");
{
cob_div_quotient (&f_5, &c_3, &f_7, 2);
cob_div_remainder (&f_6, 2);
}
/* fizzbuzz.cob:20: IF */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 20, "MAIN SECTION", "MAIN PARAGRAPH", "IF");
{
if (((int)cob_cmp_numdisp (b_6, 3, 0) == 0))
{
/* fizzbuzz.cob:22: DISPLAY */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 22, "MAIN SECTION", "MAIN PARAGRAPH", "DISPLAY");
{
cob_new_display (0, 0, 1, &c_4);
}
}
else
{
/* fizzbuzz.cob:24: DIVIDE */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 24, "MAIN SECTION", "MAIN PARAGRAPH", "DIVIDE");
{
cob_div_quotient (&f_5, &c_5, &f_7, 2);
cob_div_remainder (&f_6, 2);
}
/* fizzbuzz.cob:25: IF */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 25, "MAIN SECTION", "MAIN PARAGRAPH", "IF");
{
if (((int)cob_cmp_numdisp (b_6, 3, 0) == 0))
{
/* fizzbuzz.cob:27: DISPLAY */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 27, "MAIN SECTION", "MAIN PARAGRAPH", "DISPLAY");
{
cob_new_display (0, 0, 1, &c_6);
}
}
else
{
/* fizzbuzz.cob:29: DISPLAY */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 29, "MAIN SECTION", "MAIN PARAGRAPH", "DISPLAY");
{
cob_new_display (0, 0, 2, &f_5, &c_7);
}
}
}
}
}
}
}
/* fizzbuzz.cob:33: ADD */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 33, "MAIN SECTION", "MAIN PARAGRAPH", "ADD");
{
cob_add (&f_5, &c_8, 2);
}
}
}
}
/* fizzbuzz.cob:35: DISPLAY */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 35, "MAIN SECTION", "MAIN PARAGRAPH", "DISPLAY");
{
cob_new_display (0, 1, 1, &c_9);
}
/* fizzbuzz.cob:36: STOP */
cob_set_location ("fizzbuzz", "fizzbuzz.cob", 36, "MAIN SECTION", "MAIN PARAGRAPH", "STOP");
{
cob_stop_run ((*(int *) (b_1)));
}
cob_current_module = cob_current_module->next;
return (*(int *) (b_1));
}
/* Main function */
int
main (int argc, char **argv)
{
cob_init (argc, argv);
cob_stop_run (ORBITS ());
}
