home *** CD-ROM | disk | FTP | other *** search
/ minnie.tuhs.org / unixen.tar / unixen / PDP-11 / Trees / V7 / usr / src / cmd / f77 / expr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1979-05-05  |  35.8 KB  |  2,215 lines
  1. #include "defs"
  2.  
  3. /* little routines to create constant blocks */
  4.  
  5. struct constblock *mkconst(t)
  6. register int t;
  7. {
  8. register struct constblock *p;
  9.  
  10. p = ALLOC(constblock);
  11. p->tag = TCONST;
  12. p->vtype = t;
  13. return(p);
  14. }
  15.  
  16.  
  17. struct constblock *mklogcon(l)
  18. register int l;
  19. {
  20. register struct constblock * p;
  21.  
  22. p = mkconst(TYLOGICAL);
  23. p->const.ci = l;
  24. return(p);
  25. }
  26.  
  27.  
  28.  
  29. struct constblock *mkintcon(l)
  30. ftnint l;
  31. {
  32. register struct constblock *p;
  33.  
  34. p = mkconst(TYLONG);
  35. p->const.ci = l;
  36. #ifdef MAXSHORT
  37.     if(l >= -MAXSHORT   &&   l <= MAXSHORT)
  38.         p->vtype = TYSHORT;
  39. #endif
  40. return(p);
  41. }
  42.  
  43.  
  44.  
  45. struct constblock *mkaddcon(l)
  46. register int l;
  47. {
  48. register struct constblock *p;
  49.  
  50. p = mkconst(TYADDR);
  51. p->const.ci = l;
  52. return(p);
  53. }
  54.  
  55.  
  56.  
  57. struct constblock *mkrealcon(t, d)
  58. register int t;
  59. double d;
  60. {
  61. register struct constblock *p;
  62.  
  63. p = mkconst(t);
  64. p->const.cd[0] = d;
  65. return(p);
  66. }
  67.  
  68.  
  69. struct constblock *mkbitcon(shift, leng, s)
  70. int shift;
  71. int leng;
  72. char *s;
  73. {
  74. register struct constblock *p;
  75.  
  76. p = mkconst(TYUNKNOWN);
  77. p->const.ci = 0;
  78. while(--leng >= 0)
  79.     if(*s != ' ')
  80.         p->const.ci = (p->const.ci << shift) | hextoi(*s++);
  81. return(p);
  82. }
  83.  
  84.  
  85.  
  86.  
  87.  
  88. struct constblock *mkstrcon(l,v)
  89. int l;
  90. register char *v;
  91. {
  92. register struct constblock *p;
  93. register char *s;
  94.  
  95. p = mkconst(TYCHAR);
  96. p->vleng = ICON(l);
  97. p->const.ccp = s = (char *) ckalloc(l);
  98. while(--l >= 0)
  99.     *s++ = *v++;
  100. return(p);
  101. }
  102.  
  103.  
  104. struct constblock *mkcxcon(realp,imagp)
  105. register expptr realp, imagp;
  106. {
  107. int rtype, itype;
  108. register struct constblock *p;
  109.  
  110. rtype = realp->vtype;
  111. itype = imagp->vtype;
  112.  
  113. if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
  114.     {
  115.     p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX );
  116.     if( ISINT(rtype) )
  117.         p->const.cd[0] = realp->const.ci;
  118.     else    p->const.cd[0] = realp->const.cd[0];
  119.     if( ISINT(itype) )
  120.         p->const.cd[1] = imagp->const.ci;
  121.     else    p->const.cd[1] = imagp->const.cd[0];
  122.     }
  123. else
  124.     {
  125.     err("invalid complex constant");
  126.     p = errnode();
  127.     }
  128.  
  129. frexpr(realp);
  130. frexpr(imagp);
  131. return(p);
  132. }
  133.  
  134.  
  135. struct errorblock *errnode()
  136. {
  137. struct errorblock *p;
  138. p = ALLOC(errorblock);
  139. p->tag = TERROR;
  140. p->vtype = TYERROR;
  141. return(p);
  142. }
  143.  
  144.  
  145.  
  146.  
  147.  
  148. expptr mkconv(t, p)
  149. register int t;
  150. register expptr p;
  151. {
  152. register expptr q;
  153. register int pt;
  154. expptr opconv();
  155.  
  156. if(t==TYUNKNOWN || t==TYERROR)
  157.     fatal1("mkconv of impossible type %d", t);
  158. pt = p->vtype;
  159. if(t == pt)
  160.     return(p);
  161.  
  162. else if( ISCONST(p) && pt!=TYADDR)
  163.     {
  164.     q = mkconst(t);
  165.     consconv(t, &(q->const), p->vtype, &(p->const));
  166.     frexpr(p);
  167.     }
  168. #if TARGET == PDP11
  169.     else if(ISINT(t) && pt==TYCHAR)
  170.         {
  171.         q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
  172.         if(t == TYLONG)
  173.             q = opconv(q, TYLONG);
  174.         }
  175. #endif
  176. else
  177.     q = opconv(p, t);
  178.  
  179. if(t == TYCHAR)
  180.     q->vleng = ICON(1);
  181. return(q);
  182. }
  183.  
  184.  
  185.  
  186. expptr opconv(p, t)
  187. expptr p;
  188. int t;
  189. {
  190. register expptr q;
  191.  
  192. q = mkexpr(OPCONV, p, 0);
  193. q->vtype = t;
  194. return(q);
  195. }
  196.  
  197.  
  198.  
  199. struct exprblock *addrof(p)
  200. expptr p;
  201. {
  202. return( mkexpr(OPADDR, p, NULL) );
  203. }
  204.  
  205.  
  206.  
  207. tagptr cpexpr(p)
  208. register tagptr p;
  209. {
  210. register tagptr e;
  211. int tag;
  212. register chainp ep, pp;
  213. ptr cpblock();
  214.  
  215. static int blksize[ ] =
  216.     {    0,
  217.         sizeof(struct nameblock),
  218.         sizeof(struct constblock),
  219.         sizeof(struct exprblock),
  220.         sizeof(struct addrblock),
  221.         sizeof(struct primblock),
  222.         sizeof(struct listblock),
  223.         sizeof(struct errorblock)
  224.     };
  225.  
  226. if(p == NULL)
  227.     return(NULL);
  228.  
  229. if( (tag = p->tag) == TNAME)
  230.     return(p);
  231.  
  232. e = cpblock( blksize[p->tag] , p);
  233.  
  234. switch(tag)
  235.     {
  236.     case TCONST:
  237.         if(e->vtype == TYCHAR)
  238.             {
  239.             e->const.ccp = copyn(1+strlen(e->const.ccp), e->const.ccp);
  240.             e->vleng = cpexpr(e->vleng);
  241.             }
  242.     case TERROR:
  243.         break;
  244.  
  245.     case TEXPR:
  246.         e->leftp = cpexpr(p->leftp);
  247.         e->rightp = cpexpr(p->rightp);
  248.         break;
  249.  
  250.     case TLIST:
  251.         if(pp = p->listp)
  252.             {
  253.             ep = e->listp = mkchain( cpexpr(pp->datap), NULL);
  254.             for(pp = pp->nextp ; pp ; pp = pp->nextp)
  255.                 ep = ep->nextp = mkchain( cpexpr(pp->datap), NULL);
  256.             }
  257.         break;
  258.  
  259.     case TADDR:
  260.         e->vleng = cpexpr(e->vleng);
  261.         e->memoffset = cpexpr(e->memoffset);
  262.         e->istemp = NO;
  263.         break;
  264.  
  265.     case TPRIM:
  266.         e->argsp = cpexpr(e->argsp);
  267.         e->fcharp = cpexpr(e->fcharp);
  268.         e->lcharp = cpexpr(e->lcharp);
  269.         break;
  270.  
  271.     default:
  272.         fatal1("cpexpr: impossible tag %d", tag);
  273.     }
  274.  
  275. return(e);
  276. }
  277.  
  278. frexpr(p)
  279. register tagptr p;
  280. {
  281. register chainp q;
  282.  
  283. if(p == NULL)
  284.     return;
  285.  
  286. switch(p->tag)
  287.     {
  288.     case TCONST:
  289.         if( ISCHAR(p) )
  290.             {
  291.             free(p->const.ccp);
  292.             frexpr(p->vleng);
  293.             }
  294.         break;
  295.  
  296.     case TADDR:
  297.         if(p->istemp)
  298.             {
  299.             frtemp(p);
  300.             return;
  301.             }
  302.         frexpr(p->vleng);
  303.         frexpr(p->memoffset);
  304.         break;
  305.  
  306.     case TERROR:
  307.         break;
  308.  
  309.     case TNAME:
  310.         return;
  311.  
  312.     case TPRIM:
  313.         frexpr(p->argsp);
  314.         frexpr(p->fcharp);
  315.         frexpr(p->lcharp);
  316.         break;
  317.  
  318.     case TEXPR:
  319.         frexpr(p->leftp);
  320.         if(p->rightp)
  321.             frexpr(p->rightp);
  322.         break;
  323.  
  324.     case TLIST:
  325.         for(q = p->listp ; q ; q = q->nextp)
  326.             frexpr(q->datap);
  327.         frchain( &(p->listp) );
  328.         break;
  329.  
  330.     default:
  331.         fatal1("frexpr: impossible tag %d", p->tag);
  332.     }
  333.  
  334. free(p);
  335. }
  336.  
  337. /* fix up types in expression; replace subtrees and convert
  338.    names to address blocks */
  339.  
  340. expptr fixtype(p)
  341. register tagptr p;
  342. {
  343.  
  344. if(p == 0)
  345.     return(0);
  346.  
  347. switch(p->tag)
  348.     {
  349.     case TCONST:
  350.         if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) )
  351.             p = putconst(p);
  352.         return(p);
  353.  
  354.     case TADDR:
  355.         p->memoffset = fixtype(p->memoffset);
  356.         return(p);
  357.  
  358.     case TERROR:
  359.         return(p);
  360.  
  361.     default:
  362.         fatal1("fixtype: impossible tag %d", p->tag);
  363.  
  364.     case TEXPR:
  365.         return( fixexpr(p) );
  366.  
  367.     case TLIST:
  368.         return( p );
  369.  
  370.     case TPRIM:
  371.         if(p->argsp && p->namep->vclass!=CLVAR)
  372.             return( mkfunct(p) );
  373.         else    return( mklhs(p) );
  374.     }
  375. }
  376.  
  377.  
  378.  
  379.  
  380.  
  381. /* special case tree transformations and cleanups of expression trees */
  382.  
  383. expptr fixexpr(p)
  384. register struct exprblock *p;
  385. {
  386. expptr lp;
  387. register expptr rp;
  388. register expptr q;
  389. int opcode, ltype, rtype, ptype, mtype;
  390. expptr mkpower();
  391.  
  392. if(p->tag == TERROR)
  393.     return(p);
  394. else if(p->tag != TEXPR)
  395.     fatal1("fixexpr: invalid tag %d", p->tag);
  396. opcode = p->opcode;
  397. lp = p->leftp = fixtype(p->leftp);
  398. ltype = lp->vtype;
  399. if(opcode==OPASSIGN && lp->tag!=TADDR)
  400.     {
  401.     err("left side of assignment must be variable");
  402.     frexpr(p);
  403.     return( errnode() );
  404.     }
  405.  
  406. if(p->rightp)
  407.     {
  408.     rp = p->rightp = fixtype(p->rightp);
  409.     rtype = rp->vtype;
  410.     }
  411. else
  412.     {
  413.     rp = NULL;
  414.     rtype = 0;
  415.     }
  416.  
  417. /* force folding if possible */
  418. if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
  419.     {
  420.     q = mkexpr(opcode, lp, rp);
  421.     if( ISCONST(q) )
  422.         return(q);
  423.     free(q);    /* constants did not fold */
  424.     }
  425.  
  426. if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
  427.     {
  428.     frexpr(p);
  429.     return( errnode() );
  430.     }
  431.  
  432. switch(opcode)
  433.     {
  434.     case OPCONCAT:
  435.         if(p->vleng == NULL)
  436.             p->vleng = mkexpr(OPPLUS, cpexpr(lp->vleng),
  437.                 cpexpr(rp->vleng) );
  438.         break;
  439.  
  440.     case OPASSIGN:
  441.     case OPPLUSEQ:
  442.     case OPSTAREQ:
  443.         if(ltype == rtype)
  444.             break;
  445.         if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
  446.             break;
  447.         if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
  448.             break;
  449.         if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
  450. #if FAMILY==SCJ
  451.             && typesize[ltype]>=typesize[rtype] )
  452. #else
  453.             && typesize[ltype]==typesize[rtype] )
  454. #endif
  455.             break;
  456.         p->rightp = fixtype( mkconv(ptype, rp) );
  457.         break;
  458.  
  459.     case OPSLASH:
  460.         if( ISCOMPLEX(rtype) )
  461.             {
  462.             p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div",
  463.                 mkconv(ptype, lp), mkconv(ptype, rp) );
  464.             break;
  465.             }
  466.     case OPPLUS:
  467.     case OPMINUS:
  468.     case OPSTAR:
  469.     case OPMOD:
  470.         if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
  471.             (rtype==TYREAL && ! ISCONST(rp) ) ))
  472.             break;
  473.         if( ISCOMPLEX(ptype) )
  474.             break;
  475.         if(ltype != ptype)
  476.             p->leftp = fixtype(mkconv(ptype,lp));
  477.         if(rtype != ptype)
  478.             p->rightp = fixtype(mkconv(ptype,rp));
  479.         break;
  480.  
  481.     case OPPOWER:
  482.         return( mkpower(p) );
  483.  
  484.     case OPLT:
  485.     case OPLE:
  486.     case OPGT:
  487.     case OPGE:
  488.     case OPEQ:
  489.     case OPNE:
  490.         if(ltype == rtype)
  491.             break;
  492.         mtype = cktype(OPMINUS, ltype, rtype);
  493.         if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
  494.             (rtype==TYREAL && ! ISCONST(rp)) ))
  495.             break;
  496.         if( ISCOMPLEX(mtype) )
  497.             break;
  498.         if(ltype != mtype)
  499.             p->leftp = fixtype(mkconv(mtype,lp));
  500.         if(rtype != mtype)
  501.             p->rightp = fixtype(mkconv(mtype,rp));
  502.         break;
  503.  
  504.  
  505.     case OPCONV:
  506.         ptype = cktype(OPCONV, p->vtype, ltype);
  507.         if(lp->tag==TEXPR && lp->opcode==OPCOMMA)
  508.             {
  509.             lp->rightp = fixtype( mkconv(ptype, lp->rightp) );
  510.             free(p);
  511.             p = lp;
  512.             }
  513.         break;
  514.  
  515.     case OPADDR:
  516.         if(lp->tag==TEXPR && lp->opcode==OPADDR)
  517.             fatal("addr of addr");
  518.         break;
  519.  
  520.     case OPCOMMA:
  521.     case OPQUEST:
  522.     case OPCOLON:
  523.         break;
  524.  
  525.     case OPMIN:
  526.     case OPMAX:
  527.         ptype = p->vtype;
  528.         break;
  529.  
  530.     default:
  531.         break;
  532.     }
  533.  
  534. p->vtype = ptype;
  535. return(p);
  536. }
  537.  
  538. #if SZINT < SZLONG
  539. /*
  540.    for efficient subscripting, replace long ints by shorts
  541.    in easy places
  542. */
  543.  
  544. expptr shorten(p)
  545. register expptr p;
  546. {
  547. register expptr q;
  548.  
  549. if(p->vtype != TYLONG)
  550.     return(p);
  551.  
  552. switch(p->tag)
  553.     {
  554.     case TERROR:
  555.     case TLIST:
  556.         return(p);
  557.  
  558.     case TCONST:
  559.     case TADDR:
  560.         return( mkconv(TYINT,p) );
  561.  
  562.     case TEXPR:
  563.         break;
  564.  
  565.     default:
  566.         fatal1("shorten: invalid tag %d", p->tag);
  567.     }
  568.  
  569. switch(p->opcode)
  570.     {
  571.     case OPPLUS:
  572.     case OPMINUS:
  573.     case OPSTAR:
  574.         q = shorten( cpexpr(p->rightp) );
  575.         if(q->vtype == TYINT)
  576.             {
  577.             p->leftp = shorten(p->leftp);
  578.             if(p->leftp->vtype == TYLONG)
  579.                 frexpr(q);
  580.             else
  581.                 {
  582.                 frexpr(p->rightp);
  583.                 p->rightp = q;
  584.                 p->vtype = TYINT;
  585.                 }
  586.             }
  587.         break;
  588.  
  589.     case OPNEG:
  590.         p->leftp = shorten(p->leftp);
  591.         if(p->leftp->vtype == TYINT)
  592.             p->vtype = TYINT;
  593.         break;
  594.  
  595.     case OPCALL:
  596.     case OPCCALL:
  597.         p = mkconv(TYINT,p);
  598.         break;
  599.     default:
  600.         break;
  601.     }
  602.  
  603. return(p);
  604. }
  605. #endif
  606.  
  607. fixargs(doput, p0)
  608. int doput;
  609. struct listblock *p0;
  610. {
  611. register chainp p;
  612. register tagptr q, t;
  613. register int qtag;
  614. int nargs;
  615. struct addrblock *mkaddr();
  616.  
  617. nargs = 0;
  618. if(p0)
  619.     for(p = p0->listp ; p ; p = p->nextp)
  620.     {
  621.     ++nargs;
  622.     q = p->datap;
  623.     qtag = q->tag;
  624.     if(qtag == TCONST)
  625.         {
  626.         if(q->vtype == TYSHORT)
  627.             q = mkconv(tyint, q);
  628.         if(doput)
  629.             p->datap = putconst(q);
  630.         else
  631.             p->datap = q;
  632.         }
  633.     else if(qtag==TPRIM && q->argsp==0 && q->namep->vclass==CLPROC)
  634.         p->datap = mkaddr(q->namep);
  635.     else if(qtag==TPRIM && q->argsp==0 && q->namep->vdim!=NULL)
  636.         p->datap = mkscalar(q->namep);
  637.     else if(qtag==TPRIM && q->argsp==0 && q->namep->vdovar && 
  638.         (t = memversion(q->namep)) )
  639.             p->datap = fixtype(t);
  640.     else    p->datap = fixtype(q);
  641.     }
  642. return(nargs);
  643. }
  644.  
  645.  
  646. mkscalar(np)
  647. register struct nameblock *np;
  648. {
  649. register struct addrblock *ap;
  650. register struct dimblock *dp;
  651.  
  652. vardcl(np);
  653. ap = mkaddr(np);
  654.  
  655. #if TARGET == VAX
  656.     /* on the VAX, prolog causes array arguments
  657.        to point at the (0,...,0) element, except when
  658.        subscript checking is on
  659.     */
  660.     if( !checksubs && np->vstg==STGARG)
  661.         {
  662.         dp = np->vdim;
  663.         frexpr(ap->memoffset);
  664.         ap->memoffset = mkexpr(OPSTAR, ICON(typesize[np->vtype]),
  665.                     cpexpr(dp->baseoffset) );
  666.         }
  667. #endif
  668. return(ap);
  669. }
  670.  
  671.  
  672.  
  673.  
  674.  
  675. expptr mkfunct(p)
  676. register struct primblock * p;
  677. {
  678. struct entrypoint *ep;
  679. struct addrblock *ap;
  680. struct extsym *mkext(), *extp;
  681. register struct nameblock *np;
  682. register struct exprblock *q;
  683. struct exprblock *intrcall(), *stfcall();
  684. int k, nargs;
  685. int class;
  686.  
  687. np = p->namep;
  688. class = np->vclass;
  689.  
  690. if(class == CLUNKNOWN)
  691.     {
  692.     np->vclass = class = CLPROC;
  693.     if(np->vstg == STGUNKNOWN)
  694.         {
  695.         if(k = intrfunct(np->varname))
  696.             {
  697.             np->vstg = STGINTR;
  698.             np->vardesc.varno = k;
  699.             np->vprocclass = PINTRINSIC;
  700.             }
  701.         else
  702.             {
  703.             extp = mkext( varunder(VL,np->varname) );
  704.             extp->extstg = STGEXT;
  705.             np->vstg = STGEXT;
  706.             np->vardesc.varno = extp - extsymtab;
  707.             np->vprocclass = PEXTERNAL;
  708.             }
  709.         }
  710.     else if(np->vstg==STGARG)
  711.         {
  712.         if(np->vtype!=TYCHAR && !ftn66flag)
  713.             warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
  714.         np->vprocclass = PEXTERNAL;
  715.         }
  716.     }
  717.  
  718. if(class != CLPROC)
  719.     fatal1("invalid class code for function", class);
  720. if(p->fcharp || p->lcharp)
  721.     {
  722.     err("no substring of function call");
  723.     goto error;
  724.     }
  725. impldcl(np);
  726. nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
  727.  
  728. switch(np->vprocclass)
  729.     {
  730.     case PEXTERNAL:
  731.         ap = mkaddr(np);
  732.     call:
  733.         q = mkexpr(OPCALL, ap, p->argsp);
  734.         q->vtype = np->vtype;
  735.         if(np->vleng)
  736.             q->vleng = cpexpr(np->vleng);
  737.         break;
  738.  
  739.     case PINTRINSIC:
  740.         q = intrcall(np, p->argsp, nargs);
  741.         break;
  742.  
  743.     case PSTFUNCT:
  744.         q = stfcall(np, p->argsp);
  745.         break;
  746.  
  747.     case PTHISPROC:
  748.         warn("recursive call");
  749.         for(ep = entries ; ep ; ep = ep->nextp)
  750.             if(ep->enamep == np)
  751.                 break;
  752.         if(ep == NULL)
  753.             fatal("mkfunct: impossible recursion");
  754.         ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) );
  755.         goto call;
  756.  
  757.     default:
  758.         fatal1("mkfunct: impossible vprocclass %d", np->vprocclass);
  759.     }
  760. free(p);
  761. return(q);
  762.  
  763. error:
  764.     frexpr(p);
  765.     return( errnode() );
  766. }
  767.  
  768.  
  769.  
  770. LOCAL struct exprblock *stfcall(np, actlist)
  771. struct nameblock *np;
  772. struct listblock *actlist;
  773. {
  774. register chainp actuals;
  775. int nargs;
  776. chainp oactp, formals;
  777. int type;
  778. struct exprblock *q, *rhs;
  779. expptr ap;
  780. register struct rplblock *rp;
  781. struct rplblock *tlist;
  782.  
  783. if(actlist)
  784.     {
  785.     actuals = actlist->listp;
  786.     free(actlist);
  787.     }
  788. else
  789.     actuals = NULL;
  790. oactp = actuals;
  791.  
  792. nargs = 0;
  793. tlist = NULL;
  794. type = np->vtype;
  795. formals = np->vardesc.vstfdesc->datap;
  796. rhs = np->vardesc.vstfdesc->nextp;
  797.  
  798. /* copy actual arguments into temporaries */
  799. while(actuals!=NULL && formals!=NULL)
  800.     {
  801.     rp = ALLOC(rplblock);
  802.     rp->rplnp = q = formals->datap;
  803.     ap = fixtype(actuals->datap);
  804.     if(q->vtype==ap->vtype && q->vtype!=TYCHAR
  805.        && (ap->tag==TCONST || ap->tag==TADDR) )
  806.         {
  807.         rp->rplvp = ap;
  808.         rp->rplxp = NULL;
  809.         rp->rpltag = ap->tag;
  810.         }
  811.     else    {
  812.         rp->rplvp = mktemp(q->vtype, q->vleng);
  813.         rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) );
  814.         if( (rp->rpltag = rp->rplxp->tag) == TERROR)
  815.             err("disagreement of argument types in statement function call");
  816.         }
  817.     rp->nextp = tlist;
  818.     tlist = rp;
  819.     actuals = actuals->nextp;
  820.     formals = formals->nextp;
  821.     ++nargs;
  822.     }
  823.  
  824. if(actuals!=NULL || formals!=NULL)
  825.     err("statement function definition and argument list differ");
  826.  
  827. /*
  828.    now push down names involved in formal argument list, then
  829.    evaluate rhs of statement function definition in this environment
  830. */
  831. rpllist = hookup(tlist, rpllist);
  832. q = mkconv(type, fixtype(cpexpr(rhs)) );
  833.  
  834. /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
  835. while(--nargs >= 0)
  836.     {
  837.     if(rpllist->rplxp)
  838.         q = mkexpr(OPCOMMA, rpllist->rplxp, q);
  839.     rp = rpllist->nextp;
  840.     frexpr(rpllist->rplvp);
  841.     free(rpllist);
  842.     rpllist = rp;
  843.     }
  844.  
  845. frchain( &oactp );
  846. return(q);
  847. }
  848.  
  849.  
  850.  
  851.  
  852. struct addrblock *mklhs(p)
  853. register struct primblock * p;
  854. {
  855. register struct addrblock *s;
  856. expptr suboffset();
  857. struct nameblock *np;
  858. register struct rplblock *rp;
  859. int regn;
  860.  
  861. /* first fixup name */
  862.  
  863. if(p->tag != TPRIM)
  864.     return(p);
  865. np = p->namep;
  866.  
  867. /* is name on the replace list? */
  868.  
  869. for(rp = rpllist ; rp ; rp = rp->nextp)
  870.     {
  871.     if(np == rp->rplnp)
  872.         {
  873.         if(rp->rpltag == TNAME)
  874.             {
  875.             np = p->namep = rp->rplvp;
  876.             break;
  877.             }
  878.         else    return( cpexpr(rp->rplvp) );
  879.         }
  880.     }
  881.  
  882. /* is variable a DO index in a register ? */
  883.  
  884. if(np->vdovar && ( (regn = inregister(np)) >= 0) )
  885.     if(np->vtype == TYERROR)
  886.         return( errnode() );
  887.     else
  888.         {
  889.         s = ALLOC(addrblock);
  890.         s->tag = TADDR;
  891.         s->vstg = STGREG;
  892.         s->vtype = TYIREG;
  893.         s->memno = regn;
  894.         s->memoffset = ICON(0);
  895.         return(s);
  896.         }
  897.  
  898. vardcl(np);
  899. s = mkaddr(np);
  900. s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
  901. frexpr(p->argsp);
  902. p->argsp = NULL;
  903.  
  904. /* now do substring part */
  905.  
  906. if(p->fcharp || p->lcharp)
  907.     {
  908.     if(np->vtype != TYCHAR)
  909.         err1("substring of noncharacter %s", varstr(VL,np->varname));
  910.     else    {
  911.         if(p->lcharp == NULL)
  912.             p->lcharp = cpexpr(s->vleng);
  913.         if(p->fcharp)
  914.             s->vleng = mkexpr(OPMINUS, p->lcharp,
  915.                 mkexpr(OPMINUS, p->fcharp, ICON(1) ));
  916.         else    {
  917.             frexpr(s->vleng);
  918.             s->vleng = p->lcharp;
  919.             }
  920.         }
  921.     }
  922.  
  923. s->vleng = fixtype( s->vleng );
  924. s->memoffset = fixtype( s->memoffset );
  925. free(p);
  926. return(s);
  927. }
  928.  
  929.  
  930.  
  931.  
  932.  
  933. deregister(np)
  934. struct nameblock *np;
  935. {
  936. if(nregvar>0 && regnamep[nregvar-1]==np)
  937.     {
  938.     --nregvar;
  939. #if FAMILY == DMR
  940.     putnreg();
  941. #endif
  942.     }
  943. }
  944.  
  945.  
  946.  
  947.  
  948. struct addrblock *memversion(np)
  949. register struct nameblock *np;
  950. {
  951. register struct addrblock *s;
  952.  
  953. if(np->vdovar==NO || (inregister(np)<0) )
  954.     return(NULL);
  955. np->vdovar = NO;
  956. s = mklhs( mkprim(np, 0,0,0) );
  957. np->vdovar = YES;
  958. return(s);
  959. }
  960.  
  961.  
  962.  
  963. inregister(np)
  964. register struct nameblock *np;
  965. {
  966. register int i;
  967.  
  968. for(i = 0 ; i < nregvar ; ++i)
  969.     if(regnamep[i] == np)
  970.         return( regnum[i] );
  971. return(-1);
  972. }
  973.  
  974.  
  975.  
  976.  
  977. enregister(np)
  978. struct nameblock *np;
  979. {
  980. if( inregister(np) >= 0)
  981.     return(YES);
  982. if(nregvar >= maxregvar)
  983.     return(NO);
  984. vardcl(np);
  985. if( ONEOF(np->vtype, MSKIREG) )
  986.     {
  987.     regnamep[nregvar++] = np;
  988.     if(nregvar > highregvar)
  989.         highregvar = nregvar;
  990. #if FAMILY == DMR
  991.     putnreg();
  992. #endif
  993.     return(YES);
  994.     }
  995. else
  996.     return(NO);
  997. }
  998.  
  999.  
  1000.  
  1001.  
  1002. expptr suboffset(p)
  1003. register struct primblock *p;
  1004. {
  1005. int n;
  1006. expptr size;
  1007. chainp cp;
  1008. expptr offp, prod;
  1009. expptr subcheck();
  1010. struct dimblock *dimp;
  1011. expptr sub[8];
  1012. register struct nameblock *np;
  1013.  
  1014. np = p->namep;
  1015. offp = ICON(0);
  1016. n = 0;
  1017. if(p->argsp)
  1018.     for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
  1019.         {
  1020.         sub[n++] = fixtype(cpexpr(cp->datap));
  1021.         if(n > 7)
  1022.             {
  1023.             err("more than 7 subscripts");
  1024.             break;
  1025.             }
  1026.         }
  1027.  
  1028. dimp = np->vdim;
  1029. if(n>0 && dimp==NULL)
  1030.     err("subscripts on scalar variable");
  1031. else if(dimp && dimp->ndim!=n)
  1032.     err1("wrong number of subscripts on %s",
  1033.         varstr(VL, np->varname) );
  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.     err1("subscript on variable %s out of range", varstr(VL,np->varname));
  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. fatal1("mkaddr: impossible storage tag %d", p->vstg);
  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.         err1("no qualifiers on parameter name", varstr(VL,v->varname));
  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.     dclerr("used as variable", v);
  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.                 dclerr("adjustable automatic array", v);
  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.         dclerr("attempt to use undefined variable", p);
  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 error;
  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.             err("attempted division by zero");
  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.         fatal1("mkexpr: impossible opcode %d", opcode);
  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. error:
  1528.     frexpr(lp);
  1529.     if(rp && opcode!=OPCALL && opcode!=OPCCALL)
  1530.         frexpr(rp);
  1531.     return( errnode() );
  1532. }
  1533.  
  1534. #define ERR(s)   { errs = s; goto error; }
  1535.  
  1536. cktype(op, lt, rt)
  1537. register int op, lt, rt;
  1538. {
  1539. char *errs;
  1540.  
  1541. if(lt==TYERROR || rt==TYERROR)
  1542.     goto error1;
  1543.  
  1544. if(lt==TYUNKNOWN)
  1545.     return(TYUNKNOWN);
  1546. if(rt==TYUNKNOWN)
  1547.     if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
  1548.         return(TYUNKNOWN);
  1549.  
  1550. switch(op)
  1551.     {
  1552.     case OPPLUS:
  1553.     case OPMINUS:
  1554.     case OPSTAR:
  1555.     case OPSLASH:
  1556.     case OPPOWER:
  1557.     case OPMOD:
  1558.         if( ISNUMERIC(lt) && ISNUMERIC(rt) )
  1559.             return( maxtype(lt, rt) );
  1560.         ERR("nonarithmetic operand of arithmetic operator")
  1561.  
  1562.     case OPNEG:
  1563.         if( ISNUMERIC(lt) )
  1564.             return(lt);
  1565.         ERR("nonarithmetic operand of negation")
  1566.  
  1567.     case OPNOT:
  1568.         if(lt == TYLOGICAL)
  1569.             return(TYLOGICAL);
  1570.         ERR("NOT of nonlogical")
  1571.  
  1572.     case OPAND:
  1573.     case OPOR:
  1574.     case OPEQV:
  1575.     case OPNEQV:
  1576.         if(lt==TYLOGICAL && rt==TYLOGICAL)
  1577.             return(TYLOGICAL);
  1578.         ERR("nonlogical operand of logical operator")
  1579.  
  1580.     case OPLT:
  1581.     case OPGT:
  1582.     case OPLE:
  1583.     case OPGE:
  1584.     case OPEQ:
  1585.     case OPNE:
  1586.         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
  1587.             {
  1588.             if(lt != rt)
  1589.                 ERR("illegal comparison")
  1590.             }
  1591.  
  1592.         else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
  1593.             {
  1594.             if(op!=OPEQ && op!=OPNE)
  1595.                 ERR("order comparison of complex data")
  1596.             }
  1597.  
  1598.         else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
  1599.             ERR("comparison of nonarithmetic data")
  1600.         return(TYLOGICAL);
  1601.  
  1602.     case OPCONCAT:
  1603.         if(lt==TYCHAR && rt==TYCHAR)
  1604.             return(TYCHAR);
  1605.         ERR("concatenation of nonchar data")
  1606.  
  1607.     case OPCALL:
  1608.     case OPCCALL:
  1609.         return(lt);
  1610.  
  1611.     case OPADDR:
  1612.         return(TYADDR);
  1613.  
  1614.     case OPCONV:
  1615.         if(rt == 0)
  1616.             return(0);
  1617.         if(lt==TYCHAR && ISINT(rt) )
  1618.             return(TYCHAR);
  1619.     case OPASSIGN:
  1620.     case OPPLUSEQ:
  1621.     case OPSTAREQ:
  1622.         if( ISINT(lt) && rt==TYCHAR)
  1623.             return(lt);
  1624.         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
  1625.             if(op!=OPASSIGN || lt!=rt)
  1626.                 {
  1627. /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
  1628. /* debug fatal("impossible conversion.  possible compiler bug"); */
  1629.                 ERR("impossible conversion")
  1630.                 }
  1631.         return(lt);
  1632.  
  1633.     case OPMIN:
  1634.     case OPMAX:
  1635.     case OPBITOR:
  1636.     case OPBITAND:
  1637.     case OPBITXOR:
  1638.     case OPBITNOT:
  1639.     case OPLSHIFT:
  1640.     case OPRSHIFT:
  1641.         return(lt);
  1642.  
  1643.     case OPCOMMA:
  1644.     case OPQUEST:
  1645.     case OPCOLON:
  1646.         return(rt);
  1647.  
  1648.     default:
  1649.         fatal1("cktype: impossible opcode %d", op);
  1650.     }
  1651. error:    err(errs);
  1652. error1:    return(TYERROR);
  1653. }
  1654.  
  1655. LOCAL expptr fold(e)
  1656. register struct exprblock *e;
  1657. {
  1658. struct constblock *p;
  1659. #ifdef VERSION6
  1660.     expptr lp, rp;
  1661. #else
  1662.     register expptr lp, rp;
  1663. #endif
  1664. int etype, mtype, ltype, rtype, opcode;
  1665. int i, ll, lr;
  1666. char *q, *s;
  1667. union constant lcon, rcon;
  1668.  
  1669. opcode = e->opcode;
  1670. etype = e->vtype;
  1671.  
  1672. lp = e->leftp;
  1673. ltype = lp->vtype;
  1674. rp = e->rightp;
  1675.  
  1676. if(rp == 0)
  1677.     switch(opcode)
  1678.         {
  1679.         case OPNOT:
  1680.             lp->const.ci = ! lp->const.ci;
  1681.             return(lp);
  1682.  
  1683.         case OPBITNOT:
  1684.             lp->const.ci = ~ lp->const.ci;
  1685.             return(lp);
  1686.  
  1687.         case OPNEG:
  1688.             consnegop(lp);
  1689.             return(lp);
  1690.  
  1691.         case OPCONV:
  1692.         case OPADDR:
  1693.             return(e);
  1694.  
  1695.         default:
  1696.             fatal1("fold: invalid unary operator %d", opcode);
  1697.         }
  1698.  
  1699. rtype = rp->vtype;
  1700.  
  1701. p = ALLOC(constblock);
  1702. p->tag = TCONST;
  1703. p->vtype = etype;
  1704. p->vleng = e->vleng;
  1705.  
  1706. switch(opcode)
  1707.     {
  1708.     case OPCOMMA:
  1709.     case OPQUEST:
  1710.     case OPCOLON:
  1711.         return(e);
  1712.  
  1713.     case OPAND:
  1714.         p->const.ci = lp->const.ci && rp->const.ci;
  1715.         break;
  1716.  
  1717.     case OPOR:
  1718.         p->const.ci = lp->const.ci || rp->const.ci;
  1719.         break;
  1720.  
  1721.     case OPEQV:
  1722.         p->const.ci = lp->const.ci == rp->const.ci;
  1723.         break;
  1724.  
  1725.     case OPNEQV:
  1726.         p->const.ci = lp->const.ci != rp->const.ci;
  1727.         break;
  1728.  
  1729.     case OPBITAND:
  1730.         p->const.ci = lp->const.ci & rp->const.ci;
  1731.         break;
  1732.  
  1733.     case OPBITOR:
  1734.         p->const.ci = lp->const.ci | rp->const.ci;
  1735.         break;
  1736.  
  1737.     case OPBITXOR:
  1738.         p->const.ci = lp->const.ci ^ rp->const.ci;
  1739.         break;
  1740.  
  1741.     case OPLSHIFT:
  1742.         p->const.ci = lp->const.ci << rp->const.ci;
  1743.         break;
  1744.  
  1745.     case OPRSHIFT:
  1746.         p->const.ci = lp->const.ci >> rp->const.ci;
  1747.         break;
  1748.  
  1749.     case OPCONCAT:
  1750.         ll = lp->vleng->const.ci;
  1751.         lr = rp->vleng->const.ci;
  1752.         p->const.ccp = q = (char *) ckalloc(ll+lr);
  1753.         p->vleng = ICON(ll+lr);
  1754.         s = lp->const.ccp;
  1755.         for(i = 0 ; i < ll ; ++i)
  1756.             *q++ = *s++;
  1757.         s = rp->const.ccp;
  1758.         for(i = 0; i < lr; ++i)
  1759.             *q++ = *s++;
  1760.         break;
  1761.  
  1762.  
  1763.     case OPPOWER:
  1764.         if( ! ISINT(rtype) )
  1765.             return(e);
  1766.         conspower(&(p->const), lp, rp->const.ci);
  1767.         break;
  1768.  
  1769.  
  1770.     default:
  1771.         if(ltype == TYCHAR)
  1772.             {
  1773.             lcon.ci = cmpstr(lp->const.ccp, rp->const.ccp,
  1774.                     lp->vleng->const.ci, rp->vleng->const.ci);
  1775.             rcon.ci = 0;
  1776.             mtype = tyint;
  1777.             }
  1778.         else    {
  1779.             mtype = maxtype(ltype, rtype);
  1780.             consconv(mtype, &lcon, ltype, &(lp->const) );
  1781.             consconv(mtype, &rcon, rtype, &(rp->const) );
  1782.             }
  1783.         consbinop(opcode, mtype, &(p->const), &lcon, &rcon);
  1784.         break;
  1785.     }
  1786.  
  1787. frexpr(e);
  1788. return(p);
  1789. }
  1790.  
  1791.  
  1792.  
  1793. /* assign constant l = r , doing coercion */
  1794.  
  1795. consconv(lt, lv, rt, rv)
  1796. int lt, rt;
  1797. register union constant *lv, *rv;
  1798. {
  1799. switch(lt)
  1800.     {
  1801.     case TYCHAR:
  1802.         *(lv->ccp = ckalloc(1)) = rv->ci;
  1803.         break;
  1804.  
  1805.     case TYSHORT:
  1806.     case TYLONG:
  1807.         if(rt == TYCHAR)
  1808.             lv->ci = rv->ccp[0];
  1809.         else if( ISINT(rt) )
  1810.             lv->ci = rv->ci;
  1811.         else    lv->ci = rv->cd[0];
  1812.         break;
  1813.  
  1814.     case TYCOMPLEX:
  1815.     case TYDCOMPLEX:
  1816.         switch(rt)
  1817.             {
  1818.             case TYSHORT:
  1819.             case TYLONG:
  1820.                 /* fall through and do real assignment of
  1821.                    first element
  1822.                 */
  1823.             case TYREAL:
  1824.             case TYDREAL:
  1825.                 lv->cd[1] = 0; break;
  1826.             case TYCOMPLEX:
  1827.             case TYDCOMPLEX:
  1828.                 lv->cd[1] = rv->cd[1]; break;
  1829.             }
  1830.  
  1831.     case TYREAL:
  1832.     case TYDREAL:
  1833.         if( ISINT(rt) )
  1834.             lv->cd[0] = rv->ci;
  1835.         else    lv->cd[0] = rv->cd[0];
  1836.         break;
  1837.  
  1838.     case TYLOGICAL:
  1839.         lv->ci = rv->ci;
  1840.         break;
  1841.     }
  1842. }
  1843.  
  1844.  
  1845.  
  1846. consnegop(p)
  1847. register struct constblock *p;
  1848. {
  1849. switch(p->vtype)
  1850.     {
  1851.     case TYSHORT:
  1852.     case TYLONG:
  1853.         p->const.ci = - p->const.ci;
  1854.         break;
  1855.  
  1856.     case TYCOMPLEX:
  1857.     case TYDCOMPLEX:
  1858.         p->const.cd[1] = - p->const.cd[1];
  1859.         /* fall through and do the real parts */
  1860.     case TYREAL:
  1861.     case TYDREAL:
  1862.         p->const.cd[0] = - p->const.cd[0];
  1863.         break;
  1864.     default:
  1865.         fatal1("consnegop: impossible type %d", p->vtype);
  1866.     }
  1867. }
  1868.  
  1869.  
  1870.  
  1871. LOCAL conspower(powp, ap, n)
  1872. register union constant *powp;
  1873. struct constblock *ap;
  1874. ftnint n;
  1875. {
  1876. register int type;
  1877. union constant x;
  1878.  
  1879. switch(type = ap->vtype)    /* pow = 1 */ 
  1880.     {
  1881.     case TYSHORT:
  1882.     case TYLONG:
  1883.         powp->ci = 1;
  1884.         break;
  1885.     case TYCOMPLEX:
  1886.     case TYDCOMPLEX:
  1887.         powp->cd[1] = 0;
  1888.     case TYREAL:
  1889.     case TYDREAL:
  1890.         powp->cd[0] = 1;
  1891.         break;
  1892.     default:
  1893.         fatal1("conspower: invalid type %d", type);
  1894.     }
  1895.  
  1896. if(n == 0)
  1897.     return;
  1898. if(n < 0)
  1899.     {
  1900.     if( ISINT(type) )
  1901.         {
  1902.         err("integer ** negative power ");
  1903.         return;
  1904.         }
  1905.     n = - n;
  1906.     consbinop(OPSLASH, type, &x, powp, &(ap->const));
  1907.     }
  1908. else
  1909.     consbinop(OPSTAR, type, &x, powp, &(ap->const));
  1910.  
  1911. for( ; ; )
  1912.     {
  1913.     if(n & 01)
  1914.         consbinop(OPSTAR, type, powp, powp, &x);
  1915.     if(n >>= 1)
  1916.         consbinop(OPSTAR, type, &x, &x, &x);
  1917.     else
  1918.         break;
  1919.     }
  1920. }
  1921.  
  1922.  
  1923.  
  1924. /* do constant operation cp = a op b */
  1925.  
  1926.  
  1927. LOCAL consbinop(opcode, type, cp, ap, bp)
  1928. int opcode, type;
  1929. register union constant *ap, *bp, *cp;
  1930. {
  1931. int k;
  1932. double temp;
  1933.  
  1934. switch(opcode)
  1935.     {
  1936.     case OPPLUS:
  1937.         switch(type)
  1938.             {
  1939.             case TYSHORT:
  1940.             case TYLONG:
  1941.                 cp->ci = ap->ci + bp->ci;
  1942.                 break;
  1943.             case TYCOMPLEX:
  1944.             case TYDCOMPLEX:
  1945.                 cp->cd[1] = ap->cd[1] + bp->cd[1];
  1946.             case TYREAL:
  1947.             case TYDREAL:
  1948.                 cp->cd[0] = ap->cd[0] + bp->cd[0];
  1949.                 break;
  1950.             }
  1951.         break;
  1952.  
  1953.     case OPMINUS:
  1954.         switch(type)
  1955.             {
  1956.             case TYSHORT:
  1957.             case TYLONG:
  1958.                 cp->ci = ap->ci - bp->ci;
  1959.                 break;
  1960.             case TYCOMPLEX:
  1961.             case TYDCOMPLEX:
  1962.                 cp->cd[1] = ap->cd[1] - bp->cd[1];
  1963.             case TYREAL:
  1964.             case TYDREAL:
  1965.                 cp->cd[0] = ap->cd[0] - bp->cd[0];
  1966.                 break;
  1967.             }
  1968.         break;
  1969.  
  1970.     case OPSTAR:
  1971.         switch(type)
  1972.             {
  1973.             case TYSHORT:
  1974.             case TYLONG:
  1975.                 cp->ci = ap->ci * bp->ci;
  1976.                 break;
  1977.             case TYREAL:
  1978.             case TYDREAL:
  1979.                 cp->cd[0] = ap->cd[0] * bp->cd[0];
  1980.                 break;
  1981.             case TYCOMPLEX:
  1982.             case TYDCOMPLEX:
  1983.                 temp = ap->cd[0] * bp->cd[0] -
  1984.                         ap->cd[1] * bp->cd[1] ;
  1985.                 cp->cd[1] = ap->cd[0] * bp->cd[1] +
  1986.                         ap->cd[1] * bp->cd[0] ;
  1987.                 cp->cd[0] = temp;
  1988.                 break;
  1989.             }
  1990.         break;
  1991.     case OPSLASH:
  1992.         switch(type)
  1993.             {
  1994.             case TYSHORT:
  1995.             case TYLONG:
  1996.                 cp->ci = ap->ci / bp->ci;
  1997.                 break;
  1998.             case TYREAL:
  1999.             case TYDREAL:
  2000.                 cp->cd[0] = ap->cd[0] / bp->cd[0];
  2001.                 break;
  2002.             case TYCOMPLEX:
  2003.             case TYDCOMPLEX:
  2004.                 zdiv(cp,ap,bp);
  2005.                 break;
  2006.             }
  2007.         break;
  2008.  
  2009.     case OPMOD:
  2010.         if( ISINT(type) )
  2011.             {
  2012.             cp->ci = ap->ci % bp->ci;
  2013.             break;
  2014.             }
  2015.         else
  2016.             fatal("inline mod of noninteger");
  2017.  
  2018.     default:      /* relational ops */
  2019.         switch(type)
  2020.             {
  2021.             case TYSHORT:
  2022.             case TYLONG:
  2023.                 if(ap->ci < bp->ci)
  2024.                     k = -1;
  2025.                 else if(ap->ci == bp->ci)
  2026.                     k = 0;
  2027.                 else    k = 1;
  2028.                 break;
  2029.             case TYREAL:
  2030.             case TYDREAL:
  2031.                 if(ap->cd[0] < bp->cd[0])
  2032.                     k = -1;
  2033.                 else if(ap->cd[0] == bp->cd[0])
  2034.                     k = 0;
  2035.                 else    k = 1;
  2036.                 break;
  2037.             case TYCOMPLEX:
  2038.             case TYDCOMPLEX:
  2039.                 if(ap->cd[0] == bp->cd[0] &&
  2040.                    ap->cd[1] == bp->cd[1] )
  2041.                     k = 0;
  2042.                 else    k = 1;
  2043.                 break;
  2044.             }
  2045.  
  2046.         switch(opcode)
  2047.             {
  2048.             case OPEQ:
  2049.                 cp->ci = (k == 0);
  2050.                 break;
  2051.             case OPNE:
  2052.                 cp->ci = (k != 0);
  2053.                 break;
  2054.             case OPGT:
  2055.                 cp->ci = (k == 1);
  2056.                 break;
  2057.             case OPLT:
  2058.                 cp->ci = (k == -1);
  2059.                 break;
  2060.             case OPGE:
  2061.                 cp->ci = (k >= 0);
  2062.                 break;
  2063.             case OPLE:
  2064.                 cp->ci = (k <= 0);
  2065.                 break;
  2066.             }
  2067.         break;
  2068.     }
  2069. }
  2070.  
  2071.  
  2072.  
  2073.  
  2074. conssgn(p)
  2075. register expptr p;
  2076. {
  2077. if( ! ISCONST(p) )
  2078.     fatal( "sgn(nonconstant)" );
  2079.  
  2080. switch(p->vtype)
  2081.     {
  2082.     case TYSHORT:
  2083.     case TYLONG:
  2084.         if(p->const.ci > 0) return(1);
  2085.         if(p->const.ci < 0) return(-1);
  2086.         return(0);
  2087.  
  2088.     case TYREAL:
  2089.     case TYDREAL:
  2090.         if(p->const.cd[0] > 0) return(1);
  2091.         if(p->const.cd[0] < 0) return(-1);
  2092.         return(0);
  2093.  
  2094.     case TYCOMPLEX:
  2095.     case TYDCOMPLEX:
  2096.         return(p->const.cd[0]!=0 || p->const.cd[1]!=0);
  2097.  
  2098.     default:
  2099.         fatal1( "conssgn(type %d)", p->vtype);
  2100.     }
  2101. /* NOTREACHED */
  2102. }
  2103.  
  2104. char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
  2105.  
  2106.  
  2107. LOCAL expptr mkpower(p)
  2108. register struct exprblock *p;
  2109. {
  2110. register expptr q, lp, rp;
  2111. int ltype, rtype, mtype;
  2112.  
  2113. lp = p->leftp;
  2114. rp = p->rightp;
  2115. ltype = lp->vtype;
  2116. rtype = rp->vtype;
  2117.  
  2118. if(ISICON(rp))
  2119.     {
  2120.     if(rp->const.ci == 0)
  2121.         {
  2122.         frexpr(p);
  2123.         if( ISINT(ltype) )
  2124.             return( ICON(1) );
  2125.         else
  2126.             return( putconst( mkconv(ltype, ICON(1))) );
  2127.         }
  2128.     if(rp->const.ci < 0)
  2129.         {
  2130.         if( ISINT(ltype) )
  2131.             {
  2132.             frexpr(p);
  2133.             err("integer**negative");
  2134.             return( errnode() );
  2135.             }
  2136.         rp->const.ci = - rp->const.ci;
  2137.         p->leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp));
  2138.         }
  2139.     if(rp->const.ci == 1)
  2140.         {
  2141.         frexpr(rp);
  2142.         free(p);
  2143.         return(lp);
  2144.         }
  2145.  
  2146.     if( ONEOF(ltype, MSKINT|MSKREAL) )
  2147.         {
  2148.         p->vtype = ltype;
  2149.         return(p);
  2150.         }
  2151.     }
  2152. if( ISINT(rtype) )
  2153.     {
  2154.     if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
  2155.         q = call2(TYSHORT, "pow_hh", lp, rp);
  2156.     else    {
  2157.         if(ltype == TYSHORT)
  2158.             {
  2159.             ltype = TYLONG;
  2160.             lp = mkconv(TYLONG,lp);
  2161.             }
  2162.         q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
  2163.         }
  2164.     }
  2165. else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
  2166.     q = call2(mtype, "pow_dd",
  2167.         mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
  2168. else    {
  2169.     q = call2(TYDCOMPLEX, "pow_zz",
  2170.         mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
  2171.     if(mtype == TYCOMPLEX)
  2172.         q = mkconv(TYCOMPLEX, q);
  2173.     }
  2174. free(p);
  2175. return(q);
  2176. }
  2177.  
  2178.  
  2179.  
  2180. /* Complex Division.  Same code as in Runtime Library
  2181. */
  2182.  
  2183. struct dcomplex { double dreal, dimag; };
  2184.  
  2185.  
  2186. LOCAL zdiv(c, a, b)
  2187. register struct dcomplex *a, *b, *c;
  2188. {
  2189. double ratio, den;
  2190. double abr, abi;
  2191.  
  2192. if( (abr = b->dreal) < 0.)
  2193.     abr = - abr;
  2194. if( (abi = b->dimag) < 0.)
  2195.     abi = - abi;
  2196. if( abr <= abi )
  2197.     {
  2198.     if(abi == 0)
  2199.         fatal("complex division by zero");
  2200.     ratio = b->dreal / b->dimag ;
  2201.     den = b->dimag * (1 + ratio*ratio);
  2202.     c->dreal = (a->dreal*ratio + a->dimag) / den;
  2203.     c->dimag = (a->dimag*ratio - a->dreal) / den;
  2204.     }
  2205.  
  2206. else
  2207.     {
  2208.     ratio = b->dimag / b->dreal ;
  2209.     den = b->dreal * (1 + ratio*ratio);
  2210.     c->dreal = (a->dreal + a->dimag*ratio) / den;
  2211.     c->dimag = (a->dimag - a->dreal*ratio) / den;
  2212.     }
  2213.  
  2214. }
  2215.