# 2.11BSD#431 - /usr/src/usr.bin/f77/expr.c

##### Functions

    addrof            X
    cktype            X
    consbinop         X
    consconv          X
    consnegop         X
    conspower         X
    conssgn           X
    cpexpr            X
    deregister        X
    enregister        X
    errnode           X
    fixargs           X
    fixexpr           X
    fixtype           X
    fold              X
    frexpr            X
    impldcl           X
    inregister        X
    letter            X
    memversion        X
    mkaddcon          X
    mkaddr            X
    mkarg             X
    mkbitcon          X
    mkconst           X
    mkconv            X
    mkcxcon           X
    mkexpr            X
    mkfunct           X
    mkintcon          X
    mklhs             X
    mklogcon          X
    mkpower           X
    mkprim            X
    mkrealcon         X
    mkscalar          X
    mkstrcon          X
    opconv            X
    shorten           X
    stfcall           X
    subcheck          X
    suboffset         X
    vardcl            X
    zdiv              X

##### Variables

    args              X
    lstr              X
    powint            X
    rstr              X
    v                 X

##### Macros

    COMMUTE           X
    ICONEQ            X

##### struct's

    dcomplex          X

       1: #include "defs"
       2: #include "string_defs"
       3:
       4: /* little routines to create constant blocks */
       5:
       6: struct constblock *mkconst(t)
       7: register int t;
       8: {
       9: register struct constblock *p;
      10:
      11: p = ALLOC(constblock);
      12: p->tag = TCONST;
      13: p->vtype = t;
      14: return(p);
      15: }
      16:
      17:
      18: struct constblock *mklogcon(l)
      19: register int l;
      20: {
      21: register struct constblock * p;
      22:
      23: p = mkconst(TYLOGICAL);
      24: p->const.ci = l;
      25: return(p);
      26: }
      27:
      28:
      29:
      30: struct constblock *mkintcon(l)
      31: ftnint l;
      32: {
      33: register struct constblock *p;
      34:
      35: p = mkconst(TYLONG);
      36: p->const.ci = l;
      37: #ifdef MAXSHORT
      38:     if(l >= -MAXSHORT   &&   l <= MAXSHORT)
      39:         p->vtype = TYSHORT;
      40: #endif
      41: return(p);
      42: }
      43:
      44:
      45:
      46: struct constblock *mkaddcon(l)
      47: register int l;
      48: {
      49: register struct constblock *p;
      50:
      51: p = mkconst(TYADDR);
      52: p->const.ci = l;
      53: return(p);
      54: }
      55:
      56:
      57:
      58: struct constblock *mkrealcon(t, d)
      59: register int t;
      60: double d;
      61: {
      62: register struct constblock *p;
      63:
      64: p = mkconst(t);
      65: p->const.cd[0] = d;
      66: return(p);
      67: }
      68:
      69:
      70: struct constblock *mkbitcon(shift, leng, s)
      71: int shift;
      72: int leng;
      73: char *s;
      74: {
      75: register struct constblock *p;
      76:
      77: p = mkconst(TYUNKNOWN);
      78: p->const.ci = 0;
      79: while(--leng >= 0)
      80:     if(*s != ' ')
      81:         p->const.ci = (p->const.ci << shift) | hextoi(*s++);
      82: return(p);
      83: }
      84:
      85:
      86:
      87:
      88:
      89: struct constblock *mkstrcon(l,v)
      90: int l;
      91: register char *v;
      92: {
      93: register struct constblock *p;
      94: register char *s;
      95:
      96: p = mkconst(TYCHAR);
      97: p->vleng = ICON(l);
      98: p->const.ccp = s = (char *) ckalloc(l);
      99: while(--l >= 0)
     100:     *s++ = *v++;
     101: return(p);
     102: }
     103:
     104:
     105: struct constblock *mkcxcon(realp,imagp)
     106: register expptr realp, imagp;
     107: {
     108: int rtype, itype;
     109: register struct constblock *p;
     110:
     111: rtype = realp->vtype;
     112: itype = imagp->vtype;
     113:
     114: if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
     115:     {
     116:     p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX );
     117:     if( ISINT(rtype) )
     118:         p->const.cd[0] = realp->const.ci;
     119:     else    p->const.cd[0] = realp->const.cd[0];
     120:     if( ISINT(itype) )
     121:         p->const.cd[1] = imagp->const.ci;
     122:     else    p->const.cd[1] = imagp->const.cd[0];
     123:     }
     124: else
     125:     {
     126:     error("invalid complex constant",0,0,ERR);
     127:     p = errnode();
     128:     }
     129:
     130: frexpr(realp);
     131: frexpr(imagp);
     132: return(p);
     133: }
     134:
     135:
     136: struct errorblock *errnode()
     137: {
     138: struct errorblock *p;
     139: p = ALLOC(errorblock);
     140: p->tag = TERROR;
     141: p->vtype = TYERROR;
     142: return(p);
     143: }
     144:
     145:
     146:
     147:
     148:
     149: expptr mkconv(t, p)
     150: register int t;
     151: register expptr p;
     152: {
     153: register expptr q;
     154: register int pt;
     155: expptr opconv();
     156:
     157: if(t==TYUNKNOWN || t==TYERROR)
     158:     error("mkconv of impossible type %d", t,0,FATAL1);
     159: pt = p->vtype;
     160: if(t == pt)
     161:     return(p);
     162:
     163: else if( ISCONST(p) && pt!=TYADDR)
     164:     {
     165:     q = mkconst(t);
     166:     consconv(t, &(q->const), p->vtype, &(p->const));
     167:     frexpr(p);
     168:     }
     169: #if TARGET == PDP11
     170:     else if(ISINT(t) && pt==TYCHAR)
     171:         {
     172:         q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
     173:         if(t == TYLONG)
     174:             q = opconv(q, TYLONG);
     175:         }
     176: #endif
     177: else
     178:     q = opconv(p, t);
     179:
     180: if(t == TYCHAR)
     181:     q->vleng = ICON(1);
     182: return(q);
     183: }
     184:
     185:
     186:
     187: expptr opconv(p, t)
     188: expptr p;
     189: int t;
     190: {
     191: register expptr q;
     192:
     193: q = mkexpr(OPCONV, p, 0);
     194: q->vtype = t;
     195: return(q);
     196: }
     197:
     198:
     199:
     200: struct exprblock *addrof(p)
     201: expptr p;
     202: {
     203: return( mkexpr(OPADDR, p, NULL) );
     204: }
     205:
     206:
     207:
     208: tagptr cpexpr(p)
     209: register tagptr p;
     210: {
     211: register tagptr e;
     212: int tag;
     213: register chainp ep, pp;
     214: ptr cpblock();
     215:
     216: static int blksize[ ] =
     217:     {   0,
     218:         sizeof(struct nameblock),
     219:         sizeof(struct constblock),
     220:         sizeof(struct exprblock),
     221:         sizeof(struct addrblock),
     222:         sizeof(struct primblock),
     223:         sizeof(struct listblock),
     224:         sizeof(struct errorblock)
     225:     };
     226:
     227: if(p == NULL)
     228:     return(NULL);
     229:
     230: if( (tag = p->tag) == TNAME)
     231:     return(p);
     232:
     233: e = cpblock( blksize[p->tag] , p);
     234:
     235: switch(tag)
     236:     {
     237:     case TCONST:
     238:         if(e->vtype == TYCHAR)
     239:             {
     240:             e->const.ccp = copyn(1+strlen(e->const.ccp), e->const.ccp);
     241:             e->vleng = cpexpr(e->vleng);
     242:             }
     243:     case TERROR:
     244:         break;
     245:
     246:     case TEXPR:
     247:         e->leftp = cpexpr(p->leftp);
     248:         e->rightp = cpexpr(p->rightp);
     249:         break;
     250:
     251:     case TLIST:
     252:         if(pp = p->listp)
     253:             {
     254:             ep = e->listp = mkchain( cpexpr(pp->datap), NULL);
     255:             for(pp = pp->nextp ; pp ; pp = pp->nextp)
     256:                 ep = ep->nextp = mkchain( cpexpr(pp->datap), NULL);
     257:             }
     258:         break;
     259:
     260:     case TADDR:
     261:         e->vleng = cpexpr(e->vleng);
     262:         e->memoffset = cpexpr(e->memoffset);
     263:         e->istemp = NO;
     264:         break;
     265:
     266:     case TPRIM:
     267:         e->argsp = cpexpr(e->argsp);
     268:         e->fcharp = cpexpr(e->fcharp);
     269:         e->lcharp = cpexpr(e->lcharp);
     270:         break;
     271:
     272:     default:
     273:         error("cpexpr: impossible tag %d", tag,0,FATAL1);
     274:     }
     275:
     276: return(e);
     277: }
     278:
     279: frexpr(p)
     280: register tagptr p;
     281: {
     282: register chainp q;
     283:
     284: if(p == NULL)
     285:     return;
     286:
     287: switch(p->tag)
     288:     {
     289:     case TCONST:
     290:         if( ISCHAR(p) )
     291:             {
     292:             free(p->const.ccp);
     293:             frexpr(p->vleng);
     294:             }
     295:         break;
     296:
     297:     case TADDR:
     298:         if(p->istemp)
     299:             {
     300:             frtemp(p);
     301:             return;
     302:             }
     303:         frexpr(p->vleng);
     304:         frexpr(p->memoffset);
     305:         break;
     306:
     307:     case TERROR:
     308:         break;
     309:
     310:     case TNAME:
     311:         return;
     312:
     313:     case TPRIM:
     314:         frexpr(p->argsp);
     315:         frexpr(p->fcharp);
     316:         frexpr(p->lcharp);
     317:         break;
     318:
     319:     case TEXPR:
     320:         frexpr(p->leftp);
     321:         if(p->rightp)
     322:             frexpr(p->rightp);
     323:         break;
     324:
     325:     case TLIST:
     326:         for(q = p->listp ; q ; q = q->nextp)
     327:             frexpr(q->datap);
     328:         frchain( &(p->listp) );
     329:         break;
     330:
     331:     default:
     332:         error("frexpr: impossible tag %d", p->tag,0,FATAL1);
     333:     }
     334:
     335: free(p);
     336: }
     337:
     338: /* fix up types in expression; replace subtrees and convert
     339:    names to address blocks */
     340:
     341: expptr fixtype(p)
     342: register tagptr p;
     343: {
     344:
     345: if(p == 0)
     346:     return(0);
     347:
     348: switch(p->tag)
     349:     {
     350:     case TCONST:
     351:         if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) )
     352:             p = putconst(p);
     353:         return(p);
     354:
     355:     case TADDR:
     356:         p->memoffset = fixtype(p->memoffset);
     357:         return(p);
     358:
     359:     case TERROR:
     360:         return(p);
     361:
     362:     default:
     363:         error("fixtype: impossible tag %d", p->tag,0,FATAL1);
     364:
     365:     case TEXPR:
     366:         return( fixexpr(p) );
     367:
     368:     case TLIST:
     369:         return( p );
     370:
     371:     case TPRIM:
     372:         if(p->argsp && p->namep->vclass!=CLVAR)
     373:             return( mkfunct(p) );
     374:         else    return( mklhs(p) );
     375:     }
     376: }
     377:
     378:
     379:
     380:
     381:
     382: /* special case tree transformations and cleanups of expression trees */
     383:
     384: expptr fixexpr(p)
     385: register struct exprblock *p;
     386: {
     387: expptr lp;
     388: register expptr rp;
     389: register expptr q;
     390: int opcode, ltype, rtype, ptype, mtype;
     391: expptr mkpower();
     392:
     393: if(p->tag == TERROR)
     394:     return(p);
     395: else if(p->tag != TEXPR)
     396:     error("fixexpr: invalid tag %d", p->tag,0,FATAL1);
     397: opcode = p->opcode;
     398: lp = p->leftp = fixtype(p->leftp);
     399: ltype = lp->vtype;
     400: if(opcode==OPASSIGN && lp->tag!=TADDR)
     401:     {
     402:     error("left side of assignment must be variable",0,0,ERR);
     403:     frexpr(p);
     404:     return( errnode() );
     405:     }
     406:
     407: if(p->rightp)
     408:     {
     409:     rp = p->rightp = fixtype(p->rightp);
     410:     rtype = rp->vtype;
     411:     }
     412: else
     413:     {
     414:     rp = NULL;
     415:     rtype = 0;
     416:     }
     417:
     418: /* force folding if possible */
     419: if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
     420:     {
     421:     q = mkexpr(opcode, lp, rp);
     422:     if( ISCONST(q) )
     423:         return(q);
     424:     free(q);    /* constants did not fold */
     425:     }
     426:
     427: if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
     428:     {
     429:     frexpr(p);
     430:     return( errnode() );
     431:     }
     432:
     433: switch(opcode)
     434:     {
     435:     case OPCONCAT:
     436:         if(p->vleng == NULL)
     437:             p->vleng = mkexpr(OPPLUS, cpexpr(lp->vleng),
     438:                 cpexpr(rp->vleng) );
     439:         break;
     440:
     441:     case OPASSIGN:
     442:     case OPPLUSEQ:
     443:     case OPSTAREQ:
     444:         if(ltype == rtype)
     445:             break;
     446:         if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
     447:             break;
     448:         if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
     449:             break;
     450:         if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
     451: #if FAMILY==SCJ
     452:             && typesize[ltype]>=typesize[rtype] )
     453: #else
     454:             && typesize[ltype]==typesize[rtype] )
     455: #endif
     456:             break;
     457:         p->rightp = fixtype( mkconv(ptype, rp) );
     458:         break;
     459:
     460:     case OPSLASH:
     461:         if( ISCOMPLEX(rtype) )
     462:             {
     463:             p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div",
     464:                 mkconv(ptype, lp), mkconv(ptype, rp) );
     465:             break;
     466:             }
     467:     case OPPLUS:
     468:     case OPMINUS:
     469:     case OPSTAR:
     470:     case OPMOD:
     471:         if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
     472:             (rtype==TYREAL && ! ISCONST(rp) ) ))
     473:             break;
     474:         if( ISCOMPLEX(ptype) )
     475:             break;
     476:         if(ltype != ptype)
     477:             p->leftp = fixtype(mkconv(ptype,lp));
     478:         if(rtype != ptype)
     479:             p->rightp = fixtype(mkconv(ptype,rp));
     480:         break;
     481:
     482:     case OPPOWER:
     483:         return( mkpower(p) );
     484:
     485:     case OPLT:
     486:     case OPLE:
     487:     case OPGT:
     488:     case OPGE:
     489:     case OPEQ:
     490:     case OPNE:
     491:         if(ltype == rtype)
     492:             break;
     493:         mtype = cktype(OPMINUS, ltype, rtype);
     494:         if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
     495:             (rtype==TYREAL && ! ISCONST(rp)) ))
     496:             break;
     497:         if( ISCOMPLEX(mtype) )
     498:             break;
     499:         if(ltype != mtype)
     500:             p->leftp = fixtype(mkconv(mtype,lp));
     501:         if(rtype != mtype)
     502:             p->rightp = fixtype(mkconv(mtype,rp));
     503:         break;
     504:
     505:
     506:     case OPCONV:
     507:         ptype = cktype(OPCONV, p->vtype, ltype);
     508:         if(lp->tag==TEXPR && lp->opcode==OPCOMMA)
     509:             {
     510:             lp->rightp = fixtype( mkconv(ptype, lp->rightp) );
     511:             free(p);
     512:             p = lp;
     513:             }
     514:         break;
     515:
     516:     case OPADDR:
     517:         if(lp->tag==TEXPR && lp->opcode==OPADDR)
     518:             error("addr of addr",0,0,FATAL);
     519:         break;
     520:
     521:     case OPCOMMA:
     522:     case OPQUEST:
     523:     case OPCOLON:
     524:         break;
     525:
     526:     case OPMIN:
     527:     case OPMAX:
     528:         ptype = p->vtype;
     529:         break;
     530:
     531:     default:
     532:         break;
     533:     }
     534:
     535: p->vtype = ptype;
     536: return(p);
     537: }
     538:
     539: #if SZINT < SZLONG
     540: /*
     541:    for efficient subscripting, replace long ints by shorts
     542:    in easy places
     543: */
     544:
     545: expptr shorten(p)
     546: register expptr p;
     547: {
     548: register expptr q;
     549:
     550: if(p->vtype != TYLONG)
     551:     return(p);
     552:
     553: switch(p->tag)
     554:     {
     555:     case TERROR:
     556:     case TLIST:
     557:         return(p);
     558:
     559:     case TCONST:
     560:     case TADDR:
     561:         return( mkconv(TYINT,p) );
     562:
     563:     case TEXPR:
     564:         break;
     565:
     566:     default:
     567:         error("shorten: invalid tag %d", p->tag,0,FATAL1);
     568:     }
     569:
     570: switch(p->opcode)
     571:     {
     572:     case OPPLUS:
     573:     case OPMINUS:
     574:     case OPSTAR:
     575:         q = shorten( cpexpr(p->rightp) );
     576:         if(q->vtype == TYINT)
     577:             {
     578:             p->leftp = shorten(p->leftp);
     579:             if(p->leftp->vtype == TYLONG)
     580:                 frexpr(q);
     581:             else
     582:                 {
     583:                 frexpr(p->rightp);
     584:                 p->rightp = q;
     585:                 p->vtype = TYINT;
     586:                 }
     587:             }
     588:         break;
     589:
     590:     case OPNEG:
     591:         p->leftp = shorten(p->leftp);
     592:         if(p->leftp->vtype == TYINT)
     593:             p->vtype = TYINT;
     594:         break;
     595:
     596:     case OPCALL:
     597:     case OPCCALL:
     598:         p = mkconv(TYINT,p);
     599:         break;
     600:     default:
     601:         break;
     602:     }
     603:
     604: return(p);
     605: }
     606: #endif
     607:
     608: fixargs(doput, p0)
     609: int doput;
     610: struct listblock *p0;
     611: {
     612: register chainp p;
     613: register tagptr q, t;
     614: register int qtag;
     615: int nargs;
     616: struct addrblock *mkaddr();
     617:
     618: nargs = 0;
     619: if(p0)
     620:     for(p = p0->listp ; p ; p = p->nextp)
     621:     {
     622:     ++nargs;
     623:     q = p->datap;
     624:     qtag = q->tag;
     625:     if(qtag == TCONST)
     626:         {
     627:         if(q->vtype == TYSHORT)
     628:             q = mkconv(tyint, q);
     629:         if(doput)
     630:             p->datap = putconst(q);
     631:         else
     632:             p->datap = q;
     633:         }
     634:     else if(qtag==TPRIM && q->argsp==0 && q->namep->vclass==CLPROC)
     635:         p->datap = mkaddr(q->namep);
     636:     else if(qtag==TPRIM && q->argsp==0 && q->namep->vdim!=NULL)
     637:         p->datap = mkscalar(q->namep);
     638:     else if(qtag==TPRIM && q->argsp==0 && q->namep->vdovar &&
     639:         (t = memversion(q->namep)) )
     640:             p->datap = fixtype(t);
     641:     else    p->datap = fixtype(q);
     642:     }
     643: return(nargs);
     644: }
     645:
     646:
     647: mkscalar(np)
     648: register struct nameblock *np;
     649: {
     650: register struct addrblock *ap;
     651: register struct dimblock *dp;
     652:
     653: vardcl(np);
     654: ap = mkaddr(np);
     655:
     656: #if TARGET == VAX
     657:     /* on the VAX, prolog causes array arguments
     658: 	   to point at the (0,...,0) element, except when
     659: 	   subscript checking is on
     660: 	*/
     661:     if( !checksubs && np->vstg==STGARG)
     662:         {
     663:         dp = np->vdim;
     664:         frexpr(ap->memoffset);
     665:         ap->memoffset = mkexpr(OPSTAR, ICON(typesize[np->vtype]),
     666:                     cpexpr(dp->baseoffset) );
     667:         }
     668: #endif
     669: return(ap);
     670: }
     671:
     672:
     673:
     674:
     675:
     676: expptr mkfunct(p)
     677: register struct primblock * p;
     678: {
     679: struct entrypoint *ep;
     680: struct addrblock *ap;
     681: struct extsym *mkext(), *extp;
     682: register struct nameblock *np;
     683: register struct exprblock *q;
     684: struct exprblock *intrcall(), *stfcall();
     685: int k, nargs;
     686: int class;
     687:
     688: np = p->namep;
     689: class = np->vclass;
     690:
     691: if(class == CLUNKNOWN)
     692:     {
     693:     np->vclass = class = CLPROC;
     694:     if(np->vstg == STGUNKNOWN)
     695:         {
     696:         if(k = intrfunct(np->varname))
     697:             {
     698:             np->vstg = STGINTR;
     699:             np->vardesc.varno = k;
     700:             np->vprocclass = PINTRINSIC;
     701:             }
     702:         else
     703:             {
     704:             extp = mkext( varunder(VL,np->varname) );
     705:             extp->extstg = STGEXT;
     706:             np->vstg = STGEXT;
     707:             np->vardesc.varno = extp - extsymtab;
     708:             np->vprocclass = PEXTERNAL;
     709:             }
     710:         }
     711:     else if(np->vstg==STGARG)
     712:         {
     713:         if(np->vtype!=TYCHAR && !ftn66flag)
     714:             error("Dummy procedure not declared EXTERNAL. Code may be wrong.",0,0,WARN);
     715:         np->vprocclass = PEXTERNAL;
     716:         }
     717:     }
     718:
     719: if(class != CLPROC)
     720:     error("invalid class code for function", class,0,FATAL1);
     721: if(p->fcharp || p->lcharp)
     722:     {
     723:     error("no substring of function call",0,0,ERR);
     724:     goto err;
     725:     }
     726: impldcl(np);
     727: nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
     728:
     729: switch(np->vprocclass)
     730:     {
     731:     case PEXTERNAL:
     732:         ap = mkaddr(np);
     733:     call:
     734:         q = mkexpr(OPCALL, ap, p->argsp);
     735:         q->vtype = np->vtype;
     736:         if(np->vleng)
     737:             q->vleng = cpexpr(np->vleng);
     738:         break;
     739:
     740:     case PINTRINSIC:
     741:         q = intrcall(np, p->argsp, nargs);
     742:         break;
     743:
     744:     case PSTFUNCT:
     745:         q = stfcall(np, p->argsp);
     746:         break;
     747:
     748:     case PTHISPROC:
     749:         error("recursive call",0,0,WARN);
     750:         for(ep = entries ; ep ; ep = ep->nextp)
     751:             if(ep->enamep == np)
     752:                 break;
     753:         if(ep == NULL)
     754:             error("mkfunct: impossible recursion",0,0,FATAL);
     755:         ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) );
     756:         goto call;
     757:
     758:     default:
     759:         error("mkfunct: impossible vprocclass %d", np->vprocclass,0,FATAL1);
     760:     }
     761: free(p);
     762: return(q);
     763:
     764: err:
     765:     frexpr(p);
     766:     return( errnode() );
     767: }
     768:
     769:
     770:
     771: LOCAL struct exprblock *stfcall(np, actlist)
     772: struct nameblock *np;
     773: struct listblock *actlist;
     774: {
     775: register chainp actuals;
     776: int nargs;
     777: chainp oactp, formals;
     778: int type;
     779: struct exprblock *q, *rhs;
     780: expptr ap;
     781: register struct rplblock *rp;
     782: struct rplblock *tlist;
     783:
     784: if(actlist)
     785:     {
     786:     actuals = actlist->listp;
     787:     free(actlist);
     788:     }
     789: else
     790:     actuals = NULL;
     791: oactp = actuals;
     792:
     793: nargs = 0;
     794: tlist = NULL;
     795: type = np->vtype;
     796: formals = np->vardesc.vstfdesc->datap;
     797: rhs = np->vardesc.vstfdesc->nextp;
     798:
     799: /* copy actual arguments into temporaries */
     800: while(actuals!=NULL && formals!=NULL)
     801:     {
     802:     rp = ALLOC(rplblock);
     803:     rp->rplnp = q = formals->datap;
     804:     ap = fixtype(actuals->datap);
     805:     if(q->vtype==ap->vtype && q->vtype!=TYCHAR
     806:        && (ap->tag==TCONST || ap->tag==TADDR) )
     807:         {
     808:         rp->rplvp = ap;
     809:         rp->rplxp = NULL;
     810:         rp->rpltag = ap->tag;
     811:         }
     812:     else    {
     813:         rp->rplvp = mktemp(q->vtype, q->vleng);
     814:         rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) );
     815:         if( (rp->rpltag = rp->rplxp->tag) == TERROR)
     816:             error("disagreement of argument types in statement function call",0,0,ERR);
     817:         }
     818:     rp->nextp = tlist;
     819:     tlist = rp;
     820:     actuals = actuals->nextp;
     821:     formals = formals->nextp;
     822:     ++nargs;
     823:     }
     824:
     825: if(actuals!=NULL || formals!=NULL)
     826:     error("statement function definition and argument list differ",0,0,ERR);
     827:
     828: /*
     829:    now push down names involved in formal argument list, then
     830:    evaluate rhs of statement function definition in this environment
     831: */
     832: rpllist = hookup(tlist, rpllist);
     833: q = mkconv(type, fixtype(cpexpr(rhs)) );
     834:
     835: /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
     836: while(--nargs >= 0)
     837:     {
     838:     if(rpllist->rplxp)
     839:         q = mkexpr(OPCOMMA, rpllist->rplxp, q);
     840:     rp = rpllist->nextp;
     841:     frexpr(rpllist->rplvp);
     842:     free(rpllist);
     843:     rpllist = rp;
     844:     }
     845:
     846: frchain( &oactp );
     847: return(q);
     848: }
     849:
     850:
     851:
     852:
     853: struct addrblock *mklhs(p)
     854: register struct primblock * p;
     855: {
     856: register struct addrblock *s;
     857: expptr suboffset();
     858: struct nameblock *np;
     859: register struct rplblock *rp;
     860: int regn;
     861:
     862: /* first fixup name */
     863:
     864: if(p->tag != TPRIM)
     865:     return(p);
     866: np = p->namep;
     867:
     868: /* is name on the replace list? */
     869:
     870: for(rp = rpllist ; rp ; rp = rp->nextp)
     871:     {
     872:     if(np == rp->rplnp)
     873:         {
     874:         if(rp->rpltag == TNAME)
     875:             {
     876:             np = p->namep = rp->rplvp;
     877:             break;
     878:             }
     879:         else    return( cpexpr(rp->rplvp) );
     880:         }
     881:     }
     882:
     883: /* is variable a DO index in a register ? */
     884:
     885: if(np->vdovar && ( (regn = inregister(np)) >= 0) )
     886:     if(np->vtype == TYERROR)
     887:         return( errnode() );
     888:     else
     889:         {
     890:         s = ALLOC(addrblock);
     891:         s->tag = TADDR;
     892:         s->vstg = STGREG;
     893:         s->vtype = TYIREG;
     894:         s->memno = regn;
     895:         s->memoffset = ICON(0);
     896:         return(s);
     897:         }
     898:
     899: vardcl(np);
     900: s = mkaddr(np);
     901: s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
     902: frexpr(p->argsp);
     903: p->argsp = NULL;
     904:
     905: /* now do substring part */
     906:
     907: if(p->fcharp || p->lcharp)
     908:     {
     909:     if(np->vtype != TYCHAR)
     910:         error("substring of noncharacter %s", varstr(VL,np->varname),0,ERR1);
     911:     else    {
     912:         if(p->lcharp == NULL)
     913:             p->lcharp = cpexpr(s->vleng);
     914:         if(p->fcharp)
     915:             s->vleng = mkexpr(OPMINUS, p->lcharp,
     916:                 mkexpr(OPMINUS, p->fcharp, ICON(1) ));
     917:         else    {
     918:             frexpr(s->vleng);
     919:             s->vleng = p->lcharp;
     920:             }
     921:         }
     922:     }
     923:
     924: s->vleng = fixtype( s->vleng );
     925: s->memoffset = fixtype( s->memoffset );
     926: free(p);
     927: return(s);
     928: }
     929:
     930:
     931:
     932:
     933:
     934: deregister(np)
     935: struct nameblock *np;
     936: {
     937: if(nregvar>0 && regnamep[nregvar-1]==np)
     938:     {
     939:     --nregvar;
     940: #if FAMILY == DMR
     941:     putnreg();
     942: #endif
     943:     }
     944: }
     945:
     946:
     947:
     948:
     949: struct addrblock *memversion(np)
     950: register struct nameblock *np;
     951: {
     952: register struct addrblock *s;
     953:
     954: if(np->vdovar==NO || (inregister(np)<0) )
     955:     return(NULL);
     956: np->vdovar = NO;
     957: s = mklhs( mkprim(np, 0,0,0) );
     958: np->vdovar = YES;
     959: return(s);
     960: }
     961:
     962:
     963:
     964: inregister(np)
     965: register struct nameblock *np;
     966: {
     967: register int i;
     968:
     969: for(i = 0 ; i < nregvar ; ++i)
     970:     if(regnamep[i] == np)
     971:         return( regnum[i] );
     972: return(-1);
     973: }
     974:
     975:
     976:
     977:
     978: enregister(np)
     979: struct nameblock *np;
     980: {
     981: if( inregister(np) >= 0)
     982:     return(YES);
     983: if(nregvar >= maxregvar)
     984:     return(NO);
     985: vardcl(np);
     986: if( ONEOF(np->vtype, MSKIREG) )
     987:     {
     988:     regnamep[nregvar++] = np;
     989:     if(nregvar > highregvar)
     990:         highregvar = nregvar;
     991: #if FAMILY == DMR
     992:     putnreg();
     993: #endif
     994:     return(YES);
     995:     }
     996: else
     997:     return(NO);
     998: }
     999:
    1000:
    1001:
    1002:
    1003: expptr suboffset(p)
    1004: register struct primblock *p;
    1005: {
    1006: int n;
    1007: expptr size;
    1008: chainp cp;
    1009: expptr offp, prod;
    1010: expptr subcheck();
    1011: struct dimblock *dimp;
    1012: expptr sub[8];
    1013: register struct nameblock *np;
    1014:
    1015: np = p->namep;
    1016: offp = ICON(0);
    1017: n = 0;
    1018: if(p->argsp)
    1019:     for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
    1020:         {
    1021:         sub[n++] = fixtype(cpexpr(cp->datap));
    1022:         if(n > 7)
    1023:             {
    1024:             error("more than 7 subscripts",0,0,ERR);
    1025:             break;
    1026:             }
    1027:         }
    1028:
    1029: dimp = np->vdim;
    1030: if(n>0 && dimp==NULL)
    1031:     error("subscripts on scalar variable",0,0,ERR);
    1032: else if(dimp && dimp->ndim!=n)
    1033:     error("wrong number of subscripts on %s", varstr(VL, np->varname),0,ERR1);
    1034: else if(n > 0)
    1035:     {
    1036:     prod = sub[--n];
    1037:     while( --n >= 0)
    1038:         prod = mkexpr(OPPLUS, sub[n],
    1039:             mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
    1040: #if TARGET == VAX
    1041:     if(checksubs || np->vstg!=STGARG)
    1042:         prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
    1043: #else
    1044:     prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
    1045: #endif
    1046:     if(checksubs)
    1047:         prod = subcheck(np, prod);
    1048:     if(np->vtype == TYCHAR)
    1049:         size = cpexpr(np->vleng);
    1050:     else    size = ICON( typesize[np->vtype] );
    1051:     prod = mkexpr(OPSTAR, prod, size);
    1052:     offp = mkexpr(OPPLUS, offp, prod);
    1053:     }
    1054:
    1055: if(p->fcharp && np->vtype==TYCHAR)
    1056:     offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) ));
    1057:
    1058: return(offp);
    1059: }
    1060:
    1061:
    1062:
    1063:
    1064: expptr subcheck(np, p)
    1065: struct nameblock *np;
    1066: register expptr p;
    1067: {
    1068: struct dimblock *dimp;
    1069: expptr t, checkvar, checkcond, badcall;
    1070:
    1071: dimp = np->vdim;
    1072: if(dimp->nelt == NULL)
    1073:     return(p);  /* don't check arrays with * bounds */
    1074: checkvar = NULL;
    1075: checkcond = NULL;
    1076: if( ISICON(p) )
    1077:     {
    1078:     if(p->const.ci < 0)
    1079:         goto badsub;
    1080:     if( ISICON(dimp->nelt) )
    1081:         if(p->const.ci < dimp->nelt->const.ci)
    1082:             return(p);
    1083:         else
    1084:             goto badsub;
    1085:     }
    1086: if(p->tag==TADDR && p->vstg==STGREG)
    1087:     {
    1088:     checkvar = cpexpr(p);
    1089:     t = p;
    1090:     }
    1091: else    {
    1092:     checkvar = mktemp(p->vtype, NULL);
    1093:     t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
    1094:     }
    1095: checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
    1096: if( ! ISICON(p) )
    1097:     checkcond = mkexpr(OPAND, checkcond,
    1098:             mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
    1099:
    1100: badcall = call4(p->vtype, "s_rnge", mkstrcon(VL, np->varname),
    1101:         mkconv(TYLONG,  cpexpr(checkvar)),
    1102:         mkstrcon(XL, procname), ICON(lineno));
    1103: badcall->opcode = OPCCALL;
    1104: p = mkexpr(OPQUEST, checkcond,
    1105:     mkexpr(OPCOLON, checkvar, badcall));
    1106:
    1107: return(p);
    1108:
    1109: badsub:
    1110:     frexpr(p);
    1111:     error("subscript on variable %s out of range", varstr(VL,np->varname),0,ERR1);
    1112:     return ( ICON(0) );
    1113: }
    1114:
    1115:
    1116:
    1117:
    1118: struct addrblock *mkaddr(p)
    1119: register struct nameblock *p;
    1120: {
    1121: struct extsym *mkext(), *extp;
    1122: register struct addrblock *t;
    1123: struct addrblock *intraddr();
    1124:
    1125: switch( p->vstg)
    1126:     {
    1127:     case STGUNKNOWN:
    1128:         if(p->vclass != CLPROC)
    1129:             break;
    1130:         extp = mkext( varunder(VL, p->varname) );
    1131:         extp->extstg = STGEXT;
    1132:         p->vstg = STGEXT;
    1133:         p->vardesc.varno = extp - extsymtab;
    1134:         p->vprocclass = PEXTERNAL;
    1135:
    1136:     case STGCOMMON:
    1137:     case STGEXT:
    1138:     case STGBSS:
    1139:     case STGINIT:
    1140:     case STGEQUIV:
    1141:     case STGARG:
    1142:     case STGLENG:
    1143:     case STGAUTO:
    1144:         t = ALLOC(addrblock);
    1145:         t->tag = TADDR;
    1146:         if(p->vclass==CLPROC && p->vprocclass==PTHISPROC)
    1147:             t->vclass = CLVAR;
    1148:         else
    1149:             t->vclass = p->vclass;
    1150:         t->vtype = p->vtype;
    1151:         t->vstg = p->vstg;
    1152:         t->memno = p->vardesc.varno;
    1153:         t->memoffset = ICON(p->voffset);
    1154:         if(p->vleng)
    1155:             t->vleng = cpexpr(p->vleng);
    1156:         return(t);
    1157:
    1158:     case STGINTR:
    1159:         return( intraddr(p) );
    1160:
    1161:     }
    1162: /*debug*/ fprintf(diagfile, "mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass);
    1163: error("mkaddr: impossible storage tag %d", p->vstg,0,FATAL1);
    1164: /* NOTREACHED */
    1165: }
    1166:
    1167:
    1168:
    1169:
    1170: mkarg(type, argno)
    1171: int type, argno;
    1172: {
    1173: register struct addrblock *p;
    1174:
    1175: p = ALLOC(addrblock);
    1176: p->tag = TADDR;
    1177: p->vtype = type;
    1178: p->vclass = CLVAR;
    1179: p->vstg = (type==TYLENG ? STGLENG : STGARG);
    1180: p->memno = argno;
    1181: return(p);
    1182: }
    1183:
    1184:
    1185:
    1186:
    1187: tagptr mkprim(v, args, lstr, rstr)
    1188: register union { struct paramblock; struct nameblock; } *v;
    1189: struct listblock *args;
    1190: expptr lstr, rstr;
    1191: {
    1192: register struct primblock *p;
    1193:
    1194: if(v->vclass == CLPARAM)
    1195:     {
    1196:     if(args || lstr || rstr)
    1197:         {
    1198:         error("no qualifiers on parameter name", varstr(VL,v->varname),0,ERR1);
    1199:         frexpr(args);
    1200:         frexpr(lstr);
    1201:         frexpr(rstr);
    1202:         frexpr(v);
    1203:         return( errnode() );
    1204:         }
    1205:     return( cpexpr(v->paramval) );
    1206:     }
    1207:
    1208: p = ALLOC(primblock);
    1209: p->tag = TPRIM;
    1210: p->vtype = v->vtype;
    1211: p->namep = v;
    1212: p->argsp = args;
    1213: p->fcharp = lstr;
    1214: p->lcharp = rstr;
    1215: return(p);
    1216: }
    1217:
    1218:
    1219:
    1220: vardcl(v)
    1221: register struct nameblock *v;
    1222: {
    1223: int nelt;
    1224: struct dimblock *t;
    1225: struct addrblock *p;
    1226: expptr neltp;
    1227:
    1228: if(v->vdcldone) return;
    1229:
    1230: if(v->vtype == TYUNKNOWN)
    1231:     impldcl(v);
    1232: if(v->vclass == CLUNKNOWN)
    1233:     v->vclass = CLVAR;
    1234: else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
    1235:     {
    1236:     error("used as variable", v, 0, DCLERR);
    1237:     return;
    1238:     }
    1239: if(v->vstg==STGUNKNOWN)
    1240:     v->vstg = implstg[ letter(v->varname[0]) ];
    1241:
    1242: switch(v->vstg)
    1243:     {
    1244:     case STGBSS:
    1245:         v->vardesc.varno = ++lastvarno;
    1246:         break;
    1247:     case STGAUTO:
    1248:         if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
    1249:             break;
    1250:         nelt = 1;
    1251:         if(t = v->vdim)
    1252:             if( (neltp = t->nelt) && ISCONST(neltp) )
    1253:                 nelt = neltp->const.ci;
    1254:             else
    1255:                 error("adjustable automatic array", v, 0, DCLERR);
    1256:         p = autovar(nelt, v->vtype, v->vleng);
    1257:         v->voffset = p->memoffset->const.ci;
    1258:         frexpr(p);
    1259:         break;
    1260:
    1261:     default:
    1262:         break;
    1263:     }
    1264: v->vdcldone = YES;
    1265: }
    1266:
    1267:
    1268:
    1269:
    1270: impldcl(p)
    1271: register struct nameblock *p;
    1272: {
    1273: register int k;
    1274: int type, leng;
    1275:
    1276: if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
    1277:     return;
    1278: if(p->vtype == TYUNKNOWN)
    1279:     {
    1280:     k = letter(p->varname[0]);
    1281:     type = impltype[ k ];
    1282:     leng = implleng[ k ];
    1283:     if(type == TYUNKNOWN)
    1284:         {
    1285:         if(p->vclass == CLPROC)
    1286:             return;
    1287:         error("attempt to use undefined variable", p, 0, DCLERR);
    1288:         type = TYERROR;
    1289:         leng = 1;
    1290:         }
    1291:     settype(p, type, leng);
    1292:     }
    1293: }
    1294:
    1295:
    1296:
    1297:
    1298: LOCAL letter(c)
    1299: register int c;
    1300: {
    1301: if( isupper(c) )
    1302:     c = tolower(c);
    1303: return(c - 'a');
    1304: }
    1305:
    1306: #define ICONEQ(z, c)  (ISICON(z) && z->const.ci==c)
    1307: #define COMMUTE { e = lp;  lp = rp;  rp = e; }
    1308:
    1309:
    1310: expptr mkexpr(opcode, lp, rp)
    1311: int opcode;
    1312: register expptr lp, rp;
    1313: {
    1314: register struct exprblock *e, *e1;
    1315: int etype;
    1316: int ltype, rtype;
    1317: int ltag, rtag;
    1318: expptr fold();
    1319:
    1320: ltype = lp->vtype;
    1321: ltag = lp->tag;
    1322: if(rp && opcode!=OPCALL && opcode!=OPCCALL)
    1323:     {
    1324:     rtype = rp->vtype;
    1325:     rtag = rp->tag;
    1326:     }
    1327: else  rtype = 0;
    1328:
    1329: etype = cktype(opcode, ltype, rtype);
    1330: if(etype == TYERROR)
    1331:     goto err;
    1332:
    1333: switch(opcode)
    1334:     {
    1335:     /* check for multiplication by 0 and 1 and addition to 0 */
    1336:
    1337:     case OPSTAR:
    1338:         if( ISCONST(lp) )
    1339:             COMMUTE
    1340:
    1341:         if( ISICON(rp) )
    1342:             {
    1343:             if(rp->const.ci == 0)
    1344:                 goto retright;
    1345:             goto mulop;
    1346:             }
    1347:         break;
    1348:
    1349:     case OPSLASH:
    1350:     case OPMOD:
    1351:         if( ICONEQ(rp, 0) )
    1352:             {
    1353:             error("attempted division by zero",0,0,ERR);
    1354:             rp = ICON(1);
    1355:             break;
    1356:             }
    1357:         if(opcode == OPMOD)
    1358:             break;
    1359:
    1360:
    1361:     mulop:
    1362:         if( ISICON(rp) )
    1363:             {
    1364:             if(rp->const.ci == 1)
    1365:                 goto retleft;
    1366:
    1367:             if(rp->const.ci == -1)
    1368:                 {
    1369:                 frexpr(rp);
    1370:                 return( mkexpr(OPNEG, lp, 0) );
    1371:                 }
    1372:             }
    1373:
    1374:         if( ISSTAROP(lp) && ISICON(lp->rightp) )
    1375:             {
    1376:             if(opcode == OPSTAR)
    1377:                 e = mkexpr(OPSTAR, lp->rightp, rp);
    1378:             else  if(ISICON(rp) && lp->rightp->const.ci % rp->const.ci == 0)
    1379:                 e = mkexpr(OPSLASH, lp->rightp, rp);
    1380:             else    break;
    1381:
    1382:             e1 = lp->leftp;
    1383:             free(lp);
    1384:             return( mkexpr(OPSTAR, e1, e) );
    1385:             }
    1386:         break;
    1387:
    1388:
    1389:     case OPPLUS:
    1390:         if( ISCONST(lp) )
    1391:             COMMUTE
    1392:         goto addop;
    1393:
    1394:     case OPMINUS:
    1395:         if( ICONEQ(lp, 0) )
    1396:             {
    1397:             frexpr(lp);
    1398:             return( mkexpr(OPNEG, rp, 0) );
    1399:             }
    1400:
    1401:         if( ISCONST(rp) )
    1402:             {
    1403:             opcode = OPPLUS;
    1404:             consnegop(rp);
    1405:             }
    1406:
    1407:     addop:
    1408:         if( ISICON(rp) )
    1409:             {
    1410:             if(rp->const.ci == 0)
    1411:                 goto retleft;
    1412:             if( ISPLUSOP(lp) && ISICON(lp->rightp) )
    1413:                 {
    1414:                 e = mkexpr(OPPLUS, lp->rightp, rp);
    1415:                 e1 = lp->leftp;
    1416:                 free(lp);
    1417:                 return( mkexpr(OPPLUS, e1, e) );
    1418:                 }
    1419:             }
    1420:         break;
    1421:
    1422:
    1423:     case OPPOWER:
    1424:         break;
    1425:
    1426:     case OPNEG:
    1427:         if(ltag==TEXPR && lp->opcode==OPNEG)
    1428:             {
    1429:             e = lp->leftp;
    1430:             free(lp);
    1431:             return(e);
    1432:             }
    1433:         break;
    1434:
    1435:     case OPNOT:
    1436:         if(ltag==TEXPR && lp->opcode==OPNOT)
    1437:             {
    1438:             e = lp->leftp;
    1439:             free(lp);
    1440:             return(e);
    1441:             }
    1442:         break;
    1443:
    1444:     case OPCALL:
    1445:     case OPCCALL:
    1446:         etype = ltype;
    1447:         if(rp!=NULL && rp->listp==NULL)
    1448:             {
    1449:             free(rp);
    1450:             rp = NULL;
    1451:             }
    1452:         break;
    1453:
    1454:     case OPAND:
    1455:     case OPOR:
    1456:         if( ISCONST(lp) )
    1457:             COMMUTE
    1458:
    1459:         if( ISCONST(rp) )
    1460:             {
    1461:             if(rp->const.ci == 0)
    1462:                 if(opcode == OPOR)
    1463:                     goto retleft;
    1464:                 else
    1465:                     goto retright;
    1466:             else if(opcode == OPOR)
    1467:                 goto retright;
    1468:             else
    1469:                 goto retleft;
    1470:             }
    1471:     case OPEQV:
    1472:     case OPNEQV:
    1473:
    1474:     case OPBITAND:
    1475:     case OPBITOR:
    1476:     case OPBITXOR:
    1477:     case OPBITNOT:
    1478:     case OPLSHIFT:
    1479:     case OPRSHIFT:
    1480:
    1481:     case OPLT:
    1482:     case OPGT:
    1483:     case OPLE:
    1484:     case OPGE:
    1485:     case OPEQ:
    1486:     case OPNE:
    1487:
    1488:     case OPCONCAT:
    1489:         break;
    1490:     case OPMIN:
    1491:     case OPMAX:
    1492:
    1493:     case OPASSIGN:
    1494:     case OPPLUSEQ:
    1495:     case OPSTAREQ:
    1496:
    1497:     case OPCONV:
    1498:     case OPADDR:
    1499:
    1500:     case OPCOMMA:
    1501:     case OPQUEST:
    1502:     case OPCOLON:
    1503:         break;
    1504:
    1505:     default:
    1506:         error("mkexpr: impossible opcode %d", opcode,0,FATAL1);
    1507:     }
    1508:
    1509: e = ALLOC(exprblock);
    1510: e->tag = TEXPR;
    1511: e->opcode = opcode;
    1512: e->vtype = etype;
    1513: e->leftp = lp;
    1514: e->rightp = rp;
    1515: if(ltag==TCONST && (rp==0 || rtag==TCONST) )
    1516:     e = fold(e);
    1517: return(e);
    1518:
    1519: retleft:
    1520:     frexpr(rp);
    1521:     return(lp);
    1522:
    1523: retright:
    1524:     frexpr(lp);
    1525:     return(rp);
    1526:
    1527: err:
    1528:     frexpr(lp);
    1529:     if(rp && opcode!=OPCALL && opcode!=OPCCALL)
    1530:         frexpr(rp);
    1531:     return( errnode() );
    1532: }
    1533:
    1534:
    1535: cktype(op, lt, rt)
    1536: register int op, lt, rt;
    1537: {
    1538: char *errs;
    1539:
    1540: if(lt==TYERROR || rt==TYERROR)
    1541:     goto err1;
    1542:
    1543: if(lt==TYUNKNOWN)
    1544:     return(TYUNKNOWN);
    1545: if(rt==TYUNKNOWN)
    1546:     if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
    1547:         return(TYUNKNOWN);
    1548:
    1549: switch(op)
    1550:     {
    1551:     case OPPLUS:
    1552:     case OPMINUS:
    1553:     case OPSTAR:
    1554:     case OPSLASH:
    1555:     case OPPOWER:
    1556:     case OPMOD:
    1557:         if( ISNUMERIC(lt) && ISNUMERIC(rt) )
    1558:             return( maxtype(lt, rt) );
    1559:         error("nonarithmetic operand of arithmetic operator",0,0,ERR);goto err1;
    1560:
    1561:     case OPNEG:
    1562:         if( ISNUMERIC(lt) )
    1563:             return(lt);
    1564:         error("nonarithmetic operand of negation",0,0,ERR);goto err1;
    1565:
    1566:     case OPNOT:
    1567:         if(lt == TYLOGICAL)
    1568:             return(TYLOGICAL);
    1569:         error("NOT of nonlogical",0,0,ERR);goto err1;
    1570:
    1571:     case OPAND:
    1572:     case OPOR:
    1573:     case OPEQV:
    1574:     case OPNEQV:
    1575:         if(lt==TYLOGICAL && rt==TYLOGICAL)
    1576:             return(TYLOGICAL);
    1577:         error("nonlogical operand of logical operator",0,0,ERR);goto err1;
    1578:
    1579:     case OPLT:
    1580:     case OPGT:
    1581:     case OPLE:
    1582:     case OPGE:
    1583:     case OPEQ:
    1584:     case OPNE:
    1585:         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
    1586:             {
    1587:             if(lt != rt)
    1588:                 {error("illegal comparison",0,0,ERR);goto err1;}
    1589:             }
    1590:
    1591:         else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
    1592:             {
    1593:             if(op!=OPEQ && op!=OPNE)
    1594:                 {error("order comparison of complex data",0,0,ERR);goto err1;}
    1595:             }
    1596:
    1597:         else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
    1598:             {error("comparison of nonarithmetic data",0,0,ERR);goto err1;}
    1599:         return(TYLOGICAL);
    1600:
    1601:     case OPCONCAT:
    1602:         if(lt==TYCHAR && rt==TYCHAR)
    1603:             return(TYCHAR);
    1604:         error("concatenation of nonchar data",0,0,ERR);goto err1;
    1605:
    1606:     case OPCALL:
    1607:     case OPCCALL:
    1608:         return(lt);
    1609:
    1610:     case OPADDR:
    1611:         return(TYADDR);
    1612:
    1613:     case OPCONV:
    1614:         if(rt == 0)
    1615:             return(0);
    1616:         if(lt==TYCHAR && ISINT(rt) )
    1617:             return(TYCHAR);
    1618:     case OPASSIGN:
    1619:     case OPPLUSEQ:
    1620:     case OPSTAREQ:
    1621:         if( ISINT(lt) && rt==TYCHAR)
    1622:             return(lt);
    1623:         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
    1624:             if(op!=OPASSIGN || lt!=rt)
    1625:                 {
    1626: /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
    1627: /* debug error("impossible conversion.  possible compiler bug",0,0,FATAL); */
    1628:                 error("impossible conversion",0,0,ERR);goto err1;
    1629:                 }
    1630:         return(lt);
    1631:
    1632:     case OPMIN:
    1633:     case OPMAX:
    1634:     case OPBITOR:
    1635:     case OPBITAND:
    1636:     case OPBITXOR:
    1637:     case OPBITNOT:
    1638:     case OPLSHIFT:
    1639:     case OPRSHIFT:
    1640:         return(lt);
    1641:
    1642:     case OPCOMMA:
    1643:     case OPQUEST:
    1644:     case OPCOLON:
    1645:         return(rt);
    1646:
    1647:     default:
    1648:         error("cktype: impossible opcode %d", op,0,FATAL1);
    1649:     }
    1650: err1:   return(TYERROR);
    1651: }
    1652:
    1653: LOCAL expptr fold(e)
    1654: register struct exprblock *e;
    1655: {
    1656: struct constblock *p;
    1657: #ifdef VERSION6
    1658:     expptr lp, rp;
    1659: #else
    1660:     register expptr lp, rp;
    1661: #endif
    1662: int etype, mtype, ltype, rtype, opcode;
    1663: int i, ll, lr;
    1664: char *q, *s;
    1665: union constant lcon, rcon;
    1666:
    1667: opcode = e->opcode;
    1668: etype = e->vtype;
    1669:
    1670: lp = e->leftp;
    1671: ltype = lp->vtype;
    1672: rp = e->rightp;
    1673:
    1674: if(rp == 0)
    1675:     switch(opcode)
    1676:         {
    1677:         case OPNOT:
    1678:             lp->const.ci = ! lp->const.ci;
    1679:             return(lp);
    1680:
    1681:         case OPBITNOT:
    1682:             lp->const.ci = ~ lp->const.ci;
    1683:             return(lp);
    1684:
    1685:         case OPNEG:
    1686:             consnegop(lp);
    1687:             return(lp);
    1688:
    1689:         case OPCONV:
    1690:         case OPADDR:
    1691:             return(e);
    1692:
    1693:         default:
    1694:             error("fold: invalid unary operator %d", opcode,0,FATAL1);
    1695:         }
    1696:
    1697: rtype = rp->vtype;
    1698:
    1699: p = ALLOC(constblock);
    1700: p->tag = TCONST;
    1701: p->vtype = etype;
    1702: p->vleng = e->vleng;
    1703:
    1704: switch(opcode)
    1705:     {
    1706:     case OPCOMMA:
    1707:     case OPQUEST:
    1708:     case OPCOLON:
    1709:         return(e);
    1710:
    1711:     case OPAND:
    1712:         p->const.ci = lp->const.ci && rp->const.ci;
    1713:         break;
    1714:
    1715:     case OPOR:
    1716:         p->const.ci = lp->const.ci || rp->const.ci;
    1717:         break;
    1718:
    1719:     case OPEQV:
    1720:         p->const.ci = lp->const.ci == rp->const.ci;
    1721:         break;
    1722:
    1723:     case OPNEQV:
    1724:         p->const.ci = lp->const.ci != rp->const.ci;
    1725:         break;
    1726:
    1727:     case OPBITAND:
    1728:         p->const.ci = lp->const.ci & rp->const.ci;
    1729:         break;
    1730:
    1731:     case OPBITOR:
    1732:         p->const.ci = lp->const.ci | rp->const.ci;
    1733:         break;
    1734:
    1735:     case OPBITXOR:
    1736:         p->const.ci = lp->const.ci ^ rp->const.ci;
    1737:         break;
    1738:
    1739:     case OPLSHIFT:
    1740:         p->const.ci = lp->const.ci << rp->const.ci;
    1741:         break;
    1742:
    1743:     case OPRSHIFT:
    1744:         p->const.ci = lp->const.ci >> rp->const.ci;
    1745:         break;
    1746:
    1747:     case OPCONCAT:
    1748:         ll = lp->vleng->const.ci;
    1749:         lr = rp->vleng->const.ci;
    1750:         p->const.ccp = q = (char *) ckalloc(ll+lr);
    1751:         p->vleng = ICON(ll+lr);
    1752:         s = lp->const.ccp;
    1753:         for(i = 0 ; i < ll ; ++i)
    1754:             *q++ = *s++;
    1755:         s = rp->const.ccp;
    1756:         for(i = 0; i < lr; ++i)
    1757:             *q++ = *s++;
    1758:         break;
    1759:
    1760:
    1761:     case OPPOWER:
    1762:         if( ! ISINT(rtype) )
    1763:             return(e);
    1764:         conspower(&(p->const), lp, rp->const.ci);
    1765:         break;
    1766:
    1767:
    1768:     default:
    1769:         if(ltype == TYCHAR)
    1770:             {
    1771:             lcon.ci = cmpstr(lp->const.ccp, rp->const.ccp,
    1772:                     lp->vleng->const.ci, rp->vleng->const.ci);
    1773:             rcon.ci = 0;
    1774:             mtype = tyint;
    1775:             }
    1776:         else    {
    1777:             mtype = maxtype(ltype, rtype);
    1778:             consconv(mtype, &lcon, ltype, &(lp->const) );
    1779:             consconv(mtype, &rcon, rtype, &(rp->const) );
    1780:             }
    1781:         consbinop(opcode, mtype, &(p->const), &lcon, &rcon);
    1782:         break;
    1783:     }
    1784:
    1785: frexpr(e);
    1786: return(p);
    1787: }
    1788:
    1789:
    1790:
    1791: /* assign constant l = r , doing coercion */
    1792:
    1793: consconv(lt, lv, rt, rv)
    1794: int lt, rt;
    1795: register union constant *lv, *rv;
    1796: {
    1797: switch(lt)
    1798:     {
    1799:     case TYCHAR:
    1800:         *(lv->ccp = ckalloc(1)) = rv->ci;
    1801:         break;
    1802:
    1803:     case TYSHORT:
    1804:     case TYLONG:
    1805:         if(rt == TYCHAR)
    1806:             lv->ci = rv->ccp[0];
    1807:         else if( ISINT(rt) )
    1808:             lv->ci = rv->ci;
    1809:         else    lv->ci = rv->cd[0];
    1810:         break;
    1811:
    1812:     case TYCOMPLEX:
    1813:     case TYDCOMPLEX:
    1814:         switch(rt)
    1815:             {
    1816:             case TYSHORT:
    1817:             case TYLONG:
    1818:                 /* fall through and do real assignment of
    1819: 				   first element
    1820: 				*/
    1821:             case TYREAL:
    1822:             case TYDREAL:
    1823:                 lv->cd[1] = 0; break;
    1824:             case TYCOMPLEX:
    1825:             case TYDCOMPLEX:
    1826:                 lv->cd[1] = rv->cd[1]; break;
    1827:             }
    1828:
    1829:     case TYREAL:
    1830:     case TYDREAL:
    1831:         if( ISINT(rt) )
    1832:             lv->cd[0] = rv->ci;
    1833:         else    lv->cd[0] = rv->cd[0];
    1834:         break;
    1835:
    1836:     case TYLOGICAL:
    1837:         lv->ci = rv->ci;
    1838:         break;
    1839:     }
    1840: }
    1841:
    1842:
    1843:
    1844: consnegop(p)
    1845: register struct constblock *p;
    1846: {
    1847: switch(p->vtype)
    1848:     {
    1849:     case TYSHORT:
    1850:     case TYLONG:
    1851:         p->const.ci = - p->const.ci;
    1852:         break;
    1853:
    1854:     case TYCOMPLEX:
    1855:     case TYDCOMPLEX:
    1856:         p->const.cd[1] = - p->const.cd[1];
    1857:         /* fall through and do the real parts */
    1858:     case TYREAL:
    1859:     case TYDREAL:
    1860:         p->const.cd[0] = - p->const.cd[0];
    1861:         break;
    1862:     default:
    1863:         error("consnegop: impossible type %d", p->vtype,0,FATAL1);
    1864:     }
    1865: }
    1866:
    1867:
    1868:
    1869: LOCAL conspower(powp, ap, n)
    1870: register union constant *powp;
    1871: struct constblock *ap;
    1872: ftnint n;
    1873: {
    1874: register int type;
    1875: union constant x;
    1876:
    1877: switch(type = ap->vtype)    /* pow = 1 */
    1878:     {
    1879:     case TYSHORT:
    1880:     case TYLONG:
    1881:         powp->ci = 1;
    1882:         break;
    1883:     case TYCOMPLEX:
    1884:     case TYDCOMPLEX:
    1885:         powp->cd[1] = 0;
    1886:     case TYREAL:
    1887:     case TYDREAL:
    1888:         powp->cd[0] = 1;
    1889:         break;
    1890:     default:
    1891:         error("conspower: invalid type %d", type,0,FATAL1);
    1892:     }
    1893:
    1894: if(n == 0)
    1895:     return;
    1896: if(n < 0)
    1897:     {
    1898:     if( ISINT(type) )
    1899:         {
    1900:         error("integer ** negative power ",0,0,ERR);
    1901:         return;
    1902:         }
    1903:     n = - n;
    1904:     consbinop(OPSLASH, type, &x, powp, &(ap->const));
    1905:     }
    1906: else
    1907:     consbinop(OPSTAR, type, &x, powp, &(ap->const));
    1908:
    1909: for( ; ; )
    1910:     {
    1911:     if(n & 01)
    1912:         consbinop(OPSTAR, type, powp, powp, &x);
    1913:     if(n >>= 1)
    1914:         consbinop(OPSTAR, type, &x, &x, &x);
    1915:     else
    1916:         break;
    1917:     }
    1918: }
    1919:
    1920:
    1921:
    1922: /* do constant operation cp = a op b */
    1923:
    1924:
    1925: LOCAL consbinop(opcode, type, cp, ap, bp)
    1926: int opcode, type;
    1927: register union constant *ap, *bp, *cp;
    1928: {
    1929: int k;
    1930: double temp;
    1931:
    1932: switch(opcode)
    1933:     {
    1934:     case OPPLUS:
    1935:         switch(type)
    1936:             {
    1937:             case TYSHORT:
    1938:             case TYLONG:
    1939:                 cp->ci = ap->ci + bp->ci;
    1940:                 break;
    1941:             case TYCOMPLEX:
    1942:             case TYDCOMPLEX:
    1943:                 cp->cd[1] = ap->cd[1] + bp->cd[1];
    1944:             case TYREAL:
    1945:             case TYDREAL:
    1946:                 cp->cd[0] = ap->cd[0] + bp->cd[0];
    1947:                 break;
    1948:             }
    1949:         break;
    1950:
    1951:     case OPMINUS:
    1952:         switch(type)
    1953:             {
    1954:             case TYSHORT:
    1955:             case TYLONG:
    1956:                 cp->ci = ap->ci - bp->ci;
    1957:                 break;
    1958:             case TYCOMPLEX:
    1959:             case TYDCOMPLEX:
    1960:                 cp->cd[1] = ap->cd[1] - bp->cd[1];
    1961:             case TYREAL:
    1962:             case TYDREAL:
    1963:                 cp->cd[0] = ap->cd[0] - bp->cd[0];
    1964:                 break;
    1965:             }
    1966:         break;
    1967:
    1968:     case OPSTAR:
    1969:         switch(type)
    1970:             {
    1971:             case TYSHORT:
    1972:             case TYLONG:
    1973:                 cp->ci = ap->ci * bp->ci;
    1974:                 break;
    1975:             case TYREAL:
    1976:             case TYDREAL:
    1977:                 cp->cd[0] = ap->cd[0] * bp->cd[0];
    1978:                 break;
    1979:             case TYCOMPLEX:
    1980:             case TYDCOMPLEX:
    1981:                 temp = ap->cd[0] * bp->cd[0] -
    1982:                         ap->cd[1] * bp->cd[1] ;
    1983:                 cp->cd[1] = ap->cd[0] * bp->cd[1] +
    1984:                         ap->cd[1] * bp->cd[0] ;
    1985:                 cp->cd[0] = temp;
    1986:                 break;
    1987:             }
    1988:         break;
    1989:     case OPSLASH:
    1990:         switch(type)
    1991:             {
    1992:             case TYSHORT:
    1993:             case TYLONG:
    1994:                 cp->ci = ap->ci / bp->ci;
    1995:                 break;
    1996:             case TYREAL:
    1997:             case TYDREAL:
    1998:                 cp->cd[0] = ap->cd[0] / bp->cd[0];
    1999:                 break;
    2000:             case TYCOMPLEX:
    2001:             case TYDCOMPLEX:
    2002:                 zdiv(cp,ap,bp);
    2003:                 break;
    2004:             }
    2005:         break;
    2006:
    2007:     case OPMOD:
    2008:         if( ISINT(type) )
    2009:             {
    2010:             cp->ci = ap->ci % bp->ci;
    2011:             break;
    2012:             }
    2013:         else
    2014:             error("inline mod of noninteger",0,0,FATAL);
    2015:
    2016:     default:      /* relational ops */
    2017:         switch(type)
    2018:             {
    2019:             case TYSHORT:
    2020:             case TYLONG:
    2021:                 if(ap->ci < bp->ci)
    2022:                     k = -1;
    2023:                 else if(ap->ci == bp->ci)
    2024:                     k = 0;
    2025:                 else    k = 1;
    2026:                 break;
    2027:             case TYREAL:
    2028:             case TYDREAL:
    2029:                 if(ap->cd[0] < bp->cd[0])
    2030:                     k = -1;
    2031:                 else if(ap->cd[0] == bp->cd[0])
    2032:                     k = 0;
    2033:                 else    k = 1;
    2034:                 break;
    2035:             case TYCOMPLEX:
    2036:             case TYDCOMPLEX:
    2037:                 if(ap->cd[0] == bp->cd[0] &&
    2038:                    ap->cd[1] == bp->cd[1] )
    2039:                     k = 0;
    2040:                 else    k = 1;
    2041:                 break;
    2042:             }
    2043:
    2044:         switch(opcode)
    2045:             {
    2046:             case OPEQ:
    2047:                 cp->ci = (k == 0);
    2048:                 break;
    2049:             case OPNE:
    2050:                 cp->ci = (k != 0);
    2051:                 break;
    2052:             case OPGT:
    2053:                 cp->ci = (k == 1);
    2054:                 break;
    2055:             case OPLT:
    2056:                 cp->ci = (k == -1);
    2057:                 break;
    2058:             case OPGE:
    2059:                 cp->ci = (k >= 0);
    2060:                 break;
    2061:             case OPLE:
    2062:                 cp->ci = (k <= 0);
    2063:                 break;
    2064:             }
    2065:         break;
    2066:     }
    2067: }
    2068:
    2069:
    2070:
    2071:
    2072: conssgn(p)
    2073: register expptr p;
    2074: {
    2075: if( ! ISCONST(p) )
    2076:     error("sgn(nonconstant)" ,0,0,FATAL);
    2077:
    2078: switch(p->vtype)
    2079:     {
    2080:     case TYSHORT:
    2081:     case TYLONG:
    2082:         if(p->const.ci > 0) return(1);
    2083:         if(p->const.ci < 0) return(-1);
    2084:         return(0);
    2085:
    2086:     case TYREAL:
    2087:     case TYDREAL:
    2088:         if(p->const.cd[0] > 0) return(1);
    2089:         if(p->const.cd[0] < 0) return(-1);
    2090:         return(0);
    2091:
    2092:     case TYCOMPLEX:
    2093:     case TYDCOMPLEX:
    2094:         return(p->const.cd[0]!=0 || p->const.cd[1]!=0);
    2095:
    2096:     default:
    2097:         error("conssgn(type %d)", p->vtype,0,FATAL1);
    2098:     }
    2099: /* NOTREACHED */
    2100: }
    2101:
    2102: char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
    2103:
    2104:
    2105: LOCAL expptr mkpower(p)
    2106: register struct exprblock *p;
    2107: {
    2108: register expptr q, lp, rp;
    2109: int ltype, rtype, mtype;
    2110:
    2111: lp = p->leftp;
    2112: rp = p->rightp;
    2113: ltype = lp->vtype;
    2114: rtype = rp->vtype;
    2115:
    2116: if(ISICON(rp))
    2117:     {
    2118:     if(rp->const.ci == 0)
    2119:         {
    2120:         frexpr(p);
    2121:         if( ISINT(ltype) )
    2122:             return( ICON(1) );
    2123:         else
    2124:             return( putconst( mkconv(ltype, ICON(1))) );
    2125:         }
    2126:     if(rp->const.ci < 0)
    2127:         {
    2128:         if( ISINT(ltype) )
    2129:             {
    2130:             frexpr(p);
    2131:             error("integer**negative",0,0,ERR);
    2132:             return( errnode() );
    2133:             }
    2134:         rp->const.ci = - rp->const.ci;
    2135:         p->leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp));
    2136:         }
    2137:     if(rp->const.ci == 1)
    2138:         {
    2139:         frexpr(rp);
    2140:         free(p);
    2141:         return(lp);
    2142:         }
    2143:
    2144:     if( ONEOF(ltype, MSKINT|MSKREAL) )
    2145:         {
    2146:         p->vtype = ltype;
    2147:         return(p);
    2148:         }
    2149:     }
    2150: if( ISINT(rtype) )
    2151:     {
    2152:     if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
    2153:         q = call2(TYSHORT, "pow_hh", lp, rp);
    2154:     else    {
    2155:         if(ltype == TYSHORT)
    2156:             {
    2157:             ltype = TYLONG;
    2158:             lp = mkconv(TYLONG,lp);
    2159:             }
    2160:         q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
    2161:         }
    2162:     }
    2163: else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
    2164:     q = call2(mtype, "pow_dd",
    2165:         mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
    2166: else    {
    2167:     q = call2(TYDCOMPLEX, "pow_zz",
    2168:         mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
    2169:     if(mtype == TYCOMPLEX)
    2170:         q = mkconv(TYCOMPLEX, q);
    2171:     }
    2172: free(p);
    2173: return(q);
    2174: }
    2175:
    2176:
    2177:
    2178: /* Complex Division.  Same code as in Runtime Library
    2179: */
    2180:
    2181: struct dcomplex { double dreal, dimag; };
    2182:
    2183:
    2184: LOCAL zdiv(c, a, b)
    2185: register struct dcomplex *a, *b, *c;
    2186: {
    2187: double ratio, den;
    2188: double abr, abi;
    2189:
    2190: if( (abr = b->dreal) < 0.)
    2191:     abr = - abr;
    2192: if( (abi = b->dimag) < 0.)
    2193:     abi = - abi;
    2194: if( abr <= abi )
    2195:     {
    2196:     if(abi == 0)
    2197:         error("complex division by zero",0,0,FATAL);
    2198:     ratio = b->dreal / b->dimag ;
    2199:     den = b->dimag * (1 + ratio*ratio);
    2200:     c->dreal = (a->dreal*ratio + a->dimag) / den;
    2201:     c->dimag = (a->dimag*ratio - a->dreal) / den;
    2202:     }
    2203:
    2204: else
    2205:     {
    2206:     ratio = b->dimag / b->dreal ;
    2207:     den = b->dreal * (1 + ratio*ratio);
    2208:     c->dreal = (a->dreal + a->dimag*ratio) / den;
    2209:     c->dimag = (a->dimag - a->dreal*ratio) / den;
    2210:     }
    2211:
    2212: }

#### Defined functions

addrof defined in line 200; used 7 times

- in /usr/src/usr.bin/f77/defs line 439
- in /usr/src/usr.bin/f77/io.c line 606, 633, 644, 796, 811
- in /usr/src/usr.bin/f77/putdmr.c line 944

cktype defined in line 1535; used 5 times

- in line 427, 493, 507, 1329
- in /usr/src/usr.bin/f77/data.c line 228

consbinop defined in line 1925; used 5 times

- in line 1781, 1904-1914(4)

consconv defined in line 1793; used 4 times

- in line 166, 1778-1779(2)
- in /usr/src/usr.bin/f77/data.c line 236

consnegop defined in line 1844; used 3 times

- in line 1404, 1686
- in /usr/src/usr.bin/f77/gram.dcl line 156

conspower defined in line 1869; used 1 times

- in line 1764

conssgn defined in line 2072; used 2 times

- in /usr/src/usr.bin/f77/exec.c line 347, 368

cpexpr defined in line 208; used 141 times

- in line 241, 247-248(2), 254-269(7), 437-438(2), 575, 666, 737, 814, 833, 879, 913, 1021, 1039-1049(4), 1056, 1088-1101(5), 1155, 1205
- in /usr/src/usr.bin/f77/data.c line 80, 87, 96, 148
- in /usr/src/usr.bin/f77/defs line 444
- in /usr/src/usr.bin/f77/exec.c line 361(2), 367(2), 379-383(3), 390-397(4), 405-415(5), 435-439(2)
- in /usr/src/usr.bin/f77/gram.expr line 78
- in /usr/src/usr.bin/f77/intr.c line 609-613(4), 623
- in /usr/src/usr.bin/f77/io.c line 461, 469, 476, 536-537(2), 553, 576, 587, 597, 605, 616, 644, 673, 683-688(2), 696, 707, 717-719(2), 733, 753, 765-766(2), 780, 796, 811, 825
- in /usr/src/usr.bin/f77/pdp11.c line 390-398(5)
- in /usr/src/usr.bin/f77/proc.c line 189, 229, 236, 845, 858, 872
- in /usr/src/usr.bin/f77/put.c line 94(2), 106, 123, 147
- in /usr/src/usr.bin/f77/putdmr.c line 443, 504(2), 513-518(4), 530-531(3), 551, 619, 629, 689-690(2), 696-697(2), 716-717(2), 796-797(2), 805, 939-943(3), 967, 1069, 1094, 1117, 1166-1180(8)

deregister defined in line 934; used 1 times

- in /usr/src/usr.bin/f77/exec.c line 452

enregister defined in line 978; used 1 times

- in /usr/src/usr.bin/f77/exec.c line 297

errnode defined in line 136; used 12 times

- in line 127, 404, 430, 766, 887, 1203, 1531, 2132
- in /usr/src/usr.bin/f77/defs line 445
- in /usr/src/usr.bin/f77/intr.c line 514, 579
- in /usr/src/usr.bin/f77/proc.c line 603

fixargs defined in line 608; used 2 times

- in line 727
- in /usr/src/usr.bin/f77/intr.c line 465

fixexpr defined in line 384; used 10 times

- in line 366, 2135
- in /usr/src/usr.bin/f77/defs line 443
- in /usr/src/usr.bin/f77/intr.c line 475-480(2)
- in /usr/src/usr.bin/f77/io.c line 553
- in /usr/src/usr.bin/f77/put.c line 74, 94
- in /usr/src/usr.bin/f77/putdmr.c line 762, 1168

fixtype defined in line 341; used 38 times

- in line 356, 398, 409, 457, 477-479(2), 500-502(2), 510, 640-641(2), 804, 814, 833, 924-925(2), 1021
- in /usr/src/usr.bin/f77/data.c line 80, 87, 96
- in /usr/src/usr.bin/f77/defs line 443
- in /usr/src/usr.bin/f77/exec.c line 309, 494
- in /usr/src/usr.bin/f77/gram.exec line 71
- in /usr/src/usr.bin/f77/io.c line 413, 461, 469, 519, 597, 642, 782
- in /usr/src/usr.bin/f77/pdp11.c line 390-394(4)
- in /usr/src/usr.bin/f77/put.c line 62
- in /usr/src/usr.bin/f77/putdmr.c line 81, 480

fold defined in line 1653; used 2 times

- in line 1318, 1516

frexpr defined in line 279; used 85 times

- in line 130-131(2), 167, 293, 303-304(2), 314-327(6), 403, 429, 580-583(2), 664, 765, 841, 902, 918, 1110, 1199-1202(4), 1258, 1369, 1397, 1520-1530(4), 1785, 2120, 2130, 2139
- in /usr/src/usr.bin/f77/data.c line 24-27(2), 46-50(2), 91, 100, 122, 177, 313
- in /usr/src/usr.bin/f77/equiv.c line 83
- in /usr/src/usr.bin/f77/exec.c line 139-140(2), 225, 363, 373, 416, 454, 499
- in /usr/src/usr.bin/f77/init.c line 178-188(6)
- in /usr/src/usr.bin/f77/intr.c line 614, 624
- in /usr/src/usr.bin/f77/io.c line 269, 351, 485, 542, 601
- in /usr/src/usr.bin/f77/proc.c line 684, 833
- in /usr/src/usr.bin/f77/put.c line 187, 267
- in /usr/src/usr.bin/f77/putdmr.c line 85, 256, 472, 534-537(3), 575, 656, 737-738(2), 854, 933, 1027

impldcl defined in line 1270; used 5 times

- in line 726, 1231
- in /usr/src/usr.bin/f77/exec.c line 177
- in /usr/src/usr.bin/f77/proc.c line 303, 358

inregister defined in line 964; used 3 times

- in line 885, 954, 981

letter defined in line 1298; used 2 times

- in line 1240, 1280

memversion defined in line 949; used 4 times

- in line 639
- in /usr/src/usr.bin/f77/defs line 441
- in /usr/src/usr.bin/f77/exec.c line 448
- in /usr/src/usr.bin/f77/io.c line 467

mkaddcon defined in line 46; used 7 times

- in /usr/src/usr.bin/f77/exec.c line 474, 480
- in /usr/src/usr.bin/f77/gram.head line 25
- in /usr/src/usr.bin/f77/io.c line 568, 648
- in /usr/src/usr.bin/f77/pdp11.c line 310, 398

mkaddr defined in line 1118; used 7 times

- in line 616, 635, 654, 732, 900
- in /usr/src/usr.bin/f77/data.c line 134
- in /usr/src/usr.bin/f77/defs line 441

mkarg defined in line 1170; used 2 times

- in /usr/src/usr.bin/f77/proc.c line 334, 363

mkbitcon defined in line 70; used 4 times

- in /usr/src/usr.bin/f77/gram.expr line 96-100(3)
- in /usr/src/usr.bin/f77/gram.head line 24

mkconst defined in line 6; used 8 times

- in line 23, 35, 51, 64, 77, 96, 116, 165

mkconv defined in line 149; used 42 times

- in line 457, 464(2), 477-479(2), 500-502(2), 510, 561, 598, 628, 833, 1101, 2124, 2158-2170(7)
- in /usr/src/usr.bin/f77/defs line 443
- in /usr/src/usr.bin/f77/exec.c line 340, 346
- in /usr/src/usr.bin/f77/intr.c line 395, 433-437(3), 499, 609
- in /usr/src/usr.bin/f77/io.c line 519-521(2)
- in /usr/src/usr.bin/f77/putdmr.c line 176, 303, 381, 458, 480, 902, 1065, 1097, 1132, 1293

mkcxcon defined in line 105; used 4 times

- in /usr/src/usr.bin/f77/gram.expr line 92
- in /usr/src/usr.bin/f77/gram.head line 26
- in /usr/src/usr.bin/f77/intr.c line 381, 432

mkexpr defined in line 1310; used 130 times

- in line 172, 193, 203, 421, 437, 665, 734, 814, 839, 901, 915-916(2), 1038-1044(4), 1051-1056(4), 1093-1098(4), 1104-1105(2), 1370, 1377-1384(3), 1398, 1414-1417(2), 2135
- in /usr/src/usr.bin/f77/data.c line 138
- in /usr/src/usr.bin/f77/defs line 443
- in /usr/src/usr.bin/f77/exec.c line 366-367(2), 381-384(3), 393-394(2), 405-409(3), 434-444(4), 521
- in /usr/src/usr.bin/f77/gram.expr line 21-46(12), 111-124(6)
- in /usr/src/usr.bin/f77/intr.c line 409, 415, 433, 475-480(2), 491, 609-618(7), 629
- in /usr/src/usr.bin/f77/io.c line 506, 536-537(2), 553-557(2), 782
- in /usr/src/usr.bin/f77/misc.c line 513
- in /usr/src/usr.bin/f77/proc.c line 845-846(2), 858, 872(2)
- in /usr/src/usr.bin/f77/put.c line 74, 83, 94, 125
- in /usr/src/usr.bin/f77/putdmr.c line 443, 513, 530-531(2), 662-663(2), 669, 676-679(2), 689-690(2), 696-705(8), 716-717(2), 759-761(3), 805, 940-942(2), 973, 1166-1167(3)

mkfunct defined in line 676; used 3 times

- in line 373
- in /usr/src/usr.bin/f77/defs line 443
- in /usr/src/usr.bin/f77/exec.c line 203

mkintcon defined in line 30; used 5 times

- in /usr/src/usr.bin/f77/data.c line 66, 138
- in /usr/src/usr.bin/f77/defines line 238
- in /usr/src/usr.bin/f77/defs line 442
- in /usr/src/usr.bin/f77/gram.expr line 86

mklhs defined in line 853; used 11 times

- in line 374, 957
- in /usr/src/usr.bin/f77/data.c line 148
- in /usr/src/usr.bin/f77/defs line 441
- in /usr/src/usr.bin/f77/exec.c line 153, 288, 301, 434, 449, 476, 553

mklogcon defined in line 18; used 3 times

- in /usr/src/usr.bin/f77/gram.expr line 83-84(2)
- in /usr/src/usr.bin/f77/gram.head line 25

mkpower defined in line 2105; used 2 times

- in line 391, 483

mkprim defined in line 1187; used 13 times

- in line 957
- in /usr/src/usr.bin/f77/defs line 444
- in /usr/src/usr.bin/f77/exec.c line 203, 288, 301, 434, 449, 476, 553
- in /usr/src/usr.bin/f77/gram.expr line 62-68(4)

mkrealcon defined in line 58; used 6 times

- in /usr/src/usr.bin/f77/gram.expr line 87-88(2)
- in /usr/src/usr.bin/f77/gram.head line 25
- in /usr/src/usr.bin/f77/put.c line 119, 128
- in /usr/src/usr.bin/f77/putdmr.c line 728

mkscalar defined in line 647; used 5 times

- in line 637
- in /usr/src/usr.bin/f77/io.c line 442, 462, 593, 633

mkstrcon defined in line 89; used 10 times

- in line 1100-1102(2)
- in /usr/src/usr.bin/f77/defines line 239
- in /usr/src/usr.bin/f77/exec.c line 218, 226, 239, 245-248(2)
- in /usr/src/usr.bin/f77/gram.expr line 85
- in /usr/src/usr.bin/f77/gram.head line 26

opconv defined in line 187; used 4 times

- in line 155, 172-178(3)

shorten defined in line 545; used 5 times

- in line 575-578(2), 591
- in /usr/src/usr.bin/f77/putdmr.c line 1278, 1290

stfcall defined in line 771; used 2 times

- in line 684, 745

subcheck defined in line 1064; used 2 times

- in line 1010, 1047

suboffset defined in line 1003; used 4 times

- in line 857, 901
- in /usr/src/usr.bin/f77/equiv.c line 19, 46

vardcl defined in line 1220; used 10 times

- in line 653, 899, 985
- in /usr/src/usr.bin/f77/equiv.c line 32
- in /usr/src/usr.bin/f77/exec.c line 187
- in /usr/src/usr.bin/f77/gram.dcl line 197
- in /usr/src/usr.bin/f77/io.c line 459, 583, 630
- in /usr/src/usr.bin/f77/proc.c line 488

zdiv defined in line 2184; used 1 times

- in line 2002

#### Defined variables

args defined in line 1189; used 4 times

- in line 1187, 1196-1199(2), 1212

lstr defined in line 1190; used 4 times

- in line 1187, 1196-1200(2), 1213

powint defined in line 2102; used 1 times

- in line 2160

rstr defined in line 1190; used 4 times

- in line 1187, 1196-1201(2), 1214

v defined in line 1188; used 33 times

- in line 89-91(2), 100, 1187, 1194-1211(6), 1220-1221(2), 1228-1257(20), 1264

#### Defined struct's

dcomplex defined in line 2181; used 2 times

- in line 2185(2)

#### Defined macros

COMMUTE defined in line 1307; used 3 times

- in line 1339, 1391, 1457

ICONEQ defined in line 1306; used 2 times

- in line 1351, 1395

Last modified: 1987-02-17 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 4091 |