Annotation of researchv10no/cmd/f2c/names.c, revision 1.1.1.1

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 *);

unix.superglobalmegacorp.com

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.