Return to proc.c CVS log

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

Annotation of researchv10no/cmd/f2c/proc.c, revision 1.1

1.1     ! root        1: /****************************************************************
        !             2: Copyright 1990, 1991, 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 "names.h"
        !            26: #include "output.h"
        !            27: #include "p1defs.h"
        !            28: 
        !            29: #define EXNULL (union Expression *)0
        !            30: 
        !            31: LOCAL dobss(), docomleng(), docommon(), doentry(),
        !            32:        epicode(), nextarg(), retval();
        !            33: 
        !            34: static char Blank[] = BLANKCOMMON;
        !            35: 
        !            36:  static char *postfix[] = { "g", "h", "i",
        !            37: #ifdef TYQUAD
        !            38:                                        "j",
        !            39: #endif
        !            40:                                        "r", "d", "c", "z", "g", "h", "i" };
        !            41: 
        !            42:  chainp new_procs;
        !            43:  int prev_proc, proc_argchanges, proc_protochanges;
        !            44: 
        !            45:  void
        !            46: changedtype(q)
        !            47:  Namep q;
        !            48: {
        !            49:        char buf[200];
        !            50:        int qtype, type1;
        !            51:        register Extsym *e;
        !            52:        Argtypes *at;
        !            53: 
        !            54:        if (q->vtypewarned)
        !            55:                return;
        !            56:        q->vtypewarned = 1;
        !            57:        qtype = q->vtype;
        !            58:        e = &extsymtab[q->vardesc.varno];
        !            59:        if (!(at = e->arginfo)) {
        !            60:                if (!e->exused)
        !            61:                        return;
        !            62:                }
        !            63:        else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
        !            64:                proc_protochanges++;
        !            65:        type1 = e->extype;
        !            66:        if (type1 == TYUNKNOWN)
        !            67:                return;
        !            68:        if (qtype == TYUNKNOWN)
        !            69:                /* e.g.,
        !            70:                        subroutine foo
        !            71:                        end
        !            72:                        external foo
        !            73:                        call goo(foo)
        !            74:                        end
        !            75:                */
        !            76:                return;
        !            77:        sprintf(buf, "%.90s: inconsistent declarations:\n\
        !            78:        here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
        !            79:                qtype == TYSUBR ? "" : " function",
        !            80:                ftn_types[type1], type1 == TYSUBR ? "" : " function");
        !            81:        warn(buf);
        !            82:        }
        !            83: 
        !            84:  void
        !            85: unamstring(q, s)
        !            86:  register Addrp q;
        !            87:  register char *s;
        !            88: {
        !            89:        register int k;
        !            90:        register char *t;
        !            91: 
        !            92:        k = strlen(s);
        !            93:        if (k < IDENT_LEN) {
        !            94:                q->uname_tag = UNAM_IDENT;
        !            95:                t = q->user.ident;
        !            96:                }
        !            97:        else {
        !            98:                q->uname_tag = UNAM_CHARP;
        !            99:                q->user.Charp = t = mem(k+1, 0);
        !           100:                }
        !           101:        strcpy(t, s);
        !           102:        }
        !           103: 
        !           104:  static void
        !           105: fix_entry_returns()    /* for multiple entry points */
        !           106: {
        !           107:        Addrp a;
        !           108:        int i;
        !           109:        struct Entrypoint *e;
        !           110:        Namep np;
        !           111: 
        !           112:        e = entries = (struct Entrypoint *)revchain((chainp)entries);
        !           113:        allargs = revchain(allargs);
        !           114:        if (!multitype)
        !           115:                return;
        !           116: 
        !           117:        /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
        !           118: 
        !           119:        for(i = TYINT1; i <= TYLOGICAL; i++)
        !           120:                if (a = xretslot[i])
        !           121:                        sprintf(a->user.ident, "(*ret_val).%s",
        !           122:                                postfix[i-TYINT1]);
        !           123: 
        !           124:        do {
        !           125:                np = e->enamep;
        !           126:                switch(np->vtype) {
        !           127:                        case TYINT1:
        !           128:                        case TYSHORT:
        !           129:                        case TYLONG:
        !           130: #ifdef TYQUAD
        !           131:                        case TYQUAD:
        !           132: #endif
        !           133:                        case TYREAL:
        !           134:                        case TYDREAL:
        !           135:                        case TYCOMPLEX:
        !           136:                        case TYDCOMPLEX:
        !           137:                        case TYLOGICAL1:
        !           138:                        case TYLOGICAL2:
        !           139:                        case TYLOGICAL:
        !           140:                                np->vstg = STGARG;
        !           141:                        }
        !           142:                }
        !           143:                while(e = e->entnextp);
        !           144:        }
        !           145: 
        !           146:  static void
        !           147: putentries(outfile)    /* put out wrappers for multiple entries */
        !           148:  FILE *outfile;
        !           149: {
        !           150:        char base[IDENT_LEN];
        !           151:        struct Entrypoint *e;
        !           152:        Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
        !           153:        chainp args, lengths, length_comp();
        !           154:        void listargs(), list_arg_types();
        !           155:        int i, k, mt, nL, type;
        !           156:        extern char *dfltarg[], **dfltproc;
        !           157: 
        !           158:        e = entries;
        !           159:        if (!e->enamep) /* only possible with erroneous input */
        !           160:                return;
        !           161:        nL = (nallargs + nallchargs) * sizeof(Namep *);
        !           162:        A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
        !           163:        Ae = A + nallargs;
        !           164:        Alp = (Namep **)(Ae1 = Ae + nallchargs);
        !           165:        i = k = 0;
        !           166:        for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
        !           167:                np = (Namep)args->datap;
        !           168:                if (np->vtype == TYCHAR && np->vclass != CLPROC)
        !           169:                        *a1 = &Ae[i++];
        !           170:                }
        !           171: 
        !           172:        mt = multitype;
        !           173:        multitype = 0;
        !           174:        sprintf(base, "%s0_", e->enamep->cvarname);
        !           175:        do {
        !           176:                np = e->enamep;
        !           177:                lengths = length_comp(e, 0);
        !           178:                proctype = type = np->vtype;
        !           179:                if (protofile)
        !           180:                        protowrite(protofile, type, np->cvarname, e, lengths);
        !           181:                nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
        !           182:                nice_printf(outfile, "%s", np->cvarname);
        !           183:                if (!Ansi) {
        !           184:                        listargs(outfile, e, 0, lengths);
        !           185:                        nice_printf(outfile, "\n");
        !           186:                        }
        !           187:                list_arg_types(outfile, e, lengths, 0, "\n");
        !           188:                nice_printf(outfile, "{\n");
        !           189:                frchain(&lengths);
        !           190:                next_tab(outfile);
        !           191:                if (mt)
        !           192:                        nice_printf(outfile,
        !           193:                                "Multitype ret_val;\n%s(%d, &ret_val",
        !           194:                                base, k); /*)*/
        !           195:                else if (ISCOMPLEX(type))
        !           196:                        nice_printf(outfile, "%s(%d,%s", base, k,
        !           197:                                xretslot[type]->user.ident); /*)*/
        !           198:                else if (type == TYCHAR)
        !           199:                        nice_printf(outfile,
        !           200:                                "%s(%d, ret_val, ret_val_len", base, k); /*)*/
        !           201:                else
        !           202:                        nice_printf(outfile, "return %s(%d", base, k); /*)*/
        !           203:                k++;
        !           204:                memset((char *)A, 0, nL);
        !           205:                for(args = e->arglist; args; args = args->nextp) {
        !           206:                        np = (Namep)args->datap;
        !           207:                        A[np->argno] = np;
        !           208:                        if (np->vtype == TYCHAR && np->vclass != CLPROC)
        !           209:                                *Alp[np->argno] = np;
        !           210:                        }
        !           211:                args = allargs;
        !           212:                for(a = A; a < Ae; a++, args = args->nextp)
        !           213:                        nice_printf(outfile, ", %s", (np = *a)
        !           214:                                ? np->cvarname
        !           215:                                : ((Namep)args->datap)->vclass == CLPROC
        !           216:                                ? dfltproc[((Namep)args->datap)->vtype]
        !           217:                                : dfltarg[((Namep)args->datap)->vtype]);
        !           218:                for(; a < Ae1; a++)
        !           219:                        if (np = *a)
        !           220:                                nice_printf(outfile, ", %s_len", np->fvarname);
        !           221:                        else
        !           222:                                nice_printf(outfile, ", (ftnint)0");
        !           223:                nice_printf(outfile, /*(*/ ");\n");
        !           224:                if (mt) {
        !           225:                        if (type == TYCOMPLEX)
        !           226:                                nice_printf(outfile,
        !           227:                    "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\nreturn 0;\n");
        !           228:                        else if (type == TYDCOMPLEX)
        !           229:                                nice_printf(outfile,
        !           230:                    "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\nreturn 0;\n");
        !           231:                        else nice_printf(outfile, "return ret_val.%s;\n",
        !           232:                                postfix[type-TYINT1]);
        !           233:                        }
        !           234:                nice_printf(outfile, "}\n");
        !           235:                prev_tab(outfile);
        !           236:                }
        !           237:                while(e = e->entnextp);
        !           238:        free((char *)A);
        !           239:        }
        !           240: 
        !           241:  static void
        !           242: entry_goto(outfile)
        !           243:  FILEP outfile;
        !           244: {
        !           245:        struct Entrypoint *e = entries;
        !           246:        int k = 0;
        !           247: 
        !           248:        nice_printf(outfile, "switch(n__) {\n");
        !           249:        next_tab(outfile);
        !           250:        while(e = e->entnextp)
        !           251:                nice_printf(outfile, "case %d: goto %s;\n", ++k,
        !           252:                        user_label((long)(extsymtab - e->entryname - 1)));
        !           253:        nice_printf(outfile, "}\n\n");
        !           254:        prev_tab(outfile);
        !           255:        }
        !           256: 
        !           257: /* start a new procedure */
        !           258: 
        !           259: newproc()
        !           260: {
        !           261:        if(parstate != OUTSIDE)
        !           262:        {
        !           263:                execerr("missing end statement", CNULL);
        !           264:                endproc();
        !           265:        }
        !           266: 
        !           267:        parstate = INSIDE;
        !           268:        procclass = CLMAIN;     /* default */
        !           269: }
        !           270: 
        !           271:  static void
        !           272: zap_changes()
        !           273: {
        !           274:        register chainp cp;
        !           275:        register Argtypes *at;
        !           276: 
        !           277:        /* arrange to get correct count of prototypes that would
        !           278:           change by running f2c again */
        !           279: 
        !           280:        if (prev_proc && proc_argchanges)
        !           281:                proc_protochanges++;
        !           282:        prev_proc = proc_argchanges = 0;
        !           283:        for(cp = new_procs; cp; cp = cp->nextp)
        !           284:                if (at = ((Namep)cp->datap)->arginfo)
        !           285:                        at->changes &= ~1;
        !           286:        frchain(&new_procs);
        !           287:        }
        !           288: 
        !           289: /* end of procedure. generate variables, epilogs, and prologs */
        !           290: 
        !           291: endproc()
        !           292: {
        !           293:        struct Labelblock *lp;
        !           294:        Extsym *ext;
        !           295: 
        !           296:        if(parstate < INDATA)
        !           297:                enddcl();
        !           298:        if(ctlstack >= ctls)
        !           299:                err("DO loop or BLOCK IF not closed");
        !           300:        for(lp = labeltab ; lp < labtabend ; ++lp)
        !           301:                if(lp->stateno!=0 && lp->labdefined==NO)
        !           302:                        errstr("missing statement label %s",
        !           303:                                convic(lp->stateno) );
        !           304: 
        !           305: /* Save copies of the common variables in extptr -> allextp */
        !           306: 
        !           307:        for (ext = extsymtab; ext < nextext; ext++)
        !           308:                if (ext -> extstg == STGCOMMON && ext -> extp) {
        !           309:                        extern int usedefsforcommon;
        !           310: 
        !           311: /* Write out the abbreviations for common block reference */
        !           312: 
        !           313:                        copy_data (ext -> extp);
        !           314:                        if (usedefsforcommon) {
        !           315:                                wr_abbrevs (c_file, 1, ext -> extp);
        !           316:                                ext -> used_here = 1;
        !           317:                                }
        !           318:                        else
        !           319:                                ext -> extp = CHNULL;
        !           320: 
        !           321:                        }
        !           322: 
        !           323:        if (nentry > 1)
        !           324:                fix_entry_returns();
        !           325:        epicode();
        !           326:        donmlist();
        !           327:        dobss();
        !           328:        start_formatting ();
        !           329:        if (nentry > 1)
        !           330:                putentries(c_file);
        !           331: 
        !           332:        zap_changes();
        !           333:        procinit();     /* clean up for next procedure */
        !           334: }
        !           335: 
        !           336: 
        !           337: 
        !           338: /* End of declaration section of procedure.  Allocate storage. */
        !           339: 
        !           340: enddcl()
        !           341: {
        !           342:        register struct Entrypoint *ep;
        !           343:        struct Entrypoint *ep0;
        !           344:        extern void freetemps();
        !           345:        chainp cp;
        !           346:        extern char *err_proc;
        !           347:        static char comblks[] = "common blocks";
        !           348: 
        !           349:        err_proc = comblks;
        !           350:        docommon();
        !           351: 
        !           352: /* Now the hash table entries for fields of common blocks have STGCOMMON,
        !           353:    vdcldone, voffset, and varno.  And the common blocks themselves have
        !           354:    their full sizes in extleng. */
        !           355: 
        !           356:        err_proc = "equivalences";
        !           357:        doequiv();
        !           358: 
        !           359:        err_proc = comblks;
        !           360:        docomleng();
        !           361: 
        !           362: /* This implies that entry points in the declarations are buffered in
        !           363:    entries   but not written out */
        !           364: 
        !           365:        err_proc = "entries";
        !           366:        if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
        !           367:                /* entries could be 0 in case of an error */
        !           368:                do doentry(ep);
        !           369:                        while(ep = ep->entnextp);
        !           370:                entries = (struct Entrypoint *)revchain((chainp)ep0);
        !           371:                }
        !           372: 
        !           373:        err_proc = 0;
        !           374:        parstate = INEXEC;
        !           375:        p1put(P1_PROCODE);
        !           376:        freetemps();
        !           377:        if (earlylabs) {
        !           378:                for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
        !           379:                        p1_label((long)cp->datap);
        !           380:                frchain(&earlylabs);
        !           381:                }
        !           382: }
        !           383: 
        !           384: /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
        !           385: 
        !           386: /* Main program or Block data */
        !           387: 
        !           388: startproc(progname, class)
        !           389: Extsym * progname;
        !           390: int class;
        !           391: {
        !           392:        register struct Entrypoint *p;
        !           393: 
        !           394:        p = ALLOC(Entrypoint);
        !           395:        if(class == CLMAIN) {
        !           396:                puthead(CNULL, CLMAIN);
        !           397:                if (progname)
        !           398:                    strcpy (main_alias, progname->cextname);
        !           399:        } else
        !           400:                puthead(CNULL, CLBLOCK);
        !           401:        if(class == CLMAIN)
        !           402:                newentry( mkname(" MAIN"), 0 )->extinit = 1;
        !           403:        p->entryname = progname;
        !           404:        entries = p;
        !           405: 
        !           406:        procclass = class;
        !           407:        fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
        !           408:        if(progname) {
        !           409:                fprintf(diagfile, " %s", progname->fextname);
        !           410:                procname = progname->cextname;
        !           411:                }
        !           412:        fprintf(diagfile, ":\n");
        !           413:        fflush(diagfile);
        !           414: }
        !           415: 
        !           416: /* subroutine or function statement */
        !           417: 
        !           418: Extsym *newentry(v, substmsg)
        !           419:  register Namep v;
        !           420:  int substmsg;
        !           421: {
        !           422:        register Extsym *p;
        !           423:        char buf[128], badname[64];
        !           424:        static int nbad = 0;
        !           425:        static char already[] = "external name already used";
        !           426: 
        !           427:        p = mkext(v->fvarname, addunder(v->cvarname));
        !           428: 
        !           429:        if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
        !           430:        {
        !           431:                sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
        !           432:                if (substmsg) {
        !           433:                        sprintf(buf,"%s\n\tsubstituting \"%s\"",
        !           434:                                already, badname);
        !           435:                        dclerr(buf, v);
        !           436:                        }
        !           437:                else
        !           438:                        dclerr(already, v);
        !           439:                p = mkext(v->fvarname, badname);
        !           440:        }
        !           441:        v->vstg = STGAUTO;
        !           442:        v->vprocclass = PTHISPROC;
        !           443:        v->vclass = CLPROC;
        !           444:        if (p->extstg == STGEXT)
        !           445:                prev_proc = 1;
        !           446:        else
        !           447:                p->extstg = STGEXT;
        !           448:        p->extinit = YES;
        !           449:        v->vardesc.varno = p - extsymtab;
        !           450:        return(p);
        !           451: }
        !           452: 
        !           453: 
        !           454: entrypt(class, type, length, entry, args)
        !           455: int class, type;
        !           456: ftnint length;
        !           457: Extsym *entry;
        !           458: chainp args;
        !           459: {
        !           460:        register Namep q;
        !           461:        register struct Entrypoint *p;
        !           462: 
        !           463:        if(class != CLENTRY)
        !           464:                puthead( procname = entry->cextname, class);
        !           465:        else
        !           466:                fprintf(diagfile, "       entry ");
        !           467:        fprintf(diagfile, "   %s:\n", entry->fextname);
        !           468:        fflush(diagfile);
        !           469:        q = mkname(entry->fextname);
        !           470:        if (type == TYSUBR)
        !           471:                q->vstg = STGEXT;
        !           472: 
        !           473:        type = lengtype(type, length);
        !           474:        if(class == CLPROC)
        !           475:        {
        !           476:                procclass = CLPROC;
        !           477:                proctype = type;
        !           478:                procleng = type == TYCHAR ? length : 0;
        !           479:        }
        !           480: 
        !           481:        p = ALLOC(Entrypoint);
        !           482: 
        !           483:        p->entnextp = entries;
        !           484:        entries = p;
        !           485: 
        !           486:        p->entryname = entry;
        !           487:        p->arglist = revchain(args);
        !           488:        p->enamep = q;
        !           489: 
        !           490:        if(class == CLENTRY)
        !           491:        {
        !           492:                class = CLPROC;
        !           493:                if(proctype == TYSUBR)
        !           494:                        type = TYSUBR;
        !           495:        }
        !           496: 
        !           497:        q->vclass = class;
        !           498:        q->vprocclass = 0;
        !           499:        settype(q, type, length);
        !           500:        q->vprocclass = PTHISPROC;
        !           501:        /* hold all initial entry points till end of declarations */
        !           502:        if(parstate >= INDATA)
        !           503:                doentry(p);
        !           504: }
        !           505: 
        !           506: /* generate epilogs */
        !           507: 
        !           508: /* epicode -- write out the proper function return mechanism at the end of
        !           509:    the procedure declaration.  Handles multiple return value types, as
        !           510:    well as cooercion into the proper value */
        !           511: 
        !           512: LOCAL epicode()
        !           513: {
        !           514:        extern int lastwasbranch;
        !           515: 
        !           516:        if(procclass==CLPROC)
        !           517:        {
        !           518:                if(proctype==TYSUBR)
        !           519:                {
        !           520: 
        !           521: /* Return a zero only when the alternate return mechanism has been
        !           522:    specified in the function header */
        !           523: 
        !           524:                        if ((substars || Ansi) && lastwasbranch != YES)
        !           525:                            p1_subr_ret (ICON(0));
        !           526:                }
        !           527:                else if (!multitype && lastwasbranch != YES)
        !           528:                        retval(proctype);
        !           529:        }
        !           530:        else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
        !           531:                p1_subr_ret (ICON(0));
        !           532:        lastwasbranch = NO;
        !           533: }
        !           534: 
        !           535: 
        !           536: /* generate code to return value of type  t */
        !           537: 
        !           538: LOCAL retval(t)
        !           539: register int t;
        !           540: {
        !           541:        register Addrp p;
        !           542: 
        !           543:        switch(t)
        !           544:        {
        !           545:        case TYCHAR:
        !           546:        case TYCOMPLEX:
        !           547:        case TYDCOMPLEX:
        !           548:                break;
        !           549: 
        !           550:        case TYLOGICAL:
        !           551:                t = tylogical;
        !           552:        case TYINT1:
        !           553:        case TYADDR:
        !           554:        case TYSHORT:
        !           555:        case TYLONG:
        !           556: #ifdef TYQUAD
        !           557:        case TYQUAD:
        !           558: #endif
        !           559:        case TYREAL:
        !           560:        case TYDREAL:
        !           561:        case TYLOGICAL1:
        !           562:        case TYLOGICAL2:
        !           563:                p = (Addrp) cpexpr((expptr)retslot);
        !           564:                p->vtype = t;
        !           565:                p1_subr_ret (mkconv (t, fixtype((expptr)p)));
        !           566:                break;
        !           567: 
        !           568:        default:
        !           569:                badtype("retval", t);
        !           570:        }
        !           571: }
        !           572: 
        !           573: 
        !           574: /* Do parameter adjustments */
        !           575: 
        !           576: procode(outfile)
        !           577: FILE *outfile;
        !           578: {
        !           579:        prolog(outfile, allargs);
        !           580: 
        !           581:        if (nentry > 1)
        !           582:                entry_goto(outfile);
        !           583:        }
        !           584: 
        !           585: /* Finish bound computations now that all variables are declared.
        !           586:  * This used to be in setbound(), but under -u the following incurred
        !           587:  * an erroneous error message:
        !           588:  *     subroutine foo(x,n)
        !           589:  *     real x(n)
        !           590:  *     integer n
        !           591:  */
        !           592: 
        !           593:  static void
        !           594: dim_finish(v)
        !           595:  Namep v;
        !           596: {
        !           597:        register struct Dimblock *p;
        !           598:        register expptr q;
        !           599:        register int i, nd;
        !           600:        extern expptr make_int_expr();
        !           601: 
        !           602:        p = v->vdim;
        !           603:        v->vdimfinish = 0;
        !           604:        nd = p->ndim;
        !           605:        doin_setbound = 1;
        !           606:        for(i = 0; i < nd; i++)
        !           607:                if (q = p->dims[i].dimexpr) {
        !           608:                        q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
        !           609:                        if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
        !           610:                                errstr("bad dimension type for %.70s",
        !           611:                                        v->fvarname);
        !           612:                        }
        !           613:        if (q = p->basexpr)
        !           614:                p->basexpr = make_int_expr(putx(fixtype(q)));
        !           615:        doin_setbound = 0;
        !           616:        }
        !           617: 
        !           618:  static void
        !           619: duparg(q)
        !           620:  Namep q;
        !           621: { errstr("duplicate argument %.80s", q->fvarname); }
        !           622: 
        !           623: /*
        !           624:    manipulate argument lists (allocate argument slot positions)
        !           625:  * keep track of return types and labels
        !           626:  */
        !           627: 
        !           628: LOCAL doentry(ep)
        !           629: struct Entrypoint *ep;
        !           630: {
        !           631:        register int type;
        !           632:        register Namep np;
        !           633:        chainp p, p1;
        !           634:        register Namep q;
        !           635:        Addrp mkarg(), rs;
        !           636:        int it, k;
        !           637:        extern char dflttype[26];
        !           638:        Extsym *entryname = ep->entryname;
        !           639: 
        !           640:        if (++nentry > 1)
        !           641:                p1_label((long)(extsymtab - entryname - 1));
        !           642: 
        !           643: /* The main program isn't allowed to have parameters, so any given
        !           644:    parameters are ignored */
        !           645: 
        !           646:        if(procclass == CLMAIN || procclass == CLBLOCK)
        !           647:                return;
        !           648: 
        !           649: /* So now we're working with something other than CLMAIN or CLBLOCK.
        !           650:    Determine the type of its return value. */
        !           651: 
        !           652:        impldcl( np = mkname(entryname->fextname) );
        !           653:        type = np->vtype;
        !           654:        proc_argchanges = prev_proc && type != entryname->extype;
        !           655:        entryname->extseen = 1;
        !           656:        if(proctype == TYUNKNOWN)
        !           657:                if( (proctype = type) == TYCHAR)
        !           658:                        procleng = np->vleng ? np->vleng->constblock.Const.ci
        !           659:                                             : (ftnint) (-1);
        !           660: 
        !           661:        if(proctype == TYCHAR)
        !           662:        {
        !           663:                if(type != TYCHAR)
        !           664:                        err("noncharacter entry of character function");
        !           665: 
        !           666: /* Functions returning type   char   can only have multiple entries if all
        !           667:    entries return the same length */
        !           668: 
        !           669:                else if( (np->vleng ? np->vleng->constblock.Const.ci :
        !           670:                    (ftnint) (-1)) != procleng)
        !           671:                        err("mismatched character entry lengths");
        !           672:        }
        !           673:        else if(type == TYCHAR)
        !           674:                err("character entry of noncharacter function");
        !           675:        else if(type != proctype)
        !           676:                multitype = YES;
        !           677:        if(rtvlabel[type] == 0)
        !           678:                rtvlabel[type] = newlabel();
        !           679:        ep->typelabel = rtvlabel[type];
        !           680: 
        !           681:        if(type == TYCHAR)
        !           682:        {
        !           683:                if(chslot < 0)
        !           684:                {
        !           685:                        chslot = nextarg(TYADDR);
        !           686:                        chlgslot = nextarg(TYLENG);
        !           687:                }
        !           688:                np->vstg = STGARG;
        !           689: 
        !           690: /* Put a new argument in the function, one which will hold the result of
        !           691:    a character function.  This will have to be named sometime, probably in
        !           692:    mkarg(). */
        !           693: 
        !           694:                if(procleng < 0) {
        !           695:                        np->vleng = (expptr) mkarg(TYLENG, chlgslot);
        !           696:                        np->vleng->addrblock.uname_tag = UNAM_IDENT;
        !           697:                        strcpy (np -> vleng -> addrblock.user.ident,
        !           698:                                new_func_length());
        !           699:                        }
        !           700:                if (!xretslot[TYCHAR]) {
        !           701:                        xretslot[TYCHAR] = rs =
        !           702:                                autovar(0, type, ISCONST(np->vleng)
        !           703:                                        ? np->vleng : ICON(0), "");
        !           704:                        strcpy(rs->user.ident, "ret_val");
        !           705:                        }
        !           706:        }
        !           707: 
        !           708: /* Handle a   complex   return type -- declare a new parameter (pointer to
        !           709:    a complex value) */
        !           710: 
        !           711:        else if( ISCOMPLEX(type) ) {
        !           712:                if (!xretslot[type])
        !           713:                        xretslot[type] =
        !           714:                                autovar(0, type, EXNULL, " ret_val");
        !           715:                                /* the blank is for use in out_addr */
        !           716:                np->vstg = STGARG;
        !           717:                if(cxslot < 0)
        !           718:                        cxslot = nextarg(TYADDR);
        !           719:                }
        !           720:        else if (type != TYSUBR) {
        !           721:                if (type == TYUNKNOWN) {
        !           722:                        dclerr("untyped function", np);
        !           723:                        proctype = type = np->vtype =
        !           724:                                dflttype[letter(np->fvarname[0])];
        !           725:                        }
        !           726:                if (!xretslot[type])
        !           727:                        xretslot[type] = retslot =
        !           728:                                autovar(1, type, EXNULL, " ret_val");
        !           729:                                /* the blank is for use in out_addr */
        !           730:                np->vstg = STGAUTO;
        !           731:                }
        !           732: 
        !           733:        for(p = ep->arglist ; p ; p = p->nextp)
        !           734:                if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
        !           735:                        q->vknownarg = 1;
        !           736:                        q->vardesc.varno = nextarg(TYADDR);
        !           737:                        allargs = mkchain((char *)q, allargs);
        !           738:                        q->argno = nallargs++;
        !           739:                        }
        !           740:                else if (nentry == 1)
        !           741:                        duparg(q);
        !           742:                else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
        !           743:                        if ((Namep)p1->datap == q)
        !           744:                                duparg(q);
        !           745: 
        !           746:        k = 0;
        !           747:        for(p = ep->arglist ; p ; p = p->nextp) {
        !           748:                if(! (( q = (Namep) (p->datap) )->vdcldone) )
        !           749:                        {
        !           750:                        impldcl(q);
        !           751:                        q->vdcldone = YES;
        !           752:                        if(q->vtype == TYCHAR)
        !           753:                                {
        !           754: 
        !           755: /* If we don't know the length of a char*(*) (i.e. a string), we must add
        !           756:    in this additional length argument. */
        !           757: 
        !           758:                                ++nallchargs;
        !           759:                                if (q->vclass == CLPROC)
        !           760:                                        nallchargs--;
        !           761:                                else if (q->vleng == NULL) {
        !           762:                                        /* character*(*) */
        !           763:                                        q->vleng = (expptr)
        !           764:                                            mkarg(TYLENG, nextarg(TYLENG) );
        !           765:                                        unamstring((Addrp)q->vleng,
        !           766:                                                new_arg_length(q));
        !           767:                                        }
        !           768:                                }
        !           769:                        }
        !           770:                if (q->vdimfinish)
        !           771:                        dim_finish(q);
        !           772:                if (q->vtype == TYCHAR && q->vclass != CLPROC)
        !           773:                        k++;
        !           774:                }
        !           775: 
        !           776:        if (entryname->extype != type)
        !           777:                changedtype(np);
        !           778: 
        !           779:        /* save information for checking consistency of arg lists */
        !           780: 
        !           781:        it = infertypes;
        !           782:        if (entryname->exproto)
        !           783:                infertypes = 1;
        !           784:        save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
        !           785:                        0, np->fvarname, STGEXT, k, np->vtype, 2);
        !           786:        infertypes = it;
        !           787: }
        !           788: 
        !           789: 
        !           790: 
        !           791: LOCAL nextarg(type)
        !           792: int type;
        !           793: {
        !           794:        int k;
        !           795:        k = lastargslot;
        !           796:        lastargslot += typesize[type];
        !           797:        return(k);
        !           798: }
        !           799: 
        !           800:  LOCAL
        !           801: dim_check(q)
        !           802:  Namep q;
        !           803: {
        !           804:        register struct Dimblock *vdim = q->vdim;
        !           805: 
        !           806:        if(!vdim->nelt || !ISICON(vdim->nelt))
        !           807:                dclerr("adjustable dimension on non-argument", q);
        !           808:        else if (vdim->nelt->constblock.Const.ci <= 0)
        !           809:                dclerr("nonpositive dimension", q);
        !           810:        }
        !           811: 
        !           812: LOCAL dobss()
        !           813: {
        !           814:        register struct Hashentry *p;
        !           815:        register Namep q;
        !           816:        int qstg, qclass, qtype;
        !           817:        Extsym *e;
        !           818: 
        !           819:        for(p = hashtab ; p<lasthash ; ++p)
        !           820:                if(q = p->varp)
        !           821:                {
        !           822:                        qstg = q->vstg;
        !           823:                        qtype = q->vtype;
        !           824:                        qclass = q->vclass;
        !           825: 
        !           826:                        if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
        !           827:                            (qclass==CLVAR && qstg==STGUNKNOWN) ) {
        !           828:                                if (!(q->vis_assigned | q->vimpldovar))
        !           829:                                        warn1("local variable %s never used",
        !           830:                                                q->fvarname);
        !           831:                                }
        !           832:                        else if(qclass==CLVAR && qstg==STGBSS)
        !           833:                        { ; }
        !           834: 
        !           835: /* Give external procedures the proper storage class */
        !           836: 
        !           837:                        else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
        !           838:                                        && qstg!=STGARG) {
        !           839:                                e = mkext(q->fvarname,addunder(q->cvarname));
        !           840:                                e->extstg = STGEXT;
        !           841:                                q->vardesc.varno = e - extsymtab;
        !           842:                                if (e->extype != qtype)
        !           843:                                        changedtype(q);
        !           844:                                }
        !           845:                        if(qclass==CLVAR) {
        !           846:                            if (qstg != STGARG && q->vdim)
        !           847:                                dim_check(q);
        !           848:                        } /* if qclass == CLVAR */
        !           849:                }
        !           850: 
        !           851: }
        !           852: 
        !           853: 
        !           854: 
        !           855: donmlist()
        !           856: {
        !           857:        register struct Hashentry *p;
        !           858:        register Namep q;
        !           859: 
        !           860:        for(p=hashtab; p<lasthash; ++p)
        !           861:                if( (q = p->varp) && q->vclass==CLNAMELIST)
        !           862:                        namelist(q);
        !           863: }
        !           864: 
        !           865: 
        !           866: /* iarrlen -- Returns the size of the array in bytes, or -1 */
        !           867: 
        !           868: ftnint iarrlen(q)
        !           869: register Namep q;
        !           870: {
        !           871:        ftnint leng;
        !           872: 
        !           873:        leng = typesize[q->vtype];
        !           874:        if(leng <= 0)
        !           875:                return(-1);
        !           876:        if(q->vdim)
        !           877:                if( ISICON(q->vdim->nelt) )
        !           878:                        leng *= q->vdim->nelt->constblock.Const.ci;
        !           879:                else    return(-1);
        !           880:        if(q->vleng)
        !           881:                if( ISICON(q->vleng) )
        !           882:                        leng *= q->vleng->constblock.Const.ci;
        !           883:                else return(-1);
        !           884:        return(leng);
        !           885: }
        !           886: 
        !           887: namelist(np)
        !           888: Namep np;
        !           889: {
        !           890:        register chainp q;
        !           891:        register Namep v;
        !           892:        int y;
        !           893: 
        !           894:        if (!np->visused)
        !           895:                return;
        !           896:        y = 0;
        !           897: 
        !           898:        for(q = np->varxptr.namelist ; q ; q = q->nextp)
        !           899:        {
        !           900:                vardcl( v = (Namep) (q->datap) );
        !           901:                if( !ONEOF(v->vstg, MSKSTATIC) )
        !           902:                        dclerr("may not appear in namelist", v);
        !           903:                else {
        !           904:                        v->vnamelist = 1;
        !           905:                        v->visused = 1;
        !           906:                        v->vsave = 1;
        !           907:                        y = 1;
        !           908:                        }
        !           909:        np->visused = y;
        !           910:        }
        !           911: }
        !           912: 
        !           913: /* docommon -- called at the end of procedure declarations, before
        !           914:    equivalences and the procedure body */
        !           915: 
        !           916: LOCAL docommon()
        !           917: {
        !           918:     register Extsym *extptr;
        !           919:     register chainp q, q1;
        !           920:     struct Dimblock *t;
        !           921:     expptr neltp;
        !           922:     register Namep comvar;
        !           923:     ftnint size;
        !           924:     int i, k, pref, type;
        !           925:     extern int type_pref[];
        !           926: 
        !           927:     for(extptr = extsymtab ; extptr<nextext ; ++extptr)
        !           928:        if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
        !           929: 
        !           930: /* If a common declaration also had a list of variables ... */
        !           931: 
        !           932:            q = extptr->extp = revchain(q);
        !           933:            pref = 1;
        !           934:            for(k = TYCHAR; q ; q = q->nextp)
        !           935:            {
        !           936:                comvar = (Namep) (q->datap);
        !           937: 
        !           938:                if(comvar->vdcldone == NO)
        !           939:                    vardcl(comvar);
        !           940:                type = comvar->vtype;
        !           941:                if (pref < type_pref[type])
        !           942:                        pref = type_pref[k = type];
        !           943:                if(extptr->extleng % typealign[type] != 0) {
        !           944:                    dclerr("common alignment", comvar);
        !           945:                    --nerr; /* don't give bad return code for this */
        !           946: #if 0
        !           947:                    extptr->extleng = roundup(extptr->extleng, typealign[type]);
        !           948: #endif
        !           949:                } /* if extptr -> extleng % */
        !           950: 
        !           951: /* Set the offset into the common block */
        !           952: 
        !           953:                comvar->voffset = extptr->extleng;
        !           954:                comvar->vardesc.varno = extptr - extsymtab;
        !           955:                if(type == TYCHAR)
        !           956:                    size = comvar->vleng->constblock.Const.ci;
        !           957:                else
        !           958:                    size = typesize[type];
        !           959:                if(t = comvar->vdim)
        !           960:                    if( (neltp = t->nelt) && ISCONST(neltp) )
        !           961:                        size *= neltp->constblock.Const.ci;
        !           962:                    else
        !           963:                        dclerr("adjustable array in common", comvar);
        !           964: 
        !           965: /* Adjust the length of the common block so far */
        !           966: 
        !           967:                extptr->extleng += size;
        !           968:            } /* for */
        !           969: 
        !           970:            extptr->extype = k;
        !           971: 
        !           972: /* Determine curno and, if new, save this identifier chain */
        !           973: 
        !           974:            q1 = extptr->extp;
        !           975:            for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
        !           976:                if (struct_eq((chainp)q->datap, q1))
        !           977:                        break;
        !           978:            if (q)
        !           979:                extptr->curno = extptr->maxno - i;
        !           980:            else {
        !           981:                extptr->curno = ++extptr->maxno;
        !           982:                extptr->allextp = mkchain((char *)extptr->extp,
        !           983:                                                extptr->allextp);
        !           984:                }
        !           985:        } /* if extptr -> extstg == STGCOMMON */
        !           986: 
        !           987: /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
        !           988:    varno.  And the common block itself has its full size in extleng. */
        !           989: 
        !           990: } /* docommon */
        !           991: 
        !           992: 
        !           993: /* copy_data -- copy the Namep entries so they are available even after
        !           994:    the hash table is empty */
        !           995: 
        !           996: copy_data (list)
        !           997: chainp list;
        !           998: {
        !           999:     for (; list; list = list -> nextp) {
        !          1000:        Namep namep = ALLOC (Nameblock);
        !          1001:        int size, nd, i;
        !          1002:        struct Dimblock *dp;
        !          1003: 
        !          1004:        cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
        !          1005:        namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
        !          1006:                namep->fvarname);
        !          1007:        namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
        !          1008:                ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
        !          1009:                : namep->fvarname;
        !          1010:        if (namep -> vleng)
        !          1011:            namep -> vleng = (expptr) cpexpr (namep -> vleng);
        !          1012:        if (namep -> vdim) {
        !          1013:            nd = namep -> vdim -> ndim;
        !          1014:            size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
        !          1015:            dp = (struct Dimblock *) ckalloc (size);
        !          1016:            cpn(size, (char *)namep->vdim, (char *)dp);
        !          1017:            namep -> vdim = dp;
        !          1018:            dp->nelt = (expptr)cpexpr(dp->nelt);
        !          1019:            for (i = 0; i < nd; i++) {
        !          1020:                dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
        !          1021:            } /* for */
        !          1022:        } /* if */
        !          1023:        list -> datap = (char *) namep;
        !          1024:     } /* for */
        !          1025: } /* copy_data */
        !          1026: 
        !          1027: 
        !          1028: 
        !          1029: LOCAL docomleng()
        !          1030: {
        !          1031:        register Extsym *p;
        !          1032: 
        !          1033:        for(p = extsymtab ; p < nextext ; ++p)
        !          1034:                if(p->extstg == STGCOMMON)
        !          1035:                {
        !          1036:                        if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
        !          1037:                            && strcmp(Blank, p->cextname) )
        !          1038:                                warn1("incompatible lengths for common block %.60s",
        !          1039:                                    p->fextname);
        !          1040:                        if(p->maxleng < p->extleng)
        !          1041:                                p->maxleng = p->extleng;
        !          1042:                        p->extleng = 0;
        !          1043:                }
        !          1044: }
        !          1045: 
        !          1046: 
        !          1047: /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
        !          1048: 
        !          1049: frtemp(p)
        !          1050: Addrp p;
        !          1051: {
        !          1052:        /* put block on chain of temps to be reclaimed */
        !          1053:        holdtemps = mkchain((char *)p, holdtemps);
        !          1054: }
        !          1055: 
        !          1056:  void
        !          1057: freetemps()
        !          1058: {
        !          1059:        register chainp p, p1;
        !          1060:        register Addrp q;
        !          1061:        register int t;
        !          1062: 
        !          1063:        p1 = holdtemps;
        !          1064:        while(p = p1) {
        !          1065:                q = (Addrp)p->datap;
        !          1066:                t = q->vtype;
        !          1067:                if (t == TYCHAR && q->varleng != 0) {
        !          1068:                        /* restore clobbered character string lengths */
        !          1069:                        frexpr(q->vleng);
        !          1070:                        q->vleng = ICON(q->varleng);
        !          1071:                        }
        !          1072:                p1 = p->nextp;
        !          1073:                p->nextp = templist[t];
        !          1074:                templist[t] = p;
        !          1075:                }
        !          1076:        holdtemps = 0;
        !          1077:        }
        !          1078: 
        !          1079: /* allocate an automatic variable slot for each of   nelt   variables */
        !          1080: 
        !          1081: Addrp autovar(nelt0, t, lengp, name)
        !          1082: register int nelt0, t;
        !          1083: expptr lengp;
        !          1084: char *name;
        !          1085: {
        !          1086:        ftnint leng;
        !          1087:        register Addrp q;
        !          1088:        char *temp_name ();
        !          1089:        register int nelt = nelt0 > 0 ? nelt0 : 1;
        !          1090:        extern char *av_pfix[];
        !          1091: 
        !          1092:        if(t == TYCHAR)
        !          1093:                if( ISICON(lengp) )
        !          1094:                        leng = lengp->constblock.Const.ci;
        !          1095:                else    {
        !          1096:                        Fatal("automatic variable of nonconstant length");
        !          1097:                }
        !          1098:        else
        !          1099:                leng = typesize[t];
        !          1100: 
        !          1101:        q = ALLOC(Addrblock);
        !          1102:        q->tag = TADDR;
        !          1103:        q->vtype = t;
        !          1104:        if(t == TYCHAR)
        !          1105:        {
        !          1106:                q->vleng = ICON(leng);
        !          1107:                q->varleng = leng;
        !          1108:        }
        !          1109:        q->vstg = STGAUTO;
        !          1110:        q->ntempelt = nelt;
        !          1111:        q->isarray = (nelt > 1);
        !          1112:        q->memoffset = ICON(0);
        !          1113: 
        !          1114:        /* kludge for nls so we can have ret_val rather than ret_val_4 */
        !          1115:        if (*name == ' ')
        !          1116:                unamstring(q, name);
        !          1117:        else {
        !          1118:                q->uname_tag = UNAM_IDENT;
        !          1119:                temp_name(av_pfix[t], ++autonum[t], q->user.ident);
        !          1120:                }
        !          1121:        if (nelt0 > 0)
        !          1122:                declare_new_addr (q);
        !          1123:        return(q);
        !          1124: }
        !          1125: 
        !          1126: 
        !          1127: /* Returns a temporary of the appropriate type.  Will reuse existing
        !          1128:    temporaries when possible */
        !          1129: 
        !          1130: Addrp mktmpn(nelt, type, lengp)
        !          1131: int nelt;
        !          1132: register int type;
        !          1133: expptr lengp;
        !          1134: {
        !          1135:        ftnint leng;
        !          1136:        chainp p, oldp;
        !          1137:        register Addrp q;
        !          1138: 
        !          1139:        if(type==TYUNKNOWN || type==TYERROR)
        !          1140:                badtype("mktmpn", type);
        !          1141: 
        !          1142:        if(type==TYCHAR)
        !          1143:                if(lengp && ISICON(lengp) )
        !          1144:                        leng = lengp->constblock.Const.ci;
        !          1145:                else    {
        !          1146:                        err("adjustable length");
        !          1147:                        return( (Addrp) errnode() );
        !          1148:                }
        !          1149:        else if (type > TYCHAR || type < TYADDR) {
        !          1150:                erri("mktmpn: unexpected type %d", type);
        !          1151:                exit(1);
        !          1152:                }
        !          1153: /*
        !          1154:  * if a temporary of appropriate shape is on the templist,
        !          1155:  * remove it from the list and return it
        !          1156:  */
        !          1157:        for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
        !          1158:        {
        !          1159:                q = (Addrp) (p->datap);
        !          1160:                if(q->ntempelt==nelt &&
        !          1161:                    (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
        !          1162:                {
        !          1163:                        if(oldp)
        !          1164:                                oldp->nextp = p->nextp;
        !          1165:                        else
        !          1166:                                templist[type] = p->nextp;
        !          1167:                        free( (charptr) p);
        !          1168:                        return(q);
        !          1169:                }
        !          1170:        }
        !          1171:        q = autovar(nelt, type, lengp, "");
        !          1172:        return(q);
        !          1173: }
        !          1174: 
        !          1175: 
        !          1176: 
        !          1177: 
        !          1178: /* mktmp -- create new local variable; call it something like   name
        !          1179:    lengp   is taken directly, not copied */
        !          1180: 
        !          1181: Addrp mktmp(type, lengp)
        !          1182: int type;
        !          1183: expptr lengp;
        !          1184: {
        !          1185:        Addrp rv;
        !          1186:        /* arrange for temporaries to be recycled */
        !          1187:        /* at the end of this statement... */
        !          1188:        rv = mktmpn(1,type,lengp);
        !          1189:        frtemp((Addrp)cpexpr((expptr)rv));
        !          1190:        return rv;
        !          1191: }
        !          1192: 
        !          1193: /* mktmp0 omits frtemp() */
        !          1194: Addrp mktmp0(type, lengp)
        !          1195: int type;
        !          1196: expptr lengp;
        !          1197: {
        !          1198:        Addrp rv;
        !          1199:        /* arrange for temporaries to be recycled */
        !          1200:        /* when this Addrp is freed */
        !          1201:        rv = mktmpn(1,type,lengp);
        !          1202:        rv->istemp = YES;
        !          1203:        return rv;
        !          1204: }
        !          1205: 
        !          1206: /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
        !          1207: 
        !          1208: /* comblock -- Declare a new common block.  Input parameters name the block;
        !          1209:    s   will be NULL if the block is unnamed */
        !          1210: 
        !          1211: Extsym *comblock(s)
        !          1212:  register char *s;
        !          1213: {
        !          1214:        Extsym *p;
        !          1215:        register char *t;
        !          1216:        register int c, i;
        !          1217:        char cbuf[256], *s0;
        !          1218: 
        !          1219: /* Give the unnamed common block a unique name */
        !          1220: 
        !          1221:        if(*s == 0)
        !          1222:                p = mkext(Blank,Blank);
        !          1223:        else {
        !          1224:                s0 = s;
        !          1225:                t = cbuf;
        !          1226:                for(i = 0; c = *t = *s++; t++)
        !          1227:                        if (c == '_')
        !          1228:                                i = 1;
        !          1229:                if (i)
        !          1230:                        *t++ = '_';
        !          1231:                t[0] = '_';
        !          1232:                t[1] = 0;
        !          1233:                p = mkext(s0,cbuf);
        !          1234:                }
        !          1235:        if(p->extstg == STGUNKNOWN)
        !          1236:                p->extstg = STGCOMMON;
        !          1237:        else if(p->extstg != STGCOMMON)
        !          1238:        {
        !          1239:                errstr("%.68s cannot be a common block name", s);
        !          1240:                return(0);
        !          1241:        }
        !          1242: 
        !          1243:        return( p );
        !          1244: }
        !          1245: 
        !          1246: 
        !          1247: /* incomm -- add a new variable to a common declaration */
        !          1248: 
        !          1249: incomm(c, v)
        !          1250: Extsym *c;
        !          1251: Namep v;
        !          1252: {
        !          1253:        if (!c)
        !          1254:                return;
        !          1255:        if(v->vstg != STGUNKNOWN && !v->vimplstg)
        !          1256:                dclerr(v->vstg == STGARG
        !          1257:                        ? "dummy arguments cannot be in common"
        !          1258:                        : "incompatible common declaration", v);
        !          1259:        else
        !          1260:        {
        !          1261:                v->vstg = STGCOMMON;
        !          1262:                c->extp = mkchain((char *)v, c->extp);
        !          1263:        }
        !          1264: }
        !          1265: 
        !          1266: 
        !          1267: 
        !          1268: 
        !          1269: /* settype -- set the type or storage class of a Namep object.  If
        !          1270:    v -> vstg == STGUNKNOWN && type < 0,   attempt to reset vstg to be
        !          1271:    -type.  This function will not change any earlier definitions in   v,
        !          1272:    in will only attempt to fill out more information give the other params */
        !          1273: 
        !          1274: settype(v, type, length)
        !          1275: register Namep  v;
        !          1276: register int type;
        !          1277: register ftnint length;
        !          1278: {
        !          1279:        int type1;
        !          1280: 
        !          1281:        if(type == TYUNKNOWN)
        !          1282:                return;
        !          1283: 
        !          1284:        if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
        !          1285:        {
        !          1286:                v->vtype = TYSUBR;
        !          1287:                frexpr(v->vleng);
        !          1288:                v->vleng = 0;
        !          1289:                v->vimpltype = 0;
        !          1290:        }
        !          1291:        else if(type < 0)       /* storage class set */
        !          1292:        {
        !          1293:                if(v->vstg == STGUNKNOWN)
        !          1294:                        v->vstg = - type;
        !          1295:                else if(v->vstg != -type)
        !          1296:                        dclerr("incompatible storage declarations", v);
        !          1297:        }
        !          1298:        else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
        !          1299:        {
        !          1300:                if( (v->vtype = lengtype(type, length))==TYCHAR )
        !          1301:                        if (length>=0)
        !          1302:                                v->vleng = ICON(length);
        !          1303:                        else if (parstate >= INDATA)
        !          1304:                                v->vleng = ICON(1);     /* avoid a memory fault */
        !          1305:                v->vimpltype = 0;
        !          1306: 
        !          1307:                if (v->vclass == CLPROC) {
        !          1308:                        if (v->vstg == STGEXT
        !          1309:                         && (type1 = extsymtab[v->vardesc.varno].extype)
        !          1310:                         &&  type1 != v->vtype)
        !          1311:                                changedtype(v);
        !          1312:                        else if (v->vprocclass == PTHISPROC
        !          1313:                                        && (parstate >= INDATA
        !          1314:                                                || procclass == CLMAIN)
        !          1315:                                        && !xretslot[type]) {
        !          1316:                                xretslot[type] = autovar(ONEOF(type,
        !          1317:                                        MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
        !          1318:                                        v->vleng, " ret_val");
        !          1319:                                if (procclass == CLMAIN)
        !          1320:                                        errstr(
        !          1321:                                "illegal use of %.60s (main program name)",
        !          1322:                                        v->fvarname);
        !          1323:                                /* not completely right, but enough to */
        !          1324:                                /* avoid memory faults; we won't */
        !          1325:                                /* emit any C as we have illegal Fortran */
        !          1326:                                }
        !          1327:                        }
        !          1328:        }
        !          1329:        else if(v->vtype!=type) {
        !          1330:  incompat:
        !          1331:                dclerr("incompatible type declarations", v);
        !          1332:                }
        !          1333:        else if (type==TYCHAR)
        !          1334:                if (v->vleng && v->vleng->constblock.Const.ci != length)
        !          1335:                        goto incompat;
        !          1336:                else if (parstate >= INDATA)
        !          1337:                        v->vleng = ICON(1);     /* avoid a memory fault */
        !          1338: }
        !          1339: 
        !          1340: 
        !          1341: 
        !          1342: 
        !          1343: 
        !          1344: /* lengtype -- returns the proper compiler type, given input of Fortran
        !          1345:    type and length specifier */
        !          1346: 
        !          1347: lengtype(type, len)
        !          1348: register int type;
        !          1349: ftnint len;
        !          1350: {
        !          1351:        register int length = (int)len;
        !          1352:        switch(type)
        !          1353:        {
        !          1354:        case TYREAL:
        !          1355:                if(length == typesize[TYDREAL])
        !          1356:                        return(TYDREAL);
        !          1357:                if(length == typesize[TYREAL])
        !          1358:                        goto ret;
        !          1359:                break;
        !          1360: 
        !          1361:        case TYCOMPLEX:
        !          1362:                if(length == typesize[TYDCOMPLEX])
        !          1363:                        return(TYDCOMPLEX);
        !          1364:                if(length == typesize[TYCOMPLEX])
        !          1365:                        goto ret;
        !          1366:                break;
        !          1367: 
        !          1368:        case TYINT1:
        !          1369:        case TYSHORT:
        !          1370:        case TYDREAL:
        !          1371:        case TYDCOMPLEX:
        !          1372:        case TYCHAR:
        !          1373:        case TYLOGICAL1:
        !          1374:        case TYLOGICAL2:
        !          1375:        case TYUNKNOWN:
        !          1376:        case TYSUBR:
        !          1377:        case TYERROR:
        !          1378: #ifdef TYQUAD
        !          1379:        case TYQUAD:
        !          1380: #endif
        !          1381:                goto ret;
        !          1382: 
        !          1383:        case TYLOGICAL:
        !          1384:                switch(length) {
        !          1385:                        case 0: return tylog;
        !          1386:                        case 1: return TYLOGICAL1;
        !          1387:                        case 2: return TYLOGICAL2;
        !          1388:                        case 4: goto ret;
        !          1389:                        }
        !          1390: #if 0 /*!!??!!*/
        !          1391:                if(length == typesize[TYLOGICAL])
        !          1392:                        goto ret;
        !          1393: #endif
        !          1394:                break;
        !          1395: 
        !          1396:        case TYLONG:
        !          1397:                if(length == 0)
        !          1398:                        return(tyint);
        !          1399:                if (length == 1)
        !          1400:                        return TYINT1;
        !          1401:                if(length == typesize[TYSHORT])
        !          1402:                        return(TYSHORT);
        !          1403: #ifdef TYQUAD
        !          1404:                if(length == typesize[TYQUAD] && use_tyquad)
        !          1405:                        return(TYQUAD);
        !          1406: #endif
        !          1407:                if(length == typesize[TYLONG])
        !          1408:                        goto ret;
        !          1409:                break;
        !          1410:        default:
        !          1411:                badtype("lengtype", type);
        !          1412:        }
        !          1413: 
        !          1414:        if(len != 0)
        !          1415:                err("incompatible type-length combination");
        !          1416: 
        !          1417: ret:
        !          1418:        return(type);
        !          1419: }
        !          1420: 
        !          1421: 
        !          1422: 
        !          1423: 
        !          1424: 
        !          1425: /* setintr -- Set Intrinsic function */
        !          1426: 
        !          1427: setintr(v)
        !          1428: register Namep  v;
        !          1429: {
        !          1430:        int k;
        !          1431: 
        !          1432:        if(v->vstg == STGUNKNOWN)
        !          1433:                v->vstg = STGINTR;
        !          1434:        else if(v->vstg!=STGINTR)
        !          1435:                dclerr("incompatible use of intrinsic function", v);
        !          1436:        if(v->vclass==CLUNKNOWN)
        !          1437:                v->vclass = CLPROC;
        !          1438:        if(v->vprocclass == PUNKNOWN)
        !          1439:                v->vprocclass = PINTRINSIC;
        !          1440:        else if(v->vprocclass != PINTRINSIC)
        !          1441:                dclerr("invalid intrinsic declaration", v);
        !          1442:        if(k = intrfunct(v->fvarname)) {
        !          1443:                if ((*(struct Intrpacked *)&k).f4)
        !          1444:                        if (noextflag)
        !          1445:                                goto unknown;
        !          1446:                        else
        !          1447:                                dcomplex_seen++;
        !          1448:                v->vardesc.varno = k;
        !          1449:                }
        !          1450:        else {
        !          1451:  unknown:
        !          1452:                dclerr("unknown intrinsic function", v);
        !          1453:                }
        !          1454: }
        !          1455: 
        !          1456: 
        !          1457: 
        !          1458: /* setext -- Set External declaration -- assume that unknowns will become
        !          1459:    procedures */
        !          1460: 
        !          1461: setext(v)
        !          1462: register Namep  v;
        !          1463: {
        !          1464:        if(v->vclass == CLUNKNOWN)
        !          1465:                v->vclass = CLPROC;
        !          1466:        else if(v->vclass != CLPROC)
        !          1467:                dclerr("invalid external declaration", v);
        !          1468: 
        !          1469:        if(v->vprocclass == PUNKNOWN)
        !          1470:                v->vprocclass = PEXTERNAL;
        !          1471:        else if(v->vprocclass != PEXTERNAL)
        !          1472:                dclerr("invalid external declaration", v);
        !          1473: } /* setext */
        !          1474: 
        !          1475: 
        !          1476: 
        !          1477: 
        !          1478: /* create dimensions block for array variable */
        !          1479: 
        !          1480: setbound(v, nd, dims)
        !          1481: register Namep  v;
        !          1482: int nd;
        !          1483: struct Dims dims[ ];
        !          1484: {
        !          1485:        register expptr q, t;
        !          1486:        register struct Dimblock *p;
        !          1487:        int i;
        !          1488:        extern chainp new_vars;
        !          1489:        char buf[256];
        !          1490: 
        !          1491:        if(v->vclass == CLUNKNOWN)
        !          1492:                v->vclass = CLVAR;
        !          1493:        else if(v->vclass != CLVAR)
        !          1494:        {
        !          1495:                dclerr("only variables may be arrays", v);
        !          1496:                return;
        !          1497:        }
        !          1498: 
        !          1499:        v->vdim = p = (struct Dimblock *)
        !          1500:            ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
        !          1501:        p->ndim = nd--;
        !          1502:        p->nelt = ICON(1);
        !          1503:        doin_setbound = 1;
        !          1504: 
        !          1505:        for(i = 0; i <= nd; ++i)
        !          1506:        {
        !          1507:                if( (q = dims[i].ub) == NULL)
        !          1508:                {
        !          1509:                        if(i == nd)
        !          1510:                        {
        !          1511:                                frexpr(p->nelt);
        !          1512:                                p->nelt = NULL;
        !          1513:                        }
        !          1514:                        else
        !          1515:                                err("only last bound may be asterisk");
        !          1516:                        p->dims[i].dimsize = ICON(1);
        !          1517:                        ;
        !          1518:                        p->dims[i].dimexpr = NULL;
        !          1519:                }
        !          1520:                else
        !          1521:                {
        !          1522: 
        !          1523:                        if(dims[i].lb)
        !          1524:                        {
        !          1525:                                q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
        !          1526:                                q = mkexpr(OPPLUS, q, ICON(1) );
        !          1527:                        }
        !          1528:                        if( ISCONST(q) )
        !          1529:                        {
        !          1530:                                p->dims[i].dimsize = q;
        !          1531:                                p->dims[i].dimexpr = (expptr) PNULL;
        !          1532:                        }
        !          1533:                        else {
        !          1534:                                sprintf(buf, " %s_dim%d", v->fvarname, i+1);
        !          1535:                                p->dims[i].dimsize = (expptr)
        !          1536:                                        autovar(1, tyint, EXNULL, buf);
        !          1537:                                p->dims[i].dimexpr = q;
        !          1538:                                if (i == nd)
        !          1539:                                        v->vlastdim = new_vars;
        !          1540:                                v->vdimfinish = 1;
        !          1541:                        }
        !          1542:                        if(p->nelt)
        !          1543:                                p->nelt = mkexpr(OPSTAR, p->nelt,
        !          1544:                                    cpexpr(p->dims[i].dimsize) );
        !          1545:                }
        !          1546:        }
        !          1547: 
        !          1548:        q = dims[nd].lb;
        !          1549:        if(q == NULL)
        !          1550:                q = ICON(1);
        !          1551: 
        !          1552:        for(i = nd-1 ; i>=0 ; --i)
        !          1553:        {
        !          1554:                t = dims[i].lb;
        !          1555:                if(t == NULL)
        !          1556:                        t = ICON(1);
        !          1557:                if(p->dims[i].dimsize)
        !          1558:                        q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
        !          1559:        }
        !          1560: 
        !          1561:        if( ISCONST(q) )
        !          1562:        {
        !          1563:                p->baseoffset = q;
        !          1564:                p->basexpr = NULL;
        !          1565:        }
        !          1566:        else
        !          1567:        {
        !          1568:                sprintf(buf, " %s_offset", v->fvarname);
        !          1569:                p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
        !          1570:                p->basexpr = q;
        !          1571:                v->vdimfinish = 1;
        !          1572:        }
        !          1573:        doin_setbound = 0;
        !          1574: }
        !          1575: 
        !          1576: 
        !          1577: 
        !          1578: wr_abbrevs (outfile, function_head, vars)
        !          1579: FILE *outfile;
        !          1580: int function_head;
        !          1581: chainp vars;
        !          1582: {
        !          1583:     for (; vars; vars = vars -> nextp) {
        !          1584:        Namep name = (Namep) vars -> datap;
        !          1585:        if (!name->visused)
        !          1586:                continue;
        !          1587: 
        !          1588:        if (function_head)
        !          1589:            nice_printf (outfile, "#define ");
        !          1590:        else
        !          1591:            nice_printf (outfile, "#undef ");
        !          1592:        out_name (outfile, name);
        !          1593: 
        !          1594:        if (function_head) {
        !          1595:            Extsym *comm = &extsymtab[name -> vardesc.varno];
        !          1596: 
        !          1597:            nice_printf (outfile, " (");
        !          1598:            extern_out (outfile, comm);
        !          1599:            nice_printf (outfile, "%d.", comm->curno);
        !          1600:            nice_printf (outfile, "%s)", name->cvarname);
        !          1601:        } /* if function_head */
        !          1602:        nice_printf (outfile, "\n");
        !          1603:     } /* for */
        !          1604: } /* wr_abbrevs */

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