![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to names.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to names.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 ! root 1: /**************************************************************** ! 2: Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore. ! 3: ! 4: Permission to use, copy, modify, and distribute this software ! 5: and its documentation for any purpose and without fee is hereby ! 6: granted, provided that the above copyright notice appear in all ! 7: copies and that both that the copyright notice and this ! 8: permission notice and warranty disclaimer appear in supporting ! 9: documentation, and that the names of AT&T Bell Laboratories or ! 10: Bellcore or any of their entities not be used in advertising or ! 11: publicity pertaining to distribution of the software without ! 12: specific, written prior permission. ! 13: ! 14: AT&T and Bellcore disclaim all warranties with regard to this ! 15: software, including all implied warranties of merchantability ! 16: and fitness. In no event shall AT&T or Bellcore be liable for ! 17: any special, indirect or consequential damages or any damages ! 18: whatsoever resulting from loss of use, data or profits, whether ! 19: in an action of contract, negligence or other tortious action, ! 20: arising out of or in connection with the use or performance of ! 21: this software. ! 22: ****************************************************************/ ! 23: ! 24: #include "defs.h" ! 25: #include "output.h" ! 26: #include "names.h" ! 27: #include "iob.h" ! 28: ! 29: ! 30: /* Names generated by the translator are guaranteed to be unique from the ! 31: Fortan names because Fortran does not allow underscores in identifiers, ! 32: and all of the system generated names do have underscores. The various ! 33: naming conventions are outlined below: ! 34: ! 35: FORMAT APPLICATION ! 36: ---------------------------------------------------------------------- ! 37: io_# temporaries generated by IO calls; these will ! 38: contain the device number (e.g. 5, 6, 0) ! 39: ret_val function return value, required for complex and ! 40: character functions. ! 41: ret_val_len length of the return value in character functions ! 42: ! 43: ssss_len length of character argument "ssss" ! 44: ! 45: c_# member of the literal pool, where # is an ! 46: arbitrary label assigned by the system ! 47: cs_# short integer constant in the literal pool ! 48: t_# expression temporary, # is the depth of arguments ! 49: on the stack. ! 50: L# label "#", given by user in the Fortran program. ! 51: This is unique because Fortran labels are numeric ! 52: pad_# label on an init field required for alignment ! 53: xxx_init label on a common block union, if a block data ! 54: requires a separate declaration ! 55: */ ! 56: ! 57: /* generate variable references */ ! 58: ! 59: char *c_type_decl (type, is_extern) ! 60: int type, is_extern; ! 61: { ! 62: static char buff[100]; ! 63: ! 64: switch (type) { ! 65: case TYREAL: if (!is_extern || !forcedouble) ! 66: { strcpy (buff, "real");break; } ! 67: case TYDREAL: strcpy (buff, "doublereal"); break; ! 68: case TYCOMPLEX: if (is_extern) ! 69: strcpy (buff, "/* Complex */ VOID"); ! 70: else ! 71: strcpy (buff, "complex"); ! 72: break; ! 73: case TYDCOMPLEX:if (is_extern) ! 74: strcpy (buff, "/* Double Complex */ VOID"); ! 75: else ! 76: strcpy (buff, "doublecomplex"); ! 77: break; ! 78: case TYADDR: ! 79: case TYINT1: ! 80: case TYSHORT: ! 81: case TYLONG: ! 82: #ifdef TYQUAD ! 83: case TYQUAD: ! 84: #endif ! 85: case TYLOGICAL1: ! 86: case TYLOGICAL2: ! 87: case TYLOGICAL: strcpy(buff, typename[type]); ! 88: break; ! 89: case TYCHAR: if (is_extern) ! 90: strcpy (buff, "/* Character */ VOID"); ! 91: else ! 92: strcpy (buff, "char"); ! 93: break; ! 94: ! 95: case TYUNKNOWN: strcpy (buff, "UNKNOWN"); ! 96: ! 97: /* If a procedure's type is unknown, assume it's a subroutine */ ! 98: ! 99: if (!is_extern) ! 100: break; ! 101: ! 102: /* Subroutines must return an INT, because they might return a label ! 103: value. Even if one doesn't, the caller will EXPECT it to. */ ! 104: ! 105: case TYSUBR: strcpy (buff, "/* Subroutine */ int"); ! 106: break; ! 107: case TYERROR: strcpy (buff, "ERROR"); break; ! 108: case TYVOID: strcpy (buff, "void"); break; ! 109: case TYCILIST: strcpy (buff, "cilist"); break; ! 110: case TYICILIST: strcpy (buff, "icilist"); break; ! 111: case TYOLIST: strcpy (buff, "olist"); break; ! 112: case TYCLLIST: strcpy (buff, "cllist"); break; ! 113: case TYALIST: strcpy (buff, "alist"); break; ! 114: case TYINLIST: strcpy (buff, "inlist"); break; ! 115: case TYFTNLEN: strcpy (buff, "ftnlen"); break; ! 116: default: sprintf (buff, "BAD DECL '%d'", type); ! 117: break; ! 118: } /* switch */ ! 119: ! 120: return buff; ! 121: } /* c_type_decl */ ! 122: ! 123: ! 124: char *new_func_length() ! 125: { return "ret_val_len"; } ! 126: ! 127: char *new_arg_length(arg) ! 128: Namep arg; ! 129: { ! 130: static char buf[64]; ! 131: sprintf (buf, "%s_len", arg->fvarname); ! 132: ! 133: return buf; ! 134: } /* new_arg_length */ ! 135: ! 136: ! 137: /* declare_new_addr -- Add a new local variable to the function, given a ! 138: pointer to an Addrblock structure (which must have the uname_tag set) ! 139: This list of idents will be printed in reverse (i.e., chronological) ! 140: order */ ! 141: ! 142: void ! 143: declare_new_addr (addrp) ! 144: struct Addrblock *addrp; ! 145: { ! 146: extern chainp new_vars; ! 147: ! 148: new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars); ! 149: } /* declare_new_addr */ ! 150: ! 151: ! 152: wr_nv_ident_help (outfile, addrp) ! 153: FILE *outfile; ! 154: struct Addrblock *addrp; ! 155: { ! 156: int eltcount = 0; ! 157: ! 158: if (addrp == (struct Addrblock *) NULL) ! 159: return; ! 160: ! 161: if (addrp -> isarray) { ! 162: frexpr (addrp -> memoffset); ! 163: addrp -> memoffset = ICON(0); ! 164: eltcount = addrp -> ntempelt; ! 165: addrp -> ntempelt = 0; ! 166: addrp -> isarray = 0; ! 167: } /* if */ ! 168: out_addr (outfile, addrp); ! 169: if (eltcount) ! 170: nice_printf (outfile, "[%d]", eltcount); ! 171: } /* wr_nv_ident_help */ ! 172: ! 173: int nv_type_help (addrp) ! 174: struct Addrblock *addrp; ! 175: { ! 176: if (addrp == (struct Addrblock *) NULL) ! 177: return -1; ! 178: ! 179: return addrp -> vtype; ! 180: } /* nv_type_help */ ! 181: ! 182: ! 183: /* lit_name -- returns a unique identifier for the given literal. Make ! 184: the label useful, when possible. For example: ! 185: ! 186: 1 -> c_1 (constant 1) ! 187: 2 -> c_2 (constant 2) ! 188: 1000 -> c_1000 (constant 1000) ! 189: 1000000 -> c_b<memno> (big constant number) ! 190: 1.2 -> c_1_2 (constant 1.2) ! 191: 1.234345 -> c_b<memno> (big constant number) ! 192: -1 -> c_n1 (constant -1) ! 193: -1.0 -> c_n1_0 (constant -1.0) ! 194: .true. -> c_true (constant true) ! 195: .false. -> c_false (constant false) ! 196: default -> c_b<memno> (default label) ! 197: */ ! 198: ! 199: char *lit_name (litp) ! 200: struct Literal *litp; ! 201: { ! 202: static char buf[CONST_IDENT_MAX]; ! 203: ftnint val; ! 204: ! 205: if (litp == (struct Literal *) NULL) ! 206: return NULL; ! 207: ! 208: switch (litp -> littype) { ! 209: case TYINT1: ! 210: val = litp -> litval.litival; ! 211: if (val >= 256 || val < -255) ! 212: sprintf (buf, "c_b%d", litp -> litnum); ! 213: else if (val < 0) ! 214: sprintf (buf, "ci1_n%ld", -val); ! 215: else ! 216: sprintf(buf, "ci1__%ld", val); ! 217: case TYSHORT: ! 218: val = litp -> litval.litival; ! 219: if (val >= 32768 || val <= -32769) ! 220: sprintf (buf, "c_b%d", litp -> litnum); ! 221: else if (val < 0) ! 222: sprintf (buf, "cs_n%ld", -val); ! 223: else ! 224: sprintf (buf, "cs__%ld", val); ! 225: break; ! 226: case TYLONG: ! 227: #ifdef TYQUAD ! 228: case TYQUAD: ! 229: #endif ! 230: val = litp -> litval.litival; ! 231: if (val >= 100000 || val <= -10000) ! 232: sprintf (buf, "c_b%d", litp -> litnum); ! 233: else if (val < 0) ! 234: sprintf (buf, "c_n%ld", -val); ! 235: else ! 236: sprintf (buf, "c__%ld", val); ! 237: break; ! 238: case TYLOGICAL1: ! 239: case TYLOGICAL2: ! 240: case TYLOGICAL: ! 241: sprintf (buf, "c_%s", (litp -> litval.litival ! 242: ? "true" : "false")); ! 243: break; ! 244: case TYREAL: ! 245: case TYDREAL: ! 246: /* Given a limit of 6 or 8 character on external names, */ ! 247: /* few f.p. values can be meaningfully encoded in the */ ! 248: /* constant name. Just going with the default cb_# */ ! 249: /* seems to be the best course for floating-point */ ! 250: /* constants. */ ! 251: case TYCHAR: ! 252: /* Shouldn't be any of these */ ! 253: case TYADDR: ! 254: case TYCOMPLEX: ! 255: case TYDCOMPLEX: ! 256: case TYSUBR: ! 257: default: ! 258: sprintf (buf, "c_b%d", litp -> litnum); ! 259: } /* switch */ ! 260: return buf; ! 261: } /* lit_name */ ! 262: ! 263: ! 264: ! 265: char * ! 266: comm_union_name(count) ! 267: int count; ! 268: { ! 269: static char buf[12]; ! 270: ! 271: sprintf(buf, "%d", count); ! 272: return buf; ! 273: } ! 274: ! 275: ! 276: ! 277: ! 278: /* wr_globals -- after every function has been translated, we need to ! 279: output the global declarations, such as the static table of constant ! 280: values */ ! 281: ! 282: wr_globals (outfile) ! 283: FILE *outfile; ! 284: { ! 285: struct Literal *litp, *lastlit; ! 286: extern int hsize; ! 287: extern char *lit_name(); ! 288: char *litname; ! 289: int did_one, t; ! 290: struct Constblock cb; ! 291: ftnint x, y; ! 292: ! 293: if (nliterals == 0) ! 294: return; ! 295: ! 296: lastlit = litpool + nliterals; ! 297: did_one = 0; ! 298: for (litp = litpool; litp < lastlit; litp++) { ! 299: if (!litp->lituse) ! 300: continue; ! 301: litname = lit_name(litp); ! 302: if (!did_one) { ! 303: margin_printf(outfile, "/* Table of constant values */\n\n"); ! 304: did_one = 1; ! 305: } ! 306: cb.vtype = litp->littype; ! 307: if (litp->littype == TYCHAR) { ! 308: x = litp->litval.litival2[0] + litp->litval.litival2[1]; ! 309: if (y = x % hsize) ! 310: x += y = hsize - y; ! 311: nice_printf(outfile, ! 312: "static struct { %s fill; char val[%ld+1];", halign, x); ! 313: nice_printf(outfile, " char fill2[%ld];", hsize - 1); ! 314: nice_printf(outfile, " } %s_st = { 0,", litname); ! 315: cb.vleng = ICON(litp->litval.litival2[0]); ! 316: cb.Const.ccp = litp->cds[0]; ! 317: cb.Const.ccp1.blanks = litp->litval.litival2[1] + y; ! 318: cb.vtype = TYCHAR; ! 319: out_const(outfile, &cb); ! 320: frexpr(cb.vleng); ! 321: nice_printf(outfile, " };\n"); ! 322: nice_printf(outfile, "#define %s %s_st.val\n", litname, litname); ! 323: continue; ! 324: } ! 325: nice_printf(outfile, "static %s %s = ", ! 326: c_type_decl(litp->littype,0), litname); ! 327: ! 328: t = litp->littype; ! 329: if (ONEOF(t, MSKREAL|MSKCOMPLEX)) { ! 330: cb.vstg = 1; ! 331: cb.Const.cds[0] = litp->cds[0]; ! 332: cb.Const.cds[1] = litp->cds[1]; ! 333: } ! 334: else { ! 335: memcpy((char *)&cb.Const, (char *)&litp->litval, ! 336: sizeof(cb.Const)); ! 337: cb.vstg = 0; ! 338: } ! 339: out_const(outfile, &cb); ! 340: ! 341: nice_printf (outfile, ";\n"); ! 342: } /* for */ ! 343: if (did_one) ! 344: nice_printf (outfile, "\n"); ! 345: } /* wr_globals */ ! 346: ! 347: ftnint ! 348: commlen(vl) ! 349: register chainp vl; ! 350: { ! 351: ftnint size; ! 352: int type; ! 353: struct Dimblock *t; ! 354: Namep v; ! 355: ! 356: while(vl->nextp) ! 357: vl = vl->nextp; ! 358: v = (Namep)vl->datap; ! 359: type = v->vtype; ! 360: if (type == TYCHAR) ! 361: size = v->vleng->constblock.Const.ci; ! 362: else ! 363: size = typesize[type]; ! 364: if ((t = v->vdim) && ISCONST(t->nelt)) ! 365: size *= t->nelt->constblock.Const.ci; ! 366: return size + v->voffset; ! 367: } ! 368: ! 369: static void /* Pad common block if an EQUIVALENCE extended it. */ ! 370: pad_common(c) ! 371: Extsym *c; ! 372: { ! 373: register chainp cvl; ! 374: register Namep v; ! 375: long L = c->maxleng; ! 376: int type; ! 377: struct Dimblock *t; ! 378: int szshort = typesize[TYSHORT]; ! 379: ! 380: for(cvl = c->allextp; cvl; cvl = cvl->nextp) ! 381: if (commlen((chainp)cvl->datap) >= L) ! 382: return; ! 383: v = ALLOC(Nameblock); ! 384: v->vtype = type = L % szshort ? TYCHAR ! 385: : type_choice[L/szshort % 4]; ! 386: v->vstg = STGCOMMON; ! 387: v->vclass = CLVAR; ! 388: v->tag = TNAME; ! 389: v->vdim = t = ALLOC(Dimblock); ! 390: t->ndim = 1; ! 391: t->dims[0].dimsize = ICON(L / typesize[type]); ! 392: v->fvarname = v->cvarname = "eqv_pad"; ! 393: if (type == TYCHAR) ! 394: v->vleng = ICON(1); ! 395: c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp); ! 396: } ! 397: ! 398: ! 399: /* wr_common_decls -- outputs the common declarations in one of three ! 400: formats. If all references to a common block look the same (field ! 401: names and types agree), only one actual declaration will appear. ! 402: Otherwise, the same block will require many structs. If there is no ! 403: block data, these structs will be union'ed together (so the linker ! 404: knows the size of the largest one). If there IS a block data, only ! 405: that version will be associated with the variable, others will only be ! 406: defined as types, so the pointer can be cast to it. e.g. ! 407: ! 408: FORTRAN C ! 409: ---------------------------------------------------------------------- ! 410: common /com1/ a, b, c struct { real a, b, c; } com1_; ! 411: ! 412: common /com1/ a, b, c union { ! 413: common /com1/ i, j, k struct { real a, b, c; } _1; ! 414: struct { integer i, j, k; } _2; ! 415: } com1_; ! 416: ! 417: common /com1/ a, b, c struct com1_1_ { real a, b, c; }; ! 418: block data struct { integer i, j, k; } com1_ = ! 419: common /com1/ i, j, k { 1, 2, 3 }; ! 420: data i/1/, j/2/, k/3/ ! 421: ! 422: ! 423: All of these versions will be followed by #defines, since the code in ! 424: the function bodies can't know ahead of time which of these options ! 425: will be taken */ ! 426: ! 427: /* Macros for deciding the output type */ ! 428: ! 429: #define ONE_STRUCT 1 ! 430: #define UNION_STRUCT 2 ! 431: #define INIT_STRUCT 3 ! 432: ! 433: wr_common_decls(outfile) ! 434: FILE *outfile; ! 435: { ! 436: Extsym *ext; ! 437: extern int extcomm; ! 438: static char *Extern[4] = {"", "Extern ", "extern "}; ! 439: char *E, *E0 = Extern[extcomm]; ! 440: int did_one = 0; ! 441: ! 442: for (ext = extsymtab; ext < nextext; ext++) { ! 443: if (ext -> extstg == STGCOMMON && ext->allextp) { ! 444: chainp comm; ! 445: int count = 1; ! 446: int which; /* which display to use; ! 447: ONE_STRUCT, UNION or INIT */ ! 448: ! 449: if (!did_one) ! 450: nice_printf (outfile, "/* Common Block Declarations */\n\n"); ! 451: ! 452: pad_common(ext); ! 453: ! 454: /* Construct the proper, condensed list of structs; eliminate duplicates ! 455: from the initial list ext -> allextp */ ! 456: ! 457: comm = ext->allextp = revchain(ext->allextp); ! 458: ! 459: if (ext -> extinit) ! 460: which = INIT_STRUCT; ! 461: else if (comm->nextp) { ! 462: which = UNION_STRUCT; ! 463: nice_printf (outfile, "%sunion {\n", E0); ! 464: next_tab (outfile); ! 465: E = ""; ! 466: } ! 467: else { ! 468: which = ONE_STRUCT; ! 469: E = E0; ! 470: } ! 471: ! 472: for (; comm; comm = comm -> nextp, count++) { ! 473: ! 474: if (which == INIT_STRUCT) ! 475: nice_printf (outfile, "struct %s%d_ {\n", ! 476: ext->cextname, count); ! 477: else ! 478: nice_printf (outfile, "%sstruct {\n", E); ! 479: ! 480: next_tab (c_file); ! 481: ! 482: wr_struct (outfile, (chainp) comm -> datap); ! 483: ! 484: prev_tab (c_file); ! 485: if (which == UNION_STRUCT) ! 486: nice_printf (outfile, "} _%d;\n", count); ! 487: else if (which == ONE_STRUCT) ! 488: nice_printf (outfile, "} %s;\n", ext->cextname); ! 489: else ! 490: nice_printf (outfile, "};\n"); ! 491: } /* for */ ! 492: ! 493: if (which == UNION_STRUCT) { ! 494: prev_tab (c_file); ! 495: nice_printf (outfile, "} %s;\n", ext->cextname); ! 496: } /* if */ ! 497: did_one = 1; ! 498: nice_printf (outfile, "\n"); ! 499: ! 500: for (count = 1, comm = ext -> allextp; comm; ! 501: comm = comm -> nextp, count++) { ! 502: def_start(outfile, ext->cextname, ! 503: comm_union_name(count), ""); ! 504: switch (which) { ! 505: case ONE_STRUCT: ! 506: extern_out (outfile, ext); ! 507: break; ! 508: case UNION_STRUCT: ! 509: nice_printf (outfile, "("); ! 510: extern_out (outfile, ext); ! 511: nice_printf(outfile, "._%d)", count); ! 512: break; ! 513: case INIT_STRUCT: ! 514: nice_printf (outfile, "(*(struct "); ! 515: extern_out (outfile, ext); ! 516: nice_printf (outfile, "%d_ *) &", count); ! 517: extern_out (outfile, ext); ! 518: nice_printf (outfile, ")"); ! 519: break; ! 520: } /* switch */ ! 521: nice_printf (outfile, "\n"); ! 522: } /* for count = 1, comm = ext -> allextp */ ! 523: nice_printf (outfile, "\n"); ! 524: } /* if ext -> extstg == STGCOMMON */ ! 525: } /* for ext = extsymtab */ ! 526: } /* wr_common_decls */ ! 527: ! 528: ! 529: wr_struct (outfile, var_list) ! 530: FILE *outfile; ! 531: chainp var_list; ! 532: { ! 533: int last_type = -1; ! 534: int did_one = 0; ! 535: chainp this_var; ! 536: ! 537: for (this_var = var_list; this_var; this_var = this_var -> nextp) { ! 538: Namep var = (Namep) this_var -> datap; ! 539: int type; ! 540: char *comment = NULL, *wr_ardecls (); ! 541: ! 542: if (var == (Namep) NULL) ! 543: err ("wr_struct: null variable"); ! 544: else if (var -> tag != TNAME) ! 545: erri ("wr_struct: bad tag on variable '%d'", ! 546: var -> tag); ! 547: ! 548: type = var -> vtype; ! 549: ! 550: if (last_type == type && did_one) ! 551: nice_printf (outfile, ", "); ! 552: else { ! 553: if (did_one) ! 554: nice_printf (outfile, ";\n"); ! 555: nice_printf (outfile, "%s ", ! 556: c_type_decl (type, var -> vclass == CLPROC)); ! 557: } /* else */ ! 558: ! 559: /* Character type is really a string type. Put out a '*' for parameters ! 560: with unknown length and functions returning character */ ! 561: ! 562: if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng)) ! 563: || var -> vclass == CLPROC)) ! 564: nice_printf (outfile, "*"); ! 565: ! 566: var -> vstg = STGAUTO; ! 567: out_name (outfile, var); ! 568: if (var -> vclass == CLPROC) ! 569: nice_printf (outfile, "()"); ! 570: else if (var -> vdim) ! 571: comment = wr_ardecls(outfile, var->vdim, ! 572: var->vtype == TYCHAR && ISICON(var->vleng) ! 573: ? var->vleng->constblock.Const.ci : 1L); ! 574: else if (var -> vtype == TYCHAR && var -> vclass != CLPROC && ! 575: ISICON ((var -> vleng))) ! 576: nice_printf (outfile, "[%ld]", ! 577: var -> vleng -> constblock.Const.ci); ! 578: ! 579: if (comment) ! 580: nice_printf (outfile, "%s", comment); ! 581: did_one = 1; ! 582: last_type = type; ! 583: } /* for this_var */ ! 584: ! 585: if (did_one) ! 586: nice_printf (outfile, ";\n"); ! 587: } /* wr_struct */ ! 588: ! 589: ! 590: char *user_label(stateno) ! 591: ftnint stateno; ! 592: { ! 593: static char buf[USER_LABEL_MAX + 1]; ! 594: static char *Lfmt[2] = { "L_%ld", "L%ld" }; ! 595: ! 596: if (stateno >= 0) ! 597: sprintf(buf, Lfmt[shiftcase], stateno); ! 598: else ! 599: sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname); ! 600: return buf; ! 601: } /* user_label */ ! 602: ! 603: ! 604: char *temp_name (starter, num, storage) ! 605: char *starter; ! 606: int num; ! 607: char *storage; ! 608: { ! 609: static char buf[IDENT_LEN]; ! 610: char *pointer = buf; ! 611: char *prefix = "t"; ! 612: ! 613: if (storage) ! 614: pointer = storage; ! 615: ! 616: if (starter && *starter) ! 617: prefix = starter; ! 618: ! 619: sprintf (pointer, "%s__%d", prefix, num); ! 620: return pointer; ! 621: } /* temp_name */ ! 622: ! 623: ! 624: char *equiv_name (memno, store) ! 625: int memno; ! 626: char *store; ! 627: { ! 628: static char buf[IDENT_LEN]; ! 629: char *pointer = buf; ! 630: ! 631: if (store) ! 632: pointer = store; ! 633: ! 634: sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno); ! 635: return pointer; ! 636: } /* equiv_name */ ! 637: ! 638: void ! 639: def_commons(of) ! 640: FILE *of; ! 641: { ! 642: Extsym *ext; ! 643: int c, onefile, Union; ! 644: char buf[64]; ! 645: chainp comm; ! 646: extern int ext1comm; ! 647: FILE *c_filesave = c_file; ! 648: ! 649: if (ext1comm == 1) { ! 650: onefile = 1; ! 651: c_file = of; ! 652: fprintf(of, "/*>>>'/dev/null'<<<*/\n\ ! 653: #ifdef Define_COMMONs\n\ ! 654: /*<<</dev/null>>>*/\n"); ! 655: } ! 656: else ! 657: onefile = 0; ! 658: for(ext = extsymtab; ext < nextext; ext++) ! 659: if (ext->extstg == STGCOMMON ! 660: && !ext->extinit && (comm = ext->allextp)) { ! 661: sprintf(buf, "%scom.c", ext->cextname); ! 662: if (onefile) ! 663: fprintf(of, "/*>>>'%s'<<<*/\n", ! 664: buf); ! 665: else { ! 666: c_file = of = fopen(buf,textwrite); ! 667: if (!of) ! 668: fatalstr("can't open %s", buf); ! 669: } ! 670: fprintf(of, "#include \"f2c.h\"\n"); ! 671: if (comm->nextp) { ! 672: Union = 1; ! 673: nice_printf(of, "union {\n"); ! 674: next_tab(of); ! 675: } ! 676: else ! 677: Union = 0; ! 678: for(c = 1; comm; comm = comm->nextp) { ! 679: nice_printf(of, "struct {\n"); ! 680: next_tab(of); ! 681: wr_struct(of, (chainp)comm->datap); ! 682: prev_tab(of); ! 683: if (Union) ! 684: nice_printf(of, "} _%d;\n", c++); ! 685: } ! 686: if (Union) ! 687: prev_tab(of); ! 688: nice_printf(of, "} %s;\n", ext->cextname); ! 689: if (onefile) ! 690: fprintf(of, "/*<<<%s>>>*/\n", buf); ! 691: else ! 692: fclose(of); ! 693: } ! 694: if (onefile) ! 695: fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\ ! 696: /*<<</dev/null>>>*/\n"); ! 697: c_file = c_filesave; ! 698: } ! 699: ! 700: /* C Language keywords. Needed to filter unwanted fortran identifiers like ! 701: * "int", etc. Source: Kernighan & Ritchie, eds. 1 and 2; Stroustrup. ! 702: * Also includes C++ keywords and types used for I/O in f2c.h . ! 703: * These keywords must be in alphabetical order (as defined by strcmp()). ! 704: */ ! 705: ! 706: char *c_keywords[] = { ! 707: "Long", "Multitype", "Namelist", "Vardesc", ! 708: "abs", "acos", "address", "alist", "asin", "asm", ! 709: "atan", "atan2", "auto", "break", ! 710: "case", "catch", "char", "cilist", "class", "cllist", ! 711: "complex", "const", "continue", "cos", "cosh", ! 712: "dabs", "default", "defined", "delete", ! 713: "dmax", "dmin", "do", "double", "doublecomplex", "doublereal", ! 714: "else", "entry", "enum", "exp", "extern", ! 715: "flag", "float", "for", "friend", "ftnint", "ftnlen", "goto", ! 716: "icilist", "if", "include", "inline", "inlist", "int", "integer", ! 717: "integer1", "log", "logical", "logical1", "long", "longint", ! 718: "max", "min", "new", ! 719: "olist", "operator", "overload", "private", "protected", "public", ! 720: "real", "register", "return", ! 721: "short", "shortint", "shortlogical", "signed", "sin", "sinh", ! 722: "sizeof", "sqrt", "static", "struct", "switch", ! 723: "tan", "tanh", "template", "this", "try", "typedef", ! 724: "union", "unsigned", "virtual", "void", "volatile", "while" ! 725: }; /* c_keywords */ ! 726: ! 727: int n_keywords = sizeof(c_keywords)/sizeof(char *); ! 728: ! 729: char *st_fields[] = { ! 730: "addr", "aerr", "aunit", "c", "cerr", "ciend", "cierr", ! 731: "cifmt", "cirec", "ciunit", "csta", "cunit", "d", "dims", ! 732: "h", "i", "iciend", "icierr", "icifmt", "icirlen", ! 733: "icirnum", "iciunit", "inacc", "inacclen", "inblank", ! 734: "inblanklen", "indir", "indirlen", "inerr", "inex", ! 735: "infile", "infilen", "infmt", "infmtlen", "inform", ! 736: "informlen", "inname", "innamed", "innamlen", "innrec", ! 737: "innum", "inopen", "inrecl", "inseq", "inseqlen", "inunf", ! 738: "inunflen", "inunit", "name", "nvars", "oacc", "oblnk", ! 739: "oerr", "ofm", "ofnm", "ofnmlen", "orl", "osta", "ounit", ! 740: "r", "type", "vars", "z" ! 741: }; ! 742: int n_st_fields = sizeof(st_fields)/sizeof(char *);
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.