00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024 #include "defs.h"
00025 #include "output.h"
00026 #include "names.h"
00027 #include "iob.h"
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037
00038
00039
00040
00041
00042
00043
00044
00045
00046
00047
00048
00049
00050
00051
00052
00053
00054
00055
00056
00057
00058
00059 char *
00060 #ifdef KR_headers
00061 c_type_decl(type, is_extern)
00062 int type;
00063 int is_extern;
00064 #else
00065 c_type_decl(int type, int is_extern)
00066 #endif
00067 {
00068 static char buff[100];
00069
00070 switch (type) {
00071 case TYREAL: if (!is_extern || !forcedouble)
00072 { strcpy (buff, "real");break; }
00073 case TYDREAL: strcpy (buff, "doublereal"); break;
00074 case TYCOMPLEX: if (is_extern)
00075 strcpy (buff, "/* Complex */ VOID");
00076 else
00077 strcpy (buff, "complex");
00078 break;
00079 case TYDCOMPLEX:if (is_extern)
00080 strcpy (buff, "/* Double Complex */ VOID");
00081 else
00082 strcpy (buff, "doublecomplex");
00083 break;
00084 case TYADDR:
00085 case TYINT1:
00086 case TYSHORT:
00087 case TYLONG:
00088 #ifdef TYQUAD
00089 case TYQUAD:
00090 #endif
00091 case TYLOGICAL1:
00092 case TYLOGICAL2:
00093 case TYLOGICAL: strcpy(buff, typename[type]);
00094 break;
00095 case TYCHAR: if (is_extern)
00096 strcpy (buff, "/* Character */ VOID");
00097 else
00098 strcpy (buff, "char");
00099 break;
00100
00101 case TYUNKNOWN: strcpy (buff, "UNKNOWN");
00102
00103
00104
00105 if (!is_extern)
00106 break;
00107
00108
00109
00110
00111 case TYSUBR: strcpy (buff, "/* Subroutine */ int");
00112 break;
00113 case TYERROR: strcpy (buff, "ERROR"); break;
00114 case TYVOID: strcpy (buff, "void"); break;
00115 case TYCILIST: strcpy (buff, "cilist"); break;
00116 case TYICILIST: strcpy (buff, "icilist"); break;
00117 case TYOLIST: strcpy (buff, "olist"); break;
00118 case TYCLLIST: strcpy (buff, "cllist"); break;
00119 case TYALIST: strcpy (buff, "alist"); break;
00120 case TYINLIST: strcpy (buff, "inlist"); break;
00121 case TYFTNLEN: strcpy (buff, "ftnlen"); break;
00122 default: sprintf (buff, "BAD DECL '%d'", type);
00123 break;
00124 }
00125
00126 return buff;
00127 }
00128
00129
00130 char *
00131 new_func_length(Void)
00132 { return "ret_val_len"; }
00133
00134 char *
00135 #ifdef KR_headers
00136 new_arg_length(arg)
00137 Namep arg;
00138 #else
00139 new_arg_length(Namep arg)
00140 #endif
00141 {
00142 static char buf[64];
00143 char *fmt = "%s_len", *s = arg->fvarname;
00144 switch(*s) {
00145 case 'r':
00146 if (!strcmp(s+1, "et_val"))
00147 goto adjust_fmt;
00148 break;
00149 case 'h':
00150 case 'i':
00151 if (!s[1]) {
00152 adjust_fmt:
00153 fmt = "%s_length";
00154 }
00155 }
00156 sprintf (buf, fmt, s);
00157 return buf;
00158 }
00159
00160
00161
00162
00163
00164
00165
00166 void
00167 #ifdef KR_headers
00168 declare_new_addr(addrp)
00169 struct Addrblock *addrp;
00170 #else
00171 declare_new_addr(struct Addrblock *addrp)
00172 #endif
00173 {
00174 extern chainp new_vars;
00175
00176 new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
00177 }
00178
00179
00180 void
00181 #ifdef KR_headers
00182 wr_nv_ident_help(outfile, addrp)
00183 FILE *outfile;
00184 struct Addrblock *addrp;
00185 #else
00186 wr_nv_ident_help(FILE *outfile, struct Addrblock *addrp)
00187 #endif
00188 {
00189 int eltcount = 0;
00190
00191 if (addrp == (struct Addrblock *) NULL)
00192 return;
00193
00194 if (addrp -> isarray) {
00195 frexpr (addrp -> memoffset);
00196 addrp -> memoffset = ICON(0);
00197 eltcount = addrp -> ntempelt;
00198 addrp -> ntempelt = 0;
00199 addrp -> isarray = 0;
00200 }
00201 out_addr (outfile, addrp);
00202 if (eltcount)
00203 nice_printf (outfile, "[%d]", eltcount);
00204 }
00205
00206 int
00207 #ifdef KR_headers
00208 nv_type_help(addrp)
00209 struct Addrblock *addrp;
00210 #else
00211 nv_type_help(struct Addrblock *addrp)
00212 #endif
00213 {
00214 if (addrp == (struct Addrblock *) NULL)
00215 return -1;
00216
00217 return addrp -> vtype;
00218 }
00219
00220
00221
00222
00223
00224
00225
00226
00227
00228
00229
00230
00231
00232
00233
00234
00235
00236
00237 char *
00238 #ifdef KR_headers
00239 lit_name(litp)
00240 struct Literal *litp;
00241 #else
00242 lit_name(struct Literal *litp)
00243 #endif
00244 {
00245 static char buf[CONST_IDENT_MAX];
00246 ftnint val;
00247 char *fmt;
00248
00249 if (litp == (struct Literal *) NULL)
00250 return NULL;
00251
00252 switch (litp -> littype) {
00253 case TYINT1:
00254 val = litp -> litval.litival;
00255 if (val >= 256 || val < -255)
00256 sprintf (buf, "ci1_b%ld", litp -> litnum);
00257 else if (val < 0)
00258 sprintf (buf, "ci1_n%ld", -val);
00259 else
00260 sprintf(buf, "ci1__%ld", val);
00261 break;
00262 case TYSHORT:
00263 val = litp -> litval.litival;
00264 if (val >= 32768 || val <= -32769)
00265 sprintf (buf, "cs_b%ld", litp -> litnum);
00266 else if (val < 0)
00267 sprintf (buf, "cs_n%ld", -val);
00268 else
00269 sprintf (buf, "cs__%ld", val);
00270 break;
00271 case TYLONG:
00272 #ifdef TYQUAD
00273 case TYQUAD:
00274 #endif
00275 val = litp -> litval.litival;
00276 if (val >= 100000 || val <= -10000)
00277 sprintf (buf, "c_b%ld", litp -> litnum);
00278 else if (val < 0)
00279 sprintf (buf, "c_n%ld", -val);
00280 else
00281 sprintf (buf, "c__%ld", val);
00282 break;
00283 case TYLOGICAL1:
00284 fmt = "cl1_%s";
00285 goto spr_logical;
00286 case TYLOGICAL2:
00287 fmt = "cl2_%s";
00288 goto spr_logical;
00289 case TYLOGICAL:
00290 fmt = "c_%s";
00291 spr_logical:
00292 sprintf (buf, fmt, (litp -> litval.litival
00293 ? "true" : "false"));
00294 break;
00295 case TYREAL:
00296 case TYDREAL:
00297
00298
00299
00300
00301
00302 case TYCHAR:
00303
00304 case TYADDR:
00305 case TYCOMPLEX:
00306 case TYDCOMPLEX:
00307 case TYSUBR:
00308 default:
00309 sprintf (buf, "c_b%ld", litp -> litnum);
00310 }
00311 return buf;
00312 }
00313
00314
00315
00316 char *
00317 #ifdef KR_headers
00318 comm_union_name(count)
00319 int count;
00320 #else
00321 comm_union_name(int count)
00322 #endif
00323 {
00324 static char buf[12];
00325
00326 sprintf(buf, "%d", count);
00327 return buf;
00328 }
00329
00330
00331
00332
00333
00334
00335
00336
00337 void
00338 #ifdef KR_headers
00339 wr_globals(outfile)
00340 FILE *outfile;
00341 #else
00342 wr_globals(FILE *outfile)
00343 #endif
00344 {
00345 struct Literal *litp, *lastlit;
00346 extern int hsize;
00347 char *litname;
00348 int did_one, t;
00349 struct Constblock cb;
00350 ftnint x, y;
00351
00352 if (nliterals == 0)
00353 return;
00354
00355 lastlit = litpool + nliterals;
00356 did_one = 0;
00357 for (litp = litpool; litp < lastlit; litp++) {
00358 if (!litp->lituse)
00359 continue;
00360 litname = lit_name(litp);
00361 if (!did_one) {
00362 margin_printf(outfile, "/* Table of constant values */\n\n");
00363 did_one = 1;
00364 }
00365 cb.vtype = litp->littype;
00366 if (litp->littype == TYCHAR) {
00367 x = litp->litval.litival2[0] + litp->litval.litival2[1];
00368 if (y = x % hsize)
00369 x += y = hsize - y;
00370 nice_printf(outfile,
00371 "static struct { %s fill; char val[%ld+1];", halign, x);
00372 nice_printf(outfile, " char fill2[%ld];", hsize - 1);
00373 nice_printf(outfile, " } %s_st = { 0,", litname);
00374 cb.vleng = ICON(litp->litval.litival2[0]);
00375 cb.Const.ccp = litp->cds[0];
00376 cb.Const.ccp1.blanks = litp->litval.litival2[1] + y;
00377 cb.vtype = TYCHAR;
00378 out_const(outfile, &cb);
00379 frexpr(cb.vleng);
00380 nice_printf(outfile, " };\n");
00381 nice_printf(outfile, "#define %s %s_st.val\n", litname, litname);
00382 continue;
00383 }
00384 nice_printf(outfile, "static %s %s = ",
00385 c_type_decl(litp->littype,0), litname);
00386
00387 t = litp->littype;
00388 if (ONEOF(t, MSKREAL|MSKCOMPLEX)) {
00389 cb.vstg = 1;
00390 cb.Const.cds[0] = litp->cds[0];
00391 cb.Const.cds[1] = litp->cds[1];
00392 }
00393 else {
00394 memcpy((char *)&cb.Const, (char *)&litp->litval,
00395 sizeof(cb.Const));
00396 cb.vstg = 0;
00397 }
00398 out_const(outfile, &cb);
00399
00400 nice_printf (outfile, ";\n");
00401 }
00402 if (did_one)
00403 nice_printf (outfile, "\n");
00404 }
00405
00406 ftnint
00407 #ifdef KR_headers
00408 commlen(vl)
00409 register chainp vl;
00410 #else
00411 commlen(register chainp vl)
00412 #endif
00413 {
00414 ftnint size;
00415 int type;
00416 struct Dimblock *t;
00417 Namep v;
00418
00419 while(vl->nextp)
00420 vl = vl->nextp;
00421 v = (Namep)vl->datap;
00422 type = v->vtype;
00423 if (type == TYCHAR)
00424 size = v->vleng->constblock.Const.ci;
00425 else
00426 size = typesize[type];
00427 if ((t = v->vdim) && ISCONST(t->nelt))
00428 size *= t->nelt->constblock.Const.ci;
00429 return size + v->voffset;
00430 }
00431
00432 static void
00433 #ifdef KR_headers
00434 pad_common(c)
00435 Extsym *c;
00436 #else
00437 pad_common(Extsym *c)
00438 #endif
00439 {
00440 register chainp cvl;
00441 register Namep v;
00442 long L = c->maxleng;
00443 int type;
00444 struct Dimblock *t;
00445 int szshort = typesize[TYSHORT];
00446
00447 for(cvl = c->allextp; cvl; cvl = cvl->nextp)
00448 if (commlen((chainp)cvl->datap) >= L)
00449 return;
00450 v = ALLOC(Nameblock);
00451 v->vtype = type = L % szshort ? TYCHAR
00452 : type_choice[L/szshort % 4];
00453 v->vstg = STGCOMMON;
00454 v->vclass = CLVAR;
00455 v->tag = TNAME;
00456 v->vdim = t = ALLOC(Dimblock);
00457 t->ndim = 1;
00458 t->dims[0].dimsize = ICON(L / typesize[type]);
00459 v->fvarname = v->cvarname = "eqv_pad";
00460 if (type == TYCHAR)
00461 v->vleng = ICON(1);
00462 c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
00463 }
00464
00465
00466
00467
00468
00469
00470
00471
00472
00473
00474
00475
00476
00477
00478
00479
00480
00481
00482
00483
00484
00485
00486
00487
00488
00489
00490
00491
00492
00493
00494
00495
00496 #define ONE_STRUCT 1
00497 #define UNION_STRUCT 2
00498 #define INIT_STRUCT 3
00499
00500 void
00501 #ifdef KR_headers
00502 wr_common_decls(outfile)
00503 FILE *outfile;
00504 #else
00505 wr_common_decls(FILE *outfile)
00506 #endif
00507 {
00508 Extsym *ext;
00509 extern int extcomm;
00510 static char *Extern[4] = {"", "Extern ", "extern "};
00511 char *E, *E0 = Extern[extcomm];
00512 int did_one = 0;
00513
00514 for (ext = extsymtab; ext < nextext; ext++) {
00515 if (ext -> extstg == STGCOMMON && ext->allextp) {
00516 chainp comm;
00517 int count = 1;
00518 int which;
00519
00520
00521 if (!did_one)
00522 nice_printf (outfile, "/* Common Block Declarations */\n\n");
00523
00524 pad_common(ext);
00525
00526
00527
00528
00529 comm = ext->allextp = revchain(ext->allextp);
00530
00531 if (ext -> extinit)
00532 which = INIT_STRUCT;
00533 else if (comm->nextp) {
00534 which = UNION_STRUCT;
00535 nice_printf (outfile, "%sunion {\n", E0);
00536 next_tab (outfile);
00537 E = "";
00538 }
00539 else {
00540 which = ONE_STRUCT;
00541 E = E0;
00542 }
00543
00544 for (; comm; comm = comm -> nextp, count++) {
00545
00546 if (which == INIT_STRUCT)
00547 nice_printf (outfile, "struct %s%d_ {\n",
00548 ext->cextname, count);
00549 else
00550 nice_printf (outfile, "%sstruct {\n", E);
00551
00552 next_tab (c_file);
00553
00554 wr_struct (outfile, (chainp) comm -> datap);
00555
00556 prev_tab (c_file);
00557 if (which == UNION_STRUCT)
00558 nice_printf (outfile, "} _%d;\n", count);
00559 else if (which == ONE_STRUCT)
00560 nice_printf (outfile, "} %s;\n", ext->cextname);
00561 else
00562 nice_printf (outfile, "};\n");
00563 }
00564
00565 if (which == UNION_STRUCT) {
00566 prev_tab (c_file);
00567 nice_printf (outfile, "} %s;\n", ext->cextname);
00568 }
00569 did_one = 1;
00570 nice_printf (outfile, "\n");
00571
00572 for (count = 1, comm = ext -> allextp; comm;
00573 comm = comm -> nextp, count++) {
00574 def_start(outfile, ext->cextname,
00575 comm_union_name(count), "");
00576 switch (which) {
00577 case ONE_STRUCT:
00578 extern_out (outfile, ext);
00579 break;
00580 case UNION_STRUCT:
00581 nice_printf (outfile, "(");
00582 extern_out (outfile, ext);
00583 nice_printf(outfile, "._%d)", count);
00584 break;
00585 case INIT_STRUCT:
00586 nice_printf (outfile, "(*(struct ");
00587 extern_out (outfile, ext);
00588 nice_printf (outfile, "%d_ *) &", count);
00589 extern_out (outfile, ext);
00590 nice_printf (outfile, ")");
00591 break;
00592 }
00593 nice_printf (outfile, "\n");
00594 }
00595 nice_printf (outfile, "\n");
00596 }
00597 }
00598 }
00599
00600 void
00601 #ifdef KR_headers
00602 wr_struct(outfile, var_list)
00603 FILE *outfile;
00604 chainp var_list;
00605 #else
00606 wr_struct(FILE *outfile, chainp var_list)
00607 #endif
00608 {
00609 int last_type = -1;
00610 int did_one = 0;
00611 chainp this_var;
00612
00613 for (this_var = var_list; this_var; this_var = this_var -> nextp) {
00614 Namep var = (Namep) this_var -> datap;
00615 int type;
00616 char *comment = NULL;
00617
00618 if (var == (Namep) NULL)
00619 err ("wr_struct: null variable");
00620 else if (var -> tag != TNAME)
00621 erri ("wr_struct: bad tag on variable '%d'",
00622 var -> tag);
00623
00624 type = var -> vtype;
00625
00626 if (last_type == type && did_one)
00627 nice_printf (outfile, ", ");
00628 else {
00629 if (did_one)
00630 nice_printf (outfile, ";\n");
00631 nice_printf (outfile, "%s ",
00632 c_type_decl (type, var -> vclass == CLPROC));
00633 }
00634
00635
00636
00637
00638 if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
00639 || var -> vclass == CLPROC))
00640 nice_printf (outfile, "*");
00641
00642 var -> vstg = STGAUTO;
00643 out_name (outfile, var);
00644 if (var -> vclass == CLPROC)
00645 nice_printf (outfile, "()");
00646 else if (var -> vdim)
00647 comment = wr_ardecls(outfile, var->vdim,
00648 var->vtype == TYCHAR && ISICON(var->vleng)
00649 ? var->vleng->constblock.Const.ci : 1L);
00650 else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
00651 ISICON ((var -> vleng)))
00652 nice_printf (outfile, "[%ld]",
00653 var -> vleng -> constblock.Const.ci);
00654
00655 if (comment)
00656 nice_printf (outfile, "%s", comment);
00657 did_one = 1;
00658 last_type = type;
00659 }
00660
00661 if (did_one)
00662 nice_printf (outfile, ";\n");
00663 }
00664
00665
00666 char *
00667 #ifdef KR_headers
00668 user_label(stateno)
00669 ftnint stateno;
00670 #else
00671 user_label(ftnint stateno)
00672 #endif
00673 {
00674 static char buf[USER_LABEL_MAX + 1];
00675 static char *Lfmt[2] = { "L_%ld", "L%ld" };
00676
00677 if (stateno >= 0)
00678 sprintf(buf, Lfmt[shiftcase], stateno);
00679 else
00680 sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
00681 return buf;
00682 }
00683
00684
00685 char *
00686 #ifdef KR_headers
00687 temp_name(starter, num, storage)
00688 char *starter;
00689 int num;
00690 char *storage;
00691 #else
00692 temp_name(char *starter, int num, char *storage)
00693 #endif
00694 {
00695 static char buf[IDENT_LEN];
00696 char *pointer = buf;
00697 char *prefix = "t";
00698
00699 if (storage)
00700 pointer = storage;
00701
00702 if (starter && *starter)
00703 prefix = starter;
00704
00705 sprintf (pointer, "%s__%d", prefix, num);
00706 return pointer;
00707 }
00708
00709
00710 char *
00711 #ifdef KR_headers
00712 equiv_name(memno, store)
00713 int memno;
00714 char *store;
00715 #else
00716 equiv_name(int memno, char *store)
00717 #endif
00718 {
00719 static char buf[IDENT_LEN];
00720 char *pointer = buf;
00721
00722 if (store)
00723 pointer = store;
00724
00725 sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
00726 return pointer;
00727 }
00728
00729 void
00730 #ifdef KR_headers
00731 def_commons(of)
00732 FILE *of;
00733 #else
00734 def_commons(FILE *of)
00735 #endif
00736 {
00737 Extsym *ext;
00738 int c, onefile, Union;
00739 chainp comm;
00740 extern int ext1comm;
00741 FILE *c_filesave = c_file;
00742
00743 if (ext1comm == 1) {
00744 onefile = 1;
00745 c_file = of;
00746 fprintf(of, "/*>>>'/dev/null'<<<*/\n\
00747 #ifdef Define_COMMONs\n\
00748 /*<<</dev/null>>>*/\n");
00749 }
00750 else
00751 onefile = 0;
00752 for(ext = extsymtab; ext < nextext; ext++)
00753 if (ext->extstg == STGCOMMON
00754 && !ext->extinit && (comm = ext->allextp)) {
00755 sprintf(outbtail, "%scom.c", ext->cextname);
00756 if (onefile)
00757 fprintf(of, "/*>>>'%s'<<<*/\n",
00758 outbtail);
00759 else {
00760 c_file = of = fopen(outbuf,textwrite);
00761 if (!of)
00762 fatalstr("can't open %s", outbuf);
00763 }
00764 fprintf(of, "#include \"f2c.h\"\n");
00765 if (Ansi == 2)
00766 fprintf(of,
00767 "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n");
00768 if (comm->nextp) {
00769 Union = 1;
00770 nice_printf(of, "union {\n");
00771 next_tab(of);
00772 }
00773 else
00774 Union = 0;
00775 for(c = 1; comm; comm = comm->nextp) {
00776 nice_printf(of, "struct {\n");
00777 next_tab(of);
00778 wr_struct(of, (chainp)comm->datap);
00779 prev_tab(of);
00780 if (Union)
00781 nice_printf(of, "} _%d;\n", c++);
00782 }
00783 if (Union)
00784 prev_tab(of);
00785 nice_printf(of, "} %s;\n", ext->cextname);
00786 if (Ansi == 2)
00787 fprintf(of,
00788 "\n#ifdef __cplusplus\n}\n#endif\n");
00789 if (onefile)
00790 fprintf(of, "/*<<<%s>>>*/\n", outbtail);
00791 else
00792 fclose(of);
00793 }
00794 if (onefile)
00795 fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\
00796 /*<<</dev/null>>>*/\n");
00797 c_file = c_filesave;
00798 }
00799
00800
00801
00802
00803
00804
00805
00806 char *c_keywords[] = {
00807 "Long", "Multitype", "Namelist", "Vardesc", "abs", "acos",
00808 "addr", "address", "aerr", "alist", "asin", "asm", "atan",
00809 "atan2", "aunit", "auto", "break", "c", "case", "catch", "cerr",
00810 "char", "ciend", "cierr", "cifmt", "cilist", "cirec", "ciunit",
00811 "class", "cllist", "complex", "const", "continue", "cos",
00812 "cosh", "csta", "cunit", "d", "dabs", "default", "defined",
00813 "delete", "dims", "dmax", "dmin", "do", "double",
00814 "doublecomplex", "doublereal", "else", "entry", "enum", "exp",
00815 "extern", "far", "flag", "float", "for", "friend", "ftnint",
00816 "ftnlen", "goto", "h", "huge", "i", "iciend", "icierr",
00817 "icifmt", "icilist", "icirlen", "icirnum", "iciunit", "if",
00818 "inacc", "inacclen", "inblank", "inblanklen", "include",
00819 "indir", "indirlen", "inerr", "inex", "infile", "infilen",
00820 "infmt", "infmtlen", "inform", "informlen", "inline", "inlist",
00821 "inname", "innamed", "innamlen", "innrec", "innum", "inopen",
00822 "inrecl", "inseq", "inseqlen", "int", "integer", "integer1",
00823 "inunf", "inunflen", "inunit", "log", "logical", "logical1",
00824 "long", "longint", "max", "min", "name", "near", "new", "nvars",
00825 "oacc", "oblnk", "oerr", "ofm", "ofnm", "ofnmlen", "olist",
00826 "operator", "orl", "osta", "ounit", "overload", "private",
00827 "protected", "public", "r", "real", "register", "return",
00828 "short", "shortint", "shortlogical", "signed", "sin", "sinh",
00829 "sizeof", "sqrt", "static", "struct", "switch", "tan", "tanh",
00830 "template", "this", "try", "type", "typedef", "uinteger",
00831 "ulongint", "union", "unsigned", "vars", "virtual", "void",
00832 "volatile", "while", "z"
00833 };
00834
00835 int n_keywords = sizeof(c_keywords)/sizeof(char *);