OpenCOBOL 1.1pre-rel
|
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 }