00001 /****************************************************************
00002 Copyright 1990, 1992 - 1996 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "defs.h"
00025 #include "output.h"
00026 #include "names.h"
00027 #include "iob.h"
00028 
00029 
00030 /* Names generated by the translator are guaranteed to be unique from the
00031    Fortan names because Fortran does not allow underscores in identifiers,
00032    and all of the system generated names do have underscores.  The various
00033    naming conventions are outlined below:
00034 
00035         FORMAT          APPLICATION
00036    ----------------------------------------------------------------------
00037         io_#            temporaries generated by IO calls; these will
00038                         contain the device number (e.g. 5, 6, 0)
00039         ret_val         function return value, required for complex and
00040                         character functions.
00041         ret_val_len     length of the return value in character functions
00042 
00043         ssss_len        length of character argument "ssss"
00044 
00045         c_#             member of the literal pool, where # is an
00046                         arbitrary label assigned by the system
00047         cs_#            short integer constant in the literal pool
00048         t_#             expression temporary, # is the depth of arguments
00049                         on the stack.
00050         L#              label "#", given by user in the Fortran program.
00051                         This is unique because Fortran labels are numeric
00052         pad_#           label on an init field required for alignment
00053         xxx_init        label on a common block union, if a block data
00054                         requires a separate declaration
00055 */
00056 
00057 /* generate variable references */
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 /* If a procedure's type is unknown, assume it's a subroutine */
00104 
00105                         if (!is_extern)
00106                             break;
00107 
00108 /* Subroutines must return an INT, because they might return a label
00109    value.  Even if one doesn't, the caller will EXPECT it to. */
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     } /* switch */
00125 
00126     return buff;
00127 } /* c_type_decl */
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"; /* avoid conflict with libF77 */
00154                         }
00155           }
00156         sprintf (buf, fmt, s);
00157         return buf;
00158 } /* new_arg_length */
00159 
00160 
00161 /* declare_new_addr -- Add a new local variable to the function, given a
00162    pointer to an Addrblock structure (which must have the uname_tag set)
00163    This list of idents will be printed in reverse (i.e., chronological)
00164    order */
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 } /* declare_new_addr */
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     } /* if */
00201     out_addr (outfile, addrp);
00202     if (eltcount)
00203         nice_printf (outfile, "[%d]", eltcount);
00204 } /* wr_nv_ident_help */
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 } /* nv_type_help */
00219 
00220 
00221 /* lit_name -- returns a unique identifier for the given literal.  Make
00222    the label useful, when possible.  For example:
00223 
00224         1 -> c_1                (constant 1)
00225         2 -> c_2                (constant 2)
00226         1000 -> c_1000          (constant 1000)
00227         1000000 -> c_b<memno>   (big constant number)
00228         1.2 -> c_1_2            (constant 1.2)
00229         1.234345 -> c_b<memno>  (big constant number)
00230         -1 -> c_n1              (constant -1)
00231         -1.0 -> c_n1_0          (constant -1.0)
00232         .true. -> c_true        (constant true)
00233         .false. -> c_false      (constant false)
00234         default -> c_b<memno>   (default label)
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                 /* Given a limit of 6 or 8 character on external names, */
00298                 /* few f.p. values can be meaningfully encoded in the   */
00299                 /* constant name.  Just going with the default cb_#     */
00300                 /* seems to be the best course for floating-point       */
00301                 /* constants.   */
00302         case TYCHAR:
00303                 /* Shouldn't be any of these */
00304         case TYADDR:
00305         case TYCOMPLEX:
00306         case TYDCOMPLEX:
00307         case TYSUBR:
00308         default:
00309                 sprintf (buf, "c_b%ld", litp -> litnum);
00310     } /* switch */
00311     return buf;
00312 } /* lit_name */
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 /* wr_globals -- after every function has been translated, we need to
00334    output the global declarations, such as the static table of constant
00335    values */
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     } /* for */
00402     if (did_one)
00403         nice_printf (outfile, "\n");
00404 } /* wr_globals */
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    /* Pad common block if an EQUIVALENCE extended it. */
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 /* wr_common_decls -- outputs the common declarations in one of three
00467    formats.  If all references to a common block look the same (field
00468    names and types agree), only one actual declaration will appear.
00469    Otherwise, the same block will require many structs.  If there is no
00470    block data, these structs will be union'ed together (so the linker
00471    knows the size of the largest one).  If there IS a block data, only
00472    that version will be associated with the variable, others will only be
00473    defined as types, so the pointer can be cast to it.  e.g.
00474 
00475         FORTRAN                         C
00476 ----------------------------------------------------------------------
00477         common /com1/ a, b, c           struct { real a, b, c; } com1_;
00478 
00479         common /com1/ a, b, c           union {
00480         common /com1/ i, j, k               struct { real a, b, c; } _1;
00481                                             struct { integer i, j, k; } _2;
00482                                         } com1_;
00483 
00484         common /com1/ a, b, c           struct com1_1_ { real a, b, c; };
00485         block data                      struct { integer i, j, k; } com1_ =
00486         common /com1/ i, j, k             { 1, 2, 3 };
00487         data i/1/, j/2/, k/3/
00488 
00489 
00490    All of these versions will be followed by #defines, since the code in
00491    the function bodies can't know ahead of time which of these options
00492    will be taken */
00493 
00494 /* Macros for deciding the output type */
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;                  /* which display to use;
00519                                            ONE_STRUCT, UNION or INIT */
00520 
00521             if (!did_one)
00522                 nice_printf (outfile, "/* Common Block Declarations */\n\n");
00523 
00524             pad_common(ext);
00525 
00526 /* Construct the proper, condensed list of structs; eliminate duplicates
00527    from the initial list   ext -> allextp   */
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             } /* for */
00564 
00565             if (which == UNION_STRUCT) {
00566                 prev_tab (c_file);
00567                 nice_printf (outfile, "} %s;\n", ext->cextname);
00568             } /* if */
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                 } /* switch */
00593                 nice_printf (outfile, "\n");
00594             } /* for count = 1, comm = ext -> allextp */
00595             nice_printf (outfile, "\n");
00596         } /* if ext -> extstg == STGCOMMON */
00597     } /* for ext = extsymtab */
00598 } /* wr_common_decls */
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         } /* else */
00634 
00635 /* Character type is really a string type.  Put out a '*' for parameters
00636    with unknown length and functions returning character */
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     } /* for this_var */
00660 
00661     if (did_one)
00662         nice_printf (outfile, ";\n");
00663 } /* wr_struct */
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 } /* user_label */
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 } /* temp_name */
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 } /* equiv_name */
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 /* C Language keywords.  Needed to filter unwanted fortran identifiers like
00801  * "int", etc.  Source:  Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
00802  * Also includes C++ keywords and types used for I/O in f2c.h .
00803  * These keywords must be in alphabetical order (as defined by strcmp()).
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         }; /* c_keywords */
00834 
00835 int n_keywords = sizeof(c_keywords)/sizeof(char *);