OpenCOBOL 1.1pre-rel
codegen.c
Go to the documentation of this file.
00001 /*
00002  * Copyright (C) 2002-2009 Keisuke Nishida
00003  * Copyright (C) 2007-2009 Roger While
00004  *
00005  * This program is free software; you can redistribute it and/or modify
00006  * it under the terms of the GNU General Public License as published by
00007  * the Free Software Foundation; either version 2, or (at your option)
00008  * any later version.
00009  * 
00010  * This program 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 General Public License for more details.
00014  * 
00015  * You should have received a copy of the GNU General Public License
00016  * along with this software; see the file COPYING.  If not, write to
00017  * the Free Software Foundation, 51 Franklin Street, Fifth Floor
00018  * Boston, MA 02110-1301 USA
00019  */
00020 
00021 #include "config.h"
00022 
00023 #include <stdio.h>
00024 #include <stdlib.h>
00025 #include <stdarg.h>
00026 #include <string.h>
00027 #include <ctype.h>
00028 #include <time.h>
00029 
00030 #include <tarstamp.h>
00031 
00032 #include "cobc.h"
00033 #include "tree.h"
00034 
00035 #define COB_USE_SETJMP          0
00036 #define COB_MAX_SUBSCRIPTS      16
00037 
00038 #define INITIALIZE_NONE         0
00039 #define INITIALIZE_ONE          1
00040 #define INITIALIZE_DEFAULT      2
00041 #define INITIALIZE_COMPOUND     3
00042 #define INITIALIZE_EXTERNAL     4
00043 
00044 #ifndef __GNUC__
00045 static int                      inside_check = 0;
00046 static int                      inside_stack[64];
00047 #endif
00048 static int                      param_id = 0;
00049 static int                      stack_id = 0;
00050 static int                      num_cob_fields = 0;
00051 static int                      loop_counter = 0;
00052 static int                      progid = 0;
00053 static int                      last_line = 0;
00054 static int                      needs_exit_prog = 0;
00055 static int                      need_double = 0;
00056 static int                      gen_ebcdic = 0;
00057 static int                      gen_ebcdic_ascii = 0;
00058 static int                      gen_full_ebcdic = 0;
00059 static int                      gen_native = 0;
00060 static int                      gen_custom = 0;
00061 static int                      field_iteration = 0;
00062 static int                      screenptr = 0;
00063 
00064 static int                      i_counters[COB_MAX_SUBSCRIPTS];
00065 
00066 static int                      output_indent_level = 0;
00067 static FILE                     *output_target;
00068 static const char               *excp_current_program_id = NULL;
00069 static const char               *excp_current_section = NULL;
00070 static const char               *excp_current_paragraph = NULL;
00071 static struct cb_program        *current_prog;
00072 
00073 static struct label_list {
00074         struct label_list       *next;
00075         int                     id;
00076         int                     call_num;
00077 } *label_cache = NULL;
00078 
00079 static struct attr_list {
00080         struct attr_list        *next;
00081         unsigned char           *pic;
00082         int                     id;
00083         int                     type;
00084         int                     digits;
00085         int                     scale;
00086         int                     flags;
00087         int                     lenstr;
00088 } *attr_cache = NULL;
00089 
00090 static struct literal_list {
00091         struct literal_list     *next;
00092         struct cb_literal       *literal;
00093         cb_tree                 x;
00094         int                     id;
00095 } *literal_cache = NULL;
00096 
00097 static struct field_list {
00098         struct field_list       *next;
00099         struct cb_field         *f;
00100         cb_tree                 x;
00101         const char              *curr_prog;
00102         int                     nulldata;
00103 } *field_cache = NULL;
00104 
00105 static struct call_list {
00106         struct call_list        *next;
00107         const char              *callname;
00108 } *call_cache = NULL;
00109 
00110 static struct base_list {
00111         struct base_list        *next;
00112         struct cb_field         *f;
00113         const char              *curr_prog;
00114 } *base_cache = NULL;
00115 
00116 static struct local_list {
00117         struct local_list       *next;
00118         struct cb_field         *f;
00119 } *local_cache = NULL;
00120 
00121 struct sort_list {
00122         struct sort_list        *next;
00123 };
00124 
00125 struct system_table {
00126         const char              *syst_name;
00127         const char              *syst_call;
00128 };
00129 
00130 static const struct system_table        system_tab[] = {
00131 #undef  COB_SYSTEM_GEN
00132 #define COB_SYSTEM_GEN(x, y, z) { x, #z },
00133 #include "libcob/system.def"
00134         { NULL, NULL }
00135 };
00136 
00137 /* Globals */
00138 int                             has_external = 0;
00139 
00140 #ifdef __GNUC__
00141 static void output (const char *fmt, ...)
00142     __attribute__ ((__format__ (__printf__, 1, 2)));
00143 static void output_line (const char *fmt, ...)
00144     __attribute__ ((__format__ (__printf__, 1, 2)));
00145 static void output_storage (const char *fmt, ...)
00146     __attribute__ ((__format__ (__printf__, 1, 2)));
00147 #else
00148 static void output (const char *fmt, ...);
00149 static void output_line (const char *fmt, ...);
00150 static void output_storage (const char *fmt, ...);
00151 #endif
00152 
00153 static void output_stmt (cb_tree x);
00154 static void output_integer (cb_tree x);
00155 static void output_index (cb_tree x);
00156 static void output_func_1 (const char *name, cb_tree x);
00157 static void output_param (cb_tree x, int id);
00158 
00159 static void
00160 lookup_call (const char *p)
00161 {
00162         struct call_list *clp;
00163 
00164         for (clp = call_cache; clp; clp = clp->next) {
00165                 if (strcmp (p, clp->callname) == 0) {
00166                         return;
00167                 }
00168         }
00169         clp = cobc_malloc (sizeof (struct call_list));
00170         clp->callname = p;
00171         clp->next = call_cache;
00172         call_cache = clp;
00173 }
00174 
00175 static struct attr_list *
00176 attr_list_reverse (struct attr_list *p)
00177 {
00178         struct attr_list        *next;
00179         struct attr_list        *last = NULL;
00180 
00181         for (; p; p = next) {
00182                 next = p->next;
00183                 p->next = last;
00184                 last = p;
00185         }
00186         return last;
00187 }
00188 
00189 static struct literal_list *
00190 literal_list_reverse (struct literal_list *p)
00191 {
00192         struct literal_list     *next;
00193         struct literal_list     *last = NULL;
00194 
00195         for (; p; p = next) {
00196                 next = p->next;
00197                 p->next = last;
00198                 last = p;
00199         }
00200         return last;
00201 }
00202 
00203 static struct local_list *
00204 local_list_reverse (struct local_list *p)
00205 {
00206         struct local_list       *next;
00207         struct local_list       *last = NULL;
00208 
00209         for (; p; p = next) {
00210                 next = p->next;
00211                 p->next = last;
00212                 last = p;
00213         }
00214         return last;
00215 }
00216 
00217 /*
00218  * Output routines
00219  */
00220 
00221 static void
00222 output (const char *fmt, ...)
00223 {
00224         va_list         ap;
00225 
00226         if (output_target) {
00227                 va_start (ap, fmt);
00228                 vfprintf (output_target, fmt, ap);
00229                 va_end (ap);
00230         }
00231 }
00232 
00233 static void
00234 output_newline (void)
00235 {
00236         if (output_target) {
00237                 fputs ("\n", output_target);
00238         }
00239 }
00240 
00241 static void
00242 output_prefix (void)
00243 {
00244         int     i;
00245 
00246         if (output_target) {
00247                 for (i = 0; i < output_indent_level; i++) {
00248                         fputc (' ', output_target);
00249                 }
00250         }
00251 }
00252 
00253 static void
00254 output_line (const char *fmt, ...)
00255 {
00256         va_list         ap;
00257 
00258         if (output_target) {
00259                 output_prefix ();
00260                 va_start (ap, fmt);
00261                 vfprintf (output_target, fmt, ap);
00262                 va_end (ap);
00263                 fputc ('\n', output_target);
00264         }
00265 }
00266 
00267 static void
00268 output_indent (const char *str)
00269 {
00270         const char      *p;
00271         int             level = 2;
00272 
00273         for (p = str; *p == ' '; p++) {
00274                 level++;
00275         }
00276 
00277         if (*p == '}' && strcmp (str, "})") != 0) {
00278                 output_indent_level -= level;
00279         }
00280 
00281         output_line (str);
00282 
00283         if (*p == '{' && strcmp (str, ")}") != 0) {
00284                 output_indent_level += level;
00285         }
00286 }
00287 
00288 static void
00289 output_string (const unsigned char *s, int size)
00290 {
00291         int     i;
00292         int     c;
00293         int     printable = 1;
00294 
00295         for (i = 0; i < size; i++) {
00296                 if (!isprint (s[i])) {
00297                         printable = 0;
00298                 }
00299         }
00300 
00301         output ("\"");
00302         for (i = 0; i < size; i++) {
00303                 c = s[i];
00304                 if (printable) {
00305                         if (c == '\"' || c == '\\') {
00306                                 output ("\\%c", c);
00307                         } else {
00308                                 output ("%c", c);
00309                         }
00310                 } else {
00311                         output ("\\%03o", c);
00312                 }
00313         }
00314         output ("\"");
00315 }
00316 
00317 static void
00318 output_storage (const char *fmt, ...)
00319 {
00320         va_list         ap;
00321 
00322         if (cb_storage_file) {
00323                 va_start (ap, fmt);
00324                 vfprintf (cb_storage_file, fmt, ap);
00325                 va_end (ap);
00326         }
00327 }
00328 
00329 static void
00330 output_local (const char *fmt, ...)
00331 {
00332         va_list         ap;
00333 
00334         if (current_prog->local_storage_file) {
00335                 va_start (ap, fmt);
00336                 vfprintf (current_prog->local_storage_file, fmt, ap);
00337                 va_end (ap);
00338         }
00339 }
00340 
00341 /*
00342  * Field
00343  */
00344 
00345 static void
00346 output_base (struct cb_field *f)
00347 {
00348         struct cb_field         *f01;
00349         struct cb_field         *p;
00350         struct cb_field         *v;
00351         struct base_list        *bl;
00352         char                    *nmp;
00353         char                    name[COB_MINI_BUFF];
00354 
00355         f01 = cb_field_founder (f);
00356 
00357         if (f->flag_item_78) {
00358                 fprintf (stderr, "Unexpected CONSTANT item\n");
00359                 ABORT ();
00360         }
00361 
00362         if (f01->redefines) {
00363                 f01 = f01->redefines;
00364         }
00365 
00366         /* Base name */
00367         if (f01->flag_external) {
00368                 strcpy (name, f01->name);
00369                 for (nmp = name; *nmp; nmp++) {
00370                         if (*nmp == '-') {
00371                                 *nmp = '_';
00372                         }
00373                 }
00374         } else {
00375                 sprintf (name, "%d", f01->id);
00376         }
00377 
00378         if (!f01->flag_base) {
00379                 if (!f01->flag_external) {
00380                         if (!f01->flag_local || f01->flag_is_global) {
00381                                 bl = cobc_malloc (sizeof (struct base_list));
00382                                 bl->f = f01;
00383                                 bl->curr_prog = excp_current_program_id;
00384                                 bl->next = base_cache;
00385                                 base_cache = bl;
00386                         } else {
00387                                 if (current_prog->flag_global_use) {
00388                                         output_local ("unsigned char\t\t*%s%s = NULL;",
00389                                                         CB_PREFIX_BASE, name);
00390                                         output_local ("\t/* %s */\n", f01->name);
00391                                         output_local ("static unsigned char\t*save_%s%s;\n",
00392                                                         CB_PREFIX_BASE, name);
00393                                 } else {
00394                                         output_local ("unsigned char\t*%s%s = NULL;",
00395                                                         CB_PREFIX_BASE, name);
00396                                         output_local ("\t/* %s */\n", f01->name);
00397                                 }
00398                         }
00399                 }
00400                 f01->flag_base = 1;
00401         }
00402         output ("%s%s", CB_PREFIX_BASE, name);
00403 
00404         if (cb_field_variable_address (f)) {
00405                 for (p = f->parent; p; f = f->parent, p = f->parent) {
00406                         for (p = p->children; p != f; p = p->sister) {
00407                                 v = cb_field_variable_size (p);
00408                                 if (v) {
00409                                         output (" + %d + ", v->offset - p->offset);
00410                                         if (v->size != 1) {
00411                                                 output ("%d * ", v->size);
00412                                         }
00413                                         output_integer (v->occurs_depending);
00414                                 } else {
00415                                         output (" + %d", p->size * p->occurs_max);
00416                                 }
00417                         }
00418                 }
00419         } else if (f->offset > 0) {
00420                 output (" + %d", f->offset);
00421         }
00422 }
00423 
00424 static void
00425 output_data (cb_tree x)
00426 {
00427         struct cb_literal       *l;
00428         struct cb_reference     *r;
00429         struct cb_field         *f;
00430         cb_tree                 lsub;
00431 
00432         switch (CB_TREE_TAG (x)) {
00433         case CB_TAG_LITERAL:
00434                 l = CB_LITERAL (x);
00435                 if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
00436                         output ("(unsigned char *)\"%s%s\"", l->data,
00437                                 (l->sign < 0) ? "-" : (l->sign > 0) ? "+" : "");
00438                 } else {
00439                         output ("(unsigned char *)");
00440                         output_string (l->data, (int) l->size);
00441                 }
00442                 break;
00443         case CB_TAG_REFERENCE:
00444                 r = CB_REFERENCE (x);
00445                 f = CB_FIELD (r->value);
00446 
00447                 /* Base address */
00448                 output_base (f);
00449 
00450                 /* Subscripts */
00451                 if (r->subs) {
00452                         lsub = r->subs;
00453                         for (; f; f = f->parent) {
00454                                 if (f->flag_occurs) {
00455                                         output (" + ");
00456                                         if (f->size != 1) {
00457                                                 output ("%d * ", f->size);
00458                                         }
00459                                         output_index (CB_VALUE (lsub));
00460                                         lsub = CB_CHAIN (lsub);
00461                                 }
00462                         }
00463                 }
00464 
00465                 /* Offset */
00466                 if (r->offset) {
00467                         output (" + ");
00468                         output_index (r->offset);
00469                 }
00470                 break;
00471         case CB_TAG_CAST:
00472                 output ("&");
00473                 output_param (x, 0);
00474                 break;
00475         case CB_TAG_INTRINSIC:
00476                 output ("module.cob_procedure_parameters[%d]->data", field_iteration);
00477                 break;
00478         case CB_TAG_CONST:
00479                 if (x == cb_null) {
00480                         output ("NULL");
00481                         return;
00482                 }
00483                 /* Fall through */
00484         default:
00485                 fprintf (stderr, "Unexpected tree tag %d\n", CB_TREE_TAG (x));
00486                 ABORT ();
00487         }
00488 }
00489 
00490 static void
00491 output_size (cb_tree x)
00492 {
00493         struct cb_literal       *l;
00494         struct cb_reference     *r;
00495         struct cb_field         *f;
00496         struct cb_field         *p;
00497         struct cb_field         *q;
00498 
00499         switch (CB_TREE_TAG (x)) {
00500         case CB_TAG_CONST:
00501                 output ("1");
00502                 break;
00503         case CB_TAG_LITERAL:
00504                 l = CB_LITERAL (x);
00505                 output ("%d", (int)(l->size + ((l->sign != 0) ? 1 : 0)));
00506                 break;
00507         case CB_TAG_REFERENCE:
00508                 r = CB_REFERENCE (x);
00509                 f = CB_FIELD (r->value);
00510                 if (r->length) {
00511                         output_integer (r->length);
00512                 } else if (r->offset) {
00513                         output ("%d - ", f->size);
00514                         output_index (r->offset);
00515                 } else {
00516                         p = cb_field_variable_size (f);
00517                         q = f;
00518 
00519 again:
00520                         if (p && (r->type == CB_SENDING_OPERAND
00521                             || !cb_field_subordinate (cb_field (p->occurs_depending), q))) {
00522                                 if (p->offset - q->offset > 0) {
00523                                         output ("%d + ", p->offset - q->offset);
00524                                 }
00525                                 if (p->size != 1) {
00526                                         output ("%d * ", p->size);
00527                                 }
00528                                 output_integer (p->occurs_depending);
00529                                 q = p;
00530                         } else {
00531                                 output ("%d", q->size);
00532                         }
00533 
00534                         for (; q != f; q = q->parent) {
00535                                 if (q->sister && !q->sister->redefines) {
00536                                         q = q->sister;
00537                                         p = q->occurs_depending ? q : cb_field_variable_size (q);
00538                                         output (" + ");
00539                                         goto again;
00540                                 }
00541                         }
00542                 }
00543                 break;
00544         default:
00545                 fprintf (stderr, "Unexpected tree tag %d\n", CB_TREE_TAG (x));
00546                 ABORT ();
00547         }
00548 }
00549 
00550 static int
00551 lookup_attr (int type, int digits, int scale, int flags, unsigned char *pic, int lenstr)
00552 {
00553         struct attr_list *l;
00554 
00555         /* Search attribute cache */
00556         for (l = attr_cache; l; l = l->next) {
00557                 if (type == l->type
00558                     && digits == l->digits
00559                     && scale == l->scale && flags == l->flags
00560                     && ((pic == l->pic) || (pic && l->pic && lenstr == l->lenstr
00561                     && memcmp ((char *)pic, (char *)(l->pic), (size_t)lenstr) == 0))) {
00562                         return l->id;
00563                 }
00564         }
00565 
00566         /* Output new attribute */
00567 
00568         /* Cache it */
00569         l = cobc_malloc (sizeof (struct attr_list));
00570         l->id = cb_attr_id;
00571         l->type = type;
00572         l->digits = digits;
00573         l->scale = scale;
00574         l->flags = flags;
00575         l->pic = pic;
00576         l->lenstr = lenstr;
00577         l->next = attr_cache;
00578         attr_cache = l;
00579 
00580         return cb_attr_id++;
00581 }
00582 
00583 static void
00584 output_attr (cb_tree x)
00585 {
00586         struct cb_literal       *l;
00587         struct cb_reference     *r;
00588         struct cb_field         *f;
00589         int                     id;
00590         int                     type;
00591         int                     flags;
00592 
00593         switch (CB_TREE_TAG (x)) {
00594         case CB_TAG_LITERAL:
00595                 l = CB_LITERAL (x);
00596                 if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
00597                         flags = 0;
00598                         if (l->sign != 0) {
00599                                 flags = COB_FLAG_HAVE_SIGN | COB_FLAG_SIGN_SEPARATE;
00600                         }
00601                         id = lookup_attr (COB_TYPE_NUMERIC_DISPLAY,
00602                                           (int) l->size, l->scale, flags, NULL, 0);
00603                 } else {
00604                         if (l->all) {
00605                                 id = lookup_attr (COB_TYPE_ALPHANUMERIC_ALL, 0, 0, 0, NULL, 0);
00606                         } else {
00607                                 id = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
00608                         }
00609                 }
00610                 break;
00611         case CB_TAG_REFERENCE:
00612                 type = cb_tree_type (x);
00613                 r = CB_REFERENCE (x);
00614                 f = CB_FIELD (r->value);
00615                 flags = 0;
00616                 if (r->offset) {
00617                         id = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
00618                 } else {
00619                         switch (type) {
00620                         case COB_TYPE_GROUP:
00621                         case COB_TYPE_ALPHANUMERIC:
00622                                 if (f->flag_justified) {
00623                                         id = lookup_attr (type, 0, 0, COB_FLAG_JUSTIFIED, NULL, 0);
00624                                 } else {
00625                                         id = lookup_attr (type, 0, 0, 0, NULL, 0);
00626                                 }
00627                                 break;
00628                         default:
00629                                 if (f->pic->have_sign) {
00630                                         flags |= COB_FLAG_HAVE_SIGN;
00631                                         if (f->flag_sign_separate) {
00632                                                 flags |= COB_FLAG_SIGN_SEPARATE;
00633                                         }
00634                                         if (f->flag_sign_leading) {
00635                                                 flags |= COB_FLAG_SIGN_LEADING;
00636                                         }
00637                                 }
00638                                 if (f->flag_blank_zero) {
00639                                         flags |= COB_FLAG_BLANK_ZERO;
00640                                 }
00641                                 if (f->flag_justified) {
00642                                         flags |= COB_FLAG_JUSTIFIED;
00643                                 }
00644                                 if (f->flag_binary_swap) {
00645                                         flags |= COB_FLAG_BINARY_SWAP;
00646                                 }
00647                                 if (f->flag_real_binary) {
00648                                         flags |= COB_FLAG_REAL_BINARY;
00649                                 }
00650                                 if (f->flag_is_pointer) {
00651                                         flags |= COB_FLAG_IS_POINTER;
00652                                 }
00653 
00654                                 id = lookup_attr (type, f->pic->digits, f->pic->scale,
00655                                                   flags, (ucharptr) f->pic->str, f->pic->lenstr);
00656                                 break;
00657                         }
00658                 }
00659                 break;
00660         case CB_TAG_ALPHABET_NAME:
00661                 id = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
00662                 break;
00663         default:
00664                 fprintf (stderr, "Unexpected tree tag %d\n", CB_TREE_TAG (x));
00665                 ABORT ();
00666         }
00667 
00668         output ("&%s%d", CB_PREFIX_ATTR, id);
00669 }
00670 
00671 static void
00672 output_field (cb_tree x)
00673 {
00674         output ("{");
00675         output_size (x);
00676         output (", ");
00677         output_data (x);
00678         output (", ");
00679         output_attr (x);
00680         output ("}");
00681 }
00682 
00683 /*
00684  * Literal
00685  */
00686 
00687 static int
00688 lookup_literal (cb_tree x)
00689 {
00690 
00691         struct cb_literal       *literal;
00692         struct literal_list     *l;
00693         FILE                    *savetarget;
00694 
00695         literal = CB_LITERAL (x);
00696         /* Search literal cache */
00697         for (l = literal_cache; l; l = l->next) {
00698                 if (CB_TREE_CLASS (literal) == CB_TREE_CLASS (l->literal)
00699                     && literal->size == l->literal->size
00700                     && literal->all == l->literal->all
00701                     && literal->sign == l->literal->sign
00702                     && literal->scale == l->literal->scale
00703                     && memcmp (literal->data, l->literal->data, literal->size) == 0) {
00704                         return l->id;
00705                 }
00706         }
00707 
00708         /* Output new literal */
00709         savetarget = output_target;
00710         output_target = NULL;
00711         output_field (x);
00712 
00713         output_target = savetarget;
00714 
00715         /* Cache it */
00716         l = cobc_malloc (sizeof (struct literal_list));
00717         l->id = cb_literal_id;
00718         l->literal = literal;
00719         l->x = x;
00720         l->next = literal_cache;
00721         literal_cache = l;
00722 
00723         return cb_literal_id++;
00724 }
00725 
00726 /*
00727  * Integer
00728  */
00729 
00730 static void
00731 output_integer (cb_tree x)
00732 {
00733         struct cb_binary_op     *p;
00734         struct cb_cast          *cp;
00735         struct cb_field         *f;
00736 
00737         switch (CB_TREE_TAG (x)) {
00738         case CB_TAG_CONST:
00739                 if (x == cb_zero) {
00740                         output ("0");
00741                 } else if (x == cb_null) {
00742                         output ("(unsigned char *)NULL");
00743                 } else {
00744                         output ("%s", CB_CONST (x)->val);
00745                 }
00746                 break;
00747         case CB_TAG_INTEGER:
00748                 output ("%d", CB_INTEGER (x)->val);
00749                 break;
00750         case CB_TAG_LITERAL:
00751                 output ("%d", cb_get_int (x));
00752                 break;
00753         case CB_TAG_BINARY_OP:
00754                 p = CB_BINARY_OP (x);
00755                 if (p->op == '^') {
00756                         output ("(int) pow (");
00757                         output_integer (p->x);
00758                         output (", ");
00759                         output_integer (p->y);
00760                         output (")");
00761                 } else {
00762                         output ("(");
00763                         if (need_double) {
00764                                 output ("(double)");
00765                         }
00766                         output_integer (p->x);
00767                         output (" %c ", p->op);
00768                         if (need_double) {
00769                                 output ("(double)");
00770                         }
00771                         output_integer (p->y);
00772                         output (")");
00773                 }
00774                 break;
00775         case CB_TAG_CAST:
00776                 cp = CB_CAST (x);
00777                 switch (cp->type) {
00778                 case CB_CAST_ADDRESS:
00779                         output ("(");
00780                         output_data (cp->val);
00781                         output (")");
00782                         break;
00783                 case CB_CAST_PROGRAM_POINTER:
00784                         output_func_1 ("cob_call_resolve", x);
00785                         break;
00786                 default:
00787                         fprintf (stderr, "Unexpected cast type %d\n", cp->type);
00788                         ABORT ();
00789                 }
00790                 break;
00791         case CB_TAG_REFERENCE:
00792                 f = cb_field (x);
00793                 switch (f->usage) {
00794                 case CB_USAGE_INDEX:
00795                 case CB_USAGE_LENGTH:
00796                         output ("(*(int *) (");
00797                         output_data (x);
00798                         output ("))");
00799                         return;
00800 
00801                 case CB_USAGE_POINTER:
00802 #ifdef  COB_NON_ALIGNED
00803                         output ("(cob_get_pointer (");
00804                         output_data (x);
00805                         output ("))");
00806 #else
00807                         output ("(*(unsigned char **) (");
00808                         output_data (x);
00809                         output ("))");
00810 #endif
00811                         return;
00812 
00813                 case CB_USAGE_PROGRAM_POINTER:
00814 #ifdef  COB_NON_ALIGNED
00815                         output ("(cob_get_prog_pointer (");
00816                         output_data (x);
00817                         output ("))");
00818 #else
00819                         output ("(*(void **) (");
00820                         output_data (x);
00821                         output ("))");
00822 #endif
00823                         return;
00824 
00825                 case CB_USAGE_DISPLAY:
00826                         if (f->pic && f->pic->scale >= 0
00827                             && f->size - f->pic->scale > 0
00828                             && f->size - f->pic->scale <= 9
00829                             && f->pic->have_sign == 0) {
00830                                 output ("cob_get_numdisp (");
00831                                 output_data (x);
00832                                 output (", %d)", f->size - f->pic->scale);
00833                                 return;
00834                         }
00835                         break;
00836 
00837                 case CB_USAGE_PACKED:
00838                         if (f->pic->scale == 0 && f->pic->digits < 10) {
00839                                 output_func_1 ("cob_get_packed_int", x);
00840                                 return;
00841                         }
00842                         break;
00843 
00844                 case CB_USAGE_BINARY:
00845                 case CB_USAGE_COMP_5:
00846                 case CB_USAGE_COMP_X:
00847                         if (f->size == 1) {
00848                                 output ("(*(");
00849                                 if (!f->pic->have_sign) {
00850                                         output ("unsigned ");
00851                                 } else {
00852                                         output ("signed ");
00853                                 }
00854                                 output ("char *) (");
00855                                 output_data (x);
00856                                 output ("))");
00857                                 return;
00858                         }
00859 #ifdef  COB_NON_ALIGNED
00860                         if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 && (
00861 #ifdef  COB_SHORT_BORK
00862                                 (f->size == 2 && (f->offset % 4 == 0)) ||
00863 #else
00864                                 (f->size == 2 && (f->offset % 2 == 0)) ||
00865 #endif
00866                                 (f->size == 4 && (f->offset % 4 == 0)) ||
00867                                 (f->size == 8 && (f->offset % 8 == 0)))) {
00868 #else
00869                         if (f->size == 2 || f->size == 4 || f->size == 8) {
00870 #endif
00871                                 if (f->flag_binary_swap) {
00872                                         output ("((");
00873                                         if (!f->pic->have_sign) {
00874                                                 output ("unsigned ");
00875                                         }
00876                                         switch (f->size) {
00877                                         case 2:
00878                                                 output ("short)COB_BSWAP_16(");
00879                                                 break;
00880                                         case 4:
00881                                                 output ("int)COB_BSWAP_32(");
00882                                                 break;
00883                                         case 8:
00884                                                 output ("long long)COB_BSWAP_64(");
00885                                                 break;
00886                                         }
00887                                         output ("*(");
00888                                         switch (f->size) {
00889                                         case 2:
00890                                                 output ("short *)(");
00891                                                 break;
00892                                         case 4:
00893                                                 output ("int *)(");
00894                                                 break;
00895                                         case 8:
00896                                                 output ("long long *)(");
00897                                                 break;
00898                                         }
00899                                         output_data (x);
00900                                         output (")))");
00901                                         return;
00902                                 } else {
00903                                         output ("(*(");
00904                                         if (!f->pic->have_sign) {
00905                                                 output ("unsigned ");
00906                                         }
00907                                         switch (f->size) {
00908                                         case 2:
00909                                                 output ("short *)(");
00910                                                 break;
00911                                         case 4:
00912                                                 output ("int *)(");
00913                                                 break;
00914                                         case 8:
00915                                                 output ("long long *)(");
00916                                                 break;
00917                                         }
00918                                         output_data (x);
00919                                         output ("))");
00920                                         return;
00921                                 }
00922                         }
00923                         if (f->pic->have_sign == 0) {
00924                                 output ("(unsigned int)");
00925                         }
00926                         break;
00927 
00928                 default:
00929                         break;
00930                 }
00931 
00932                 output_func_1 ("cob_get_int", x);
00933                 break;
00934         case CB_TAG_INTRINSIC:
00935                 output ("cob_get_int (");
00936                 output_param (x, -1);
00937                 output (")");
00938                 break;
00939         default:
00940                 fprintf (stderr, "Unexpected tree tag %d\n", CB_TREE_TAG (x));
00941                 ABORT ();
00942         }
00943 }
00944 
00945 static void
00946 output_index (cb_tree x)
00947 {
00948         switch (CB_TREE_TAG (x)) {
00949         case CB_TAG_INTEGER:
00950                 output ("%d", CB_INTEGER (x)->val - 1);
00951                 break;
00952         case CB_TAG_LITERAL:
00953                 output ("%d", cb_get_int (x) - 1);
00954                 break;
00955         default:
00956                 output ("(");
00957                 output_integer (x);
00958                 output (" - 1)");
00959                 break;
00960         }
00961 }
00962 
00963 /*
00964  * Parameter
00965  */
00966 
00967 static void
00968 output_param (cb_tree x, int id)
00969 {
00970         struct cb_reference     *r;
00971         struct cb_field         *f;
00972         struct cb_field         *pechk;
00973         struct cb_cast          *cp;
00974         struct cb_binary_op     *bp;
00975         struct field_list       *fl;
00976         FILE                    *savetarget;
00977         struct cb_intrinsic     *ip;
00978         struct cb_alphabet_name *abp;
00979         struct cb_alphabet_name *rbp;
00980         cb_tree                 l;
00981         int                     n;
00982         int                     extrefs;
00983         int                     sav_stack_id;
00984         char                    fname[12];
00985 
00986         param_id = id;
00987 
00988         if (x == NULL) {
00989                 output ("NULL");
00990                 return;
00991         }
00992 
00993         switch (CB_TREE_TAG (x)) {
00994         case CB_TAG_CONST:
00995                 output ("%s", CB_CONST (x)->val);
00996                 break;
00997         case CB_TAG_INTEGER:
00998                 output_integer (x);
00999                 break;
01000         case CB_TAG_STRING:
01001                 output_string (CB_STRING (x)->data, (int) CB_STRING (x)->size);
01002                 break;
01003         case CB_TAG_LOCALE_NAME:
01004                 output_param (CB_LOCALE_NAME(x)->list, id);
01005                 break;
01006         case CB_TAG_ALPHABET_NAME:
01007                 abp = CB_ALPHABET_NAME (x);
01008                 switch (abp->type) {
01009                 case CB_ALPHABET_STANDARD_1:
01010                 case CB_ALPHABET_STANDARD_2:
01011 #ifdef  COB_EBCDIC_MACHINE
01012                         gen_ebcdic_ascii = 1;
01013                         output ("cob_ebcdic_ascii");
01014                         break;
01015 #endif
01016                 case CB_ALPHABET_NATIVE:
01017                         gen_native = 1;
01018                         output ("NULL");
01019                         break;
01020                 case CB_ALPHABET_EBCDIC:
01021 #ifdef  COB_EBCDIC_MACHINE
01022                         gen_native = 1;
01023                         output ("NULL");
01024 #else
01025                         gen_ebcdic = 1;
01026                         output ("cob_a2e");
01027 #endif
01028                         break;
01029                 case CB_ALPHABET_CUSTOM:
01030                         gen_custom = 1;
01031                         output ("%s%s", CB_PREFIX_SEQUENCE, abp->cname);
01032                         break;
01033                 }
01034                 break;
01035         case CB_TAG_CAST:
01036                 cp = CB_CAST (x);
01037                 switch (cp->type) {
01038                 case CB_CAST_INTEGER:
01039                         output_integer (cp->val);
01040                         break;
01041                 case CB_CAST_ADDRESS:
01042                         output_data (cp->val);
01043                         break;
01044                 case CB_CAST_ADDR_OF_ADDR:
01045                         output ("&");
01046                         output_data (cp->val);
01047                         break;
01048                 case CB_CAST_LENGTH:
01049                         output_size (cp->val);
01050                         break;
01051                 case CB_CAST_PROGRAM_POINTER:
01052                         output_param (cp->val, id);
01053                         break;
01054                 }
01055                 break;
01056         case CB_TAG_DECIMAL:
01057                 output ("&d%d", CB_DECIMAL (x)->id);
01058                 break;
01059         case CB_TAG_FILE:
01060                 output ("%s%s", CB_PREFIX_FILE, CB_FILE (x)->cname);
01061                 break;
01062         case CB_TAG_LITERAL:
01063                 output ("&%s%d", CB_PREFIX_CONST, lookup_literal (x));
01064                 break;
01065         case CB_TAG_FIELD:
01066                 /* TODO: remove me */
01067                 output_param (cb_build_field_reference (CB_FIELD (x), NULL), id);
01068                 break;
01069         case CB_TAG_REFERENCE:
01070                 r = CB_REFERENCE (x);
01071                 extrefs = 0;
01072                 if (r->check) {
01073 #ifdef __GNUC__
01074                         output_indent (" ({");
01075 #else
01076                         inside_stack[inside_check] = 0;
01077                         ++inside_check;
01078                         output (" (\n");
01079 #endif
01080                         for (l = r->check; l; l = CB_CHAIN (l)) {
01081                                 sav_stack_id = stack_id;
01082                                 output_stmt (CB_VALUE (l));
01083                                 stack_id = sav_stack_id;
01084                         }
01085                 }
01086 
01087                 if (CB_FILE_P (r->value)) {
01088                         output ("%s%s", CB_PREFIX_FILE, CB_FILE (r->value)->cname);
01089                         if (r->check) {
01090 #ifdef __GNUC__
01091                                 output ("; })");
01092 #else
01093                                 --inside_check;
01094                                 output (" )");
01095 #endif
01096                         }
01097                         break;
01098                 }
01099                 if (CB_ALPHABET_NAME_P (r->value)) {
01100                         rbp = CB_ALPHABET_NAME (r->value);
01101                         switch (rbp->type) {
01102                         case CB_ALPHABET_STANDARD_1:
01103                         case CB_ALPHABET_STANDARD_2:
01104 #ifdef  COB_EBCDIC_MACHINE
01105                                 gen_ebcdic_ascii = 1;
01106                                 output ("&f_ebcdic_ascii");
01107                                 break;
01108 #endif
01109                         case CB_ALPHABET_NATIVE:
01110                                 gen_native = 1;
01111                                 output ("&f_native");
01112                                 break;
01113                         case CB_ALPHABET_EBCDIC:
01114 #ifdef  COB_EBCDIC_MACHINE
01115                                 gen_native = 1;
01116                                 output ("&f_native");
01117 #else
01118                                 gen_full_ebcdic = 1;
01119                                 output ("&f_ebcdic");
01120 #endif
01121                                 break;
01122                         case CB_ALPHABET_CUSTOM:
01123                                 gen_custom = 1;
01124                                 output ("&f_%s", rbp->cname);
01125                                 break;
01126                         }
01127                         if (r->check) {
01128 #ifdef __GNUC__
01129                                 output ("; })");
01130 #else
01131                                 --inside_check;
01132                                 output (" )");
01133 #endif
01134                         }
01135                         break;
01136                 }
01137                 f = CB_FIELD (r->value);
01138                 if (f->redefines && f->redefines->flag_external) {
01139                         extrefs = 1;
01140                         f->flag_item_external = 1;
01141                         f->flag_external = 1;
01142                 }
01143                 if (f->redefines && f->redefines->flag_item_based) {
01144                         f->flag_local = 1;
01145                 }
01146                 for (pechk = f->parent; pechk; pechk = pechk->parent) {
01147                         if (pechk->flag_external) {
01148                                 extrefs = 1;
01149                                 f->flag_item_external = 1;
01150                                 break;
01151                         }
01152                         if (pechk->redefines && pechk->redefines->flag_external) {
01153                                 extrefs = 1;
01154                                 f->flag_item_external = 1;
01155                                 f->flag_external = 1;
01156                                 break;
01157                         }
01158                         if (pechk->flag_item_based) {
01159                                 f->flag_local = 1;
01160                                 break;
01161                         }
01162                         if (pechk->redefines && pechk->redefines->flag_item_based) {
01163                                 f->flag_local = 1;
01164                                 break;
01165                         }
01166                 }
01167                 if (f->flag_external) {
01168                         f->flag_item_external = 1;
01169                 }
01170                 if (!r->subs && !r->offset && f->count > 0
01171                     && !cb_field_variable_size (f) &&
01172                        !cb_field_variable_address (f)) {
01173                         if (!f->flag_field) {
01174                                 savetarget = output_target;
01175                                 output_target = NULL;
01176                                 output_field (x);
01177 
01178                                 fl = cobc_malloc (sizeof (struct field_list));
01179                                 fl->x = x;
01180                                 fl->f = f;
01181                                 fl->curr_prog = excp_current_program_id;
01182                                 fl->nulldata = (r->subs != NULL);
01183                                 fl->next = field_cache;
01184                                 field_cache = fl;
01185 
01186                                 f->flag_field = 1;
01187                                 output_target = savetarget;
01188                         }
01189                         if (f->flag_local) {
01190                                 if (f->flag_any_length && f->flag_anylen_done) {
01191                                         output ("&%s%d", CB_PREFIX_FIELD, f->id);
01192                                 } else {
01193                                         output ("(%s%d.data = ", CB_PREFIX_FIELD, f->id);
01194                                         output_data (x);
01195                                         output (", &%s%d)", CB_PREFIX_FIELD, f->id);
01196                                         if (f->flag_any_length) {
01197                                                 f->flag_anylen_done = 1;
01198                                         }
01199                                 }
01200                         } else {
01201                                 if (screenptr && f->storage == CB_STORAGE_SCREEN) {
01202                                         output ("&s_%d", f->id);
01203                                 } else {
01204                                         output ("&%s%d", CB_PREFIX_FIELD, f->id);
01205                                 }
01206                         }
01207                 } else {
01208                         if (stack_id >= num_cob_fields) {
01209                                 num_cob_fields = stack_id + 1;
01210                         }
01211                         sprintf (fname, "f%d", stack_id++);
01212 #ifndef __GNUC__
01213                         if (inside_check != 0) {
01214                                 if (inside_stack[inside_check-1] != 0) {
01215                                         inside_stack[inside_check-1] = 0;
01216                                         output (",\n");
01217                                 }
01218                         }
01219 #endif
01220                         output ("(%s.size = ", fname);
01221                         output_size (x);
01222                         output (", %s.data = ", fname);
01223                         output_data (x);
01224                         output (", %s.attr = ", fname);
01225                         output_attr (x);
01226                         output (", &%s)", fname);
01227                 }
01228 
01229                 if (r->check) {
01230 #ifdef __GNUC__
01231                         output ("; })");
01232 #else
01233                         --inside_check;
01234                         output (" )");
01235 #endif
01236                 }
01237                 break;
01238         case CB_TAG_BINARY_OP:
01239                 bp = CB_BINARY_OP (x);
01240                 output ("cob_intr_binop (");
01241                 output_param (bp->x, id);
01242                 output (", ");
01243                 output ("%d", bp->op);
01244                 output (", ");
01245                 output_param (bp->y, id);
01246                 output (")");
01247                 break;
01248         case CB_TAG_INTRINSIC:
01249                 n = 0;
01250                 ip = CB_INTRINSIC (x);
01251                 output ("%s (", ip->intr_tab->intr_routine);
01252                 if (ip->intr_tab->refmod) {
01253                         if (ip->offset) {
01254                                 output_integer (ip->offset);
01255                                 output (", ");
01256                         } else {
01257                                 output ("0, ");
01258                         }
01259                         if (ip->length) {
01260                                 output_integer (ip->length);
01261                         } else {
01262                                 output ("0");
01263                         }
01264                         if (ip->intr_field || ip->args) {
01265                                 output (", ");
01266                         }
01267                 }
01268                 if (ip->intr_field) {
01269                         if (ip->intr_field == cb_int0) {
01270                                 output ("NULL");
01271                         } else if (ip->intr_field == cb_int1) {
01272                                 for (l = ip->args; l; l = CB_CHAIN (l)) {
01273                                         n++;
01274                                 }
01275                                 output ("%d", n);
01276                         } else {
01277                                 output_param (ip->intr_field, id);
01278                         }
01279                         if (ip->args) {
01280                                 output (", ");
01281                         }
01282                 }
01283                 for (l = ip->args; l; l = CB_CHAIN (l)) {
01284                         output_param (CB_VALUE (l), id);
01285                         id++;
01286                         param_id++;
01287                         if (CB_CHAIN (l)) {
01288                                 output (", ");
01289                         }
01290                 }
01291                 output (")");
01292                 break;
01293         default:
01294                 fprintf (stderr, "Unexpected tree tag %d\n", CB_TREE_TAG (x));
01295                 ABORT ();
01296         }
01297 }
01298 
01299 /*
01300  * Function call
01301  */
01302 
01303 static void
01304 output_funcall (cb_tree x)
01305 {
01306         struct cb_funcall       *p;
01307         cb_tree                 l;
01308         int                     i;
01309 
01310         p = CB_FUNCALL (x);
01311         if (p->name[0] == '$') {
01312                 switch (p->name[1]) {
01313                 case 'E':
01314                         /* Set of one character */
01315                         output ("*(");
01316                         output_data (p->argv[0]);
01317                         output (") = ");
01318                         output_param (p->argv[1], 1);
01319                         break;
01320                 case 'F':
01321                         /* Move of one character */
01322                         output ("*(");
01323                         output_data (p->argv[0]);
01324                         output (") = *(");
01325                         output_data (p->argv[1]);
01326                         output (")");
01327                         break;
01328                 case 'G':
01329                         /* Test of one character */
01330                         output ("(int)(*(");
01331                         output_data (p->argv[0]);
01332                         if (p->argv[1] == cb_space) {
01333                                 output (") - ' ')");
01334                         } else if (p->argv[1] == cb_zero) {
01335                                 output (") - '0')");
01336                         } else if (p->argv[1] == cb_low) {
01337                                 output ("))");
01338                         } else if (p->argv[1] == cb_high) {
01339                                 output (") - 255)");
01340                         } else if (CB_LITERAL_P (p->argv[1])) {
01341                                 output (") - %d)", *(CB_LITERAL (p->argv[1])->data));
01342                         } else {
01343                                 output (") - *(");
01344                                 output_data (p->argv[1]);
01345                                 output ("))");
01346                         }
01347                         break;
01348                 default:
01349                         ABORT ();
01350                 }
01351                 return;
01352         }
01353         screenptr = p->screenptr;
01354         output ("%s (", p->name);
01355         for (i = 0; i < p->argc; i++) {
01356                 if (p->varcnt && i + 1 == p->argc) {
01357                         output ("%d, ", p->varcnt);
01358                         for (l = p->argv[i]; l; l = CB_CHAIN (l)) {
01359                                 output_param (CB_VALUE (l), i);
01360                                 i++;
01361                                 if (CB_CHAIN (l)) {
01362                                         output (", ");
01363                                 }
01364                         }
01365                 } else {
01366                         output_param (p->argv[i], i);
01367                         if (i + 1 < p->argc) {
01368                                 output (", ");
01369                         }
01370                 }
01371         }
01372         output (")");
01373         screenptr = 0;
01374 }
01375 
01376 static void
01377 output_func_1 (const char *name, cb_tree x)
01378 {
01379         output ("%s (", name);
01380         output_param (x, param_id);
01381         output (")");
01382 }
01383 
01384 /*
01385  * Condition
01386  */
01387 
01388 static void
01389 output_cond (cb_tree x, int save_flag)
01390 {
01391         struct cb_binary_op     *p;
01392 
01393         switch (CB_TREE_TAG (x)) {
01394         case CB_TAG_CONST:
01395                 if (x == cb_true) {
01396                         output ("1");
01397                 } else if (x == cb_false) {
01398                         output ("0");
01399                 } else {
01400                         ABORT ();
01401                 }
01402                 break;
01403         case CB_TAG_BINARY_OP:
01404                 p = CB_BINARY_OP (x);
01405                 switch (p->op) {
01406                 case '!':
01407                         output ("!");
01408                         output_cond (p->x, save_flag);
01409                         break;
01410 
01411                 case '&':
01412                 case '|':
01413                         output ("(");
01414                         output_cond (p->x, save_flag);
01415                         output (p->op == '&' ? " && " : " || ");
01416                         output_cond (p->y, save_flag);
01417                         output (")");
01418                         break;
01419 
01420                 case '=':
01421                 case '<':
01422                 case '[':
01423                 case '>':
01424                 case ']':
01425                 case '~':
01426                         output ("((int)");
01427                         output_cond (p->x, save_flag);
01428                         switch (p->op) {
01429                         case '=':
01430                                 output (" == 0");
01431                                 break;
01432                         case '<':
01433                                 output (" <  0");
01434                                 break;
01435                         case '[':
01436                                 output (" <= 0");
01437                                 break;
01438                         case '>':
01439                                 output (" >  0");
01440                                 break;
01441                         case ']':
01442                                 output (" >= 0");
01443                                 break;
01444                         case '~':
01445                                 output (" != 0");
01446                                 break;
01447                         }
01448                         output (")");
01449                         break;
01450 
01451                 default:
01452                         output_integer (x);
01453                         break;
01454                 }
01455                 break;
01456         case CB_TAG_FUNCALL:
01457                 if (save_flag) {
01458                         output ("(ret = ");
01459                 }
01460                 output_funcall (x);
01461                 if (save_flag) {
01462                         output (")");
01463                 }
01464                 break;
01465         case CB_TAG_LIST:
01466                 if (save_flag) {
01467                         output ("(ret = ");
01468                 }
01469 #ifdef __GNUC__
01470                 output_indent ("({");
01471 #else
01472                 inside_stack[inside_check] = 0;
01473                 ++inside_check;
01474                 output ("(\n");
01475 #endif
01476                 for (; x; x = CB_CHAIN (x)) {
01477                         output_stmt (CB_VALUE (x));
01478                 }
01479 #ifdef __GNUC__
01480                 output_indent ("})");
01481 #else
01482                 --inside_check;
01483                 output (")");
01484 #endif
01485                 if (save_flag) {
01486                         output (")");
01487                 }
01488                 break;
01489         default:
01490                 fprintf (stderr, "Unexpected tree tag %d\n", CB_TREE_TAG (x));
01491                 ABORT ();
01492         }
01493 }
01494 
01495 /*
01496  * MOVE
01497  */
01498 
01499 static void
01500 output_move (cb_tree src, cb_tree dst)
01501 {
01502         /* suppress warnings */
01503         suppress_warn = 1;
01504         output_stmt (cb_build_move (src, dst));
01505         suppress_warn = 0;
01506 }
01507 
01508 /*
01509  * INITIALIZE
01510  */
01511 
01512 static int
01513 initialize_type (struct cb_initialize *p, struct cb_field *f, int topfield)
01514 {
01515         cb_tree         l;
01516         int             type;
01517 
01518         if (f->flag_item_78) {
01519                 fprintf (stderr, "Unexpected CONSTANT item\n");
01520                 ABORT ();
01521         }
01522 
01523         if (f->flag_chained) {
01524                 return INITIALIZE_ONE;
01525         }
01526 
01527         if (f->flag_external) {
01528                 return INITIALIZE_EXTERNAL;
01529         }
01530 
01531         if (f->redefines && (!topfield || !p->flag_statement)) {
01532                 return INITIALIZE_NONE;
01533         }
01534 
01535         if (p->val && f->values) {
01536                 return INITIALIZE_ONE;
01537         }
01538 
01539         if (p->flag_statement && !f->children) {
01540                 if (strlen (f->name) > 4 && f->name[4] == '$') {
01541                         return INITIALIZE_NONE;
01542                 }
01543         }
01544 
01545         if (f->children) {
01546                 type = initialize_type (p, f->children, 0);
01547                 if (type == INITIALIZE_ONE) {
01548                         return INITIALIZE_COMPOUND;
01549                 }
01550                 for (f = f->children->sister; f; f = f->sister) {
01551                         if (type != initialize_type (p, f, 0)) {
01552                                 return INITIALIZE_COMPOUND;
01553                         }
01554                 }
01555                 return type;
01556         } else {
01557                 for (l = p->rep; l; l = CB_CHAIN (l)) {
01558                         if ((int)CB_PURPOSE_INT (l) == (int)CB_TREE_CATEGORY (f)) {
01559                                 return INITIALIZE_ONE;
01560                         }
01561                 }
01562         }
01563 
01564         if (p->def) {
01565                 if (f->usage == CB_USAGE_FLOAT || f->usage == CB_USAGE_DOUBLE) {
01566                         return INITIALIZE_ONE;
01567                 }
01568                 switch (CB_TREE_CATEGORY (f)) {
01569                 case CB_CATEGORY_NUMERIC_EDITED:
01570                 case CB_CATEGORY_ALPHANUMERIC_EDITED:
01571                 case CB_CATEGORY_NATIONAL_EDITED:
01572                         return INITIALIZE_ONE;
01573                 default:
01574                         if (cb_tree_type (CB_TREE (f)) == COB_TYPE_NUMERIC_PACKED) {
01575                                 return INITIALIZE_ONE;
01576                         } else {
01577                                 return INITIALIZE_DEFAULT;
01578                         }
01579                 }
01580         }
01581 
01582         return INITIALIZE_NONE;
01583 }
01584 
01585 static int
01586 initialize_uniform_char (struct cb_field *f)
01587 {
01588         int     c;
01589 
01590         if (f->children) {
01591                 c = initialize_uniform_char (f->children);
01592                 for (f = f->children->sister; f; f = f->sister) {
01593                         if (!f->redefines) {
01594                                 if (c != initialize_uniform_char (f)) {
01595                                         return -1;
01596                                 }
01597                         }
01598                 }
01599                 return c;
01600         } else {
01601                 switch (cb_tree_type (CB_TREE (f))) {
01602                 case COB_TYPE_NUMERIC_BINARY:
01603                         return 0;
01604                 case COB_TYPE_NUMERIC_DISPLAY:
01605                         return '0';
01606                 case COB_TYPE_ALPHANUMERIC:
01607                         return ' ';
01608                 default:
01609                         return -1;
01610                 }
01611         }
01612 }
01613 
01614 static void
01615 output_figurative (cb_tree x, struct cb_field *f, const int value)
01616 {
01617         output_prefix ();
01618         if (f->size == 1) {
01619                 output ("*(unsigned char *)(");
01620                 output_data (x);
01621                 output (") = %d;\n", value);
01622         } else {
01623                 output ("memset (");
01624                 output_data (x);
01625                 if (CB_REFERENCE_P(x) && CB_REFERENCE(x)->length) {
01626                         output (", %d, ", value);
01627                         output_size (x);
01628                         output (");\n");
01629                 } else {
01630                         output (", %d, %d);\n", value, f->size);
01631                 }
01632         }
01633 }
01634 
01635 static void
01636 output_initialize_literal (cb_tree x, struct cb_field *f, struct cb_literal *l)
01637 {
01638         size_t  i;
01639         size_t  n;
01640 
01641         if (l->size == 1) {
01642                 output_prefix ();
01643                 output ("memset (");
01644                 output_data (x);
01645                 if (CB_REFERENCE_P(x) && CB_REFERENCE(x)->length) {
01646                         output (", %d, ", l->data[0]);
01647                         output_size (x);
01648                         output (");\n");
01649                 } else {
01650                         output (", %d, %d);\n", l->data[0], f->size);
01651                 }
01652                 return;
01653         }
01654         if (l->size >= f->size) {
01655                 output_prefix ();
01656                 output ("memcpy (");
01657                 output_data (x);
01658                 output (", ");
01659                 output_string (l->data, f->size);
01660                 output (", %d);\n", f->size);
01661                 return;
01662         }
01663         i = f->size / l->size;
01664         i_counters[0] = 1;
01665         output_line ("for (i0 = 0; i0 < %u; i0++)", (unsigned int)i);
01666         output_indent ("  {");
01667         output_prefix ();
01668         output ("memcpy (");
01669         output_data (x);
01670         output (" + (i0 * %u), ", (unsigned int)l->size);
01671         output_string (l->data, l->size);
01672         output (", %u);\n", (unsigned int)l->size);
01673         output_indent ("  }");
01674         n = f->size % l->size;
01675         if (n) {
01676                 output_prefix ();
01677                 output ("memcpy (");
01678                 output_data (x);
01679                 output (" + (i0 * %u), ", (unsigned int)l->size);
01680                 output_string (l->data, n);
01681                 output (", %u);\n", (unsigned int)n);
01682         }
01683 }
01684 
01685 static void
01686 output_initialize_fp (cb_tree x, struct cb_field *f)
01687 {
01688         output_prefix ();
01689         if (f->usage == CB_USAGE_FLOAT) {
01690                 output ("{float temp = 0.0;");
01691         } else {
01692                 output ("{double temp = 0.0;");
01693         }
01694         output (" memcpy (");
01695         output_data (x);
01696         output (", (char *)&temp, sizeof(temp));}\n");
01697 }
01698 
01699 static void
01700 output_initialize_external (cb_tree x, struct cb_field *f)
01701 {
01702         unsigned char   *p;
01703         char            name[COB_MINI_BUFF];
01704 
01705         output_prefix ();
01706         output_data (x);
01707         if (f->ename) {
01708                 output (" = cob_external_addr (\"%s\", %d);\n", f->ename, f->size);
01709         } else {
01710                 strcpy (name, f->name);
01711                 for (p = (unsigned char *)name; *p; p++) {
01712                         if (islower (*p)) {
01713                                 *p = toupper (*p);
01714                         }
01715                 }
01716                 output (" = cob_external_addr (\"%s\", %d);\n", name, f->size);
01717         }
01718 }
01719 
01720 static void
01721 output_initialize_uniform (cb_tree x, int c, int size)
01722 {
01723         output_prefix ();
01724         if (size == 1) {
01725                 output ("*(unsigned char *)(");
01726                 output_data (x);
01727                 output (") = %d;\n", c);
01728         } else {
01729                 output ("memset (");
01730                 output_data (x);
01731                 if (CB_REFERENCE_P(x) && CB_REFERENCE(x)->length) {
01732                         output (", %d, ", c);
01733                         output_size (x);
01734                         output (");\n");
01735                 } else {
01736                         output (", %d, %d);\n", c, size);
01737                 }
01738         }
01739 }
01740 
01741 static void
01742 output_initialize_one (struct cb_initialize *p, cb_tree x)
01743 {
01744         struct cb_field         *f;
01745         cb_tree                 value;
01746         cb_tree                 lrp;
01747         struct cb_literal       *l;
01748         int                     i;
01749         int                     n;
01750         int                     buffchar;
01751 
01752         static char             *buff = NULL;
01753         static int              lastsize = 0;
01754 
01755         f = cb_field (x);
01756 
01757         /* CHAINING */
01758         if (f->flag_chained) {
01759                 output_prefix ();
01760                 output ("cob_chain_setup (");
01761                 output_data (x);
01762                 output (", %d, %d);\n", f->param_num, f->size);
01763                 return;
01764         }
01765         /* Initialize by value */
01766         if (p->val && f->values) {
01767                 value = CB_VALUE (f->values);
01768                 if (value == cb_space) {
01769                         /* Fixme: This is to avoid an error when a
01770                            numeric-edited item has VALUE SPACE because
01771                            cob_build_move doubly checks the value.
01772                            We should instead check the value only once.  */
01773                         output_figurative (x, f, ' ');
01774                 } else if (value == cb_low) {
01775                         output_figurative (x, f, 0);
01776                 } else if (value == cb_high) {
01777                         output_figurative (x, f, 255);
01778                 } else if (value == cb_quote) {
01779                         output_figurative (x, f, '"');
01780                 } else if (value == cb_zero && f->usage == CB_USAGE_DISPLAY) {
01781                         output_figurative (x, f, '0');
01782                 } else if (value == cb_null && f->usage == CB_USAGE_DISPLAY) {
01783                         output_figurative (x, f, 0);
01784                 } else if (CB_LITERAL_P (value) && CB_LITERAL (value)->all) {
01785                         /* ALL literal */
01786                         output_initialize_literal (x, f, CB_LITERAL (value));
01787                 } else if (CB_CONST_P (value)
01788                            || CB_TREE_CLASS (value) == CB_CLASS_NUMERIC) {
01789                         /* Figurative literal, numeric literal */
01790                         output_move (value, x);
01791                 } else {
01792                         /* Alphanumeric literal */
01793                         /* We do not use output_move here because
01794                            we do not want to have the value be edited. */
01795                         l = CB_LITERAL (value);
01796                         if (!buff) {
01797                                 if (f->size <= COB_SMALL_BUFF) {
01798                                         buff = cobc_malloc (COB_SMALL_BUFF);
01799                                         lastsize = COB_SMALL_BUFF;
01800                                 } else {
01801                                         buff = cobc_malloc ((size_t)f->size);
01802                                         lastsize = f->size;
01803                                 }
01804                         } else {
01805                                 if (f->size > lastsize) {
01806                                         free (buff);
01807                                         buff = cobc_malloc ((size_t)f->size);
01808                                         lastsize = f->size;
01809                                 }
01810                         }
01811                         l = CB_LITERAL (value);
01812                         if ((int)l->size >= (int)f->size) {
01813                                 memcpy (buff, l->data, (size_t)f->size);
01814                         } else {
01815                                 memcpy (buff, l->data, l->size);
01816                                 memset (buff + l->size, ' ', f->size - l->size);
01817                         }
01818                         output_prefix ();
01819                         if (f->size == 1) {
01820                                 output ("*(unsigned char *) (");
01821                                 output_data (x);
01822                                 output (") = %d;\n", *(unsigned char *)buff);
01823                         } else {
01824                                 buffchar = *buff;
01825                                 for (i = 0; i < f->size; i++) {
01826                                         if (*(buff + i) != buffchar) {
01827                                                 break;
01828                                         }
01829                                 }
01830                                 if (i == f->size) {
01831                                         output ("memset (");
01832                                         output_data (x);
01833                                         output (", %d, %d);\n", buffchar, f->size);
01834                                 } else {
01835                                         if (f->size >= 8) {
01836                                                 buffchar = *(buff + f->size - 1);
01837                                                 n = 0;
01838                                                 for (i = f->size - 1; i >= 0; i--, n++) {
01839                                                         if (*(buff + i) != buffchar) {
01840                                                                 break;
01841                                                         }
01842                                                 }
01843                                                 if (n > 2) {
01844                                                         output ("memcpy (");
01845                                                         output_data (x);
01846                                                         output (", ");
01847                                                         output_string ((ucharptr) buff,
01848                                                                        f->size - n);
01849                                                         output (", %d);\n", f->size - n);
01850                                                         output_prefix ();
01851                                                         output ("memset (");
01852                                                         output_data (x);
01853                                                         output (" + %d, %d, %d);\n",
01854                                                                 f->size - n, buffchar, n);
01855                                                         return;
01856                                                 }
01857                                         }
01858                                         output ("memcpy (");
01859                                         output_data (x);
01860                                         output (", ");
01861                                         output_string ((ucharptr) buff, f->size);
01862                                         output (", %d);\n", f->size);
01863                                 }
01864                         }
01865                 }
01866                 return;
01867         }
01868 
01869         /* Initialize replacing */
01870         if (!f->children) {
01871                 for (lrp = p->rep; lrp; lrp = CB_CHAIN (lrp)) {
01872                         if ((int)CB_PURPOSE_INT (lrp) == (int)CB_TREE_CATEGORY (x)) {
01873                                 output_move (CB_VALUE (lrp), x);
01874                                 return;
01875                         }
01876                 }
01877         }
01878 
01879         /* Initialize by default */
01880         if (p->def) {
01881                 if (f->usage == CB_USAGE_FLOAT || f->usage == CB_USAGE_DOUBLE) {
01882                         output_initialize_fp (x, f);
01883                         return;
01884                 }
01885                 switch (CB_TREE_CATEGORY (x)) {
01886                 case CB_CATEGORY_NUMERIC:
01887                 case CB_CATEGORY_NUMERIC_EDITED:
01888                         output_move (cb_zero, x);
01889                         break;
01890                 case CB_CATEGORY_ALPHANUMERIC_EDITED:
01891                 case CB_CATEGORY_NATIONAL_EDITED:
01892                         output_move (cb_space, x);
01893                         break;
01894                 default:
01895                         fprintf (stderr, "Unexpected tree category %d\n", CB_TREE_CATEGORY (x));
01896                         ABORT ();
01897                 }
01898         }
01899 }
01900 
01901 static void
01902 output_initialize_compound (struct cb_initialize *p, cb_tree x)
01903 {
01904         struct cb_field *ff;
01905         struct cb_field *f;
01906         struct cb_field *last_field;
01907         cb_tree         c;
01908         int             type;
01909         int             last_char;
01910         int             i;
01911         size_t          size;
01912 
01913         ff = cb_field (x);
01914         for (f = ff->children; f; f = f->sister) {
01915                 type = initialize_type (p, f, 0);
01916                 c = cb_build_field_reference (f, x);
01917 
01918                 switch (type) {
01919                 case INITIALIZE_NONE:
01920                         break;
01921                 case INITIALIZE_DEFAULT:
01922                 {
01923                         last_field = f;
01924                         last_char = initialize_uniform_char (f);
01925 
01926                         if (last_char != -1) {
01927                                 if (f->flag_occurs) {
01928                                         CB_REFERENCE (c)->subs =
01929                                             cb_cons (cb_int1, CB_REFERENCE (c)->subs);
01930                                 }
01931 
01932                                 for (; f->sister; f = f->sister) {
01933                                         if (!f->sister->redefines) {
01934                                                 if (initialize_type (p, f->sister, 0) != INITIALIZE_DEFAULT
01935                                                     || initialize_uniform_char (f->sister) != last_char) {
01936                                                         break;
01937                                                 }
01938                                         }
01939                                 }
01940 
01941                                 if (f->sister) {
01942                                         size = f->sister->offset - last_field->offset;
01943                                 } else {
01944                                         size = ff->offset + ff->size - last_field->offset;
01945                                 }
01946 
01947                                 output_initialize_uniform (c, last_char, (int) size);
01948                                 break;
01949                         }
01950                         /* Fall through */
01951                 }
01952                 default:
01953                         if (f->flag_occurs) {
01954                                 /* Begin occurs loop */
01955                                 i = f->indexes;
01956                                 i_counters[i] = 1;
01957                                 output_line ("for (i%d = 1; i%d <= %d; i%d++)",
01958                                              i, i, f->occurs_max, i);
01959                                 output_indent ("  {");
01960                                 CB_REFERENCE (c)->subs =
01961                                     cb_cons (cb_i[i], CB_REFERENCE (c)->subs);
01962                         }
01963 
01964                         if (type == INITIALIZE_ONE) {
01965                                 output_initialize_one (p, c);
01966                         } else {
01967                                 output_initialize_compound (p, c);
01968                         }
01969 
01970                         if (f->flag_occurs) {
01971                                 /* Close loop */
01972                                 CB_REFERENCE (c)->subs = CB_CHAIN (CB_REFERENCE (c)->subs);
01973                                 output_indent ("  }");
01974                         }
01975                 }
01976         }
01977 }
01978 
01979 static void
01980 output_initialize (struct cb_initialize *p)
01981 {
01982         struct cb_field *f;
01983         int             c;
01984 
01985         f = cb_field (p->var);
01986         switch (initialize_type (p, f, 1)) {
01987         case INITIALIZE_NONE:
01988                 break;
01989         case INITIALIZE_ONE:
01990                 output_initialize_one (p, p->var);
01991                 break;
01992         case INITIALIZE_EXTERNAL:
01993                 output_initialize_external (p->var, f);
01994                 break;
01995         case INITIALIZE_DEFAULT:
01996                 c = initialize_uniform_char (f);
01997                 if (c != -1) {
01998                         output_initialize_uniform (p->var, c, f->size);
01999                 } else {
02000                         output_initialize_compound (p, p->var);
02001                 }
02002                 break;
02003         case INITIALIZE_COMPOUND:
02004                 output_initialize_compound (p, p->var);
02005                 break;
02006         }
02007 }
02008 
02009 /*
02010  * SEARCH
02011  */
02012 
02013 static void
02014 output_occurs (struct cb_field *p)
02015 {
02016         if (p->occurs_depending) {
02017                 output_integer (p->occurs_depending);
02018         } else {
02019                 output ("%d", p->occurs_max);
02020         }
02021 }
02022 
02023 static void
02024 output_search_whens (cb_tree table, cb_tree var, cb_tree stmt, cb_tree whens)
02025 {
02026         cb_tree         l;
02027         struct cb_field *p;
02028         cb_tree         idx = NULL;
02029 
02030         p = cb_field (table);
02031         /* Determine the index to use */
02032         if (var) {
02033                 for (l = p->index_list; l; l = CB_CHAIN (l)) {
02034                         if (cb_ref (CB_VALUE (l)) == cb_ref (var)) {
02035                                 idx = var;
02036                         }
02037                 }
02038         }
02039         if (!idx) {
02040                 idx = CB_VALUE (p->index_list);
02041         }
02042 
02043         /* Start loop */
02044         output_line ("while (1)");
02045         output_indent ("  {");
02046 
02047         /* End test */
02048         output_prefix ();
02049         output ("if (");
02050         output_integer (idx);
02051         output (" > ");
02052         output_occurs (p);
02053         output (")\n");
02054         output_indent ("  {");
02055         if (stmt) {
02056                 output_stmt (stmt);
02057         }
02058         output_line ("break;");
02059         output_indent ("  }");
02060 
02061         /* WHEN test */
02062         output_stmt (whens);
02063         output_line ("else");
02064         output_indent ("  {");
02065         output_prefix ();
02066         output_integer (idx);
02067         output ("++;\n");
02068         if (var && var != idx) {
02069                 output_move (idx, var);
02070         }
02071         output_line ("continue;");
02072         output_indent ("  }");
02073         output_line ("break;");
02074         output_indent ("  }");
02075 }
02076 
02077 static void
02078 output_search_all (cb_tree table, cb_tree stmt, cb_tree cond, cb_tree when)
02079 {
02080         struct cb_field *p;
02081         cb_tree         idx;
02082 
02083         p = cb_field (table);
02084         idx = CB_VALUE (p->index_list);
02085         /* Header */
02086         output_indent ("{");
02087         output_line ("int ret;");
02088         output_line ("int head = %d - 1;", p->occurs_min);
02089         output_prefix ();
02090         output ("int tail = ");
02091         output_occurs (p);
02092         output (" + 1;\n");
02093 
02094         /* Start loop */
02095         output_line ("while (1)");
02096         output_indent ("  {");
02097 
02098         /* End test */
02099         output_line ("if (head >= tail - 1)");
02100         output_indent ("  {");
02101         if (stmt) {
02102                 output_stmt (stmt);
02103         }
02104         output_line ("break;");
02105         output_indent ("  }");
02106 
02107         /* Next index */
02108         output_prefix ();
02109         output_integer (idx);
02110         output (" = (head + tail) / 2;\n");
02111 
02112         /* WHEN test */
02113         output_prefix ();
02114         output ("if (");
02115         output_cond (cond, 1);
02116         output (")\n");
02117         output_indent_level += 2;
02118         output_stmt (when);
02119         output_indent_level -= 2;
02120         output_line ("else");
02121         output_indent ("  {");
02122         output_line ("if (ret < 0)");
02123         output_prefix ();
02124         output ("  head = ");
02125         output_integer (idx);
02126         output (";\n");
02127         output_line ("else");
02128         output_prefix ();
02129         output ("  tail = ");
02130         output_integer (idx);
02131         output (";\n");
02132         output_line ("continue;");
02133         output_indent ("  }");
02134         output_line ("break;");
02135         output_indent ("  }");
02136         output_indent ("}");
02137 }
02138 
02139 static void
02140 output_search (struct cb_search *p)
02141 {
02142         if (p->flag_all) {
02143                 output_search_all (p->table, p->end_stmt,
02144                                    CB_IF (p->whens)->test, CB_IF (p->whens)->stmt1);
02145         } else {
02146                 output_search_whens (p->table, p->var, p->end_stmt, p->whens);
02147         }
02148 }
02149 
02150 /*
02151  * CALL
02152  */
02153 
02154 static void
02155 output_call (struct cb_call *p)
02156 {
02157         cb_tree                 x;
02158         cb_tree                 l;
02159         struct cb_literal       *lp;
02160         char                    *callp;
02161         struct cb_field         *f;
02162         char                    *system_call = NULL;
02163         struct system_table     *psyst;
02164         size_t                  n;
02165         size_t                  parmnum;
02166         size_t                  retptr;
02167         int                     dynamic_link = 1;
02168         int                     sizes;
02169 
02170         retptr = 0;
02171         if (p->returning && CB_TREE_CLASS(p->returning) == CB_CLASS_POINTER) {
02172                 retptr = 1;
02173         }
02174         /* System routine entry points */
02175         if (p->is_system) {
02176                 lp = CB_LITERAL (p->name);
02177                 psyst = (struct system_table *)&system_tab[0];
02178                 for (; psyst->syst_name; psyst++) {
02179                         if (!strcmp((const char *)lp->data,
02180                             (const char *)psyst->syst_name)) {
02181                                 system_call = (char *)psyst->syst_call;
02182                                 dynamic_link = 0;
02183                                 break;
02184                         }
02185                 }
02186         }
02187 
02188         if (cb_flag_static_call && CB_LITERAL_P (p->name)) {
02189                 dynamic_link = 0;
02190         }
02191 
02192         /* Local variables */
02193         output_indent ("{");
02194 #ifdef  COB_NON_ALIGNED
02195         if (dynamic_link && retptr) {
02196                 output_line ("void *temptr;");
02197         }
02198 #endif
02199 
02200         if (CB_REFERENCE_P (p->name)
02201             && CB_FIELD_P (CB_REFERENCE (p->name)->value)
02202             && CB_FIELD (CB_REFERENCE (p->name)->value)->usage == CB_USAGE_PROGRAM_POINTER) {
02203                 dynamic_link = 0;
02204         }
02205 
02206         /* Setup arguments */
02207         for (l = p->args, n = 1; l; l = CB_CHAIN (l), n++) {
02208                 x = CB_VALUE (l);
02209                 switch (CB_PURPOSE_INT (l)) {
02210                 case CB_CALL_BY_REFERENCE:
02211                         if (CB_NUMERIC_LITERAL_P (x) || CB_BINARY_OP_P (x)) {
02212                                 output_line ("union {");
02213                                 output_line ("\tunsigned char data[8];");
02214                                 output_line ("\tlong long     datall;");
02215                                 output_line ("\tint           dataint;");
02216                                 output_line ("} content_%d;", (int)n);
02217                         } else if (CB_CAST_P (x)) {
02218                                 output_line ("void *ptr_%d;", (int)n);
02219                         }
02220                         break;
02221                 case CB_CALL_BY_CONTENT:
02222                         if (CB_CAST_P (x)) {
02223                                 output_line ("void *ptr_%d;", (int)n);
02224                         } else if (CB_TREE_TAG (x) != CB_TAG_INTRINSIC &&
02225                             x != cb_null && !(CB_CAST_P (x))) {
02226                                 output_line ("union {");
02227                                 output ("\tunsigned char data[");
02228                                 if (CB_NUMERIC_LITERAL_P (x) ||
02229                                     CB_BINARY_OP_P (x) || CB_CAST_P(x)) {
02230                                         output ("8");
02231                                 } else {
02232                                         if (CB_REF_OR_FIELD_P (x)) {
02233                                                 output ("%d", (int)cb_field (x)->size);
02234                                         } else {
02235                                                 output_size (x);
02236                                         }
02237                                 }
02238                                 output ("];\n");
02239                                 output_line ("\tlong long     datall;");
02240                                 output_line ("\tint           dataint;");
02241                                 output_line ("} content_%d;", (int)n);
02242                         }
02243                         break;
02244                 }
02245         }
02246         output ("\n");
02247         for (l = p->args, n = 1; l; l = CB_CHAIN (l), n++) {
02248                 x = CB_VALUE (l);
02249                 switch (CB_PURPOSE_INT (l)) {
02250                 case CB_CALL_BY_REFERENCE:
02251                         if (CB_NUMERIC_LITERAL_P (x)) {
02252                                 output_prefix ();
02253                                 if (cb_fits_int (x)) {
02254                                         output ("content_%d.dataint = ", (int)n);
02255                                         output ("%d", cb_get_int (x));
02256                                 } else {
02257                                         output ("content_%d.datall = ", (int)n);
02258                                         output ("%lldLL", cb_get_long_long (x));
02259                                 }
02260                                 output (";\n");
02261                         } else if (CB_BINARY_OP_P (x)) {
02262                                 output_prefix ();
02263                                 output ("content_%d.dataint = ", (int)n);
02264                                 output_integer (x);
02265                                 output (";\n");
02266                         } else if (CB_CAST_P (x)) {
02267                                 output_prefix ();
02268                                 output ("ptr_%d = ", (int)n);
02269                                 output_integer (x);
02270                                 output (";\n");
02271                         }
02272                         break;
02273                 case CB_CALL_BY_CONTENT:
02274                         if (CB_CAST_P (x)) {
02275                                 output_prefix ();
02276                                 output ("ptr_%d = ", (int)n);
02277                                 output_integer (x);
02278                                 output (";\n");
02279                         } else if (CB_TREE_TAG (x) != CB_TAG_INTRINSIC) {
02280                                 if (CB_NUMERIC_LITERAL_P (x)) {
02281                                         output_prefix ();
02282                                         if (cb_fits_int (x)) {
02283                                                 output ("content_%d.dataint = ", (int)n);
02284                                                 output ("%d", cb_get_int (x));
02285                                         } else {
02286                                                 output ("content_%d.datall = ", (int)n);
02287                                                 output ("%lldLL", cb_get_long_long (x));
02288                                         }
02289                                         output (";\n");
02290                                 } else if (CB_REF_OR_FIELD_P (x) &&
02291                                            CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC &&
02292                                            cb_field (x)->usage == CB_USAGE_LENGTH) {
02293                                         output_prefix ();
02294                                         output ("content_%d.dataint = ", (int)n);
02295                                         output_integer (x);
02296                                         output (";\n");
02297                                 } else if (x != cb_null && !(CB_CAST_P (x))) {
02298                                         output_prefix ();
02299                                         output ("memcpy (content_%d.data, ", (int)n);
02300                                         output_data (x);
02301                                         output (", ");
02302                                         output_size (x);
02303                                         output (");\n");
02304                                 }
02305                         }
02306                         break;
02307                 }
02308         }
02309 
02310         /* Function name */
02311         n = 0;
02312         for (l = p->args; l; l = CB_CHAIN (l), n++) {
02313                 x = CB_VALUE (l);
02314                 field_iteration = (int) n;
02315                 output_prefix ();
02316                 output ("module.cob_procedure_parameters[%d] = ", (int)n);
02317                 switch (CB_TREE_TAG (x)) {
02318                 case CB_TAG_LITERAL:
02319                 case CB_TAG_FIELD:
02320                 case CB_TAG_INTRINSIC:
02321                         output_param (x, -1);
02322                         break;
02323                 case CB_TAG_REFERENCE:
02324                         switch (CB_TREE_TAG (CB_REFERENCE(x)->value)) {
02325                         case CB_TAG_LITERAL:
02326                         case CB_TAG_FIELD:
02327                         case CB_TAG_INTRINSIC:
02328                                 output_param (x, -1);
02329                                 break;
02330                         default:
02331                                 output ("NULL");
02332                                 break;
02333                         }
02334                         break;
02335                 default:
02336                         output ("NULL");
02337                         break;
02338                 }
02339                 output (";\n");
02340         }
02341         for (parmnum = n; parmnum < n + 4; parmnum++) {
02342                 output_line ("module.cob_procedure_parameters[%d] = NULL;", (int)parmnum);
02343         }
02344         parmnum = n;
02345         output_prefix ();
02346         output ("cob_call_params = %d;\n", (int)n);
02347         output_prefix ();
02348         if (!dynamic_link) {
02349                 if (CB_REFERENCE_P (p->name) &&
02350                     CB_FIELD_P (CB_REFERENCE (p->name)->value) &&
02351                     CB_FIELD (CB_REFERENCE (p->name)->value)->usage ==
02352                     CB_USAGE_PROGRAM_POINTER) {
02353                         output ("cob_unifunc.func_void = ");
02354                         output_integer (p->name);
02355                         output (";\n");
02356                         output_prefix ();
02357                         if (retptr) {
02358 #ifdef  COB_NON_ALIGNED
02359                                 output ("temptr");
02360 #else
02361                                 output_integer (p->returning);
02362 #endif
02363                                 output (" = cob_unifunc.funcptr");
02364                         } else {
02365                                 output_integer (current_prog->cb_return_code);
02366                                 output (" = cob_unifunc.funcint");
02367                         }
02368                 } else {
02369                         /* Static link */
02370                         if (retptr) {
02371 #ifdef  COB_NON_ALIGNED
02372                                 output ("temptr");
02373 #else
02374                                 output_integer (p->returning);
02375 #endif
02376                         } else {
02377                                 output_integer (current_prog->cb_return_code);
02378                         }
02379                         output (" = ");
02380                         if (retptr) {
02381                                 output ("(void *)");
02382                         }
02383                         if (system_call) {
02384                                 output ("%s", system_call);
02385                         } else {
02386                                 output ("%s",
02387                                         cb_encode_program_id ((char *)(CB_LITERAL (p->name)->data)));
02388                         }
02389                 }
02390         } else {
02391                 /* Dynamic link */
02392                 if (CB_LITERAL_P (p->name)) {
02393                         callp = cb_encode_program_id ((char *)(CB_LITERAL (p->name)->data));
02394                         lookup_call (callp);
02395                         output ("if (unlikely(call_%s.func_void == NULL)) {\n", callp);
02396                         output_prefix ();
02397                         output ("  call_%s.func_void = ", callp);
02398                         if (!p->stmt1) {
02399                                 output ("cob_resolve_1 ((const char *)\"%s\");\n",
02400                                          (char *)(CB_LITERAL (p->name)->data));
02401                         } else {
02402                                 output ("cob_resolve ((const char *)\"%s\");\n",
02403                                          (char *)(CB_LITERAL (p->name)->data));
02404                         }
02405                         output_prefix ();
02406                         output ("}\n");
02407                 } else {
02408                         callp = NULL;
02409                         output ("cob_unifunc.func_void = ");
02410                         if (!p->stmt1) {
02411                                 output_funcall (cb_build_funcall_1 (
02412                                                 "cob_call_resolve_1", p->name));
02413                         } else {
02414                                 output_funcall (cb_build_funcall_1 (
02415                                                 "cob_call_resolve", p->name));
02416                         }
02417                         output (";\n");
02418                 }
02419                 if (p->stmt1) {
02420                         if (callp) {
02421                                 output_line ("if (unlikely(call_%s.func_void == NULL))", callp);
02422                         } else {
02423                                 output_line ("if (unlikely(cob_unifunc.func_void == NULL))");
02424                         }
02425                         output_indent_level += 2;
02426                         output_stmt (p->stmt1);
02427                         output_indent_level -= 2;
02428                         output_line ("else");
02429                         output_indent ("  {");
02430                 }
02431                 output_prefix ();
02432                 if (retptr) {
02433 #ifdef  COB_NON_ALIGNED
02434                         output ("temptr");
02435 #else
02436                         output_integer (p->returning);
02437 #endif
02438                         if (callp) {
02439                                 output (" = call_%s.funcptr", callp);
02440                         } else {
02441                                 output (" = cob_unifunc.funcptr");
02442                         }
02443                 } else {
02444                         output_integer (current_prog->cb_return_code);
02445                         if (callp) {
02446                                 output (" = call_%s.funcint", callp);
02447                         } else {
02448                                 output (" = cob_unifunc.funcint");
02449                         }
02450                 }
02451         }
02452 
02453         /* Arguments */
02454         output (" (");
02455         for (l = p->args, n = 1; l; l = CB_CHAIN (l), n++) {
02456                 x = CB_VALUE (l);
02457                 switch (CB_PURPOSE_INT (l)) {
02458                 case CB_CALL_BY_REFERENCE:
02459                         if (CB_NUMERIC_LITERAL_P (x) || CB_BINARY_OP_P (x)) {
02460                                 output ("content_%d.data", (int)n);
02461                         } else if (CB_REFERENCE_P (x) && CB_FILE_P (cb_ref (x))) {
02462                                 output_param (cb_ref (x), -1);
02463                         } else if (CB_CAST_P (x)) {
02464                                 output ("&ptr_%d", (int)n);
02465                         } else {
02466                                 output_data (x);
02467                         }
02468                         break;
02469                 case CB_CALL_BY_CONTENT:
02470                         if (CB_TREE_TAG (x) != CB_TAG_INTRINSIC && x != cb_null) {
02471                                 if (CB_CAST_P (x)) {
02472                                         output ("&ptr_%d", (int)n);
02473                                 } else {
02474                                         output ("content_%d.data", (int)n);
02475                                 }
02476                         } else {
02477                                 output_data (x);
02478                         }
02479                         break;
02480                 case CB_CALL_BY_VALUE:
02481                         if (CB_TREE_TAG (x) != CB_TAG_INTRINSIC) {
02482                                 switch (CB_TREE_TAG (x)) {
02483                                 case CB_TAG_CAST:
02484                                         output_integer (x);
02485                                         break;
02486                                 case CB_TAG_LITERAL:
02487                                         if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
02488                                                 output ("%d", cb_get_int (x));
02489                                         } else {
02490                                                 output ("%d", CB_LITERAL (x)->data[0]);
02491                                         }
02492                                         break;
02493                                 default:
02494 /* RXWRXW
02495                                         if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
02496                                                 output_integer (x);
02497                                         } else {
02498                                                 output ("*(");
02499                                                 output_data (x);
02500                                                 output (")");
02501                                         }
02502 */
02503                                         f = cb_field (x);
02504                                         switch (f->usage) {
02505                                         case CB_USAGE_BINARY:
02506                                         case CB_USAGE_COMP_5:
02507                                         case CB_USAGE_COMP_X:
02508                                         /* RXWRXW */
02509                                         case CB_USAGE_PACKED:
02510                                         case CB_USAGE_DISPLAY:
02511                                                 sizes = CB_SIZES_INT (l);
02512                                                 if (sizes == CB_SIZE_AUTO) {
02513                                                         if (f->pic->have_sign) {
02514                                                                 output ("(unsigned ");
02515                                                         } else {
02516                                                                 output ("(");
02517                                                         }
02518                                                         if (f->usage == CB_USAGE_PACKED ||
02519                                                             f->usage == CB_USAGE_DISPLAY) {
02520                                                                 sizes = f->pic->digits - f->pic->scale;
02521                                                         } else {
02522                                                                 sizes = f->size;
02523                                                         }
02524                                                         switch (sizes) {
02525                                                         case 0:
02526                                                                 sizes = CB_SIZE_4;
02527                                                                 break;
02528                                                         case 1:
02529                                                                 sizes = CB_SIZE_1;
02530                                                                 break;
02531                                                         case 2:
02532                                                                 sizes = CB_SIZE_2;
02533                                                                 break;
02534                                                         case 3:
02535                                                                 sizes = CB_SIZE_4;
02536                                                                 break;
02537                                                         case 4:
02538                                                                 sizes = CB_SIZE_4;
02539                                                                 break;
02540                                                         case 5:
02541                                                                 sizes = CB_SIZE_8;
02542                                                                 break;
02543                                                         case 6:
02544                                                                 sizes = CB_SIZE_8;
02545                                                                 break;
02546                                                         case 7:
02547                                                                 sizes = CB_SIZE_8;
02548                                                                 break;
02549                                                         default:
02550                                                                 sizes = CB_SIZE_8;
02551                                                                 break;
02552                                                         }
02553                                                 } else {
02554                                                         if (CB_SIZES_INT_UNSIGNED(l)) {
02555                                                                 output ("(unsigned ");
02556                                                         } else {
02557                                                                 output ("(");
02558                                                         }
02559                                                 }
02560                                                 switch (sizes) {
02561                                                 case CB_SIZE_1:
02562                                                         output ("char");
02563                                                         break;
02564                                                 case CB_SIZE_2:
02565                                                         output ("short");
02566                                                         break;
02567                                                 case CB_SIZE_4:
02568                                                         output ("int");
02569                                                         break;
02570                                                 case CB_SIZE_8:
02571                                                         output ("long long");
02572                                                         break;
02573                                                 default:
02574                                                         output ("int");
02575                                                         break;
02576                                                 }
02577                                                 output (")(");
02578                                                 output_integer (x);
02579                                                 output (")");
02580                                                 break;
02581                                         case CB_USAGE_INDEX:
02582                                         case CB_USAGE_LENGTH:
02583                                         case CB_USAGE_POINTER:
02584                                         case CB_USAGE_PROGRAM_POINTER:
02585                                                 output_integer (x);
02586                                                 break;
02587                                         default:
02588                                                 output ("*(");
02589                                                 output_data (x);
02590                                                 output (")");
02591                                                 break;
02592                                         }
02593                                         break;
02594                                 }
02595                         } else {
02596                                 output_data (x);
02597                         }
02598                         break;
02599                 }
02600                 if (CB_CHAIN (l)) {
02601                         output (", ");
02602                 }
02603         }
02604         if (!system_call) {
02605                 if (cb_sticky_linkage || cb_flag_null_param) {
02606                         for (n = 0; n < 4; n++) {
02607                                 if (n != 0 || parmnum != 0) {
02608                                         output (", ");
02609                                 }
02610                                 output ("NULL");
02611                         }
02612                 }
02613         }
02614         output (");\n");
02615         if (p->returning) {
02616                 if (!retptr) {
02617                         /* suppress warnings */
02618                         suppress_warn = 1;
02619                         output_stmt (cb_build_move (current_prog->cb_return_code,
02620                                                     p->returning));
02621                         suppress_warn = 0;
02622 #ifdef  COB_NON_ALIGNED
02623                 } else {
02624                         output_prefix ();
02625                         output ("memcpy (");
02626                         output_data (p->returning);
02627                         output (", &temptr, %d);\n", sizeof (void *));
02628 #endif
02629                 }
02630         }
02631         if (p->stmt2) {
02632                 output_stmt (p->stmt2);
02633         }
02634         if (dynamic_link && p->stmt1) {
02635                 output_indent ("  }");
02636         }
02637         output_indent ("}");
02638 }
02639 
02640 /*
02641  * GO TO
02642  */
02643 
02644 static void
02645 output_goto_1 (cb_tree x)
02646 {
02647         output_line ("goto %s%d;", CB_PREFIX_LABEL, CB_LABEL (cb_ref (x))->id);
02648 }
02649 
02650 static void
02651 output_goto (struct cb_goto *p)
02652 {
02653         cb_tree l;
02654         int     i = 1;
02655 
02656         if (p->depending) {
02657                 output_prefix ();
02658                 output ("switch (");
02659                 output_param (cb_build_cast_integer (p->depending), 0);
02660                 output (")\n");
02661                 output_indent ("  {");
02662                 for (l = p->target; l; l = CB_CHAIN (l)) {
02663                         output_indent_level -= 2;
02664                         output_line ("case %d:", i++);
02665                         output_indent_level += 2;
02666                         output_goto_1 (CB_VALUE (l));
02667                 }
02668                 output_indent ("  }");
02669         } else if (p->target == NULL) {
02670                 needs_exit_prog = 1;
02671                 if (cb_flag_implicit_init) {
02672                         output_line ("goto exit_program;");
02673                 } else {
02674                         output_line ("if (module.next)");
02675                         output_line ("  goto exit_program;");
02676                 }
02677         } else if (p->target == cb_int1) {
02678                 needs_exit_prog = 1;
02679                 output_line ("goto exit_program;");
02680         } else {
02681                 output_goto_1 (p->target);
02682         }
02683 }
02684 
02685 /*
02686  * PERFORM
02687  */
02688 
02689 static void
02690 output_perform_call (struct cb_label *lb, struct cb_label *le)
02691 {
02692 #ifndef __GNUC__
02693         struct label_list *l;
02694 #endif
02695 
02696         if (lb == le) {
02697                 output_line ("/* PERFORM %s */", lb->name);
02698         } else {
02699                 output_line ("/* PERFORM %s THRU %s */", lb->name, le->name);
02700         }
02701         output_line ("frame_ptr++;");
02702         if (cb_flag_stack_check) {
02703                 output_line ("if (unlikely(frame_ptr == frame_overflow))");
02704                 output_line ("    cob_fatal_error (COB_FERROR_STACK);");
02705         }
02706         output_line ("frame_ptr->perform_through = %d;", le->id);
02707 #ifndef __GNUC__
02708         l = cobc_malloc (sizeof (struct label_list));
02709         l->next = label_cache;
02710         l->id = cb_id;
02711         if (label_cache == NULL) {
02712                 l->call_num = 0;
02713         } else {
02714                 l->call_num = label_cache->call_num + 1;
02715         }
02716         label_cache = l;
02717         output_line ("frame_ptr->return_address = %d;", l->call_num);
02718         output_line ("goto %s%d;", CB_PREFIX_LABEL, lb->id);
02719         output_line ("%s%d:", CB_PREFIX_LABEL, cb_id);
02720 #elif   COB_USE_SETJMP
02721         output_line ("if (setjmp (frame_ptr->return_address) == 0)");
02722         output_line ("  goto %s%d;", CB_PREFIX_LABEL, lb->id);
02723 #else
02724         output_line ("frame_ptr->return_address = &&%s%d;",
02725                      CB_PREFIX_LABEL, cb_id);
02726         output_line ("goto %s%d;", CB_PREFIX_LABEL, lb->id);
02727         output_line ("%s%d:", CB_PREFIX_LABEL, cb_id);
02728 #endif
02729         cb_id++;
02730         output_line ("frame_ptr--;");
02731 }
02732 
02733 static void
02734 output_perform_exit (struct cb_label *l)
02735 {
02736         if (l->is_global) {
02737                 output_newline ();
02738                 output_line ("if (entry == %d) {", l->id);
02739                 if (cb_flag_traceall) {
02740                         output_line ("  cob_reset_trace ();");
02741                 }
02742                 /* Fixme - Check module push/pop */
02743                 output_line ("  cob_current_module = cob_current_module->next;");
02744                 output_line ("  return 0;");
02745                 output_line ("}");
02746         }
02747         output_newline ();
02748         output_line ("if (frame_ptr->perform_through == %d)", l->id);
02749 #ifndef __GNUC__
02750         output_line ("  goto P_switch;");
02751 #elif   COB_USE_SETJMP
02752         output_line ("  longjmp (frame_ptr->return_address, 1);");
02753 #else
02754         output_line ("  goto *frame_ptr->return_address;");
02755 #endif
02756         if (cb_perform_osvs) {
02757                 output_line
02758                     ("for (temp_index = frame_ptr - 1; temp_index->perform_through; temp_index--) {");
02759                 output_line ("  if (temp_index->perform_through == %d) {", l->id);
02760                 output_line ("    frame_ptr = temp_index;");
02761 #ifndef __GNUC__
02762                 output_line ("    goto P_switch;");
02763 #elif   COB_USE_SETJMP
02764                 output_line ("    longjmp (frame_ptr->return_address, 1);");
02765 #else
02766                 output_line ("    goto *frame_ptr->return_address;");
02767 #endif
02768                 output_line ("  }");
02769                 output_line ("}");
02770         }
02771 }
02772 
02773 static void
02774 output_perform_once (struct cb_perform *p)
02775 {
02776         if (p->body && CB_PAIR_P (p->body)) {
02777                 output_perform_call (CB_LABEL (cb_ref (CB_PAIR_X (p->body))),
02778                                      CB_LABEL (cb_ref (CB_PAIR_Y (p->body))));
02779         } else {
02780                 output_stmt (p->body);
02781         }
02782         if (p->cycle_label) {
02783                 output_stmt (cb_ref (p->cycle_label));
02784         }
02785 }
02786 
02787 static void
02788 output_perform_until (struct cb_perform *p, cb_tree l)
02789 {
02790         struct cb_perform_varying       *v;
02791         cb_tree                         next;
02792 
02793         if (l == NULL) {
02794                 /* Perform body at the end */
02795                 output_perform_once (p);
02796                 return;
02797         }
02798 
02799         v = CB_PERFORM_VARYING (CB_VALUE (l));
02800         next = CB_CHAIN (l);
02801 
02802         output_line ("while (1)");
02803         output_indent ("  {");
02804 
02805         if (next && CB_PERFORM_VARYING (CB_VALUE (next))->name) {
02806                 output_move (CB_PERFORM_VARYING (CB_VALUE (next))->from,
02807                              CB_PERFORM_VARYING (CB_VALUE (next))->name);
02808         }
02809 
02810         if (p->test == CB_AFTER) {
02811                 output_perform_until (p, next);
02812         }
02813 
02814         output_prefix ();
02815         output ("if (");
02816         output_cond (v->until, 0);
02817         output (")\n");
02818         output_line ("  break;");
02819 
02820         if (p->test == CB_BEFORE) {
02821                 output_perform_until (p, next);
02822         }
02823 
02824         if (v->step) {
02825                 output_stmt (v->step);
02826         }
02827 
02828         output_indent ("  }");
02829 }
02830 
02831 static void
02832 output_perform (struct cb_perform *p)
02833 {
02834         struct cb_perform_varying *v;
02835 
02836         switch (p->type) {
02837         case CB_PERFORM_EXIT:
02838                 if (CB_LABEL (p->data)->need_return) {
02839                         output_perform_exit (CB_LABEL (p->data));
02840                 }
02841                 break;
02842         case CB_PERFORM_ONCE:
02843                 output_perform_once (p);
02844                 break;
02845         case CB_PERFORM_TIMES:
02846                 output_prefix ();
02847                 output ("for (n%d = ", loop_counter);
02848                 output_param (cb_build_cast_integer (p->data), 0);
02849                 output ("; n%d > 0; n%d--)\n", loop_counter, loop_counter);
02850                 loop_counter++;
02851                 output_indent ("  {");
02852                 output_perform_once (p);
02853                 output_indent ("  }");
02854                 break;
02855         case CB_PERFORM_UNTIL:
02856                 v = CB_PERFORM_VARYING (CB_VALUE (p->varying));
02857                 if (v->name) {
02858                         output_move (v->from, v->name);
02859                 }
02860                 output_perform_until (p, p->varying);
02861                 break;
02862         case CB_PERFORM_FOREVER:
02863                 output_prefix ();
02864                 output ("while (1)\n");
02865                 output_indent ("  {");
02866                 output_perform_once (p);
02867                 output_indent ("  }");
02868                 break;
02869         }
02870         if (p->exit_label) {
02871                 output_stmt (cb_ref (p->exit_label));
02872         }
02873 }
02874 
02875 static void
02876 output_file_error (struct cb_file *pfile)
02877 {
02878         struct cb_file          *fl;
02879         cb_tree                 l;
02880 
02881         for (l =  current_prog->local_file_list; l; l = CB_CHAIN (l)) {
02882                 fl = CB_FILE(CB_VALUE (l));
02883                 if (!strcmp (pfile->name, fl->name)) {
02884                         output_perform_call (fl->handler,
02885                                              fl->handler);
02886                         return;
02887                 }
02888         }
02889         for (l =  current_prog->global_file_list; l; l = CB_CHAIN (l)) {
02890                 fl = CB_FILE(CB_VALUE (l));
02891                 if (!strcmp (pfile->name, fl->name)) {
02892                         if (fl->handler_prog == current_prog) {
02893                                 output_perform_call (fl->handler,
02894                                                      fl->handler);
02895                         } else {
02896                                 if (cb_flag_traceall) {
02897                                         output_line ("cob_reset_trace ();");
02898                                 }
02899                                 output_line ("%s_ (%d);",
02900                                         fl->handler_prog->program_id,
02901                                         fl->handler->id);
02902                                 if (cb_flag_traceall) {
02903                                         output_line ("cob_ready_trace ();");
02904                                 }
02905                         }
02906                         return;
02907                 }
02908         }
02909         output_perform_call (pfile->handler, pfile->handler);
02910 }
02911 
02912 /*
02913  * Output statement
02914  */
02915 
02916 static void
02917 output_ferror_stmt (struct cb_statement *p, int code)
02918 {
02919         output_line ("if (unlikely(cob_exception_code != 0))");
02920         output_indent ("  {");
02921         if (p->handler1) {
02922                 if ((code & 0x00ff) == 0) {
02923                         output_line ("if ((cob_exception_code & 0xff00) == 0x%04x)",
02924                              code);
02925                 } else {
02926                         output_line ("if (cob_exception_code == 0x%04x)", code);
02927                 }
02928                 output_indent ("  {");
02929                 output_stmt (p->handler1);
02930                 output_indent ("  }");
02931                 output_line ("else");
02932                 output_indent ("  {");
02933         }
02934         output_file_error (CB_FILE (p->file));
02935         output_indent ("  }");
02936         if (p->handler1) {
02937                 output_indent ("  }");
02938         }
02939         if (p->handler2 || p->handler3) {
02940                 output_line ("else");
02941                 output_indent ("  {");
02942                 if (p->handler3) {
02943                         output_stmt (p->handler3);
02944                 }
02945                 if (p->handler2) {
02946                         output_stmt (p->handler2);
02947                 }
02948                 output_indent ("  }");
02949         }
02950 }
02951 
02952 static void
02953 output_stmt (cb_tree x)
02954 {
02955         struct cb_statement     *p;
02956         struct cb_label         *lp;
02957         struct cb_assign        *ap;
02958         struct cb_if            *ip;
02959 #ifdef  COB_NON_ALIGNED
02960         struct cb_cast          *cp;
02961 #endif
02962         int                     code;
02963 
02964         stack_id = 0;
02965         if (x == NULL) {
02966                 output_line (";");
02967                 return;
02968         }
02969 #ifndef __GNUC__
02970         if (inside_check != 0) {
02971                 if (inside_stack[inside_check - 1] != 0) {
02972                         inside_stack[inside_check -1] = 0;
02973                         output (",\n");
02974                 }
02975         }
02976 #endif
02977 
02978         switch (CB_TREE_TAG (x)) {
02979         case CB_TAG_STATEMENT:
02980                 p = CB_STATEMENT (x);
02981                 /* Output source location as a comment */
02982                 if (p->name) {
02983                         output_line ("/* %s:%d: %s */",
02984                                      x->source_file, x->source_line, p->name);
02985                 }
02986                 /* Output source location as a code */
02987                 if (x->source_file && last_line != x->source_line) {
02988                         if (cb_flag_source_location) {
02989                                 output_prefix ();
02990                                 output ("cob_set_location (\"%s\", \"%s\", %d, ",
02991                                         excp_current_program_id, x->source_file,
02992                                         x->source_line);
02993                                 if (excp_current_section) {
02994                                         output ("\"%s\", ", excp_current_section);
02995                                 } else {
02996                                         output ("NULL, ");
02997                                 }
02998                                 if (excp_current_paragraph) {
02999                                         output ("\"%s\", ", excp_current_paragraph);
03000                                 } else {
03001                                         output ("NULL, ");
03002                                 }
03003                                 if (p->name) {
03004                                         output ("\"%s\");\n", p->name);
03005                                 } else {
03006                                         output ("NULL);\n");
03007                                 }
03008                         }
03009                         last_line = x->source_line;
03010                 }
03011 
03012                 if (p->handler1 || p->handler2 || (p->file && CB_EXCEPTION_ENABLE (COB_EC_I_O))) {
03013 
03014                         output_line ("cob_exception_code = 0;");
03015                 }
03016 
03017                 if (p->null_check) {
03018                         output_stmt (p->null_check);
03019                 }
03020 
03021                 if (p->body) {
03022                         output_stmt (p->body);
03023                 }
03024 
03025                 if (p->handler1 || p->handler2 || (p->file && CB_EXCEPTION_ENABLE (COB_EC_I_O))) {
03026                         code = CB_EXCEPTION_CODE (p->handler_id);
03027                         if (p->file) {
03028                                 output_ferror_stmt (p, code);
03029                         } else {
03030                                 if (p->handler1) {
03031                                         if ((code & 0x00ff) == 0) {
03032                                                 output_line ("if (unlikely((cob_exception_code & 0xff00) == 0x%04x))",
03033                                                      code);
03034                                         } else {
03035                                                 output_line ("if (unlikely(cob_exception_code == 0x%04x))", code);
03036                                         }
03037                                         output_indent ("  {");
03038                                         output_stmt (p->handler1);
03039                                         output_indent ("  }");
03040                                         if (p->handler2) {
03041                                                 output_line ("else");
03042                                         }
03043                                 }
03044                                 if (p->handler2) {
03045                                         if (p->handler1 == NULL) {
03046                                                 output_line ("if (!cob_exception_code)");
03047                                         }
03048                                         output_indent ("  {");
03049                                         output_stmt (p->handler2);
03050                                         output_indent ("  }");
03051                                 }
03052                         }
03053                 }
03054                 break;
03055         case CB_TAG_LABEL:
03056                 lp = CB_LABEL (x);
03057                 output_newline ();
03058                 if (lp->is_section) {
03059                         if (strcmp ((const char *)(lp->name) , "MAIN SECTION")) {
03060                                 output_line ("/* %s SECTION */", lp->name);
03061                         } else {
03062                                 output_line ("/* %s */", lp->name);
03063                         }
03064                         excp_current_section = (const char *)lp->name;
03065                         excp_current_paragraph = NULL;
03066                 } else {
03067                         if (lp->is_entry) {
03068                                 output_line ("/* Entry %s */", lp->orig_name);
03069                         } else {
03070                                 output_line ("/* %s */", lp->name);
03071                         }
03072                         excp_current_paragraph = (const char *)lp->name;
03073                         if (!lp->need_begin) {
03074                                 output_newline ();
03075                         }
03076                 }
03077                 if (lp->need_begin) {
03078                         output_newline ();
03079                         output_line ("%s%d:;", CB_PREFIX_LABEL, lp->id);
03080                 }
03081                 if (cb_flag_trace) {
03082                         if (lp->is_section) {
03083                                 if (strcmp ((const char *)(lp->name) , "MAIN SECTION")) {
03084                                         output_line ("fputs (\"PROGRAM-ID: %s: %s SECTION\\n\", stderr);", excp_current_program_id, lp->orig_name);
03085                                 } else {
03086                                         output_line ("fputs (\"PROGRAM-ID: %s: %s\\n\", stderr);", excp_current_program_id, lp->orig_name);
03087                                 }
03088                         } else if (lp->is_entry) {
03089                                 output_line ("fputs (\"PROGRAM-ID: %s: ENTRY %s\\n\", stderr);", excp_current_program_id, lp->orig_name);
03090                         } else {
03091                                 output_line ("fputs (\"PROGRAM-ID: %s: %s\\n\", stderr);", excp_current_program_id, lp->orig_name);
03092                         }
03093                         output_line ("fflush (stderr);");
03094                 }
03095                 break;
03096         case CB_TAG_FUNCALL:
03097                 output_prefix ();
03098                 output_funcall (x);
03099 #ifdef __GNUC__
03100                 output (";\n");
03101 #else
03102                 if (inside_check == 0) {
03103                         output (";\n");
03104                 } else {
03105                         inside_stack[inside_check -1] = 1;
03106                 }
03107 #endif
03108                 break;
03109         case CB_TAG_ASSIGN:
03110                 ap = CB_ASSIGN (x);
03111 #ifdef  COB_NON_ALIGNED
03112                 /* Nonaligned */
03113                 if (CB_TREE_CLASS (ap->var) == CB_CLASS_POINTER
03114                     || CB_TREE_CLASS (ap->val) == CB_CLASS_POINTER) {
03115                         /* Pointer assignment */
03116                         output_indent ("{");
03117                         output_line ("void *temp_ptr;");
03118 
03119                         /* temp_ptr = source address; */
03120                         output_prefix ();
03121                         if (ap->val == cb_null || ap->val == cb_zero) {
03122                                 /* MOVE NULL ... */
03123                                 output ("temp_ptr = 0;\n");
03124                         } else if (CB_TREE_TAG (ap->val) == CB_TAG_CAST) {
03125                                 /* MOVE ADDRESS OF val ... */
03126                                 cp = CB_CAST (ap->val);
03127                                 output ("temp_ptr = ");
03128                                 switch (cp->type) {
03129                                 case CB_CAST_ADDRESS:
03130                                         output_data (cp->val);
03131                                         break;
03132                                 case CB_CAST_PROGRAM_POINTER:
03133                                         output_func_1 ("cob_call_resolve", ap->val);
03134                                         break;
03135                                 default:
03136                                         fprintf (stderr, "Unexpected cast type %d\n", cp->type);
03137                                         ABORT ();
03138                                 }
03139                                 output (";\n");
03140                         } else {
03141                                 /* MOVE val ... */
03142                                 output ("memcpy(&temp_ptr, ");
03143                                 output_data (ap->val);
03144                                 output (", sizeof(temp_ptr));\n");
03145                         }
03146 
03147                         /* destination address = temp_ptr; */
03148                         output_prefix ();
03149                         if (CB_TREE_TAG (ap->var) == CB_TAG_CAST) {
03150                                 /* SET ADDRESS OF var ... */
03151                                 cp = CB_CAST (ap->var);
03152                                 if (cp->type != CB_CAST_ADDRESS) {
03153                                         fprintf (stderr, "Unexpected tree type %d\n", cp->type);
03154                                         ABORT ();
03155                                 }
03156                                 output_data (cp->val);
03157                                 output (" = temp_ptr;\n");
03158                         } else {
03159                                 /* MOVE ... TO var */
03160                                 output ("memcpy(");
03161                                 output_data (ap->var);
03162                                 output (", &temp_ptr, sizeof(temp_ptr));\n");
03163                         }
03164 
03165                         output_indent ("}");
03166                 } else {
03167                         /* Numeric assignment */
03168                         output_prefix ();
03169                         output_integer (ap->var);
03170                         output (" = ");
03171                         output_integer (ap->val);
03172 #ifdef __GNUC__
03173                         output (";\n");
03174 #else
03175                         if (inside_check == 0) {
03176                                 output (";\n");
03177                         } else {
03178                                 inside_stack[inside_check -1] = 1;
03179                         }
03180 #endif
03181                 }
03182 #else   /* Nonaligned */
03183                 output_prefix ();
03184                 output_integer (ap->var);
03185                 output (" = ");
03186                 output_integer (ap->val);
03187 #ifdef __GNUC__
03188                 output (";\n");
03189 #else
03190                 if (inside_check == 0) {
03191                         output (";\n");
03192                 } else {
03193                         inside_stack[inside_check -1] = 1;
03194                 }
03195 #endif
03196 #endif  /* Nonaligned */
03197                 break;
03198         case CB_TAG_INITIALIZE:
03199                 output_initialize (CB_INITIALIZE (x));
03200                 break;
03201         case CB_TAG_SEARCH:
03202                 output_search (CB_SEARCH (x));
03203                 break;
03204         case CB_TAG_CALL:
03205                 output_call (CB_CALL (x));
03206                 break;
03207         case CB_TAG_GOTO:
03208                 output_goto (CB_GOTO (x));
03209                 break;
03210         case CB_TAG_IF:
03211                 ip = CB_IF (x);
03212                 output_prefix ();
03213                 output ("if (");
03214                 output_cond (ip->test, 0);
03215                 output (")\n");
03216                 if (ip->stmt1) {
03217                         output_indent_level += 2;
03218                         output_stmt (ip->stmt1);
03219                         output_indent_level -= 2;
03220                 } else {
03221                         output_line ("  /* nothing */;");
03222                 }
03223                 if (ip->stmt2) {
03224                         output_line ("else");
03225                         output_indent_level += 2;
03226                         output_stmt (ip->stmt2);
03227                         output_indent_level -= 2;
03228                 }
03229                 break;
03230         case CB_TAG_PERFORM:
03231                 output_perform (CB_PERFORM (x));
03232                 break;
03233         case CB_TAG_CONTINUE:
03234                 output_prefix ();
03235                 output (";\n");
03236                 break;
03237         case CB_TAG_LIST:
03238                 output_indent ("{");
03239                 for (; x; x = CB_CHAIN (x)) {
03240                         output_stmt (CB_VALUE (x));
03241                 }
03242                 output_indent ("}");
03243                 break;
03244         default:
03245                 fprintf (stderr, "Unexpected tree tag %d\n", CB_TREE_TAG (x));
03246                 ABORT ();
03247         }
03248 }
03249 
03250 /*
03251  * File definition
03252  */
03253 
03254 static int
03255 output_file_allocation (struct cb_file *f)
03256 {
03257 
03258         if (f->global) {
03259                 output_storage ("/* Global file %s */\n", f->name);
03260         } else {
03261                 output_local ("/* File %s */\n", f->name);
03262         }
03263         /* Output RELATIVE/RECORD KEY's */
03264         if (f->organization == COB_ORG_RELATIVE || f->organization == COB_ORG_INDEXED) {
03265                 if (f->global) {
03266                         output_storage ("static struct cob_file_key\t*%s%s = NULL;\n",
03267                                 CB_PREFIX_KEYS, f->cname);
03268                 } else {
03269                         output_local ("static struct cob_file_key\t*%s%s = NULL;\n",
03270                                 CB_PREFIX_KEYS, f->cname);
03271                 }
03272         }
03273         if (f->global) {
03274                 output_storage ("static cob_file\t\t*%s%s = NULL;\n",
03275                         CB_PREFIX_FILE, f->cname);
03276                 output_storage ("static unsigned char\t%s%s_status[4];\n",
03277                         CB_PREFIX_FILE, f->cname);
03278         } else {
03279                 output_local ("static cob_file\t\t*%s%s = NULL;\n",
03280                         CB_PREFIX_FILE, f->cname);
03281                 output_local ("static unsigned char\t%s%s_status[4];\n",
03282                         CB_PREFIX_FILE, f->cname);
03283         }
03284         if (f->linage) {
03285                 return 1;
03286         }
03287         return 0;
03288 }
03289 
03290 static void
03291 output_file_initialization (struct cb_file *f)
03292 {
03293         int                     nkeys = 1;
03294         struct cb_alt_key       *l;
03295 
03296         if (f->external) {
03297                 output_line ("%s%s = (cob_file *)cob_external_addr (\"%s\", sizeof(cob_file));",
03298                              CB_PREFIX_FILE, f->cname, f->cname);
03299                 output_line ("if (cob_initial_external)");
03300                 output_indent ("{");
03301                 if (f->linage) {
03302                         output_line ("%s%s->linorkeyptr = cob_malloc (sizeof(struct linage_struct));", CB_PREFIX_FILE, f->cname);
03303                 }
03304         } else {
03305                 output_line ("if (!%s%s)", CB_PREFIX_FILE, f->cname);
03306                 output_indent ("{");
03307                 output_line ("%s%s = cob_malloc (sizeof(cob_file));", CB_PREFIX_FILE, f->cname);
03308                 if (f->linage) {
03309                         output_line ("%s%s->linorkeyptr = cob_malloc (sizeof(struct linage_struct));", CB_PREFIX_FILE, f->cname);
03310                 }
03311                 output_indent ("}");
03312         }
03313         /* Output RELATIVE/RECORD KEY's */
03314         if (f->organization == COB_ORG_RELATIVE
03315          || f->organization == COB_ORG_INDEXED) {
03316                 for (l = f->alt_key_list; l; l = l->next) {
03317                         nkeys++;
03318                 }
03319                 output_line ("if (!%s%s)", CB_PREFIX_KEYS, f->cname);
03320                 output_indent ("{");
03321                 output_line ("%s%s = cob_malloc (sizeof (struct cob_file_key) * %d);",
03322                              CB_PREFIX_KEYS, f->cname, nkeys);
03323                 output_indent ("}");
03324                 nkeys = 1;
03325                 output_prefix ();
03326                 output ("%s%s->field = ", CB_PREFIX_KEYS, f->cname);
03327                 output_param (f->key, -1);
03328                 output (";\n");
03329                 output_prefix ();
03330                 output ("%s%s->flag = 0;\n", CB_PREFIX_KEYS, f->cname);
03331                 output_prefix ();
03332                 if (f->key) {
03333                         output ("%s%s->offset = %d;\n", CB_PREFIX_KEYS, f->cname,
03334                                 cb_field (f->key)->offset);
03335                 } else {
03336                         output ("%s%s->offset = 0;\n", CB_PREFIX_KEYS, f->cname);
03337                 }
03338                 for (l = f->alt_key_list; l; l = l->next) {
03339                         output_prefix ();
03340                         output ("(%s%s + %d)->field = ", CB_PREFIX_KEYS, f->cname,
03341                                 nkeys);
03342                         output_param (l->key, -1);
03343                         output (";\n");
03344                         output_prefix ();
03345                         output ("(%s%s + %d)->flag = %d;\n", CB_PREFIX_KEYS, f->cname,
03346                                 nkeys, l->duplicates);
03347                         output_prefix ();
03348                         output ("(%s%s + %d)->offset = %d;\n", CB_PREFIX_KEYS, f->cname,
03349                                 nkeys, cb_field (l->key)->offset);
03350                         nkeys++;
03351                 }
03352         }
03353 
03354         output_line ("%s%s->select_name = (const char *)\"%s\";", CB_PREFIX_FILE, f->cname, f->name);
03355         if (f->external && !f->file_status) {
03356                 output_line ("%s%s->file_status = cob_external_addr (\"%s%s_status\", 4);",
03357                              CB_PREFIX_FILE, f->cname, CB_PREFIX_FILE, f->cname);
03358         } else {
03359                 output_line ("%s%s->file_status = %s%s_status;", CB_PREFIX_FILE, f->cname,
03360                              CB_PREFIX_FILE, f->cname);
03361                 output_line ("memset (%s%s_status, '0', 2);", CB_PREFIX_FILE, f->cname);
03362         }
03363         output_prefix ();
03364         output ("%s%s->assign = ", CB_PREFIX_FILE, f->cname);
03365         if (f->special) {
03366                 output ("NULL");
03367         } else {
03368                 output_param (f->assign, -1);
03369         }
03370         output (";\n");
03371         output_prefix ();
03372         output ("%s%s->record = ", CB_PREFIX_FILE, f->cname);
03373         output_param (CB_TREE (f->record), -1);
03374         output (";\n");
03375         output_prefix ();
03376         output ("%s%s->record_size = ", CB_PREFIX_FILE, f->cname);
03377         if (f->record_depending) {
03378                 output_param (f->record_depending, -1);
03379         } else {
03380                 output ("NULL");
03381         }
03382         output (";\n");
03383         output_line ("%s%s->record_min = %d;", CB_PREFIX_FILE, f->cname, f->record_min);
03384         output_line ("%s%s->record_max = %d;", CB_PREFIX_FILE, f->cname, f->record_max);
03385         if (f->organization == COB_ORG_RELATIVE
03386          || f->organization == COB_ORG_INDEXED) {
03387                 output_line ("%s%s->nkeys = %d;", CB_PREFIX_FILE, f->cname, nkeys);
03388                 output_line ("%s%s->keys = %s%s;", CB_PREFIX_FILE, f->cname, CB_PREFIX_KEYS,
03389                              f->cname);
03390         } else {
03391                 output_line ("%s%s->nkeys = 0;", CB_PREFIX_FILE, f->cname);
03392                 output_line ("%s%s->keys = NULL;", CB_PREFIX_FILE, f->cname);
03393         }
03394         output_line ("%s%s->file = NULL;", CB_PREFIX_FILE, f->cname);
03395 
03396         if (f->linage) {
03397                 output_line ("lingptr = (struct linage_struct *)(%s%s->linorkeyptr);",
03398                                 CB_PREFIX_FILE, f->cname);
03399                 output_prefix ();
03400                 output ("lingptr->linage = ");
03401                 output_param (f->linage, -1);
03402                 output (";\n");
03403                 output_prefix ();
03404                 output ("lingptr->linage_ctr = ");
03405                 output_param (f->linage_ctr, -1);
03406                 output (";\n");
03407                 if (f->latfoot) {
03408                         output_prefix ();
03409                         output ("lingptr->latfoot = ");
03410                         output_param (f->latfoot, -1);
03411                         output (";\n");
03412                 } else {
03413                         output_line ("lingptr->latfoot = NULL;");
03414                 }
03415                 if (f->lattop) {
03416                         output_prefix ();
03417                         output ("lingptr->lattop = ");
03418                         output_param (f->lattop, -1);
03419                         output (";\n");
03420                 } else {
03421                         output_line ("lingptr->lattop = NULL;");
03422                 }
03423                 if (f->latbot) {
03424                         output_prefix ();
03425                         output ("lingptr->latbot = ");
03426                         output_param (f->latbot, -1);
03427                         output (";\n");
03428                 } else {
03429                         output_line ("lingptr->latbot = NULL;");
03430                 }
03431                 output_line ("lingptr->lin_lines = 0;");
03432                 output_line ("lingptr->lin_foot = 0;");
03433                 output_line ("lingptr->lin_top = 0;");
03434                 output_line ("lingptr->lin_bot = 0;");
03435         }
03436 
03437         output_line ("%s%s->organization = %d;", CB_PREFIX_FILE, f->cname, f->organization);
03438         output_line ("%s%s->access_mode = %d;", CB_PREFIX_FILE, f->cname, f->access_mode);
03439         output_line ("%s%s->lock_mode = %d;", CB_PREFIX_FILE, f->cname, f->lock_mode);
03440         output_line ("%s%s->open_mode = 0;", CB_PREFIX_FILE, f->cname);
03441         output_line ("%s%s->flag_optional = %d;", CB_PREFIX_FILE, f->cname, f->optional);
03442         output_line ("%s%s->last_open_mode = 0;", CB_PREFIX_FILE, f->cname);
03443         output_line ("%s%s->special = %d;", CB_PREFIX_FILE, f->cname, f->special);
03444         output_line ("%s%s->flag_nonexistent = 0;", CB_PREFIX_FILE, f->cname);
03445         output_line ("%s%s->flag_end_of_file = 0;", CB_PREFIX_FILE, f->cname);
03446         output_line ("%s%s->flag_begin_of_file = 0;", CB_PREFIX_FILE, f->cname);
03447         output_line ("%s%s->flag_first_read = 0;", CB_PREFIX_FILE, f->cname);
03448         output_line ("%s%s->flag_read_done = 0;", CB_PREFIX_FILE, f->cname);
03449         output_line ("%s%s->flag_select_features = %d;", CB_PREFIX_FILE, f->cname,
03450                      ((f->file_status ? COB_SELECT_FILE_STATUS : 0) |
03451                      (f->linage ? COB_SELECT_LINAGE : 0) |
03452                      (f->external_assign ? COB_SELECT_EXTERNAL : 0)));
03453         output_line ("%s%s->flag_needs_nl = 0;", CB_PREFIX_FILE, f->cname);
03454         output_line ("%s%s->flag_needs_top = 0;", CB_PREFIX_FILE, f->cname);
03455         output_line ("%s%s->file_version = %d;", CB_PREFIX_FILE, f->cname, COB_FILE_VERSION);
03456         if (f->external) {
03457                 output_indent ("}");
03458         }
03459 }
03460 
03461 /*
03462  * Screen definition
03463  */
03464 
03465 static void
03466 output_screen_definition (struct cb_field *p)
03467 {
03468         int     type;
03469 
03470         if (p->sister) {
03471                 output_screen_definition (p->sister);
03472         }
03473         if (p->children) {
03474                 output_screen_definition (p->children);
03475         }
03476 
03477         type = (p->children ? COB_SCREEN_TYPE_GROUP :
03478                 p->values ? COB_SCREEN_TYPE_VALUE :
03479                 (p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
03480         output ("static cob_screen s_%d = {", p->id);
03481 
03482         if (p->sister) {
03483                 output ("&s_%d, ", p->sister->id);
03484         } else {
03485                 output ("NULL, ");
03486         }
03487         if (type == COB_SCREEN_TYPE_GROUP) {
03488                 output ("&s_%d, ", p->children->id);
03489         } else {
03490                 output ("NULL, ");
03491         }
03492         if (type == COB_SCREEN_TYPE_FIELD) {
03493                 p->count++;
03494                 output_param (cb_build_field_reference (p, NULL), -1);
03495                 output (", ");
03496         } else {
03497                 output ("NULL, ");
03498         }
03499         if (type == COB_SCREEN_TYPE_VALUE) {
03500                 output_param (CB_VALUE(p->values), p->id);
03501                 output (", ");
03502         } else {
03503                 output ("NULL, ");
03504         }
03505 
03506         if (p->screen_line) {
03507                 output_param (p->screen_line, 0);
03508                 output (", ");
03509         } else {
03510                 output ("NULL, ");
03511         }
03512         if (p->screen_column) {
03513                 output_param (p->screen_column, 0);
03514                 output (", ");
03515         } else {
03516                 output ("NULL, ");
03517         }
03518         if (p->screen_foreg) {
03519                 output_param (p->screen_foreg, 0);
03520                 output (", ");
03521         } else {
03522                 output ("NULL, ");
03523         }
03524         if (p->screen_backg) {
03525                 output_param (p->screen_backg, 0);
03526                 output (", ");
03527         } else {
03528                 output ("NULL, ");
03529         }
03530         output ("%d, %d, %d};\n", type, p->occurs_min, p->screen_flag);
03531 }
03532 
03533 /*
03534  * Alphabet-name
03535  */
03536 
03537 static int
03538 literal_value (cb_tree x)
03539 {
03540         if (x == cb_space) {
03541                 return ' ';
03542         } else if (x == cb_zero) {
03543                 return '0';
03544         } else if (x == cb_quote) {
03545                 return '"';
03546         } else if (x == cb_norm_low) {
03547                 return 0;
03548         } else if (x == cb_norm_high) {
03549                 return 255;
03550         } else if (x == cb_null) {
03551                 return 0;
03552         } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
03553                 return cb_get_int (x) - 1;
03554         } else {
03555                 return CB_LITERAL (x)->data[0];
03556         }
03557 }
03558 
03559 static void
03560 output_alphabet_name_definition (struct cb_alphabet_name *p)
03561 {
03562         cb_tree         l;
03563         cb_tree         ls;
03564         cb_tree         x;
03565         unsigned char   *data;
03566         int             i;
03567         int             n = 0;
03568         int             size;
03569         int             upper;
03570         int             lower;
03571         int             table[256];
03572 
03573         /* Reset to -1 */
03574         for (i = 0; i < 256; i++) {
03575                 table[i] = -1;
03576         }
03577 
03578         for (l = p->custom_list; l; l = CB_CHAIN (l)) {
03579                 x = CB_VALUE (l);
03580                 if (CB_PAIR_P (x)) {
03581                         /* X THRU Y */
03582                         lower = literal_value (CB_PAIR_X (x));
03583                         upper = literal_value (CB_PAIR_Y (x));
03584                         if (lower <= upper) {
03585                                 for (i = lower; i <= upper; i++) {
03586                                         table[i] = n++;
03587                                 }
03588                         } else {
03589                                 for (i = upper; i >= lower; i--) {
03590                                         table[i] = n++;
03591                                 }
03592                         }
03593                 } else if (CB_LIST_P (x)) {
03594                         /* X ALSO Y ... */
03595                         for (ls = x; ls; ls = CB_CHAIN (ls)) {
03596                                 table[literal_value (CB_VALUE (ls))] = n;
03597                         }
03598                         n++;
03599                 } else {
03600                         /* Literal */
03601                         if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
03602                                 table[literal_value (x)] = n++;
03603                         } else if (CB_LITERAL_P (x)) {
03604                                 size = (int)CB_LITERAL (x)->size;
03605                                 data = CB_LITERAL (x)->data;
03606                                 for (i = 0; i < size; i++) {
03607                                         table[data[i]] = n++;
03608                                 }
03609                         } else {
03610                                 table[literal_value (x)] = n++;
03611                         }
03612                 }
03613         }
03614 
03615         /* Fill the rest of characters */
03616         for (i = 0; i < 256; i++) {
03617                 if (table[i] == -1) {
03618                         table[i] = n++;
03619                 }
03620         }
03621 
03622         /* Output the table */
03623         output_local ("static const unsigned char %s%s[256] = {\n", CB_PREFIX_SEQUENCE, p->cname);
03624         for (i = 0; i < 256; i++) {
03625                 if (i == 255) {
03626                         output_local (" %d", table[i]);
03627                 } else {
03628                         output_local (" %d,", table[i]);
03629                 }
03630                 if (i % 16 == 15) {
03631                         output_local ("\n");
03632                 }
03633         }
03634         output_local ("};\n");
03635         i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
03636         output_local ("static cob_field f_%s = { 256, (unsigned char *)%s%s, &%s%d };\n",
03637                 p->cname, CB_PREFIX_SEQUENCE, p->cname, CB_PREFIX_ATTR, i);
03638         output_local ("\n");
03639 }
03640 
03641 /*
03642  * Class definition
03643  */
03644 
03645 static void
03646 output_class_name_definition (struct cb_class_name *p)
03647 {
03648         cb_tree         l;
03649         cb_tree         x;
03650         unsigned char   *data;
03651         size_t          i;
03652         size_t          size;
03653         int             lower;
03654         int             upper;
03655 
03656         output_line ("static int");
03657         output_line ("%s (cob_field *f)", p->cname);
03658         output_indent ("{");
03659         output_line ("int i;");
03660         output_line ("for (i = 0; i < f->size; i++)");
03661         output_prefix ();
03662         output ("  if (!(    ");
03663         for (l = p->list; l; l = CB_CHAIN (l)) {
03664                 x = CB_VALUE (l);
03665                 if (CB_PAIR_P (x)) {
03666                         lower = literal_value (CB_PAIR_X (x));
03667                         upper = literal_value (CB_PAIR_Y (x));
03668                         if (!lower) {
03669                                 output ("f->data[i] <= %d", upper);
03670                         } else {
03671                                 output ("(%d <= f->data[i] && f->data[i] <= %d)", lower, upper);
03672                         }
03673                 } else {
03674                         if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
03675                                 output ("f->data[i] == %d", literal_value(x));
03676                         } else if (x == cb_space) {
03677                                 output ("f->data[i] == %d", ' ');
03678                         } else if (x == cb_zero) {
03679                                 output ("f->data[i] == %d", '0');
03680                         } else if (x == cb_quote) {
03681                                 output ("f->data[i] == %d", '"');
03682                         } else if (x == cb_null) {
03683                                 output ("f->data[i] == 0");
03684                         } else {
03685                                 size = CB_LITERAL (x)->size;
03686                                 data = CB_LITERAL (x)->data;
03687                                 for (i = 0; i < size; i++) {
03688                                         output ("f->data[i] == %d", data[i]);
03689                                         if (i + 1 < size) {
03690                                                 output (" || ");
03691                                         }
03692                                 }
03693                         }
03694                 }
03695                 if (CB_CHAIN (l)) {
03696                         output ("\n");
03697                         output_prefix ();
03698                         output ("         || ");
03699                 }
03700         }
03701         output (" ))\n");
03702         output_line ("    return 0;");
03703         output_line ("return 1;");
03704         output_indent ("}");
03705         output_newline ();
03706 }
03707 
03708 static void
03709 output_initial_values (struct cb_field *p)
03710 {
03711         cb_tree x;
03712         cb_tree def;
03713 
03714         def = cb_auto_initialize ? cb_true : NULL;
03715         for (; p; p = p->sister) {
03716                 x = cb_build_field_reference (p, NULL);
03717                 if (p->flag_item_based) {
03718                         continue;
03719                 }
03720                 /* For special registers */
03721                 if (p->flag_no_init && !p->count) {
03722                         continue;
03723                 }
03724                 output_stmt (cb_build_initialize (x, cb_true, NULL, def, 0));
03725         }
03726 }
03727 
03728 static void
03729 output_internal_function (struct cb_program *prog, cb_tree parameter_list)
03730 {
03731         cb_tree                 l;
03732         cb_tree                 l2;
03733         struct cb_field         *f;
03734         struct cb_field         *ff;
03735         struct field_list       *k;
03736         struct local_list       *locptr;
03737         struct cb_file          *fl;
03738         char                    *p;
03739         struct handler_struct   *hstr;
03740 #ifndef __GNUC__
03741         struct label_list       *pl;
03742 #endif
03743         int                     i;
03744         int                     n;
03745         int                     parmnum = 0;
03746         int                     seen = 0;
03747         int                     anyseen;
03748         char                    name[COB_MINI_BUFF];
03749 
03750         /* Program function */
03751         output ("static int\n%s_ (const int entry", prog->program_id);
03752         if (!prog->flag_chained) {
03753                 for (l = parameter_list; l; l = CB_CHAIN (l)) {
03754                         output (", unsigned char *%s%d",
03755                                 CB_PREFIX_BASE, cb_field (CB_VALUE (l))->id);
03756                         parmnum++;
03757                 }
03758         }
03759         output (")\n");
03760         output_indent ("{");
03761 
03762         /* Local variables */
03763         output_line ("/* Local variables */");
03764         output_line ("#include \"%s\"", prog->local_storage_name);
03765         output_newline ();
03766 
03767         /* Alphabet-names */
03768         if (prog->alphabet_name_list) {
03769                 output_local ("/* Alphabet names */\n");
03770                 for (l = prog->alphabet_name_list; l; l = CB_CHAIN (l)) {
03771                         output_alphabet_name_definition (CB_ALPHABET_NAME (CB_VALUE (l)));
03772                 }
03773                 output_local ("\n");
03774         }
03775 
03776         output_line ("static int initialized = 0;");
03777         if (prog->decimal_index_max) {
03778                 output_local ("/* Decimal structures */\n");
03779                 for (i = 0; i < prog->decimal_index_max; i++) {
03780                         output_local ("static cob_decimal d%d;\n", i);
03781                 }
03782                 output_local ("\n");
03783         }
03784 
03785         output_prefix ();
03786         output ("static cob_field *cob_user_parameters[COB_MAX_FIELD_PARAMS];\n");
03787         output_prefix ();
03788         output ("static struct cob_module module = { NULL, ");
03789         if (prog->collating_sequence) {
03790                 output_param (cb_ref (prog->collating_sequence), -1);
03791         } else {
03792                 output ("NULL");
03793         }
03794         output (", ");
03795         if (prog->crt_status && cb_field (prog->crt_status)->count) {
03796                 output_param (cb_ref (prog->crt_status), -1);
03797         } else {
03798                 output ("NULL");
03799         }
03800         output (", ");
03801         if (prog->cursor_pos) {
03802                 output_param (cb_ref (prog->cursor_pos), -1);
03803         } else {
03804                 output ("NULL");
03805         }
03806         output (", cob_user_parameters");
03807 
03808         /* Note spare byte at end */
03809         output (", %d, '%c', '%c', '%c', %d, %d, %d, 0 };\n",
03810                 cb_display_sign, prog->decimal_point, prog->currency_symbol,
03811                 prog->numeric_separator, cb_filename_mapping, cb_binary_truncate,
03812                 cb_pretty_display);
03813         output_newline ();
03814 
03815         /* External items */
03816         for (f = prog->working_storage; f; f = f->sister) {
03817                 if (f->flag_external) {
03818                         strcpy (name, f->name);
03819                         for (p = name; *p; p++) {
03820                                 if (*p == '-') {
03821                                         *p = '_';
03822                                 }
03823                         }
03824                         output_local ("static unsigned char\t*%s%s = NULL;", CB_PREFIX_BASE, name);
03825                         output_local ("  /* %s */\n", f->name);
03826                 }
03827         }
03828         for (l = prog->file_list; l; l = CB_CHAIN (l)) {
03829                 f = CB_FILE (CB_VALUE (l))->record;
03830                 if (f->flag_external) {
03831                         strcpy (name, f->name);
03832                         for (p = name; *p; p++) {
03833                                 if (*p == '-') {
03834                                         *p = '_';
03835                                 }
03836                         }
03837                         output_local ("static unsigned char\t*%s%s = NULL;", CB_PREFIX_BASE, name);
03838                         output_local ("  /* %s */\n", f->name);
03839                 }
03840         }
03841         if (cb_sticky_linkage && parmnum) {
03842                 output_local ("\n/* Sticky linkage save pointers */\n");
03843                 for (i = 0; i < parmnum; i++) {
03844                         output_local ("static unsigned char\t*cob_parm_%d = NULL;\n", i);
03845                 }
03846                 output_local ("\n");
03847         }
03848 
03849         /* Files */
03850         if (prog->file_list) {
03851                 i = 0;
03852                 for (l = prog->file_list; l; l = CB_CHAIN (l)) {
03853                         i += output_file_allocation (CB_FILE (CB_VALUE (l)));
03854                 }
03855                 if (i) {
03856                         output_local ("\nstatic struct linage_struct *lingptr;\n");
03857                 }
03858         }
03859 
03860         if (prog->loop_counter) {
03861                 output_local ("\n/* Loop counters */\n");
03862                 for (i = 0; i < prog->loop_counter; i++) {
03863                         output_local ("int n%d;\n", i);
03864                 }
03865                 output_local ("\n");
03866         }
03867 
03868         /* BASED working-storage */
03869         i = 0;
03870         for (f = prog->working_storage; f; f = f->sister) {
03871                 if (f->flag_item_based) {
03872                         if (!i) {
03873                                 i = 1;
03874                                 output_local("/* BASED WORKING-STORAGE SECTION */\n");
03875                         }
03876                         output_local ("static unsigned char *%s%d = NULL; /* %s */\n",
03877                                 CB_PREFIX_BASE, f->id, f->name);
03878                 }
03879         }
03880         if (i) {
03881                 output_local ("\n");
03882         }
03883 
03884         /* BASED local-storage */
03885         i = 0;
03886         for (f = prog->local_storage; f; f = f->sister) {
03887                 if (f->flag_item_based) {
03888                         if (!i) {
03889                                 i = 1;
03890                                 output_local("/* BASED LOCAL-STORAGE */\n");
03891                         }
03892                         output_local ("unsigned char\t\t*%s%d = NULL; /* %s */\n",
03893                                 CB_PREFIX_BASE, f->id, f->name);
03894                         if (prog->flag_global_use) {
03895                                 output_local ("static unsigned char\t*save_%s%d = NULL;\n",
03896                                         CB_PREFIX_BASE, f->id, f->name);
03897                         }
03898                 }
03899         }
03900         if (i) {
03901                 output_local ("\n");
03902         }
03903 
03904         /* Dangling linkage section items */
03905         seen = 0;
03906         for (f = prog->linkage_storage; f; f = f->sister) {
03907                 for (l = parameter_list; l; l = CB_CHAIN (l)) {
03908                         if (f == cb_field (CB_VALUE (l))) {
03909                                 break;
03910                         }
03911                 }
03912                 if (l == NULL) {
03913                         if (!seen) {
03914                                 seen = 1;
03915                                 output_local ("\n/* LINKAGE SECTION (Items not referenced by USING clause) */\n");
03916                         }
03917                         output_local ("static unsigned char\t*%s%d = NULL;  /* %s */\n",
03918                                      CB_PREFIX_BASE, f->id, f->name);
03919                 }
03920         }
03921         if (seen) {
03922                 output_local ("\n");
03923         }
03924 
03925         /* Screens */
03926         if (prog->screen_storage) {
03927                 output_target = current_prog->local_storage_file;
03928                 output ("\n/* Screens */\n\n");
03929                 output_screen_definition (prog->screen_storage);
03930                 output_newline ();
03931                 output_target = yyout;
03932         }
03933 
03934         output_local ("\n/* Define perform frame stack */\n\n");
03935         if (cb_perform_osvs) {
03936                 output_local ("struct cob_frame\t*temp_index;\n");
03937         }
03938         if (cb_flag_stack_check) {
03939                 output_local ("struct cob_frame\t*frame_overflow;\n");
03940         }
03941         output_local ("struct cob_frame\t*frame_ptr;\n");
03942         output_local ("struct cob_frame\tframe_stack[%d];\n\n", COB_STACK_SIZE);
03943 
03944         i = 0;
03945         anyseen = 0;
03946         for (l = parameter_list; l; l = CB_CHAIN (l), i++) {
03947                 f = cb_field (CB_VALUE (l));
03948                 if (f->flag_any_length) {
03949                         if (!anyseen) {
03950                                 anyseen = 1;
03951                                 output_local ("/* ANY LENGTH fields */\n");
03952                         }
03953                         output_local ("cob_field\t\t*anylen_%d;\n", i);
03954                         if (prog->flag_global_use) {
03955                                 output_local ("static cob_field\t*save_anylen_%d;\n", i);
03956                         }
03957                 }
03958         }
03959         if (anyseen) {
03960                 output_local ("\n");
03961         }
03962         if (prog->flag_global_use && parameter_list) {
03963                 output_local ("/* Parameter save */\n");
03964                 for (l = parameter_list; l; l = CB_CHAIN (l)) {
03965                         f = cb_field (CB_VALUE (l));
03966                         output_local ("static unsigned char\t*save_%s%d;\n",
03967                                 CB_PREFIX_BASE, f->id);
03968                 }
03969                 output_local ("\n");
03970         }
03971 
03972         output_line ("/* Start of function code */");
03973         output_newline ();
03974         output_line ("/* CANCEL callback handling */");
03975         output_line ("if (unlikely(entry < 0)) {");
03976         output_line ("  if (!initialized) {");
03977         output_line ("          return 0;");
03978         output_line ("  }");
03979         for (l = prog->file_list; l; l = CB_CHAIN (l)) {
03980                 fl = CB_FILE (CB_VALUE (l));
03981                 if (fl->organization != COB_ORG_SORT) {
03982                         output_line ("  cob_close (%s%s, 0, NULL);",
03983                                         CB_PREFIX_FILE, fl->cname);
03984                 }
03985         }
03986         if (prog->decimal_index_max) {
03987                 for (i = 0; i < prog->decimal_index_max; i++) {
03988                         output_line ("  mpz_clear (d%d.value);", i);
03989                         output_line ("  d%d.scale = 0;", i);
03990                 }
03991         }
03992         output_line ("  initialized = 0;");
03993         output_line ("  return 0;");
03994         output_line ("}");
03995         output_newline ();
03996         if (cb_sticky_linkage && parmnum) {
03997                 output_line ("if (cob_call_params < %d) {", parmnum);
03998                 output_line ("  switch (cob_call_params) {");
03999                 for (i = 0, l = parameter_list; l; l = CB_CHAIN (l), i++) {
04000                         output_line ("  case %d:", i);
04001                         output_line ("   if (cob_parm_%d != NULL)", i);
04002                         output_line ("       %s%d = cob_parm_%d;",
04003                                      CB_PREFIX_BASE, cb_field (CB_VALUE (l))->id, i);
04004                 }
04005                 output_line ("  }");
04006                 output_line ("}");
04007                 for (i = 0, l = parameter_list; l; l = CB_CHAIN (l), i++) {
04008                         output_line ("if (%s%d != NULL)",
04009                                      CB_PREFIX_BASE, cb_field (CB_VALUE (l))->id);
04010                         output_line ("  cob_parm_%d = %s%d;", i,
04011                                      CB_PREFIX_BASE, cb_field (CB_VALUE (l))->id);
04012                 }
04013                 output_newline ();
04014         }
04015 
04016         output_line ("/* Initialize frame stack */");
04017         output_line ("frame_ptr = &frame_stack[0];");
04018         output_line ("frame_ptr->perform_through = 0;");
04019         if (cb_flag_stack_check) {
04020                 output_line ("frame_overflow = &frame_stack[COB_STACK_SIZE - 1];");
04021         }
04022         output_newline ();
04023 
04024         output_line ("/* Push module stack */");
04025         output_line ("module.next = cob_current_module;");
04026         output_line ("cob_current_module = &module;");
04027         output_newline ();
04028 
04029         /* Initialization */
04030         output_line ("/* Initialize program */");
04031         output_line ("if (unlikely(initialized == 0))");
04032         output_indent ("  {");
04033         output_line ("if (!cob_initialized) {");
04034         if (cb_flag_implicit_init) {
04035                 output_line ("  cob_init (0, NULL);");
04036         } else {
04037                 output_line ("  cob_fatal_error (COB_FERROR_INITIALIZED);");
04038         }
04039         output_line ("}");
04040         output_line
04041             ("cob_check_version (COB_SOURCE_FILE, COB_PACKAGE_VERSION, COB_PATCH_LEVEL);");
04042         if (!prog->flag_main) {
04043                 if (cb_flag_implicit_init) {
04044                         output_line ("cob_set_cancel ((const char *)\"%s\", (void *)%s, (void *)%s_);",
04045                                 prog->orig_source_name, prog->program_id,
04046                                 prog->program_id);
04047                 } else {
04048                         output_line ("if (module.next)");
04049                         output_line ("  cob_set_cancel ((const char *)\"%s\", (void *)%s, (void *)%s_);",
04050                                 prog->orig_source_name, prog->program_id,
04051                                 prog->program_id);
04052                 }
04053         }
04054         if (prog->decimal_index_max) {
04055                 output_line ("/* Initialize decimal numbers */");
04056                 for (i = 0; i < prog->decimal_index_max; i++) {
04057                         output_line ("cob_decimal_init (&d%d);", i);
04058                 }
04059                 output_newline ();
04060         }
04061         if (!prog->flag_initial) {
04062                 for (l = prog->file_list; l; l = CB_CHAIN (l)) {
04063                         f = CB_FILE (CB_VALUE (l))->record;
04064                         if (f->flag_external) {
04065                                 strcpy (name, f->name);
04066                                 for (p = name; *p; p++) {
04067                                         if (*p == '-') {
04068                                                 *p = '_';
04069                                         }
04070                                 }
04071                                 output_line ("%s%s = cob_external_addr (\"%s\", %d);",
04072                                              CB_PREFIX_BASE, name, name,
04073                                              CB_FILE (CB_VALUE (l))->record_max);
04074                         }
04075                 }
04076                 output_initial_values (prog->working_storage);
04077                 if (has_external) {
04078                         output_line ("goto L_initextern;");
04079                         output_line ("LRET_initextern: ;");
04080                 }
04081                 if (prog->file_list) {
04082                         output_newline ();
04083                         for (l = prog->file_list; l; l = CB_CHAIN (l)) {
04084                                 output_file_initialization (CB_FILE (CB_VALUE (l)));
04085                         }
04086                         output_newline ();
04087                 }
04088         }
04089 
04090         output_line ("initialized = 1;");
04091         if (prog->flag_chained) {
04092                 output ("    } else {\n");
04093                 output_line ("  cob_fatal_error (COB_FERROR_CHAINING);");
04094                 output_indent ("  }");
04095         } else {
04096                 output_indent ("  }");
04097         }
04098         output_newline ();
04099 
04100         /* Set up LOCAL-STORAGE cache */
04101         if (prog->local_storage) {
04102                 for (f = prog->local_storage; f; f = f->sister) {
04103                         ff = cb_field_founder (f);
04104                         if (ff->redefines) {
04105                                 ff = ff->redefines;
04106                         }
04107                         if (ff->flag_item_based || ff->flag_local_alloced) {
04108                                 continue;
04109                         }
04110                         if (ff->flag_item_78) {
04111                                 fprintf (stderr, "Unexpected CONSTANT item\n");
04112                                 ABORT ();
04113                         }
04114                         ff->flag_local_alloced = 1;
04115                         locptr = cobc_malloc (sizeof (struct local_list));
04116                         locptr->f = ff;
04117                         locptr->next = local_cache;
04118                         local_cache = locptr;
04119                 }
04120                 local_cache = local_list_reverse (local_cache);
04121         }
04122         /* Global entry dispatch */
04123         if (prog->global_list) {
04124                 output_line ("/* Global entry dispatch */");
04125                 output_newline ();
04126                 for (l = prog->global_list; l; l = CB_CHAIN (l)) {
04127                         output_line ("if (unlikely(entry == %d)) {",
04128                                         CB_LABEL (CB_VALUE (l))->id);
04129                         if (cb_flag_traceall) {
04130                                 output_line ("\tcob_ready_trace ();");
04131                         }
04132                         for (locptr = local_cache; locptr; locptr = locptr->next) {
04133                                 output_line ("\t%s%d = save_%s%d;",
04134                                         CB_PREFIX_BASE, locptr->f->id,
04135                                         CB_PREFIX_BASE, locptr->f->id);
04136                         }
04137                         i = 0;
04138                         for (l2 = parameter_list; l2; l2 = CB_CHAIN (l), i++) {
04139                                 f = cb_field (CB_VALUE (l2));
04140                                 output_line ("\t%s%d = save_%s%d;",
04141                                         CB_PREFIX_BASE, f->id,
04142                                         CB_PREFIX_BASE, f->id);
04143                                 if (f->flag_any_length) {
04144                                         output_line ("\tanylen_%d = save_anylen_%d;", i, i);
04145                                 }
04146                         }
04147                         output_line ("\tgoto %s%d;",
04148                                         CB_PREFIX_LABEL,
04149                                         CB_LABEL (CB_VALUE (l))->id);
04150                         output_line ("}");
04151                 }
04152                 output_newline ();
04153         }
04154 
04155         if (prog->flag_initial) {
04156                 for (l = prog->file_list; l; l = CB_CHAIN (l)) {
04157                         f = CB_FILE (CB_VALUE (l))->record;
04158                         if (f->flag_external) {
04159                                 strcpy (name, f->name);
04160                                 for (p = name; *p; p++) {
04161                                         if (*p == '-') {
04162                                                 *p = '_';
04163                                         }
04164                                 }
04165                                 output_line ("%s%s = cob_external_addr (\"%s\", %d);",
04166                                              CB_PREFIX_BASE, name, name,
04167                                              CB_FILE (CB_VALUE (l))->record_max);
04168                         }
04169                 }
04170                 output_initial_values (prog->working_storage);
04171                 if (has_external) {
04172                         output_line ("goto L_initextern;");
04173                         output_line ("LRET_initextern: ;");
04174                 }
04175                 output_newline ();
04176                 for (l = prog->file_list; l; l = CB_CHAIN (l)) {
04177                         output_file_initialization (CB_FILE (CB_VALUE (l)));
04178                 }
04179                 output_newline ();
04180         }
04181         if (prog->local_storage) {
04182                 if (local_cache) {
04183                         output_line ("/* Allocate LOCAL storage */");
04184                 }
04185                 for (locptr = local_cache; locptr; locptr = locptr->next) {
04186                         output_line ("%s%d = cob_malloc (%d);", CB_PREFIX_BASE,
04187                                         locptr->f->id, locptr->f->memory_size);
04188                         if (current_prog->flag_global_use) {
04189                                 output_line ("save_%s%d = %s%d;",
04190                                                 CB_PREFIX_BASE, locptr->f->id,
04191                                                 CB_PREFIX_BASE, locptr->f->id);
04192                         }
04193                 }
04194                 output_newline ();
04195                 output_line ("/* Initialialize LOCAL storage */");
04196                 output_initial_values (prog->local_storage);
04197                 output_newline ();
04198         }
04199 
04200         if (cb_field (current_prog->cb_call_params)->count) {
04201                 output_line ("/* Initialize number of call params */");
04202                 output ("  ");
04203                 output_integer (current_prog->cb_call_params);
04204                 output_line (" = cob_call_params;");
04205         }
04206         output_line ("cob_save_call_params = cob_call_params;");
04207         output_newline ();
04208         if (cb_flag_traceall) {
04209                 output_line ("cob_ready_trace ();");
04210                 output_newline ();
04211         }
04212 
04213         i = 0;
04214         if (anyseen) {
04215                 output_line ("/* Initialize ANY LENGTH parameters */");
04216         }
04217         for (l = parameter_list; l; l = CB_CHAIN (l), i++) {
04218                 f = cb_field (CB_VALUE (l));
04219                 if (f->flag_any_length) {
04220                         output ("  anylen_%d = ", i);
04221                         output_param (CB_VALUE (l), i);
04222                         output (";\n");
04223                         if (prog->flag_global_use) {
04224                                 output_line ("save_anylen_%d = anylen_%d;", i, i);
04225                         }
04226                         output_line ("if (cob_call_params > %d && %s%d%s)",
04227                                 i, "module.next->cob_procedure_parameters[",
04228                                 i, "]");
04229                         output_line ("  anylen_%d->size = %s%d%s;", i,
04230                                 "module.next->cob_procedure_parameters[",
04231                                 i, "]->size");
04232                 }
04233         }
04234         if (anyseen) {
04235                 output_newline ();
04236         }
04237         if (prog->flag_global_use && parameter_list) {
04238                 output_line ("/* Parameter save */");
04239                 for (l = parameter_list; l; l = CB_CHAIN (l)) {
04240                         f = cb_field (CB_VALUE (l));
04241                         output_line ("save_%s%d = %s%d;",
04242                                 CB_PREFIX_BASE, f->id,
04243                                 CB_PREFIX_BASE, f->id);
04244                 }
04245                 output_newline ();
04246         }
04247 
04248         /* Entry dispatch */
04249         output_line ("/* Entry dispatch */");
04250         if (cb_list_length (prog->entry_list) > 1) {
04251                 output_newline ();
04252                 output_line ("switch (entry)");
04253                 output_line ("  {");
04254                 for (i = 0, l = prog->entry_list; l; l = CB_CHAIN (l)) {
04255                         output_line ("  case %d:", i++);
04256                         output_line ("    goto %s%d;",
04257                                      CB_PREFIX_LABEL, CB_LABEL (CB_PURPOSE (l))->id);
04258                 }
04259                 output_line ("  }");
04260                 output_line ("/* This should never be reached */");
04261                 output_line ("cob_fatal_error (COB_FERROR_CHAINING);");
04262                 output_newline ();
04263         } else {
04264                 l = prog->entry_list;
04265                 output_line ("goto %s%d;", CB_PREFIX_LABEL, CB_LABEL (CB_PURPOSE (l))->id);
04266                 output_newline ();
04267         }
04268 
04269         /* PROCEDURE DIVISION */
04270         output_line ("/* PROCEDURE DIVISION */");
04271         for (l = prog->exec_list; l; l = CB_CHAIN (l)) {
04272                 output_stmt (CB_VALUE (l));
04273         }
04274         output_newline ();
04275         output_line ("/* Program exit */");
04276         output_newline ();
04277 
04278         if (needs_exit_prog) {
04279                 output_line ("exit_program:");
04280                 output_newline ();
04281         }
04282         if (prog->local_storage) {
04283                 output_line ("/* Deallocate LOCAL storage */");
04284                 local_cache = local_list_reverse (local_cache);
04285                 for (locptr = local_cache; locptr; locptr = locptr->next) {
04286                         output_line ("if (%s%d) {", CB_PREFIX_BASE, locptr->f->id);
04287                         output_line ("\tfree (%s%d);", CB_PREFIX_BASE, locptr->f->id);
04288                         output_line ("\t%s%d = NULL;", CB_PREFIX_BASE, locptr->f->id);
04289                         output_line ("}");
04290                 }
04291                 output_newline ();
04292         }
04293         output_line ("/* Pop module stack */");
04294         output_line ("cob_current_module = cob_current_module->next;");
04295         output_newline ();
04296         if (cb_flag_traceall) {
04297                 output_line ("cob_reset_trace ();");
04298                 output_newline ();
04299         }
04300         output_line ("/* Program return */");
04301         output_prefix ();
04302         output ("return ");
04303         output_integer (current_prog->cb_return_code);
04304         output (";\n");
04305 
04306         /* Error handlers */
04307         if (prog->file_list || prog->gen_file_error) {
04308                 output_newline ();
04309                 seen = 0;
04310                 for (i = COB_OPEN_INPUT; i <= COB_OPEN_EXTEND; i++) {
04311                         if (prog->global_handler[i].handler_label) {
04312                                 seen = 1;
04313                                 break;
04314                         }
04315                 }
04316                 output_stmt (cb_standard_error_handler);
04317                 output_newline ();
04318                 if (seen) {
04319                         output_line ("switch (cob_error_file->last_open_mode)");
04320                         output_indent ("{");
04321                         for (i = COB_OPEN_INPUT; i <= COB_OPEN_EXTEND; i++) {
04322                                 hstr = &prog->global_handler[i];
04323                                 if (hstr->handler_label) {
04324                                         output_line ("case %d:", i);
04325                                         output_indent ("{");
04326                                         if (prog == hstr->handler_prog) {
04327                                                 output_perform_call (hstr->handler_label,
04328                                                                      hstr->handler_label);
04329                                         } else {
04330                                                 if (cb_flag_traceall) {
04331                                                         output_line ("cob_reset_trace ();");
04332                                                 }
04333                                                 output_prefix ();
04334                                                 output ("%s_ (%d",
04335                                                         hstr->handler_prog->program_id,
04336                                                         hstr->handler_label->id);
04337                                                 parmnum = cb_list_length (hstr->handler_prog->parameter_list);
04338                                                 for (n = 0; n < parmnum; n++) {
04339                                                         output (", NULL");
04340                                                 }
04341                                                 output (");\n");
04342                                                 if (cb_flag_traceall) {
04343                                                         output_line ("cob_ready_trace ();");
04344                                                 }
04345                                         }
04346                                         output_line ("break;");
04347                                         output_indent ("}");
04348                                 }
04349                         }
04350                         output_line ("default:");
04351                         output_indent ("{");
04352                 }
04353                 output_line ("if (!(cob_error_file->flag_select_features & COB_SELECT_FILE_STATUS)) {");
04354                 output_line ("  cob_default_error_handle ();");
04355                 output_line ("  cob_stop_run (1);");
04356                 output_line ("}");
04357                 if (seen) {
04358                         output_line ("break;");
04359                         output_indent ("}");
04360                         output_indent ("}");
04361                 }
04362                 output_perform_exit (CB_LABEL (cb_standard_error_handler));
04363                 output_newline ();
04364                 output_line ("cob_fatal_error (COB_FERROR_CODEGEN);");
04365                 output_newline ();
04366         }
04367 #ifndef __GNUC__
04368         output_newline ();
04369         output_line ("/* Frame stack jump table */");
04370         output_line ("P_switch:");
04371         if (label_cache) {
04372                 output_line (" switch (frame_ptr->return_address) {");
04373                 for (pl = label_cache; pl; pl = pl->next) {
04374                         output_line (" case %d:", pl->call_num);
04375                         output_line ("   goto %s%d;", CB_PREFIX_LABEL, pl->id);
04376                 }
04377                 output_line (" }");
04378         }
04379         output_line (" cob_fatal_error (COB_FERROR_CODEGEN);");
04380         output_newline ();
04381 #endif
04382 
04383         if (has_external) {
04384                 output_newline ();
04385                 output_line ("/* EXTERNAL data initialization */");
04386                 output_line ("L_initextern: ;");
04387                 for (k = field_cache; k; k = k->next) {
04388                         if (k->f->flag_item_external) {
04389                                 output_prefix ();
04390                                 output ("\t%s%d.data = ", CB_PREFIX_FIELD, k->f->id);
04391                                 output_data (k->x);
04392                                 output (";\n");
04393                         }
04394                 }
04395                 output_line ("\tgoto LRET_initextern;");
04396         }
04397 
04398         output_indent ("}");
04399         output_newline ();
04400 }
04401 
04402 static void
04403 output_entry_function (struct cb_program *prog, cb_tree entry,
04404                        cb_tree parameter_list, const int gencode)
04405 {
04406 
04407         const unsigned char     *entry_name;
04408         cb_tree                 using_list;
04409         cb_tree                 l, l1, l2;
04410         struct cb_field         *f;
04411         int                     parmnum;
04412 
04413         entry_name = CB_LABEL (CB_PURPOSE (entry))->name;
04414         using_list = CB_VALUE (entry);
04415 #ifdef  _MSC_VER
04416         if (!gencode) {
04417                 output ("__declspec(dllexport) ");
04418         }
04419 #endif
04420         output ("int");
04421         if (gencode) {
04422                 output ("\n");
04423         } else {
04424                 output (" ");
04425         }
04426         output ("%s (", entry_name);
04427         if (prog->flag_chained) {
04428                 using_list = NULL;
04429                 parameter_list = NULL;
04430         }
04431         if (!gencode && !using_list) {
04432                 output ("void);\n");
04433                 return;
04434         }
04435         parmnum = 0;
04436         for (l = using_list; l; l = CB_CHAIN (l), parmnum++) {
04437                 f = cb_field (CB_VALUE (l));
04438                 switch (CB_PURPOSE_INT (l)) {
04439                 case CB_CALL_BY_VALUE:
04440                         if (CB_TREE_CLASS (CB_VALUE (l)) == CB_CLASS_NUMERIC) {
04441                                 if (CB_SIZES(l) & CB_SIZE_UNSIGNED) {
04442                                         output ("unsigned ");
04443                                 }
04444                                 switch (CB_SIZES_INT (l)) {
04445                                 case CB_SIZE_1:
04446                                         if (gencode) {
04447                                                 output ("char i_%d", f->id);
04448                                         } else {
04449                                                 output ("char");
04450                                         }
04451                                         break;
04452                                 case CB_SIZE_2:
04453                                         if (gencode) {
04454                                                 output ("short i_%d", f->id);
04455                                         } else {
04456                                                 output ("short");
04457                                         }
04458                                         break;
04459                                 case CB_SIZE_4:
04460                                         if (gencode) {
04461                                                 output ("int i_%d", f->id);
04462                                         } else {
04463                                                 output ("int");
04464                                         }
04465                                         break;
04466                                 case CB_SIZE_8:
04467                                         if (gencode) {
04468                                                 output ("long long i_%d", f->id);
04469                                         } else {
04470                                                 output ("long long");
04471                                         }
04472                                         break;
04473                                 }
04474 /* RXW
04475                                 if (!f->pic->have_sign) {
04476                                         output ("unsigned ");
04477                                 }
04478                                 if (gencode) {
04479                                         output ("int i_%d", f->id);
04480                                 } else {
04481                                         output ("int");
04482                                 }
04483 */
04484                                 break;
04485                         }
04486                         /* Fall through */
04487                 case CB_CALL_BY_REFERENCE:
04488                 case CB_CALL_BY_CONTENT:
04489                         if (gencode) {
04490                                 output ("unsigned char *%s%d", CB_PREFIX_BASE, f->id);
04491                         } else {
04492                                 output ("unsigned char *");
04493                         }
04494                         break;
04495                 }
04496                 if (CB_CHAIN (l)) {
04497                         output (", ");
04498                 }
04499         }
04500         if (gencode) {
04501                 output (")\n");
04502         } else {
04503                 output (");\n");
04504                 return;
04505         }
04506         output ("{\n");
04507         for (l1 = parameter_list; l1; l1 = CB_CHAIN (l1)) {
04508                 for (l2 = using_list; l2; l2 = CB_CHAIN (l2)) {
04509                         if (strcasecmp (cb_field (CB_VALUE (l1))->name,
04510                                         cb_field (CB_VALUE (l2))->name) == 0) {
04511                                 f = cb_field (CB_VALUE (l2));
04512                                 if (CB_PURPOSE_INT (l2) == CB_CALL_BY_VALUE &&
04513                                     (f->usage == CB_USAGE_POINTER ||
04514                                      f->usage == CB_USAGE_PROGRAM_POINTER)) {
04515                                         output ("  unsigned char *ptr_%d = %s%d;\n",
04516                                                 f->id, CB_PREFIX_BASE, f->id);
04517                                 }
04518                         }
04519                 }
04520         }
04521         output ("  return %s_ (%d", prog->program_id, progid++);
04522         for (l1 = parameter_list; l1; l1 = CB_CHAIN (l1)) {
04523                 for (l2 = using_list; l2; l2 = CB_CHAIN (l2)) {
04524                         if (strcasecmp (cb_field (CB_VALUE (l1))->name,
04525                                         cb_field (CB_VALUE (l2))->name) == 0) {
04526                                 f = cb_field (CB_VALUE (l2));
04527                                 switch (CB_PURPOSE_INT (l2)) {
04528                                 case CB_CALL_BY_VALUE:
04529                                         if (f->usage == CB_USAGE_POINTER ||
04530                                             f->usage == CB_USAGE_PROGRAM_POINTER) {
04531                                                 output (", (unsigned char *)&ptr_%d", f->id);
04532                                                 break;
04533                                         } else if (CB_TREE_CLASS (CB_VALUE (l2)) == CB_CLASS_NUMERIC) {
04534                                                 output (", (unsigned char *)&i_%d", f->id);
04535                                                 break;
04536                                         }
04537                                         /* Fall through */
04538                                 case CB_CALL_BY_REFERENCE:
04539                                 case CB_CALL_BY_CONTENT:
04540                                         output (", %s%d", CB_PREFIX_BASE, f->id);
04541                                         break;
04542                                 }
04543                                 break;
04544                         }
04545                 }
04546                 if (l2 == NULL) {
04547                         output (", NULL");
04548                 }
04549         }
04550         output (");\n");
04551         output ("}\n\n");
04552 }
04553 
04554 static void
04555 output_main_function (struct cb_program *prog)
04556 {
04557         output_line ("/* Main function */");
04558         output_line ("int");
04559         output_line ("main (int argc, char **argv)");
04560         output_indent ("{");
04561         output_line ("cob_init (argc, argv);");
04562         output_line ("cob_stop_run (%s ());", prog->program_id);
04563         output_indent ("}\n");
04564 }
04565 
04566 static void
04567 output_header (FILE *fp, const char *locbuff)
04568 {
04569         int     i;
04570 
04571         if (fp) {
04572                 fprintf (fp, "/* Generated by            cobc %s.%d */\n",
04573                         PACKAGE_VERSION, PATCH_LEVEL);
04574                 fprintf (fp, "/* Generated from          %s */\n", cb_source_file);
04575                 fprintf (fp, "/* Generated at            %s */\n", locbuff);
04576                 fprintf (fp, "/* OpenCOBOL build date    %s */\n", cb_oc_build_stamp);
04577                 fprintf (fp, "/* OpenCOBOL package date  %s */\n", octardate);
04578                 fprintf (fp, "/* Compile command         ");
04579                 for (i = 0; i < cb_saveargc; i++) {
04580                         fprintf (fp, "%s ", cb_saveargv[i]);
04581                 }
04582                 fprintf (fp, "*/\n\n");
04583         }
04584 }
04585 
04586 static int field_cache_cmp (void *mp1, void *mp2) {
04587         struct field_list       *fl1;
04588         struct field_list       *fl2;
04589         int                     ret;
04590 
04591         fl1 = (struct field_list *)mp1;
04592         fl2 = (struct field_list *)mp2;
04593         ret = strcasecmp (fl1->curr_prog, fl2->curr_prog);
04594         if (ret) {
04595                 return ret;
04596         }
04597         return fl1->f->id - fl2->f->id;
04598 }
04599 
04600 static int base_cache_cmp (void *mp1, void *mp2) {
04601         struct base_list        *fl1;
04602         struct base_list        *fl2;
04603 
04604         fl1 = (struct base_list *)mp1;
04605         fl2 = (struct base_list *)mp2;
04606         return fl1->f->id - fl2->f->id;
04607 }
04608 
04609 /* Sort a structure linked list in place */
04610 /* Assumed that "next" is first item in structure */
04611 static void *
04612 list_cache_sort (void *inlist, int (*cmpfunc)(void *mp1, void *mp2))
04613 {
04614         struct sort_list        *p;
04615         struct sort_list        *q;
04616         struct sort_list        *e;
04617         struct sort_list        *tail;
04618         struct sort_list        *list;
04619         int                     insize;
04620         int                     nmerges;
04621         int                     psize;
04622         int                     qsize;
04623         int                     i;
04624 
04625         if (!inlist) {
04626                 return NULL;
04627         }
04628         list = (struct sort_list *)inlist;
04629         insize = 1;
04630         while (1) {
04631                 p = list;
04632                 list = NULL;
04633                 tail = NULL;
04634                 nmerges = 0;
04635                 while (p) {
04636                         nmerges++;
04637                         q = p;
04638                         psize = 0;
04639                         for (i = 0; i < insize; i++) {
04640                                 psize++;
04641                                 q = q->next;
04642                                 if (!q) {
04643                                         break;
04644                                 }
04645                         }
04646                         qsize = insize;
04647                         while (psize > 0 || (qsize > 0 && q)) {
04648                                 if (psize == 0) {
04649                                         e = q;
04650                                         q = q->next;
04651                                         qsize--;
04652                                 } else if (qsize == 0 || !q) {
04653                                         e = p;
04654                                         p = p->next;
04655                                         psize--;
04656                                 } else if ((*cmpfunc) (p, q) <= 0) {
04657                                         e = p;
04658                                         p = p->next;
04659                                         psize--;
04660                                 } else {
04661                                         e = q;
04662                                         q = q->next;
04663                                         qsize--;
04664                                 }
04665                                 if (tail) {
04666                                         tail->next = e;
04667                                 } else {
04668                                         list = e;
04669                                 }
04670                                 tail = e;
04671                         }
04672                         p = q;
04673                 }
04674                 tail->next = NULL;
04675                 if (nmerges <= 1) {
04676                         return (void *)list;
04677                 }
04678                 insize *= 2;
04679         }
04680 }
04681 
04682 void
04683 codegen (struct cb_program *prog, int nested)
04684 {
04685         int                     i;
04686         cb_tree                 l;
04687         struct attr_list        *j;
04688         struct literal_list     *m;
04689         struct field_list       *k;
04690         struct call_list        *clp;
04691         struct base_list        *blp;
04692         unsigned char           *s;
04693         struct cb_program       *cp;
04694         cb_tree                 l1;
04695         cb_tree                 l2;
04696         const char              *prevprog;
04697         time_t                  loctime;
04698         char                    locbuff[48];
04699 
04700         current_prog = prog;
04701         param_id = 0;
04702         stack_id = 0;
04703         num_cob_fields = 0;
04704         progid = 0;
04705         loop_counter = 0;
04706         output_indent_level = 0;
04707         last_line = 0;
04708         needs_exit_prog = 0;
04709         gen_custom = 0;
04710         call_cache = NULL;
04711         label_cache = NULL;
04712         local_cache = NULL;
04713         excp_current_program_id = prog->orig_source_name;
04714         excp_current_section = NULL;
04715         excp_current_paragraph = NULL;
04716         memset ((char *)i_counters, 0, sizeof (i_counters));
04717 
04718         output_target = yyout;
04719 
04720         if (!nested) {
04721                 gen_ebcdic = 0;
04722                 gen_ebcdic_ascii = 0;
04723                 gen_full_ebcdic = 0;
04724                 gen_native = 0;
04725                 attr_cache = NULL;
04726                 base_cache = NULL;
04727                 literal_cache = NULL;
04728                 field_cache = NULL;
04729 
04730                 loctime = time (NULL);
04731                 strftime (locbuff, sizeof(locbuff) - 1, "%b %d %Y %H:%M:%S %Z",
04732                         localtime (&loctime));
04733                 output_header (output_target, locbuff);
04734                 output_header (cb_storage_file, locbuff);
04735                 for (cp = prog; cp; cp = cp->next_program) {
04736                         output_header (cp->local_storage_file, locbuff);
04737                 }
04738 
04739                 output_storage ("/* Frame stack declaration */\n");
04740                 output_storage ("struct cob_frame {\n");
04741                 output_storage ("\tint\tperform_through;\n");
04742 #ifndef __GNUC__
04743                 output_storage ("\tint\treturn_address;\n");
04744 #elif   COB_USE_SETJMP
04745                 output_storage ("\tjmp_buf\treturn_address;\n");
04746 #else
04747                 output_storage ("\tvoid\t*return_address;\n");
04748 #endif
04749                 output_storage ("};\n\n");
04750                 output_storage ("/* Union for CALL statement */\n");
04751                 output_storage ("union cob_call_union {\n");
04752                 output_storage ("\tvoid *(*funcptr)();\n");
04753                 output_storage ("\tint  (*funcint)();\n");
04754                 output_storage ("\tvoid *func_void;\n");
04755                 output_storage ("};\n");
04756                 output_storage ("union cob_call_union\tcob_unifunc;\n\n");
04757 
04758                 output ("#define  __USE_STRING_INLINES 1\n");
04759 #ifdef  _XOPEN_SOURCE_EXTENDED
04760                 output ("#ifndef        _XOPEN_SOURCE_EXTENDED\n");
04761                 output ("#define  _XOPEN_SOURCE_EXTENDED 1\n");
04762                 output ("#endif\n");
04763 #endif
04764                 output ("#include <stdio.h>\n");
04765                 output ("#include <stdlib.h>\n");
04766                 output ("#include <string.h>\n");
04767                 output ("#include <math.h>\n");
04768 #if     COB_USE_SETJMP
04769                 output ("#include <setjmp.h>\n");
04770 #endif
04771 #ifdef  WORDS_BIGENDIAN
04772                 output ("#define WORDS_BIGENDIAN 1\n");
04773 #endif
04774 #ifdef  HAVE_BUILTIN_EXPECT
04775                 output ("#define HAVE_BUILTIN_EXPECT\n");
04776 #endif
04777                 if (optimize_flag) {
04778                         output ("#define COB_LOCAL_INLINE\n");
04779                 }
04780                 output ("#include <libcob.h>\n\n");
04781 
04782                 output ("#define COB_SOURCE_FILE                \"%s\"\n", cb_source_file);
04783                 output ("#define COB_PACKAGE_VERSION    \"%s\"\n", PACKAGE_VERSION);
04784                 output ("#define COB_PATCH_LEVEL                %d\n\n", PATCH_LEVEL);
04785                 output ("/* Global variables */\n");
04786                 output ("#include \"%s\"\n\n", cb_storage_file_name);
04787 
04788                 for (cp = prog; cp; cp = cp->next_program) {
04789                         if (cp->gen_decset) {
04790                                 output("static void\n");
04791                                 output("cob_decimal_set_int (cob_decimal *d, const int n)\n");
04792                                 output("{\n");
04793                                 output("        mpz_set_si (d->value, n);\n");
04794                                 output("        d->scale = 0;\n");
04795                                 output("}\n\n");
04796                                 break;
04797                         }
04798                 }
04799                 for (cp = prog; cp; cp = cp->next_program) {
04800                         if (cp->gen_udecset) {
04801                                 output("static void\n");
04802                                 output("cob_decimal_set_uint (cob_decimal *d, const unsigned int n)\n");
04803                                 output("{\n");
04804                                 output("        mpz_set_ui (d->value, n);\n");
04805                                 output("        d->scale = 0;\n");
04806                                 output("}\n\n");
04807                                 break;
04808                         }
04809                 }
04810                 for (cp = prog; cp; cp = cp->next_program) {
04811                         if (cp->gen_ptrmanip) {
04812                                 output("static void\n");
04813                                 output("cob_pointer_manip (cob_field *f1, cob_field *f2, size_t addsub)\n");
04814                                 output("{\n");
04815                                 output("        unsigned char   *tmptr;\n");
04816                                 output("        memcpy (&tmptr, f1->data, sizeof(void *));\n");
04817                                 output("        if (addsub) {\n");
04818                                 output("                tmptr -= cob_get_int (f2);\n");
04819                                 output("        } else {\n");
04820                                 output("                tmptr += cob_get_int (f2);\n");
04821                                 output("        }\n");
04822                                 output("        memcpy (f1->data, &tmptr, sizeof(void *));\n");
04823                                 output("}\n\n");
04824                                 break;
04825                         }
04826                 }
04827                 output ("/* Function prototypes */\n\n");
04828                 for (cp = prog; cp; cp = cp->next_program) {
04829                         /* Build parameter list */
04830                         for (l = cp->entry_list; l; l = CB_CHAIN (l)) {
04831                                 for (l1 = CB_VALUE (l); l1; l1 = CB_CHAIN (l1)) {
04832                                         for (l2 = cp->parameter_list; l2; l2 = CB_CHAIN (l2)) {
04833                                                 if (strcasecmp (cb_field (CB_VALUE (l1))->name,
04834                                                                 cb_field (CB_VALUE (l2))->name) == 0) {
04835                                                         break;
04836                                                 }
04837                                         }
04838                                         if (l2 == NULL) {
04839                                                 cp->parameter_list = cb_list_add (cp->parameter_list, CB_VALUE (l1));
04840                                         }
04841                                 }
04842                         }
04843                         if (cp->flag_main) {
04844                                 output ("int %s ();\n", cp->program_id);
04845                         } else {
04846                                 for (l = cp->entry_list; l; l = CB_CHAIN (l)) {
04847                                         output_entry_function (cp, l, cp->parameter_list, 0);
04848                                 }
04849                         }
04850                         output ("static int %s_ (const int", cp->program_id);
04851                         if (!cp->flag_chained) {
04852                                 for (l = cp->parameter_list; l; l = CB_CHAIN (l)) {
04853                                         output (", unsigned char *");
04854                                 }
04855                         }
04856                         output (");\n");
04857                 }
04858                 output ("\n");
04859         }
04860 
04861         /* Class-names */
04862         if (!prog->nested_level && prog->class_name_list) {
04863                 output ("/* Class names */\n");
04864                 for (l = prog->class_name_list; l; l = CB_CHAIN (l)) {
04865                         output_class_name_definition (CB_CLASS_NAME (CB_VALUE (l)));
04866                 }
04867         }
04868 
04869         /* Main function */
04870         if (prog->flag_main) {
04871                 output_main_function (prog);
04872         }
04873 
04874         /* Functions */
04875         if (!nested) {
04876                 output ("/* Functions */\n\n");
04877         }
04878         for (l = prog->entry_list; l; l = CB_CHAIN (l)) {
04879                 output_entry_function (prog, l, prog->parameter_list, 1);
04880         }
04881         output_internal_function (prog, prog->parameter_list);
04882 
04883         if (!prog->next_program) {
04884                 output ("/* End functions */\n\n");
04885         }
04886 
04887         if (gen_native || gen_full_ebcdic || gen_ebcdic_ascii || prog->alphabet_name_list) {
04888                 (void)lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
04889         }
04890 
04891         output_target = cb_storage_file;
04892 
04893         /* Program local stuff */
04894         if (call_cache) {
04895                 output_local ("\n/* Call pointers */\n");
04896                 for (clp = call_cache; clp; clp = clp->next) {
04897                         output_local ("static union cob_call_union\tcall_%s = { NULL };\n", clp->callname);
04898                 }
04899                 output_local ("\n");
04900         }
04901 
04902         for (i = 0; i < COB_MAX_SUBSCRIPTS; i++) {
04903                 if (i_counters[i]) {
04904                         output_local ("int\t\ti%d;\n", i);
04905                 }
04906         }
04907 
04908         if (num_cob_fields) {
04909                 output_local ("\n/* Local cob_field items */\n");
04910                 for (i = 0; i < num_cob_fields; i++) {
04911                         output_local ("cob_field\tf%d;\n", i);
04912                 }
04913                 output_local ("\n");
04914         }
04915 
04916         /* Skip to next nested program */
04917 
04918         if (prog->next_program) {
04919                 codegen (prog->next_program, 1);
04920                 return;
04921         }
04922 
04923         /* Finalize the storage file */
04924 
04925         if (base_cache) {
04926                 output_storage ("\n/* Storage */\n");
04927                 base_cache = list_cache_sort (base_cache, &base_cache_cmp);
04928                 prevprog = NULL;
04929                 for (blp = base_cache; blp; blp = blp->next) {
04930                         if (blp->curr_prog != prevprog) {
04931                                 prevprog = blp->curr_prog;
04932                                 output_storage ("\n/* PROGRAM-ID : %s */\n", prevprog);
04933                         }
04934 #ifdef HAVE_ATTRIBUTE_ALIGNED
04935                         output_storage ("static unsigned char %s%d[%d] __attribute__((aligned));",
04936 #else
04937                         output_storage ("static unsigned char %s%d[%d];",
04938 #endif
04939                                         CB_PREFIX_BASE, blp->f->id,
04940                                         blp->f->memory_size);
04941                         output_storage ("\t/* %s */\n", blp->f->name);
04942                 }
04943                 output_storage ("\n/* End of storage */\n\n");
04944         }
04945 
04946         if (attr_cache) {
04947                 output_storage ("\n/* Attributes */\n\n");
04948                 attr_cache = attr_list_reverse (attr_cache);
04949                 for (j = attr_cache; j; j = j->next) {
04950                         output_storage ("static const cob_field_attr %s%d = ",
04951                                         CB_PREFIX_ATTR, j->id);
04952                         output_storage ("{%d, %d, %d, %d, ", j->type, j->digits,
04953                                         j->scale, j->flags);
04954                         if (j->pic) {
04955                                 output_storage ("\"");
04956                                 for (s = j->pic; *s; s += 5) {
04957                                         output_storage ("%c\\%03o\\%03o\\%03o\\%03o",
04958                                                 s[0], s[1], s[2], s[3], s[4]);
04959                                 }
04960                                 output_storage ("\"");
04961                         } else {
04962                                 output_storage ("NULL");
04963                         }
04964                         output_storage ("};\n");
04965                 }
04966         }
04967 
04968         if (field_cache) {
04969                 output_storage ("\n/* Fields */\n");
04970                 field_cache = list_cache_sort (field_cache, &field_cache_cmp);
04971                 prevprog = NULL;
04972                 for (k = field_cache; k; k = k->next) {
04973                         if (k->curr_prog != prevprog) {
04974                                 prevprog = k->curr_prog;
04975                                 output_storage ("\n/* PROGRAM-ID : %s */\n", prevprog);
04976                         }
04977                         output ("static cob_field %s%d\t= ", CB_PREFIX_FIELD, k->f->id);
04978                         if (!k->f->flag_local && !k->f->flag_item_external) {
04979                                 output_field (k->x);
04980                         } else {
04981                                 output ("{");
04982                                 output_size (k->x);
04983                                 output (", NULL, ");
04984                                 output_attr (k->x);
04985                                 output ("}");
04986                         }
04987                         output (";\t/* %s */\n", k->f->name);
04988                 }
04989                 output_storage ("\n/* End of fields */\n\n");
04990         }
04991         if (literal_cache) {
04992                 output_storage ("/* Constants */\n");
04993                 literal_cache = literal_list_reverse (literal_cache);
04994                 for (m = literal_cache; m; m = m->next) {
04995                         output ("static cob_field %s%d\t= ", CB_PREFIX_CONST, m->id);
04996                         output_field (m->x);
04997                         output (";\n");
04998                 }
04999                 output ("\n");
05000         }
05001 
05002         if (gen_ebcdic) {
05003                 output_storage ("/* EBCDIC translate table */\n");
05004                 output ("static const unsigned char\tcob_a2e[256] = {\n");
05005                 if (alt_ebcdic) {
05006                         output ("\t0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F,\n");
05007                         output ("\t0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
05008                         output ("\t0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26,\n");
05009                         output ("\t0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,\n");
05010                         output ("\t0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D,\n");
05011                         output ("\t0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,\n");
05012                         output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
05013                         output ("\t0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,\n");
05014                         output ("\t0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
05015                         output ("\t0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,\n");
05016                         output ("\t0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6,\n");
05017                         output ("\t0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,\n");
05018                         output ("\t0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
05019                         output ("\t0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,\n");
05020                         output ("\t0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6,\n");
05021                         output ("\t0xA7, 0xA8, 0xA9, 0xC0, 0x6A, 0xD0, 0xA1, 0x07,\n");
05022                         output ("\t0x68, 0xDC, 0x51, 0x42, 0x43, 0x44, 0x47, 0x48,\n");
05023                         output ("\t0x52, 0x53, 0x54, 0x57, 0x56, 0x58, 0x63, 0x67,\n");
05024                         output ("\t0x71, 0x9C, 0x9E, 0xCB, 0xCC, 0xCD, 0xDB, 0xDD,\n");
05025                         output ("\t0xDF, 0xEC, 0xFC, 0xB0, 0xB1, 0xB2, 0x3E, 0xB4,\n");
05026                         output ("\t0x45, 0x55, 0xCE, 0xDE, 0x49, 0x69, 0x9A, 0x9B,\n");
05027                         output ("\t0xAB, 0x9F, 0xBA, 0xB8, 0xB7, 0xAA, 0x8A, 0x8B,\n");
05028                         output ("\t0xB6, 0xB5, 0x62, 0x4F, 0x64, 0x65, 0x66, 0x20,\n");
05029                         output ("\t0x21, 0x22, 0x70, 0x23, 0x72, 0x73, 0x74, 0xBE,\n");
05030                         output ("\t0x76, 0x77, 0x78, 0x80, 0x24, 0x15, 0x8C, 0x8D,\n");
05031                         output ("\t0x8E, 0x41, 0x06, 0x17, 0x28, 0x29, 0x9D, 0x2A,\n");
05032                         output ("\t0x2B, 0x2C, 0x09, 0x0A, 0xAC, 0x4A, 0xAE, 0xAF,\n");
05033                         output ("\t0x1B, 0x30, 0x31, 0xFA, 0x1A, 0x33, 0x34, 0x35,\n");
05034                         output ("\t0x36, 0x59, 0x08, 0x38, 0xBC, 0x39, 0xA0, 0xBF,\n");
05035                         output ("\t0xCA, 0x3A, 0xFE, 0x3B, 0x04, 0xCF, 0xDA, 0x14,\n");
05036                         output ("\t0xE1, 0x8F, 0x46, 0x75, 0xFD, 0xEB, 0xEE, 0xED,\n");
05037                         output ("\t0x90, 0xEF, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF\n");
05038                 } else {
05039                         /* MF */
05040                         output ("\t0x00, 0x01, 0x02, 0x03, 0x1D, 0x19, 0x1A, 0x1B,\n");
05041                         output ("\t0x0F, 0x04, 0x16, 0x06, 0x07, 0x08, 0x09, 0x0A,\n");
05042                         output ("\t0x0B, 0x0C, 0x0D, 0x0E, 0x1E, 0x1F, 0x1C, 0x17,\n");
05043                         output ("\t0x10, 0x11, 0x20, 0x18, 0x12, 0x13, 0x14, 0x15,\n");
05044                         output ("\t0x21, 0x27, 0x3A, 0x36, 0x28, 0x30, 0x26, 0x38,\n");
05045                         output ("\t0x24, 0x2A, 0x29, 0x25, 0x2F, 0x2C, 0x22, 0x2D,\n");
05046                         output ("\t0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A,\n");
05047                         output ("\t0x7B, 0x7C, 0x35, 0x2B, 0x23, 0x39, 0x32, 0x33,\n");
05048                         output ("\t0x37, 0x57, 0x58, 0x59, 0x5A, 0x5B, 0x5C, 0x5D,\n");
05049                         output ("\t0x5E, 0x5F, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66,\n");
05050                         output ("\t0x67, 0x68, 0x69, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F,\n");
05051                         output ("\t0x70, 0x71, 0x72, 0x7D, 0x6A, 0x7E, 0x7F, 0x31,\n");
05052                         output ("\t0x34, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F, 0x40, 0x41,\n");
05053                         output ("\t0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,\n");
05054                         output ("\t0x4A, 0x4B, 0x4C, 0x4E, 0x4F, 0x50, 0x51, 0x52,\n");
05055                         output ("\t0x53, 0x54, 0x55, 0x56, 0x2E, 0x60, 0x4D, 0x05,\n");
05056                         output ("\t0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
05057                         output ("\t0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x8D, 0x8E, 0x8F,\n");
05058                         output ("\t0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97,\n");
05059                         output ("\t0x98, 0x99, 0x9A, 0x9B, 0x9C, 0x9D, 0x9E, 0x9F,\n");
05060                         output ("\t0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7,\n");
05061                         output ("\t0xA8, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF,\n");
05062                         output ("\t0xB0, 0xB1, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7,\n");
05063                         output ("\t0xB8, 0xB9, 0xBA, 0xBB, 0xBC, 0xBD, 0xBE, 0xBF,\n");
05064                         output ("\t0xC0, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
05065                         output ("\t0xC8, 0xC9, 0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF,\n");
05066                         output ("\t0xD0, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7,\n");
05067                         output ("\t0xD8, 0xD9, 0xDA, 0xDB, 0xDC, 0xDD, 0xDE, 0xDF,\n");
05068                         output ("\t0xE0, 0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7,\n");
05069                         output ("\t0xE8, 0xE9, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF,\n");
05070                         output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
05071                         output ("\t0xF8, 0xF9, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE, 0xFF\n");
05072                 }
05073                 output ("};\n");
05074                 output_storage ("\n");
05075         }
05076         if (gen_full_ebcdic) {
05077                 output ("static const unsigned char\tcob_ebcdic[256] = {\n");
05078                 output ("\t0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F,\n");
05079                 output ("\t0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
05080                 output ("\t0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26,\n");
05081                 output ("\t0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,\n");
05082                 output ("\t0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D,\n");
05083                 output ("\t0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,\n");
05084                 output ("\t0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,\n");
05085                 output ("\t0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,\n");
05086                 output ("\t0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,\n");
05087                 output ("\t0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,\n");
05088                 output ("\t0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6,\n");
05089                 output ("\t0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,\n");
05090                 output ("\t0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,\n");
05091                 output ("\t0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,\n");
05092                 output ("\t0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6,\n");
05093                 output ("\t0xA7, 0xA8, 0xA9, 0xC0, 0x6A, 0xD0, 0xA1, 0x07,\n");
05094                 output ("\t0x68, 0xDC, 0x51, 0x42, 0x43, 0x44, 0x47, 0x48,\n");
05095                 output ("\t0x52, 0x53, 0x54, 0x57, 0x56, 0x58, 0x63, 0x67,\n");
05096                 output ("\t0x71, 0x9C, 0x9E, 0xCB, 0xCC, 0xCD, 0xDB, 0xDD,\n");
05097                 output ("\t0xDF, 0xEC, 0xFC, 0xB0, 0xB1, 0xB2, 0x3E, 0xB4,\n");
05098                 output ("\t0x45, 0x55, 0xCE, 0xDE, 0x49, 0x69, 0x9A, 0x9B,\n");
05099                 output ("\t0xAB, 0x9F, 0xBA, 0xB8, 0xB7, 0xAA, 0x8A, 0x8B,\n");
05100                 output ("\t0xB6, 0xB5, 0x62, 0x4F, 0x64, 0x65, 0x66, 0x20,\n");
05101                 output ("\t0x21, 0x22, 0x70, 0x23, 0x72, 0x73, 0x74, 0xBE,\n");
05102                 output ("\t0x76, 0x77, 0x78, 0x80, 0x24, 0x15, 0x8C, 0x8D,\n");
05103                 output ("\t0x8E, 0x41, 0x06, 0x17, 0x28, 0x29, 0x9D, 0x2A,\n");
05104                 output ("\t0x2B, 0x2C, 0x09, 0x0A, 0xAC, 0x4A, 0xAE, 0xAF,\n");
05105                 output ("\t0x1B, 0x30, 0x31, 0xFA, 0x1A, 0x33, 0x34, 0x35,\n");
05106                 output ("\t0x36, 0x59, 0x08, 0x38, 0xBC, 0x39, 0xA0, 0xBF,\n");
05107                 output ("\t0xCA, 0x3A, 0xFE, 0x3B, 0x04, 0xCF, 0xDA, 0x14,\n");
05108                 output ("\t0xE1, 0x8F, 0x46, 0x75, 0xFD, 0xEB, 0xEE, 0xED,\n");
05109                 output ("\t0x90, 0xEF, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF\n");
05110                 output ("};\n");
05111                 i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
05112                 output
05113                     ("static cob_field f_ebcdic = { 256, (unsigned char *)cob_ebcdic, &%s%d };\n",
05114                      CB_PREFIX_ATTR, i);
05115                 output_storage ("\n");
05116         }
05117         if (gen_ebcdic_ascii) {
05118                 output ("static const unsigned char\tcob_ebcdic_ascii[256] = {\n");
05119                 output ("\t0x00, 0x01, 0x02, 0x03, 0xEC, 0x09, 0xCA, 0x7F,\n");
05120                 output ("\t0xE2, 0xD2, 0xD3, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,\n");
05121                 output ("\t0x10, 0x11, 0x12, 0x13, 0xEF, 0xC5, 0x08, 0xCB,\n");
05122                 output ("\t0x18, 0x19, 0xDC, 0xD8, 0x1C, 0x1D, 0x1E, 0x1F,\n");
05123                 output ("\t0xB7, 0xB8, 0xB9, 0xBB, 0xC4, 0x0A, 0x17, 0x1B,\n");
05124                 output ("\t0xCC, 0xCD, 0xCF, 0xD0, 0xD1, 0x05, 0x06, 0x07,\n");
05125                 output ("\t0xD9, 0xDA, 0x16, 0xDD, 0xDE, 0xDF, 0xE0, 0x04,\n");
05126                 output ("\t0xE3, 0xE5, 0xE9, 0xEB, 0x14, 0x15, 0x9E, 0x1A,\n");
05127                 output ("\t0x20, 0xC9, 0x83, 0x84, 0x85, 0xA0, 0xF2, 0x86,\n");
05128                 output ("\t0x87, 0xA4, 0xD5, 0x2E, 0x3C, 0x28, 0x2B, 0xB3,\n");
05129                 output ("\t0x26, 0x82, 0x88, 0x89, 0x8A, 0xA1, 0x8C, 0x8B,\n");
05130                 output ("\t0x8D, 0xE1, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x5E,\n");
05131                 output ("\t0x2D, 0x2F, 0xB2, 0x8E, 0xB4, 0xB5, 0xB6, 0x8F,\n");
05132                 output ("\t0x80, 0xA5, 0x7C, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,\n");
05133                 output ("\t0xBA, 0x90, 0xBC, 0xBD, 0xBE, 0xF3, 0xC0, 0xC1,\n");
05134                 output ("\t0xC2, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,\n");
05135                 output ("\t0xC3, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,\n");
05136                 output ("\t0x68, 0x69, 0xAE, 0xAF, 0xC6, 0xC7, 0xC8, 0xF1,\n");
05137                 output ("\t0xF8, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70,\n");
05138                 output ("\t0x71, 0x72, 0xA6, 0xA7, 0x91, 0xCE, 0x92, 0xA9,\n");
05139                 output ("\t0xE6, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78,\n");
05140                 output ("\t0x79, 0x7A, 0xAD, 0xA8, 0xD4, 0x5B, 0xD6, 0xD7,\n");
05141                 output ("\t0x9B, 0x9C, 0x9D, 0xFA, 0x9F, 0xB1, 0xB0, 0xAC,\n");
05142                 output ("\t0xAB, 0xFC, 0xAA, 0xFE, 0xE4, 0x5D, 0xBF, 0xE7,\n");
05143                 output ("\t0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47,\n");
05144                 output ("\t0x48, 0x49, 0xE8, 0x93, 0x94, 0x95, 0xA2, 0xED,\n");
05145                 output ("\t0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50,\n");
05146                 output ("\t0x51, 0x52, 0xEE, 0x96, 0x81, 0x97, 0xA3, 0x98,\n");
05147                 output ("\t0x5C, 0xF0, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,\n");
05148                 output ("\t0x59, 0x5A, 0xFD, 0xF5, 0x99, 0xF7, 0xF6, 0xF9,\n");
05149                 output ("\t0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,\n");
05150                 output ("\t0x38, 0x39, 0xDB, 0xFB, 0x9A, 0xF4, 0xEA, 0xFF\n");
05151                 output ("};\n");
05152                 i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
05153                 output
05154                     ("static cob_field f_ebcdic_ascii = { 256, (unsigned char *)cob_ebcdic_ascii, &%s%d };\n",
05155                      CB_PREFIX_ATTR, i);
05156                 output_storage ("\n");
05157         }
05158         if (gen_native) {
05159                 output ("static const unsigned char\tcob_native[256] = {\n");
05160                 output ("\t0, 1, 2, 3, 4, 5, 6, 7,\n");
05161                 output ("\t8, 9, 10, 11, 12, 13, 14, 15,\n");
05162                 output ("\t16, 17, 18, 19, 20, 21, 22, 23,\n");
05163                 output ("\t24, 25, 26, 27, 28, 29, 30, 31,\n");
05164                 output ("\t32, 33, 34, 35, 36, 37, 38, 39,\n");
05165                 output ("\t40, 41, 42, 43, 44, 45, 46, 47,\n");
05166                 output ("\t48, 49, 50, 51, 52, 53, 54, 55,\n");
05167                 output ("\t56, 57, 58, 59, 60, 61, 62, 63,\n");
05168                 output ("\t64, 65, 66, 67, 68, 69, 70, 71,\n");
05169                 output ("\t72, 73, 74, 75, 76, 77, 78, 79,\n");
05170                 output ("\t80, 81, 82, 83, 84, 85, 86, 87,\n");
05171                 output ("\t88, 89, 90, 91, 92, 93, 94, 95,\n");
05172                 output ("\t96, 97, 98, 99, 100, 101, 102, 103,\n");
05173                 output ("\t104, 105, 106, 107, 108, 109, 110, 111,\n");
05174                 output ("\t112, 113, 114, 115, 116, 117, 118, 119,\n");
05175                 output ("\t120, 121, 122, 123, 124, 125, 126, 127,\n");
05176                 output ("\t128, 129, 130, 131, 132, 133, 134, 135,\n");
05177                 output ("\t136, 137, 138, 139, 140, 141, 142, 143,\n");
05178                 output ("\t144, 145, 146, 147, 148, 149, 150, 151,\n");
05179                 output ("\t152, 153, 154, 155, 156, 157, 158, 159,\n");
05180                 output ("\t160, 161, 162, 163, 164, 165, 166, 167,\n");
05181                 output ("\t168, 169, 170, 171, 172, 173, 174, 175,\n");
05182                 output ("\t176, 177, 178, 179, 180, 181, 182, 183,\n");
05183                 output ("\t184, 185, 186, 187, 188, 189, 190, 191,\n");
05184                 output ("\t192, 193, 194, 195, 196, 197, 198, 199,\n");
05185                 output ("\t200, 201, 202, 203, 204, 205, 206, 207,\n");
05186                 output ("\t208, 209, 210, 211, 212, 213, 214, 215,\n");
05187                 output ("\t216, 217, 218, 219, 220, 221, 222, 223,\n");
05188                 output ("\t224, 225, 226, 227, 228, 229, 230, 231,\n");
05189                 output ("\t232, 233, 234, 235, 236, 237, 238, 239,\n");
05190                 output ("\t240, 241, 242, 243, 244, 245, 246, 247,\n");
05191                 output ("\t248, 249, 250, 251, 252, 253, 254, 255\n");
05192                 output ("};\n");
05193                 i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0);
05194                 output
05195                     ("static cob_field f_native = { 256, (unsigned char *)cob_native, &%s%d };\n",
05196                      CB_PREFIX_ATTR, i);
05197                 output_storage ("\n");
05198         }
05199 }
 All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Defines