Return to init.c CVS log

Up to [Research Unix] / researchv10no / cmd / f2c

Annotation of researchv10no/cmd/f2c/init.c, revision 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 "iob.h"
        !            27: 
        !            28: /* State required for the C output */
        !            29: char *fl_fmt_string;           /* Float format string */
        !            30: char *db_fmt_string;           /* Double format string */
        !            31: char *cm_fmt_string;           /* Complex format string */
        !            32: char *dcm_fmt_string;          /* Double complex format string */
        !            33: 
        !            34: chainp new_vars = CHNULL;      /* List of newly created locals in this
        !            35:                                   function.  These may have identifiers
        !            36:                                   which have underscores and more than VL
        !            37:                                   characters */
        !            38: chainp used_builtins = CHNULL; /* List of builtins used by this function.
        !            39:                                   These are all Addrps with UNAM_EXTERN
        !            40:                                   */
        !            41: chainp assigned_fmts = CHNULL; /* assigned formats */
        !            42: chainp allargs;                        /* union of args in all entry points */
        !            43: chainp earlylabs;              /* labels seen before enddcl() */
        !            44: char main_alias[52];           /* PROGRAM name, if any is given */
        !            45: int tab_size = 4;
        !            46: 
        !            47: 
        !            48: FILEP infile;
        !            49: FILEP diagfile;
        !            50: 
        !            51: FILEP c_file;
        !            52: FILEP pass1_file;
        !            53: FILEP initfile;
        !            54: FILEP blkdfile;
        !            55: 
        !            56: 
        !            57: char token[MAXTOKENLEN];
        !            58: int toklen;
        !            59: long lineno;                   /* Current line in the input file, NOT the
        !            60:                                   Fortran statement label number */
        !            61: char *infname;
        !            62: int needkwd;
        !            63: struct Labelblock *thislabel   = NULL;
        !            64: int nerr;
        !            65: int nwarn;
        !            66: 
        !            67: flag saveall;
        !            68: flag substars;
        !            69: int parstate   = OUTSIDE;
        !            70: flag headerdone        = NO;
        !            71: int blklevel;
        !            72: int doin_setbound;
        !            73: int impltype[26];
        !            74: ftnint implleng[26];
        !            75: int implstg[26];
        !            76: 
        !            77: int tyint      = TYLONG ;
        !            78: int tylogical  = TYLONG;
        !            79: int tylog      = TYLOGICAL;
        !            80: int typesize[NTYPES] = {
        !            81:        1, SZADDR, 1, SZSHORT, SZLONG,
        !            82: #ifdef TYQUAD
        !            83:                2*SZLONG,
        !            84: #endif
        !            85:                SZLONG, 2*SZLONG,
        !            86:                2*SZLONG, 4*SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0,
        !            87:                4*SZLONG + SZADDR,      /* sizeof(cilist) */
        !            88:                4*SZLONG + 2*SZADDR,    /* sizeof(icilist) */
        !            89:                4*SZLONG + 5*SZADDR,    /* sizeof(olist) */
        !            90:                2*SZLONG + SZADDR,      /* sizeof(cllist) */
        !            91:                2*SZLONG,               /* sizeof(alist) */
        !            92:                11*SZLONG + 15*SZADDR   /* sizeof(inlist) */
        !            93:                };
        !            94: 
        !            95: int typealign[NTYPES] = {
        !            96:        1, ALIADDR, 1, ALISHORT, ALILONG,
        !            97: #ifdef TYQUAD
        !            98:        ALIDOUBLE,
        !            99: #endif
        !           100:        ALILONG, ALIDOUBLE,
        !           101:        ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1,
        !           102:        ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
        !           103: 
        !           104: int type_choice[4] = { TYDREAL, TYSHORT, TYLONG,  TYSHORT };
        !           105: 
        !           106: char *typename[] = {
        !           107:        "<<unknown>>",
        !           108:        "address",
        !           109:        "integer1",
        !           110:        "shortint",
        !           111:        "integer",
        !           112: #ifdef TYQUAD
        !           113:        "longint",
        !           114: #endif
        !           115:        "real",
        !           116:        "doublereal",
        !           117:        "complex",
        !           118:        "doublecomplex",
        !           119:        "logical1",
        !           120:        "shortlogical",
        !           121:        "logical",
        !           122:        "char"  /* character */
        !           123:        };
        !           124: 
        !           125: int type_pref[NTYPES] = { 0, 0, 3, 5, 7,
        !           126: #ifdef TYQUAD
        !           127:                         10,
        !           128: #endif
        !           129:                                8, 11, 9, 12, 1, 4, 6, 2 };
        !           130: 
        !           131: char *protorettypes[] = {
        !           132:        "?", "??", "integer1", "shortint", "integer",
        !           133: #ifdef TYQUAD
        !           134:        "longint",
        !           135: #endif
        !           136:        "real", "doublereal",
        !           137:        "C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int"
        !           138:        };
        !           139: 
        !           140: char *casttypes[TYSUBR+1] = {
        !           141:        "U_fp", "??bug??", "I1_fp",
        !           142:        "J_fp", "I_fp",
        !           143: #ifdef TYQUAD
        !           144:        "Q_fp",
        !           145: #endif
        !           146:        "R_fp", "D_fp", "C_fp", "Z_fp",
        !           147:        "L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp"
        !           148:        };
        !           149: char *usedcasts[TYSUBR+1];
        !           150: 
        !           151: char *dfltarg[] = {
        !           152:        0, 0, "(integer1 *)0",
        !           153:        "(shortint *)0", "(integer *)0",
        !           154: #ifdef TYQUAD
        !           155:        "(longint *)0",
        !           156: #endif
        !           157:        "(real *)0",
        !           158:        "(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
        !           159:        "(logical1 *)0","(shortlogical *)0)", "(logical *)0", "(char *)0"
        !           160:        };
        !           161: 
        !           162: static char *dflt0proc[] = {
        !           163:        0, 0, "(integer1 (*)())0",
        !           164:        "(shortint (*)())0", "(integer (*)())0",
        !           165: #ifdef TYQUAD
        !           166:        "(longint (*)())0",
        !           167: #endif
        !           168:        "(real (*)())0",
        !           169:        "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
        !           170:        "(logical1 (*)())0", "(shortlogical (*)())0",
        !           171:        "(logical (*)())0", "(char (*)())0", "(int (*)())0"
        !           172:        };
        !           173: 
        !           174: char *dflt1proc[] = { "(U_fp)0", "(??bug??)0", "(I1_fp)0",
        !           175:        "(J_fp)0", "(I_fp)0",
        !           176: #ifdef TYQUAD
        !           177:        "(Q_fp)0",
        !           178: #endif
        !           179:        "(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0",
        !           180:        "(L1_fp)0","(L2_fp)0",
        !           181:        "(L_fp)0", "(H_fp)0", "(S_fp)0"
        !           182:        };
        !           183: 
        !           184: char **dfltproc = dflt0proc;
        !           185: 
        !           186: static char Bug[] = "bug";
        !           187: 
        !           188: char *ftn_types[] = { "external", "??", "integer*1",
        !           189:        "integer*2", "integer",
        !           190: #ifdef TYQUAD
        !           191:        "integer*8",
        !           192: #endif
        !           193:        "real",
        !           194:        "double precision", "complex", "double complex",
        !           195:        "logical*1", "logical*2",
        !           196:        "logical", "character", "subroutine",
        !           197:        Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
        !           198:        };
        !           199: 
        !           200: int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0,
        !           201: #ifdef TYQUAD
        !           202:                          0,
        !           203: #endif
        !           204:                          1, 1, 0, 0, 0, 2};
        !           205: 
        !           206: int proctype   = TYUNKNOWN;
        !           207: char *procname;
        !           208: int rtvlabel[NTYPES0];
        !           209: Addrp retslot;                 /* Holds automatic variable which was
        !           210:                                   allocated the function return value
        !           211:                                   */
        !           212: Addrp xretslot[NTYPES0];       /* for multiple entry points */
        !           213: int cxslot     = -1;
        !           214: int chslot     = -1;
        !           215: int chlgslot   = -1;
        !           216: int procclass  = CLUNKNOWN;
        !           217: int nentry;
        !           218: int nallargs;
        !           219: int nallchargs;
        !           220: flag multitype;
        !           221: ftnint procleng;
        !           222: long lastiolabno;
        !           223: int lastlabno;
        !           224: int lastvarno;
        !           225: int lastargslot;
        !           226: int autonum[TYVOID];
        !           227: char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i",
        !           228: #ifdef TYQUAD
        !           229:                         "i8",
        !           230: #endif
        !           231:                        "r","d","q","z","L1","L2","L","ch",
        !           232:                         "??TYSUBR??", "??TYERROR??","ci", "ici",
        !           233:                         "o", "cl", "al", "ioin" };
        !           234: 
        !           235: extern int maxctl;
        !           236: struct Ctlframe *ctls;
        !           237: struct Ctlframe *ctlstack;
        !           238: struct Ctlframe *lastctl;
        !           239: 
        !           240: Namep regnamep[MAXREGVAR];
        !           241: int highregvar;
        !           242: int nregvar;
        !           243: 
        !           244: extern int maxext;
        !           245: Extsym *extsymtab;
        !           246: Extsym *nextext;
        !           247: Extsym *lastext;
        !           248: 
        !           249: extern int maxequiv;
        !           250: struct Equivblock *eqvclass;
        !           251: 
        !           252: extern int maxhash;
        !           253: struct Hashentry *hashtab;
        !           254: struct Hashentry *lasthash;
        !           255: 
        !           256: extern int maxstno;            /* Maximum number of statement labels */
        !           257: struct Labelblock *labeltab;
        !           258: struct Labelblock *labtabend;
        !           259: struct Labelblock *highlabtab;
        !           260: 
        !           261: int maxdim     = MAXDIM;
        !           262: struct Rplblock *rpllist       = NULL;
        !           263: struct Chain *curdtp   = NULL;
        !           264: flag toomanyinit;
        !           265: ftnint curdtelt;
        !           266: chainp templist[TYVOID];
        !           267: chainp holdtemps;
        !           268: int dorange    = 0;
        !           269: struct Entrypoint *entries     = NULL;
        !           270: 
        !           271: chainp chains  = NULL;
        !           272: 
        !           273: flag inioctl;
        !           274: int iostmt;
        !           275: int nioctl;
        !           276: int nequiv     = 0;
        !           277: int eqvstart   = 0;
        !           278: int nintnames  = 0;
        !           279: extern int maxlablist;
        !           280: struct Labelblock **labarray;
        !           281: 
        !           282: struct Literal *litpool;
        !           283: int nliterals;
        !           284: 
        !           285: char dflttype[26];
        !           286: char hextoi_tab[Table_size], Letters[Table_size];
        !           287: char *ei_first, *ei_next, *ei_last;
        !           288: char *wh_first, *wh_next, *wh_last;
        !           289: 
        !           290: #define ALLOCN(n,x)    (struct x *) ckalloc((n)*sizeof(struct x))
        !           291: 
        !           292: fileinit()
        !           293: {
        !           294:        register char *s;
        !           295:        register int i, j;
        !           296:        extern void fmt_init(), mem_init(), np_init();
        !           297: 
        !           298:        lastiolabno = 100000;
        !           299:        lastlabno = 0;
        !           300:        lastvarno = 0;
        !           301:        nliterals = 0;
        !           302:        nerr = 0;
        !           303: 
        !           304:        infile = stdin;
        !           305: 
        !           306:        memset(dflttype, tyreal, 26);
        !           307:        memset(dflttype + 'i' - 'a', tyint, 6);
        !           308:        memset(hextoi_tab, 16, sizeof(hextoi_tab));
        !           309:        for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
        !           310:                hextoi(*s) = i;
        !           311:        for(i = 10, s = "ABCDEF"; *s; i++, s++)
        !           312:                hextoi(*s) = i;
        !           313:        for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
        !           314:                Letters[i] = Letters[i+'A'-'a'] = j;
        !           315: 
        !           316:        ctls = ALLOCN(maxctl+1, Ctlframe);
        !           317:        extsymtab = ALLOCN(maxext, Extsym);
        !           318:        eqvclass = ALLOCN(maxequiv, Equivblock);
        !           319:        hashtab = ALLOCN(maxhash, Hashentry);
        !           320:        labeltab = ALLOCN(maxstno, Labelblock);
        !           321:        litpool = ALLOCN(maxliterals, Literal);
        !           322:        labarray = (struct Labelblock **)ckalloc(maxlablist*
        !           323:                                        sizeof(struct Labelblock *));
        !           324:        fmt_init();
        !           325:        mem_init();
        !           326:        np_init();
        !           327: 
        !           328:        ctlstack = ctls++;
        !           329:        lastctl = ctls + maxctl;
        !           330:        nextext = extsymtab;
        !           331:        lastext = extsymtab + maxext;
        !           332:        lasthash = hashtab + maxhash;
        !           333:        labtabend = labeltab + maxstno;
        !           334:        highlabtab = labeltab;
        !           335:        main_alias[0] = '\0';
        !           336:        if (forcedouble)
        !           337:                dfltproc[TYREAL] = dfltproc[TYDREAL];
        !           338: 
        !           339: /* Initialize the routines for providing C output */
        !           340: 
        !           341:        out_init ();
        !           342: }
        !           343: 
        !           344: hashclear()    /* clear hash table */
        !           345: {
        !           346:        register struct Hashentry *hp;
        !           347:        register Namep p;
        !           348:        register struct Dimblock *q;
        !           349:        register int i;
        !           350: 
        !           351:        for(hp = hashtab ; hp < lasthash ; ++hp)
        !           352:                if(p = hp->varp)
        !           353:                {
        !           354:                        frexpr(p->vleng);
        !           355:                        if(q = p->vdim)
        !           356:                        {
        !           357:                                for(i = 0 ; i < q->ndim ; ++i)
        !           358:                                {
        !           359:                                        frexpr(q->dims[i].dimsize);
        !           360:                                        frexpr(q->dims[i].dimexpr);
        !           361:                                }
        !           362:                                frexpr(q->nelt);
        !           363:                                frexpr(q->baseoffset);
        !           364:                                frexpr(q->basexpr);
        !           365:                                free( (charptr) q);
        !           366:                        }
        !           367:                        if(p->vclass == CLNAMELIST)
        !           368:                                frchain( &(p->varxptr.namelist) );
        !           369:                        free( (charptr) p);
        !           370:                        hp->varp = NULL;
        !           371:                }
        !           372:        }
        !           373: 
        !           374: procinit()
        !           375: {
        !           376:        register struct Labelblock *lp;
        !           377:        struct Chain *cp;
        !           378:        int i;
        !           379:        struct memblock;
        !           380:        extern struct memblock *curmemblock, *firstmemblock;
        !           381:        extern char *mem_first, *mem_next, *mem_last, *mem0_last;
        !           382:        extern void frexchain();
        !           383: 
        !           384:        curmemblock = firstmemblock;
        !           385:        mem_next = mem_first;
        !           386:        mem_last = mem0_last;
        !           387:        ei_next = ei_first = ei_last = 0;
        !           388:        wh_next = wh_first = wh_last = 0;
        !           389:        iob_list = 0;
        !           390:        for(i = 0; i < 9; i++)
        !           391:                io_structs[i] = 0;
        !           392: 
        !           393:        parstate = OUTSIDE;
        !           394:        headerdone = NO;
        !           395:        blklevel = 1;
        !           396:        saveall = NO;
        !           397:        substars = NO;
        !           398:        nwarn = 0;
        !           399:        thislabel = NULL;
        !           400:        needkwd = 0;
        !           401: 
        !           402:        proctype = TYUNKNOWN;
        !           403:        procname = "MAIN_";
        !           404:        procclass = CLUNKNOWN;
        !           405:        nentry = 0;
        !           406:        nallargs = nallchargs = 0;
        !           407:        multitype = NO;
        !           408:        retslot = NULL;
        !           409:        for(i = 0; i < NTYPES0; i++) {
        !           410:                frexpr((expptr)xretslot[i]);
        !           411:                xretslot[i] = 0;
        !           412:                }
        !           413:        cxslot = -1;
        !           414:        chslot = -1;
        !           415:        chlgslot = -1;
        !           416:        procleng = 0;
        !           417:        blklevel = 1;
        !           418:        lastargslot = 0;
        !           419: 
        !           420:        for(lp = labeltab ; lp < labtabend ; ++lp)
        !           421:                lp->stateno = 0;
        !           422: 
        !           423:        hashclear();
        !           424: 
        !           425: /* Clear the list of newly generated identifiers from the previous
        !           426:    function */
        !           427: 
        !           428:        frexchain(&new_vars);
        !           429:        frexchain(&used_builtins);
        !           430:        frchain(&assigned_fmts);
        !           431:        frchain(&allargs);
        !           432:        frchain(&earlylabs);
        !           433: 
        !           434:        nintnames = 0;
        !           435:        highlabtab = labeltab;
        !           436: 
        !           437:        ctlstack = ctls - 1;
        !           438:        for(i = TYADDR; i < TYVOID; i++) {
        !           439:                for(cp = templist[i]; cp ; cp = cp->nextp)
        !           440:                        free( (charptr) (cp->datap) );
        !           441:                frchain(templist + i);
        !           442:                autonum[i] = 0;
        !           443:                }
        !           444:        holdtemps = NULL;
        !           445:        dorange = 0;
        !           446:        nregvar = 0;
        !           447:        highregvar = 0;
        !           448:        entries = NULL;
        !           449:        rpllist = NULL;
        !           450:        inioctl = NO;
        !           451:        eqvstart += nequiv;
        !           452:        nequiv = 0;
        !           453:        dcomplex_seen = 0;
        !           454: 
        !           455:        for(i = 0 ; i<NTYPES0 ; ++i)
        !           456:                rtvlabel[i] = 0;
        !           457: 
        !           458:        if(undeftype)
        !           459:                setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
        !           460:        else
        !           461:        {
        !           462:                setimpl(tyreal, (ftnint) 0, 'a', 'z');
        !           463:                setimpl(tyint,  (ftnint) 0, 'i', 'n');
        !           464:        }
        !           465:        setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
        !           466:        setlog();
        !           467: }
        !           468: 
        !           469: 
        !           470: 
        !           471: 
        !           472: setimpl(type, length, c1, c2)
        !           473: int type;
        !           474: ftnint length;
        !           475: int c1, c2;
        !           476: {
        !           477:        int i;
        !           478:        char buff[100];
        !           479: 
        !           480:        if(c1==0 || c2==0)
        !           481:                return;
        !           482: 
        !           483:        if(c1 > c2) {
        !           484:                sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
        !           485:                err(buff);
        !           486:                }
        !           487:        else {
        !           488:                c1 = letter(c1);
        !           489:                c2 = letter(c2);
        !           490:                if(type < 0)
        !           491:                        for(i = c1 ; i<=c2 ; ++i)
        !           492:                                implstg[i] = - type;
        !           493:                else {
        !           494:                        type = lengtype(type, length);
        !           495:                        if(type == TYCHAR) {
        !           496:                                if (length < 0) {
        !           497:                                        err("length (*) in implicit");
        !           498:                                        length = 1;
        !           499:                                        }
        !           500:                                }
        !           501:                        else if (type != TYLONG)
        !           502:                                length = 0;
        !           503:                        for(i = c1 ; i<=c2 ; ++i) {
        !           504:                                impltype[i] = type;
        !           505:                                implleng[i] = length;
        !           506:                                }
        !           507:                        }
        !           508:                }
        !           509:        }

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