home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / f2c / src / expr.c < prev    next >
C/C++ Source or Header  |  1999-12-13  |  58KB  |  2,918 lines
  1. /****************************************************************
  2. Copyright 1990, 1991, 1992 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "output.h"
  26. #include "names.h"
  27.  
  28. LOCAL void conspower(), consbinop(), zdiv();
  29. LOCAL expptr fold(), mkpower(), stfcall();
  30. #ifndef stfcall_MAX
  31. #define stfcall_MAX 144
  32. #endif
  33.  
  34. typedef struct { double dreal, dimag; } dcomplex;
  35.  
  36. extern char dflttype[26];
  37.  
  38. /* little routines to create constant blocks */
  39.  
  40. Constp mkconst(t)
  41. register int t;
  42. {
  43.     register Constp p;
  44.  
  45.     p = ALLOC(Constblock);
  46.     p->tag = TCONST;
  47.     p->vtype = t;
  48.     return(p);
  49. }
  50.  
  51.  
  52. /* mklogcon -- Make Logical Constant */
  53.  
  54. expptr mklogcon(l)
  55. register int l;
  56. {
  57.     register Constp  p;
  58.  
  59.     p = mkconst(TYLOGICAL);
  60.     p->Const.ci = l;
  61.     return( (expptr) p );
  62. }
  63.  
  64.  
  65.  
  66. /* mkintcon -- Make Integer Constant */
  67.  
  68. expptr mkintcon(l)
  69. ftnint l;
  70. {
  71.     register Constp p;
  72.  
  73.     p = mkconst(tyint);
  74.     p->Const.ci = l;
  75.     return( (expptr) p );
  76. }
  77.  
  78.  
  79.  
  80.  
  81. /* mkaddcon -- Make Address Constant, given integer value */
  82.  
  83. expptr mkaddcon(l)
  84. register long l;
  85. {
  86.     register Constp p;
  87.  
  88.     p = mkconst(TYADDR);
  89.     p->Const.ci = l;
  90.     return( (expptr) p );
  91. }
  92.  
  93.  
  94.  
  95. /* mkrealcon -- Make Real Constant.  The type t is assumed
  96.    to be TYREAL or TYDREAL */
  97.  
  98. expptr mkrealcon(t, d)
  99.  register int t;
  100.  char *d;
  101. {
  102.     register Constp p;
  103.  
  104.     p = mkconst(t);
  105.     p->Const.cds[0] = cds(d,CNULL);
  106.     p->vstg = 1;
  107.     return( (expptr) p );
  108. }
  109.  
  110.  
  111. /* mkbitcon -- Make bit constant.  Reads the input string, which is
  112.    assumed to correctly specify a number in base 2^shift (where   shift
  113.    is the input parameter).   shift   may not exceed 4, i.e. only binary,
  114.    quad, octal and hex bases may be input.  Constants may not exceed 32
  115.    bits, or whatever the size of (struct Constblock).ci may be. */
  116.  
  117. expptr mkbitcon(shift, leng, s)
  118. int shift;
  119. int leng;
  120. char *s;
  121. {
  122.     register Constp p;
  123.     register long x;
  124.  
  125.     p = mkconst(TYLONG);
  126.     x = 0;
  127.     while(--leng >= 0)
  128.         if(*s != ' ')
  129.             x = (x << shift) | hextoi(*s++);
  130.     /* mwm wanted to change the type to short for short constants,
  131.      * but this is dangerous -- there is no syntax for long constants
  132.      * with small values.
  133.      */
  134.     p->Const.ci = x;
  135.     return( (expptr) p );
  136. }
  137.  
  138.  
  139.  
  140.  
  141.  
  142. /* mkstrcon -- Make string constant.  Allocates storage and initializes
  143.    the memory for a copy of the input Fortran-string. */
  144.  
  145. expptr mkstrcon(l,v)
  146. int l;
  147. register char *v;
  148. {
  149.     register Constp p;
  150.     register char *s;
  151.  
  152.     p = mkconst(TYCHAR);
  153.     p->vleng = ICON(l);
  154.     p->Const.ccp = s = (char *) ckalloc(l+1);
  155.     p->Const.ccp1.blanks = 0;
  156.     while(--l >= 0)
  157.         *s++ = *v++;
  158.     *s = '\0';
  159.     return( (expptr) p );
  160. }
  161.  
  162.  
  163.  
  164. /* mkcxcon -- Make complex contsant.  A complex number is a pair of
  165.    values, each of which may be integer, real or double. */
  166.  
  167. expptr mkcxcon(realp,imagp)
  168. register expptr realp, imagp;
  169. {
  170.     int rtype, itype;
  171.     register Constp p;
  172.     expptr errnode();
  173.  
  174.     rtype = realp->headblock.vtype;
  175.     itype = imagp->headblock.vtype;
  176.  
  177.     if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
  178.     {
  179.         p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
  180.                 ? TYDCOMPLEX : tycomplex);
  181.         if (realp->constblock.vstg || imagp->constblock.vstg) {
  182.             p->vstg = 1;
  183.             p->Const.cds[0] = ISINT(rtype)
  184.                 ? string_num("", realp->constblock.Const.ci)
  185.                 : realp->constblock.vstg
  186.                     ? realp->constblock.Const.cds[0]
  187.                     : dtos(realp->constblock.Const.cd[0]);
  188.             p->Const.cds[1] = ISINT(itype)
  189.                 ? string_num("", imagp->constblock.Const.ci)
  190.                 : imagp->constblock.vstg
  191.                     ? imagp->constblock.Const.cds[0]
  192.                     : dtos(imagp->constblock.Const.cd[0]);
  193.             }
  194.         else {
  195.             p->Const.cd[0] = ISINT(rtype)
  196.                 ? realp->constblock.Const.ci
  197.                 : realp->constblock.Const.cd[0];
  198.             p->Const.cd[1] = ISINT(itype)
  199.                 ? imagp->constblock.Const.ci
  200.                 : imagp->constblock.Const.cd[0];
  201.             }
  202.     }
  203.     else
  204.     {
  205.         err("invalid complex constant");
  206.         p = (Constp)errnode();
  207.     }
  208.  
  209.     frexpr(realp);
  210.     frexpr(imagp);
  211.     return( (expptr) p );
  212. }
  213.  
  214.  
  215. /* errnode -- Allocate a new error block */
  216.  
  217. expptr errnode()
  218. {
  219.     struct Errorblock *p;
  220.     p = ALLOC(Errorblock);
  221.     p->tag = TERROR;
  222.     p->vtype = TYERROR;
  223.     return( (expptr) p );
  224. }
  225.  
  226.  
  227.  
  228.  
  229.  
  230. /* mkconv -- Make type conversion.  Cast expression   p   into type   t.
  231.    Note that casting to a character copies only the first sizeof(char)
  232.    bytes. */
  233.  
  234. expptr mkconv(t, p)
  235. register int t;
  236. register expptr p;
  237. {
  238.     register expptr q;
  239.     register int pt, charwarn = 1;
  240.     expptr opconv();
  241.  
  242.     if (t >= 100) {
  243.         t -= 100;
  244.         charwarn = 0;
  245.         }
  246.     if(t==TYUNKNOWN || t==TYERROR)
  247.         badtype("mkconv", t);
  248.     pt = p->headblock.vtype;
  249.  
  250. /* Casting to the same type is a no-op */
  251.  
  252.     if(t == pt)
  253.         return(p);
  254.  
  255. /* If we're casting a constant which is not in the literal table ... */
  256.  
  257.     else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR)
  258.     {
  259.         if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
  260.             /* avoid trouble with -i2 */
  261.             p->headblock.vtype = t;
  262.             return p;
  263.             }
  264.         q = (expptr) mkconst(t);
  265.         consconv(t, &q->constblock, &p->constblock );
  266.         frexpr(p);
  267.     }
  268.     else {
  269.         if (pt == TYCHAR && t != TYADDR && charwarn)
  270.             warn(
  271.          "ichar([first char. of] char. string) assumed for conversion to numeric");
  272.         q = opconv(p, t);
  273.         }
  274.  
  275.     if(t == TYCHAR)
  276.         q->constblock.vleng = ICON(1);
  277.     return(q);
  278. }
  279.  
  280.  
  281.  
  282. /* opconv -- Convert expression   p   to type   t   using the main
  283.    expression evaluator; returns an OPCONV expression, I think  14-jun-88 mwm */
  284.  
  285. expptr opconv(p, t)
  286. expptr p;
  287. int t;
  288. {
  289.     register expptr q;
  290.  
  291.     if (t == TYSUBR)
  292.         err("illegal use of subroutine name");
  293.     q = mkexpr(OPCONV, p, ENULL);
  294.     q->headblock.vtype = t;
  295.     return(q);
  296. }
  297.  
  298.  
  299.  
  300. /* addrof -- Create an ADDR expression operation */
  301.  
  302. expptr addrof(p)
  303. expptr p;
  304. {
  305.     return( mkexpr(OPADDR, p, ENULL) );
  306. }
  307.  
  308.  
  309.  
  310. /* cpexpr - Returns a new copy of input expression   p   */
  311.  
  312. tagptr cpexpr(p)
  313. register tagptr p;
  314. {
  315.     register tagptr e;
  316.     int tag;
  317.     register chainp ep, pp;
  318.     tagptr cpblock();
  319.  
  320. /* This table depends on the ordering of the T macros, e.g. TNAME */
  321.  
  322.     static int blksize[ ] =
  323.     {
  324.         0,
  325.         sizeof(struct Nameblock),
  326.         sizeof(struct Constblock),
  327.         sizeof(struct Exprblock),
  328.         sizeof(struct Addrblock),
  329.         sizeof(struct Primblock),
  330.         sizeof(struct Listblock),
  331.         sizeof(struct Impldoblock),
  332.         sizeof(struct Errorblock)
  333.     };
  334.  
  335.     if(p == NULL)
  336.         return(NULL);
  337.  
  338. /* TNAMEs are special, and don't get copied.  Each name in the current
  339.    symbol table has a unique TNAME structure. */
  340.  
  341.     if( (tag = p->tag) == TNAME)
  342.         return(p);
  343.  
  344.     e = cpblock(blksize[p->tag], (char *)p);
  345.  
  346.     switch(tag)
  347.     {
  348.     case TCONST:
  349.         if(e->constblock.vtype == TYCHAR)
  350.         {
  351.             e->constblock.Const.ccp =
  352.                 copyn((int)e->constblock.vleng->constblock.Const.ci+1,
  353.                 e->constblock.Const.ccp);
  354.             e->constblock.vleng =
  355.                 (expptr) cpexpr(e->constblock.vleng);
  356.         }
  357.     case TERROR:
  358.         break;
  359.  
  360.     case TEXPR:
  361.         e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
  362.         e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
  363.         break;
  364.  
  365.     case TLIST:
  366.         if(pp = p->listblock.listp)
  367.         {
  368.             ep = e->listblock.listp =
  369.                 mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
  370.             for(pp = pp->nextp ; pp ; pp = pp->nextp)
  371.                 ep = ep->nextp =
  372.                     mkchain((char *)cpexpr((tagptr)pp->datap),
  373.                         CHNULL);
  374.         }
  375.         break;
  376.  
  377.     case TADDR:
  378.         e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
  379.         e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
  380.         e->addrblock.istemp = NO;
  381.         break;
  382.  
  383.     case TPRIM:
  384.         e->primblock.argsp = (struct Listblock *)
  385.             cpexpr((expptr)e->primblock.argsp);
  386.         e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
  387.         e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
  388.         break;
  389.  
  390.     default:
  391.         badtag("cpexpr", tag);
  392.     }
  393.  
  394.     return(e);
  395. }
  396.  
  397. /* frexpr -- Free expression -- frees up memory used by expression   p   */
  398.  
  399. frexpr(p)
  400. register tagptr p;
  401. {
  402.     register chainp q;
  403.  
  404.     if(p == NULL)
  405.         return;
  406.  
  407.     switch(p->tag)
  408.     {
  409.     case TCONST:
  410.         if( ISCHAR(p) )
  411.         {
  412.             free( (charptr) (p->constblock.Const.ccp) );
  413.             frexpr(p->constblock.vleng);
  414.         }
  415.         break;
  416.  
  417.     case TADDR:
  418.         if (p->addrblock.vtype > TYERROR)    /* i/o block */
  419.             break;
  420.         frexpr(p->addrblock.vleng);
  421.         frexpr(p->addrblock.memoffset);
  422.         break;
  423.  
  424.     case TERROR:
  425.         break;
  426.  
  427. /* TNAME blocks don't get free'd - probably because they're pointed to in
  428.    the hash table. 14-Jun-88 -- mwm */
  429.  
  430.     case TNAME:
  431.         return;
  432.  
  433.     case TPRIM:
  434.         frexpr((expptr)p->primblock.argsp);
  435.         frexpr(p->primblock.fcharp);
  436.         frexpr(p->primblock.lcharp);
  437.         break;
  438.  
  439.     case TEXPR:
  440.         frexpr(p->exprblock.leftp);
  441.         if(p->exprblock.rightp)
  442.             frexpr(p->exprblock.rightp);
  443.         break;
  444.  
  445.     case TLIST:
  446.         for(q = p->listblock.listp ; q ; q = q->nextp)
  447.             frexpr((tagptr)q->datap);
  448.         frchain( &(p->listblock.listp) );
  449.         break;
  450.  
  451.     default:
  452.         badtag("frexpr", p->tag);
  453.     }
  454.  
  455.     free( (charptr) p );
  456. }
  457.  
  458.  void
  459. wronginf(np)
  460.  Namep np;
  461. {
  462.     int c, k;
  463.     warn1("fixing wrong type inferred for %.65s", np->fvarname);
  464.     np->vinftype = 0;
  465.     c = letter(np->fvarname[0]);
  466.     if ((np->vtype = impltype[c]) == TYCHAR
  467.     && (k = implleng[c]))
  468.         np->vleng = ICON(k);
  469.     }
  470.  
  471. /* fix up types in expression; replace subtrees and convert
  472.    names to address blocks */
  473.  
  474. expptr fixtype(p)
  475. register tagptr p;
  476. {
  477.  
  478.     if(p == 0)
  479.         return(0);
  480.  
  481.     switch(p->tag)
  482.     {
  483.     case TCONST:
  484.         if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
  485.             MSKREAL) )
  486.             return( (expptr) p);
  487.  
  488.         return( (expptr) putconst((Constp)p) );
  489.  
  490.     case TADDR:
  491.         p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
  492.         return( (expptr) p);
  493.  
  494.     case TERROR:
  495.         return( (expptr) p);
  496.  
  497.     default:
  498.         badtag("fixtype", p->tag);
  499.  
  500. /* This case means that   fixexpr   can't call   fixtype   with any expr,
  501.    only a subexpr of its parameter. */
  502.  
  503.     case TEXPR:
  504.         return( fixexpr((Exprp)p) );
  505.  
  506.     case TLIST:
  507.         return( (expptr) p );
  508.  
  509.     case TPRIM:
  510.         if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
  511.         {
  512.             if(p->primblock.namep->vtype == TYSUBR)
  513.             {
  514.                 err("function invocation of subroutine");
  515.                 return( errnode() );
  516.             }
  517.             else {
  518.                 if (p->primblock.namep->vinftype)
  519.                     wronginf(p->primblock.namep);
  520.                 return( mkfunct(p) );
  521.                 }
  522.         }
  523.  
  524. /* The lack of args makes   p   a function name, substring reference
  525.    or variable name. */
  526.  
  527.         else    return( mklhs((struct Primblock *) p) );
  528.     }
  529. }
  530.  
  531.  
  532.  int
  533. badchleng(p) register expptr p;
  534. {
  535.     if (!p->headblock.vleng) {
  536.         if (p->headblock.tag == TADDR
  537.         && p->addrblock.uname_tag == UNAM_NAME)
  538.             errstr("bad use of character*(*) variable %.60s",
  539.                 p->addrblock.user.name->fvarname);
  540.         else
  541.             err("Bad use of character*(*)");
  542.         return 1;
  543.         }
  544.     return 0;
  545.     }
  546.  
  547.  
  548.  static expptr
  549. cplenexpr(p)
  550.  expptr p;
  551. {
  552.     expptr rv;
  553.  
  554.     if (badchleng(p))
  555.         return ICON(1);
  556.     rv = cpexpr(p->headblock.vleng);
  557.     if (ISCONST(p) && p->constblock.vtype == TYCHAR)
  558.         rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks;
  559.     return rv;
  560.     }
  561.  
  562.  
  563. /* special case tree transformations and cleanups of expression trees.
  564.    Parameter   p   should have a TEXPR tag at its root, else an error is
  565.    returned */
  566.  
  567. expptr fixexpr(p)
  568. register Exprp p;
  569. {
  570.     expptr lp;
  571.     register expptr rp;
  572.     register expptr q;
  573.     int opcode, ltype, rtype, ptype, mtype;
  574.  
  575.     if( ISERROR(p) )
  576.         return( (expptr) p );
  577.     else if(p->tag != TEXPR)
  578.         badtag("fixexpr", p->tag);
  579.     opcode = p->opcode;
  580.  
  581. /* First set the types of the left and right subexpressions */
  582.  
  583.     lp = p->leftp;
  584.     if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR)
  585.         lp = p->leftp = fixtype(lp);
  586.     ltype = lp->headblock.vtype;
  587.  
  588.     if(opcode==OPASSIGN && lp->tag!=TADDR)
  589.     {
  590.         err("left side of assignment must be variable");
  591.         frexpr((expptr)p);
  592.         return( errnode() );
  593.     }
  594.  
  595.     if(rp = p->rightp)
  596.     {
  597.         if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR)
  598.             rp = p->rightp = fixtype(rp);
  599.         rtype = rp->headblock.vtype;
  600.     }
  601.     else
  602.         rtype = 0;
  603.  
  604.     if(ltype==TYERROR || rtype==TYERROR)
  605.     {
  606.         frexpr((expptr)p);
  607.         return( errnode() );
  608.     }
  609.  
  610. /* Now work on the whole expression */
  611.  
  612.     /* force folding if possible */
  613.  
  614.     if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
  615.     {
  616.         q = opcode == OPCONV && lp->constblock.vtype == p->vtype
  617.             ? lp : mkexpr(opcode, lp, rp);
  618.  
  619. /* mkexpr is expected to reduce constant expressions */
  620.  
  621.         if( ISCONST(q) ) {
  622.             p->leftp = p->rightp = 0;
  623.             frexpr((expptr)p);
  624.             return(q);
  625.             }
  626.         free( (charptr) q );    /* constants did not fold */
  627.     }
  628.  
  629.     if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
  630.     {
  631.         frexpr((expptr)p);
  632.         return( errnode() );
  633.     }
  634.  
  635.     if (ltype == TYCHAR && ISCONST(lp))
  636.         p->leftp =  lp = (expptr)putconst((Constp)lp);
  637.     if (rtype == TYCHAR && ISCONST(rp))
  638.         p->rightp = rp = (expptr)putconst((Constp)rp);
  639.  
  640.     switch(opcode)
  641.     {
  642.     case OPCONCAT:
  643.         if(p->vleng == NULL)
  644.             p->vleng = mkexpr(OPPLUS, cplenexpr(lp),
  645.                     cplenexpr(rp) );
  646.         break;
  647.  
  648.     case OPASSIGN:
  649.         if (rtype == TYREAL)
  650.             break;
  651.     case OPPLUSEQ:
  652.     case OPSTAREQ:
  653.         if(ltype == rtype)
  654.             break;
  655.         if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
  656.             break;
  657.         if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
  658.             break;
  659.         if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
  660.             && typesize[ltype]>=typesize[rtype] )
  661.                 break;
  662.  
  663. /* Cast the right hand side to match the type of the expression */
  664.  
  665.         p->rightp = fixtype( mkconv(ptype, rp) );
  666.         break;
  667.  
  668.     case OPSLASH:
  669.         if( ISCOMPLEX(rtype) )
  670.         {
  671.             p = (Exprp) call2(ptype,
  672.  
  673. /* Handle double precision complex variables */
  674.  
  675.                 ptype == TYCOMPLEX ? "c_div" : "z_div",
  676.                 mkconv(ptype, lp), mkconv(ptype, rp) );
  677.             break;
  678.         }
  679.     case OPPLUS:
  680.     case OPMINUS:
  681.     case OPSTAR:
  682.     case OPMOD:
  683.         if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
  684.             (rtype==TYREAL && ! ISCONST(rp) ) ))
  685.             break;
  686.         if( ISCOMPLEX(ptype) )
  687.             break;
  688.  
  689. /* Cast both sides of the expression to match the type of the whole
  690.    expression.  */
  691.  
  692.         if(ltype != ptype && (ltype < TYSHORT || ptype > TYDREAL))
  693.             p->leftp = fixtype(mkconv(ptype,lp));
  694.         if(rtype != ptype && (rtype < TYSHORT || ptype > TYDREAL))
  695.             p->rightp = fixtype(mkconv(ptype,rp));
  696.         break;
  697.  
  698.     case OPPOWER:
  699.         return( mkpower((expptr)p) );
  700.  
  701.     case OPLT:
  702.     case OPLE:
  703.     case OPGT:
  704.     case OPGE:
  705.     case OPEQ:
  706.     case OPNE:
  707.         if(ltype == rtype)
  708.             break;
  709.         mtype = cktype(OPMINUS, ltype, rtype);
  710.         if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
  711.             (rtype==TYREAL && ! ISCONST(rp)) ))
  712.             break;
  713.         if( ISCOMPLEX(mtype) )
  714.             break;
  715.         if(ltype != mtype)
  716.             p->leftp = fixtype(mkconv(mtype,lp));
  717.         if(rtype != mtype)
  718.             p->rightp = fixtype(mkconv(mtype,rp));
  719.         break;
  720.  
  721.     case OPCONV:
  722.         ptype = cktype(OPCONV, p->vtype, ltype);
  723.         if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA
  724.          && !ISCOMPLEX(ptype))
  725.         {
  726.             lp->exprblock.rightp =
  727.                 fixtype( mkconv(ptype, lp->exprblock.rightp) );
  728.             free( (charptr) p );
  729.             p = (Exprp) lp;
  730.         }
  731.         break;
  732.  
  733.     case OPADDR:
  734.         if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
  735.             Fatal("addr of addr");
  736.         break;
  737.  
  738.     case OPCOMMA:
  739.     case OPQUEST:
  740.     case OPCOLON:
  741.         break;
  742.  
  743.     case OPMIN:
  744.     case OPMAX:
  745.     case OPMIN2:
  746.     case OPMAX2:
  747.     case OPDMIN:
  748.     case OPDMAX:
  749.     case OPABS:
  750.     case OPDABS:
  751.         ptype = p->vtype;
  752.         break;
  753.  
  754.     default:
  755.         break;
  756.     }
  757.  
  758.     p->vtype = ptype;
  759.     return((expptr) p);
  760. }
  761.  
  762.  
  763. /* fix an argument list, taking due care for special first level cases */
  764.  
  765. fixargs(doput, p0)
  766. int doput;    /* doput is true if constants need to be passed by reference */
  767. struct Listblock *p0;
  768. {
  769.     register chainp p;
  770.     register tagptr q, t;
  771.     register int qtag;
  772.     int nargs;
  773.     Addrp mkscalar();
  774.  
  775.     nargs = 0;
  776.     if(p0)
  777.         for(p = p0->listp ; p ; p = p->nextp)
  778.         {
  779.             ++nargs;
  780.             q = (tagptr)p->datap;
  781.             qtag = q->tag;
  782.             if(qtag == TCONST)
  783.             {
  784.  
  785. /* Call putconst() to store values in a constant table.  Since even
  786.    constants must be passed by reference, this can optimize on the storage
  787.    required */
  788.  
  789.                 p->datap = doput ? (char *)putconst((Constp)q)
  790.                          : (char *)q;
  791.             }
  792.  
  793. /* Take a function name and turn it into an Addr.  This only happens when
  794.    nothing else has figured out the function beforehand */
  795.  
  796.             else if(qtag==TPRIM && q->primblock.argsp==0 &&
  797.                 q->primblock.namep->vclass==CLPROC &&
  798.                 q->primblock.namep->vprocclass != PTHISPROC)
  799.                 p->datap = (char *)mkaddr(q->primblock.namep);
  800.  
  801.             else if(qtag==TPRIM && q->primblock.argsp==0 &&
  802.                 q->primblock.namep->vdim!=NULL)
  803.                 p->datap = (char *)mkscalar(q->primblock.namep);
  804.  
  805.             else if(qtag==TPRIM && q->primblock.argsp==0 &&
  806.                 q->primblock.namep->vdovar &&
  807.                 (t = (tagptr) memversion(q->primblock.namep)) )
  808.                 p->datap = (char *)fixtype(t);
  809.             else
  810.                 p->datap = (char *)fixtype(q);
  811.         }
  812.     return(nargs);
  813. }
  814.  
  815.  
  816.  
  817. /* mkscalar -- only called by   fixargs   above, and by some routines in
  818.    io.c */
  819.  
  820. Addrp mkscalar(np)
  821. register Namep np;
  822. {
  823.     register Addrp ap;
  824.  
  825.     vardcl(np);
  826.     ap = mkaddr(np);
  827.  
  828.     /* The prolog causes array arguments to point to the
  829.      * (0,...,0) element, unless subscript checking is on.
  830.      */
  831.     if( !checksubs && np->vstg==STGARG)
  832.     {
  833.         register struct Dimblock *dp;
  834.         dp = np->vdim;
  835.         frexpr(ap->memoffset);
  836.         ap->memoffset = mkexpr(OPSTAR,
  837.             (np->vtype==TYCHAR ?
  838.             cpexpr(np->vleng) :
  839.             (tagptr)ICON(typesize[np->vtype]) ),
  840.             cpexpr(dp->baseoffset) );
  841.     }
  842.     return(ap);
  843. }
  844.  
  845.  
  846.  static void
  847. adjust_arginfo(np)    /* adjust arginfo to omit the length arg for the
  848.                arg that we now know to be a character-valued
  849.                function */
  850.  register Namep np;
  851. {
  852.     struct Entrypoint *ep;
  853.     register chainp args;
  854.     Argtypes *at;
  855.  
  856.     for(ep = entries; ep; ep = ep->entnextp)
  857.         for(args = ep->arglist; args; args = args->nextp)
  858.             if (np == (Namep)args->datap
  859.             && (at = ep->entryname->arginfo))
  860.                 --at->nargs;
  861.     }
  862.  
  863.  
  864.  
  865. expptr mkfunct(p0)
  866.  expptr p0;
  867. {
  868.     register struct Primblock *p = (struct Primblock *)p0;
  869.     struct Entrypoint *ep;
  870.     Addrp ap;
  871.     Extsym *extp;
  872.     register Namep np;
  873.     register expptr q;
  874.     expptr intrcall();
  875.     extern chainp new_procs;
  876.     int k, nargs;
  877.     int class;
  878.  
  879.     if(p->tag != TPRIM)
  880.         return( errnode() );
  881.  
  882.     np = p->namep;
  883.     class = np->vclass;
  884.  
  885.  
  886.     if(class == CLUNKNOWN)
  887.     {
  888.         np->vclass = class = CLPROC;
  889.         if(np->vstg == STGUNKNOWN)
  890.         {
  891.             if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
  892.                 && (zflag || !(*(struct Intrpacked *)&k).f4
  893.                     || dcomplex_seen))
  894.             {
  895.                 np->vstg = STGINTR;
  896.                 np->vardesc.varno = k;
  897.                 np->vprocclass = PINTRINSIC;
  898.             }
  899.             else
  900.             {
  901.                 extp = mkext(np->fvarname,
  902.                     addunder(np->cvarname));
  903.                 extp->extstg = STGEXT;
  904.                 np->vstg = STGEXT;
  905.                 np->vardesc.varno = extp - extsymtab;
  906.                 np->vprocclass = PEXTERNAL;
  907.             }
  908.         }
  909.         else if(np->vstg==STGARG)
  910.         {
  911.             if(np->vtype == TYCHAR) {
  912.             adjust_arginfo(np);
  913.             if (np->vpassed) {
  914.                 char wbuf[160], *who;
  915.                 who = np->fvarname;
  916.                 sprintf(wbuf, "%s%s%s\n\t%s%s%s",
  917.                     "Character-valued dummy procedure ",
  918.                     who, " not declared EXTERNAL.",
  919.             "Code may be wrong for previous function calls having ",
  920.                     who, " as a parameter.");
  921.                 warn(wbuf);
  922.                 }
  923.             }
  924.             np->vprocclass = PEXTERNAL;
  925.         }
  926.     }
  927.  
  928.     if(class != CLPROC) {
  929.         if (np->vstg == STGCOMMON)
  930.             fatalstr(
  931.              "Cannot invoke common variable %.50s as a function.",
  932.                 np->fvarname);
  933.         fatali("invalid class code %d for function", class);
  934.         }
  935.  
  936. /* F77 doesn't allow subscripting of function calls */
  937.  
  938.     if(p->fcharp || p->lcharp)
  939.     {
  940.         err("no substring of function call");
  941.         goto error;
  942.     }
  943.     impldcl(np);
  944.     np->vimpltype = 0;    /* invoking as function ==> inferred type */
  945.     np->vcalled = 1;
  946.     nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
  947.  
  948.     switch(np->vprocclass)
  949.     {
  950.     case PEXTERNAL:
  951.         if(np->vtype == TYUNKNOWN)
  952.         {
  953.             dclerr("attempt to use untyped function", np);
  954.             np->vtype = dflttype[letter(np->fvarname[0])];
  955.         }
  956.         ap = mkaddr(np);
  957.         if (!extsymtab[np->vardesc.varno].extseen) {
  958.             new_procs = mkchain((char *)np, new_procs);
  959.             extsymtab[np->vardesc.varno].extseen = 1;
  960.             }
  961. call:
  962.         q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
  963.         q->exprblock.vtype = np->vtype;
  964.         if(np->vleng)
  965.             q->exprblock.vleng = (expptr) cpexpr(np->vleng);
  966.         break;
  967.  
  968.     case PINTRINSIC:
  969.         q = intrcall(np, p->argsp, nargs);
  970.         break;
  971.  
  972.     case PSTFUNCT:
  973.         q = stfcall(np, p->argsp);
  974.         break;
  975.  
  976.     case PTHISPROC:
  977.         warn("recursive call");
  978.  
  979. /* entries   is the list of multiple entry points */
  980.  
  981.         for(ep = entries ; ep ; ep = ep->entnextp)
  982.             if(ep->enamep == np)
  983.                 break;
  984.         if(ep == NULL)
  985.             Fatal("mkfunct: impossible recursion");
  986.  
  987.         ap = builtin(np->vtype, ep->entryname->cextname, -2);
  988.         /* the negative last arg prevents adding */
  989.         /* this name to the list of used builtins */
  990.         goto call;
  991.  
  992.     default:
  993.         fatali("mkfunct: impossible vprocclass %d",
  994.             (int) (np->vprocclass) );
  995.     }
  996.     free( (charptr) p );
  997.     return(q);
  998.  
  999. error:
  1000.     frexpr((expptr)p);
  1001.     return( errnode() );
  1002. }
  1003.  
  1004.  
  1005.  
  1006. LOCAL expptr stfcall(np, actlist)
  1007. Namep np;
  1008. struct Listblock *actlist;
  1009. {
  1010.     register chainp actuals;
  1011.     int nargs;
  1012.     chainp oactp, formals;
  1013.     int type;
  1014.     expptr Ln, Lq, q, q1, rhs, ap;
  1015.     Namep tnp;
  1016.     register struct Rplblock *rp;
  1017.     struct Rplblock *tlist;
  1018.     static int inv_count;
  1019.  
  1020.     if (++inv_count > stfcall_MAX)
  1021.         Fatal("Loop invoking recursive statement function?");
  1022.     if(actlist)
  1023.     {
  1024.         actuals = actlist->listp;
  1025.         free( (charptr) actlist);
  1026.     }
  1027.     else
  1028.         actuals = NULL;
  1029.     oactp = actuals;
  1030.  
  1031.     nargs = 0;
  1032.     tlist = NULL;
  1033.     if( (type = np->vtype) == TYUNKNOWN)
  1034.     {
  1035.         dclerr("attempt to use untyped statement function", np);
  1036.         type = np->vtype = dflttype[letter(np->fvarname[0])];
  1037.     }
  1038.     formals = (chainp) np->varxptr.vstfdesc->datap;
  1039.     rhs = (expptr) (np->varxptr.vstfdesc->nextp);
  1040.  
  1041.     /* copy actual arguments into temporaries */
  1042.     while(actuals!=NULL && formals!=NULL)
  1043.     {
  1044.         rp = ALLOC(Rplblock);
  1045.         rp->rplnp = tnp = (Namep) formals->datap;
  1046.         ap = fixtype((tagptr)actuals->datap);
  1047.         if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
  1048.             && (ap->tag==TCONST || ap->tag==TADDR) )
  1049.         {
  1050.  
  1051. /* If actuals are constants or variable names, no temporaries are required */
  1052.             rp->rplvp = (expptr) ap;
  1053.             rp->rplxp = NULL;
  1054.             rp->rpltag = ap->tag;
  1055.         }
  1056.         else    {
  1057.             rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng);
  1058.             rp -> rplxp = NULL;
  1059.             putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
  1060.             if((rp->rpltag = rp->rplvp->tag) == TERROR)
  1061.                 err("disagreement of argument types in statement function call");
  1062.         }
  1063.         rp->rplnextp = tlist;
  1064.         tlist = rp;
  1065.         actuals = actuals->nextp;
  1066.         formals = formals->nextp;
  1067.         ++nargs;
  1068.     }
  1069.  
  1070.     if(actuals!=NULL || formals!=NULL)
  1071.         err("statement function definition and argument list differ");
  1072.  
  1073.     /*
  1074.    now push down names involved in formal argument list, then
  1075.    evaluate rhs of statement function definition in this environment
  1076. */
  1077.  
  1078.     if(tlist)    /* put tlist in front of the rpllist */
  1079.     {
  1080.         for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
  1081.             ;
  1082.         rp->rplnextp = rpllist;
  1083.         rpllist = tlist;
  1084.     }
  1085.  
  1086. /* So when the expression finally gets evaled, that evaluator must read
  1087.    from the globl   rpllist   14-jun-88 mwm */
  1088.  
  1089.     q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
  1090.  
  1091.     /* get length right of character-valued statement functions... */
  1092.     if (type == TYCHAR
  1093.      && (Ln = np->vleng)
  1094.      && q->tag != TERROR
  1095.      && (Lq = q->exprblock.vleng)
  1096.      && (Lq->tag != TCONST
  1097.         || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) {
  1098.         q1 = (expptr) mktmp(type, Ln);
  1099.         putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q));
  1100.         q = q1;
  1101.         }
  1102.  
  1103.     /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
  1104.     while(--nargs >= 0)
  1105.     {
  1106.         if(rpllist->rplxp)
  1107.             q = mkexpr(OPCOMMA, rpllist->rplxp, q);
  1108.         rp = rpllist->rplnextp;
  1109.         frexpr(rpllist->rplvp);
  1110.         free((char *)rpllist);
  1111.         rpllist = rp;
  1112.     }
  1113.     frchain( &oactp );
  1114.     --inv_count;
  1115.     return(q);
  1116. }
  1117.  
  1118.  
  1119. static int replaced;
  1120.  
  1121. /* mkplace -- Figure out the proper storage class for the input name and
  1122.    return an addrp with the appropriate stuff */
  1123.  
  1124. Addrp mkplace(np)
  1125. register Namep np;
  1126. {
  1127.     register Addrp s;
  1128.     register struct Rplblock *rp;
  1129.     int regn;
  1130.  
  1131.     /* is name on the replace list? */
  1132.  
  1133.     for(rp = rpllist ; rp ; rp = rp->rplnextp)
  1134.     {
  1135.         if(np == rp->rplnp)
  1136.         {
  1137.             replaced = 1;
  1138.             if(rp->rpltag == TNAME)
  1139.             {
  1140.                 np = (Namep) (rp->rplvp);
  1141.                 break;
  1142.             }
  1143.             else    return( (Addrp) cpexpr(rp->rplvp) );
  1144.         }
  1145.     }
  1146.  
  1147.     /* is variable a DO index in a register ? */
  1148.  
  1149.     if(np->vdovar && ( (regn = inregister(np)) >= 0) )
  1150.         if(np->vtype == TYERROR)
  1151.             return((Addrp) errnode() );
  1152.         else
  1153.         {
  1154.             s = ALLOC(Addrblock);
  1155.             s->tag = TADDR;
  1156.             s->vstg = STGREG;
  1157.             s->vtype = TYIREG;
  1158.             s->memno = regn;
  1159.             s->memoffset = ICON(0);
  1160.             s -> uname_tag = UNAM_NAME;
  1161.             s -> user.name = np;
  1162.             return(s);
  1163.         }
  1164.  
  1165.     if (np->vclass == CLPROC && np->vprocclass != PTHISPROC)
  1166.         errstr("external %.60s used as a variable", np->fvarname);
  1167.     vardcl(np);
  1168.     return(mkaddr(np));
  1169. }
  1170.  
  1171.  
  1172.  static int doing_vleng;
  1173.  
  1174. /* mklhs -- Compute the actual address of the given expression; account
  1175.    for array subscripts, stack offset, and substring offsets.  The f -> C
  1176.    translator will need this only to worry about the subscript stuff */
  1177.  
  1178. expptr mklhs(p)
  1179. register struct Primblock *p;
  1180. {
  1181.     expptr suboffset();
  1182.     register Addrp s;
  1183.     Namep np;
  1184.  
  1185.     if(p->tag != TPRIM)
  1186.         return( (expptr) p );
  1187.     np = p->namep;
  1188.  
  1189.     replaced = 0;
  1190.     s = mkplace(np);
  1191.     if(s->tag!=TADDR || s->vstg==STGREG)
  1192.     {
  1193.         free( (charptr) p );
  1194.         return( (expptr) s );
  1195.     }
  1196.  
  1197.     /* compute the address modified by subscripts */
  1198.  
  1199.     if (!replaced)
  1200.         s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
  1201.     frexpr((expptr)p->argsp);
  1202.     p->argsp = NULL;
  1203.  
  1204.     /* now do substring part */
  1205.  
  1206.     if(p->fcharp || p->lcharp)
  1207.     {
  1208.         if(np->vtype != TYCHAR)
  1209.             errstr("substring of noncharacter %s", np->fvarname);
  1210.         else    {
  1211.             if(p->lcharp == NULL)
  1212.                 p->lcharp = (expptr) cpexpr(s->vleng);
  1213.             if(p->fcharp) {
  1214.                 doing_vleng = 1;
  1215.                 s->vleng = fixtype(mkexpr(OPMINUS,
  1216.                         p->lcharp,
  1217.                     mkexpr(OPMINUS, p->fcharp, ICON(1) )));
  1218.                 doing_vleng = 0;
  1219.                 }
  1220.             else    {
  1221.                 frexpr(s->vleng);
  1222.                 s->vleng = p->lcharp;
  1223.             }
  1224.         }
  1225.     }
  1226.  
  1227.     s->vleng = fixtype( s->vleng );
  1228.     s->memoffset = fixtype( s->memoffset );
  1229.     free( (charptr) p );
  1230.     return( (expptr) s );
  1231. }
  1232.  
  1233.  
  1234.  
  1235.  
  1236.  
  1237. /* deregister -- remove a register allocation from the list; assumes that
  1238.    names are deregistered in stack order (LIFO order - Last In First Out) */
  1239.  
  1240. deregister(np)
  1241. Namep np;
  1242. {
  1243.     if(nregvar>0 && regnamep[nregvar-1]==np)
  1244.     {
  1245.         --nregvar;
  1246.     }
  1247. }
  1248.  
  1249.  
  1250.  
  1251.  
  1252. /* memversion -- moves a DO index REGISTER into a memory location; other
  1253.    objects are passed through untouched */
  1254.  
  1255. Addrp memversion(np)
  1256. register Namep np;
  1257. {
  1258.     register Addrp s;
  1259.  
  1260.     if(np->vdovar==NO || (inregister(np)<0) )
  1261.         return(NULL);
  1262.     np->vdovar = NO;
  1263.     s = mkplace(np);
  1264.     np->vdovar = YES;
  1265.     return(s);
  1266. }
  1267.  
  1268.  
  1269.  
  1270. /* inregister -- looks for the input name in the global list   regnamep */
  1271.  
  1272. inregister(np)
  1273. register Namep np;
  1274. {
  1275.     register int i;
  1276.  
  1277.     for(i = 0 ; i < nregvar ; ++i)
  1278.         if(regnamep[i] == np)
  1279.             return( regnum[i] );
  1280.     return(-1);
  1281. }
  1282.  
  1283.  
  1284.  
  1285. /* suboffset -- Compute the offset from the start of the array, given the
  1286.    subscripts as arguments */
  1287.  
  1288. expptr suboffset(p)
  1289. register struct Primblock *p;
  1290. {
  1291.     int n;
  1292.     expptr si, size;
  1293.     chainp cp;
  1294.     expptr e, e1, offp, prod;
  1295.     expptr subcheck();
  1296.     struct Dimblock *dimp;
  1297.     expptr sub[MAXDIM+1];
  1298.     register Namep np;
  1299.  
  1300.     np = p->namep;
  1301.     offp = ICON(0);
  1302.     n = 0;
  1303.     if(p->argsp)
  1304.         for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
  1305.         {
  1306.             si = fixtype(cpexpr((tagptr)cp->datap));
  1307.             if (!ISINT(si->headblock.vtype)) {
  1308.                 NOEXT("non-integer subscript");
  1309.                 si = mkconv(TYLONG, si);
  1310.                 }
  1311.             sub[n++] = si;
  1312.             if(n > maxdim)
  1313.             {
  1314.                 erri("more than %d subscripts", maxdim);
  1315.                 break;
  1316.             }
  1317.         }
  1318.  
  1319.     dimp = np->vdim;
  1320.     if(n>0 && dimp==NULL)
  1321.         errstr("subscripts on scalar variable %.68s", np->fvarname);
  1322.     else if(dimp && dimp->ndim!=n)
  1323.         errstr("wrong number of subscripts on %.68s", np->fvarname);
  1324.     else if(n > 0)
  1325.     {
  1326.         prod = sub[--n];
  1327.         while( --n >= 0)
  1328.             prod = mkexpr(OPPLUS, sub[n],
  1329.                 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
  1330.         if(checksubs || np->vstg!=STGARG)
  1331.             prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
  1332.  
  1333. /* Add in the run-time bounds check */
  1334.  
  1335.         if(checksubs)
  1336.             prod = subcheck(np, prod);
  1337.         size = np->vtype == TYCHAR ?
  1338.             (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
  1339.         prod = mkexpr(OPSTAR, prod, size);
  1340.         offp = mkexpr(OPPLUS, offp, prod);
  1341.     }
  1342.  
  1343. /* Check for substring indicator */
  1344.  
  1345.     if(p->fcharp && np->vtype==TYCHAR) {
  1346.         e = p->fcharp;
  1347.         e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1));
  1348.         if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) {
  1349.             e = (expptr)mktmp(TYLONG, ENULL);
  1350.             putout(putassign(cpexpr(e), e1));
  1351.             p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1));
  1352.             e1 = e;
  1353.             }
  1354.         offp = mkexpr(OPPLUS, offp, e1);
  1355.         }
  1356.     return(offp);
  1357. }
  1358.  
  1359.  
  1360.  
  1361.  
  1362. expptr subcheck(np, p)
  1363. Namep np;
  1364. register expptr p;
  1365. {
  1366.     struct Dimblock *dimp;
  1367.     expptr t, checkvar, checkcond, badcall;
  1368.  
  1369.     dimp = np->vdim;
  1370.     if(dimp->nelt == NULL)
  1371.         return(p);    /* don't check arrays with * bounds */
  1372.     np->vlastdim = 0;
  1373.     if( ISICON(p) )
  1374.     {
  1375.  
  1376. /* check for negative (constant) offset */
  1377.  
  1378.         if(p->constblock.Const.ci < 0)
  1379.             goto badsub;
  1380.         if( ISICON(dimp->nelt) )
  1381.  
  1382. /* see if constant offset exceeds the array declaration */
  1383.  
  1384.             if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
  1385.                 return(p);
  1386.             else
  1387.                 goto badsub;
  1388.     }
  1389.  
  1390. /* We know that the subscript offset   p   or   dimp -> nelt   is not a constant.
  1391.    Now find a register to use for run-time bounds checking */
  1392.  
  1393.     if(p->tag==TADDR && p->addrblock.vstg==STGREG)
  1394.     {
  1395.         checkvar = (expptr) cpexpr(p);
  1396.         t = p;
  1397.     }
  1398.     else    {
  1399.         checkvar = (expptr) mktmp(p->headblock.vtype, ENULL);
  1400.         t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
  1401.     }
  1402.     checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
  1403.     if( ! ISICON(p) )
  1404.         checkcond = mkexpr(OPAND, checkcond,
  1405.             mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
  1406.  
  1407. /* Construct the actual test */
  1408.  
  1409.     badcall = call4(p->headblock.vtype, "s_rnge",
  1410.         mkstrcon(strlen(np->fvarname), np->fvarname),
  1411.         mkconv(TYLONG,  cpexpr(checkvar)),
  1412.         mkstrcon(strlen(procname), procname),
  1413.         ICON(lineno) );
  1414.     badcall->exprblock.opcode = OPCCALL;
  1415.     p = mkexpr(OPQUEST, checkcond,
  1416.         mkexpr(OPCOLON, checkvar, badcall));
  1417.  
  1418.     return(p);
  1419.  
  1420. badsub:
  1421.     frexpr(p);
  1422.     errstr("subscript on variable %s out of range", np->fvarname);
  1423.     return ( ICON(0) );
  1424. }
  1425.  
  1426.  
  1427.  
  1428.  
  1429. Addrp mkaddr(p)
  1430. register Namep p;
  1431. {
  1432.     Extsym *extp;
  1433.     register Addrp t;
  1434.     Addrp intraddr();
  1435.     int k;
  1436.  
  1437.     switch( p->vstg)
  1438.     {
  1439.     case STGAUTO:
  1440.         if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
  1441.             return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
  1442.         goto other;
  1443.  
  1444.     case STGUNKNOWN:
  1445.         if(p->vclass != CLPROC)
  1446.             break;    /* Error */
  1447.         extp = mkext(p->fvarname, addunder(p->cvarname));
  1448.         extp->extstg = STGEXT;
  1449.         p->vstg = STGEXT;
  1450.         p->vardesc.varno = extp - extsymtab;
  1451.         p->vprocclass = PEXTERNAL;
  1452.         if ((extp->exproto || infertypes)
  1453.         && (p->vtype == TYUNKNOWN || p->vimpltype)
  1454.         && (k = extp->extype))
  1455.             inferdcl(p, k);
  1456.  
  1457.  
  1458.     case STGCOMMON:
  1459.     case STGEXT:
  1460.     case STGBSS:
  1461.     case STGINIT:
  1462.     case STGEQUIV:
  1463.     case STGARG:
  1464.     case STGLENG:
  1465.  other:
  1466.         t = ALLOC(Addrblock);
  1467.         t->tag = TADDR;
  1468.  
  1469.         t->vclass = p->vclass;
  1470.         t->vtype = p->vtype;
  1471.         t->vstg = p->vstg;
  1472.         t->memno = p->vardesc.varno;
  1473.         t->memoffset = ICON(p->voffset);
  1474.         if (p->vdim)
  1475.             t->isarray = 1;
  1476.         if(p->vleng)
  1477.         {
  1478.             t->vleng = (expptr) cpexpr(p->vleng);
  1479.             if( ISICON(t->vleng) )
  1480.                 t->varleng = t->vleng->constblock.Const.ci;
  1481.         }
  1482.  
  1483. /* Keep the original name around for the C code generation */
  1484.  
  1485.         t -> uname_tag = UNAM_NAME;
  1486.         t -> user.name = p;
  1487.         return(t);
  1488.  
  1489.     case STGINTR:
  1490.  
  1491.         return ( intraddr (p));
  1492.     }
  1493.     badstg("mkaddr", p->vstg);
  1494.     /* NOT REACHED */ return 0;
  1495. }
  1496.  
  1497.  
  1498.  
  1499.  
  1500. /* mkarg -- create storage for a new parameter.  This is called when a
  1501.    function returns a string (for the return value, which is the first
  1502.    parameter), or when a variable-length string is passed to a function. */
  1503.  
  1504. Addrp mkarg(type, argno)
  1505. int type, argno;
  1506. {
  1507.     register Addrp p;
  1508.  
  1509.     p = ALLOC(Addrblock);
  1510.     p->tag = TADDR;
  1511.     p->vtype = type;
  1512.     p->vclass = CLVAR;
  1513.  
  1514. /* TYLENG is the type of the field holding the length of a character string */
  1515.  
  1516.     p->vstg = (type==TYLENG ? STGLENG : STGARG);
  1517.     p->memno = argno;
  1518.     return(p);
  1519. }
  1520.  
  1521.  
  1522.  
  1523.  
  1524. /* mkprim -- Create a PRIM (primary/primitive) block consisting of a
  1525.    Nameblock (or Paramblock), arguments (actual params or array
  1526.    subscripts) and substring bounds.  Requires that   v   have lots of
  1527.    extra (uninitialized) storage, since it could be a paramblock or
  1528.    nameblock */
  1529.  
  1530. expptr mkprim(v0, args, substr)
  1531.  Namep v0;
  1532.  struct Listblock *args;
  1533.  chainp substr;
  1534. {
  1535.     typedef union {
  1536.         struct Paramblock paramblock;
  1537.         struct Nameblock nameblock;
  1538.         struct Headblock headblock;
  1539.         } *Primu;
  1540.     register Primu v = (Primu)v0;
  1541.     register struct Primblock *p;
  1542.  
  1543.     if(v->headblock.vclass == CLPARAM)
  1544.     {
  1545.  
  1546. /* v   is to be a Paramblock */
  1547.  
  1548.         if(args || substr)
  1549.         {
  1550.             errstr("no qualifiers on parameter name %s",
  1551.                 v->paramblock.fvarname);
  1552.             frexpr((expptr)args);
  1553.             if(substr)
  1554.             {
  1555.                 frexpr((tagptr)substr->datap);
  1556.                 frexpr((tagptr)substr->nextp->datap);
  1557.                 frchain(&substr);
  1558.             }
  1559.             frexpr((expptr)v);
  1560.             return( errnode() );
  1561.         }
  1562.         return( (expptr) cpexpr(v->paramblock.paramval) );
  1563.     }
  1564.  
  1565.     p = ALLOC(Primblock);
  1566.     p->tag = TPRIM;
  1567.     p->vtype = v->nameblock.vtype;
  1568.  
  1569. /* v   is to be a Nameblock */
  1570.  
  1571.     p->namep = (Namep) v;
  1572.     p->argsp = args;
  1573.     if(substr)
  1574.     {
  1575.         p->fcharp = (expptr) substr->datap;
  1576.         p->lcharp = (expptr) substr->nextp->datap;
  1577.         frchain(&substr);
  1578.     }
  1579.     return( (expptr) p);
  1580. }
  1581.  
  1582.  
  1583.  
  1584. /* vardcl -- attempt to fill out the Name template for variable   v.
  1585.    This function is called on identifiers known to be variables or
  1586.    recursive references to the same function */
  1587.  
  1588. vardcl(v)
  1589. register Namep v;
  1590. {
  1591.     struct Dimblock *t;
  1592.     expptr neltp;
  1593.     extern int doing_stmtfcn;
  1594.  
  1595.     if(v->vclass == CLUNKNOWN) {
  1596.         v->vclass = CLVAR;
  1597.         if (v->vinftype) {
  1598.             v->vtype = TYUNKNOWN;
  1599.             if (v->vdcldone) {
  1600.                 v->vdcldone = 0;
  1601.                 impldcl(v);
  1602.                 }
  1603.             }
  1604.         }
  1605.     if(v->vdcldone)
  1606.         return;
  1607.     if(v->vclass == CLNAMELIST)
  1608.         return;
  1609.  
  1610.     if(v->vtype == TYUNKNOWN)
  1611.         impldcl(v);
  1612.     else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
  1613.     {
  1614.         dclerr("used as variable", v);
  1615.         return;
  1616.     }
  1617.     if(v->vstg==STGUNKNOWN) {
  1618.         if (doing_stmtfcn) {
  1619.             /* neither declare this variable if its only use */
  1620.             /* is in defining a stmt function, nor complain  */
  1621.             /* that it is never used */
  1622.             v->vimpldovar = 1;
  1623.             return;
  1624.             }
  1625.         v->vstg = implstg[ letter(v->fvarname[0]) ];
  1626.         v->vimplstg = 1;
  1627.         }
  1628.  
  1629. /* Compute the actual storage location, i.e. offsets from base addresses,
  1630.    possibly the stack pointer */
  1631.  
  1632.     switch(v->vstg)
  1633.     {
  1634.     case STGBSS:
  1635.         v->vardesc.varno = ++lastvarno;
  1636.         break;
  1637.     case STGAUTO:
  1638.         if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
  1639.             break;
  1640.         if(t = v->vdim)
  1641.             if( (neltp = t->nelt) && ISCONST(neltp) ) ;
  1642.             else
  1643.                 dclerr("adjustable automatic array", v);
  1644.         break;
  1645.  
  1646.     default:
  1647.         break;
  1648.     }
  1649.     v->vdcldone = YES;
  1650. }
  1651.  
  1652.  
  1653.  
  1654. /* Set the implicit type declaration of parameter   p   based on its first
  1655.    letter */
  1656.  
  1657. impldcl(p)
  1658. register Namep p;
  1659. {
  1660.     register int k;
  1661.     int type;
  1662.     ftnint leng;
  1663.  
  1664.     if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
  1665.         return;
  1666.     if(p->vtype == TYUNKNOWN)
  1667.     {
  1668.         k = letter(p->fvarname[0]);
  1669.         type = impltype[ k ];
  1670.         leng = implleng[ k ];
  1671.         if(type == TYUNKNOWN)
  1672.         {
  1673.             if(p->vclass == CLPROC)
  1674.                 return;
  1675.             dclerr("attempt to use undefined variable", p);
  1676.             type = dflttype[k];
  1677.             leng = 0;
  1678.         }
  1679.         settype(p, type, leng);
  1680.         p->vimpltype = 1;
  1681.     }
  1682. }
  1683.  
  1684.  void
  1685. inferdcl(np,type)
  1686.  Namep np;
  1687.  int type;
  1688. {
  1689.     int k = impltype[letter(np->fvarname[0])];
  1690.     if (k != type) {
  1691.         np->vinftype = 1;
  1692.         np->vtype = type;
  1693.         frexpr(np->vleng);
  1694.         np->vleng = 0;
  1695.         }
  1696.     np->vimpltype = 0;
  1697.     np->vinfproc = 1;
  1698.     }
  1699.  
  1700.  
  1701. #define ICONEQ(z, c)  (ISICON(z) && z->constblock.Const.ci==c)
  1702. #define COMMUTE    { e = lp;  lp = rp;  rp = e; }
  1703.  
  1704.  
  1705.  
  1706. /* mkexpr -- Make expression, and simplify constant subcomponents (tree
  1707.    order is not preserved).  Assumes that   lp   is nonempty, and uses
  1708.    fold()   to simplify adjacent constants */
  1709.  
  1710. expptr mkexpr(opcode, lp, rp)
  1711. int opcode;
  1712. register expptr lp, rp;
  1713. {
  1714.     register expptr e, e1;
  1715.     int etype;
  1716.     int ltype, rtype;
  1717.     int ltag, rtag;
  1718.     long L;
  1719.  
  1720.     ltype = lp->headblock.vtype;
  1721.     ltag = lp->tag;
  1722.     if(rp && opcode!=OPCALL && opcode!=OPCCALL)
  1723.     {
  1724.         rtype = rp->headblock.vtype;
  1725.         rtag = rp->tag;
  1726.     }
  1727.     else rtype = 0;
  1728.  
  1729.     etype = cktype(opcode, ltype, rtype);
  1730.     if(etype == TYERROR)
  1731.         goto error;
  1732.  
  1733.     switch(opcode)
  1734.     {
  1735.         /* check for multiplication by 0 and 1 and addition to 0 */
  1736.  
  1737.     case OPSTAR:
  1738.         if( ISCONST(lp) )
  1739.             COMMUTE
  1740.  
  1741.                 if( ISICON(rp) )
  1742.             {
  1743.                 if(rp->constblock.Const.ci == 0)
  1744.                     goto retright;
  1745.                 goto mulop;
  1746.             }
  1747.         break;
  1748.  
  1749.     case OPSLASH:
  1750.     case OPMOD:
  1751.         if( ICONEQ(rp, 0) )
  1752.         {
  1753.             err("attempted division by zero");
  1754.             rp = ICON(1);
  1755.             break;
  1756.         }
  1757.         if(opcode == OPMOD)
  1758.             break;
  1759.  
  1760. /* Handle multiplying or dividing by 1, -1 */
  1761.  
  1762. mulop:
  1763.         if( ISICON(rp) )
  1764.         {
  1765.             if(rp->constblock.Const.ci == 1)
  1766.                 goto retleft;
  1767.  
  1768.             if(rp->constblock.Const.ci == -1)
  1769.             {
  1770.                 frexpr(rp);
  1771.                 return( mkexpr(OPNEG, lp, ENULL) );
  1772.             }
  1773.         }
  1774.  
  1775. /* Group all constants together.  In particular,
  1776.  
  1777.     (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
  1778.     (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
  1779. */
  1780.  
  1781.         if (lp->tag != TEXPR || !lp->exprblock.rightp
  1782.                 || !ISICON(lp->exprblock.rightp))
  1783.             break;
  1784.  
  1785.         if (lp->exprblock.opcode == OPLSHIFT) {
  1786.             L = 1 << lp->exprblock.rightp->constblock.Const.ci;
  1787.             if (opcode == OPSTAR || ISICON(rp) &&
  1788.                     !(L % rp->constblock.Const.ci)) {
  1789.                 lp->exprblock.opcode = OPSTAR;
  1790.                 lp->exprblock.rightp->constblock.Const.ci = L;
  1791.                 }
  1792.             }
  1793.  
  1794.         if (lp->exprblock.opcode == OPSTAR) {
  1795.             if(opcode == OPSTAR)
  1796.                 e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
  1797.             else if(ISICON(rp) &&
  1798.                 (lp->exprblock.rightp->constblock.Const.ci %
  1799.                 rp->constblock.Const.ci) == 0)
  1800.                 e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
  1801.             else    break;
  1802.  
  1803.             e1 = lp->exprblock.leftp;
  1804.             free( (charptr) lp );
  1805.             return( mkexpr(OPSTAR, e1, e) );
  1806.             }
  1807.         break;
  1808.  
  1809.  
  1810.     case OPPLUS:
  1811.         if( ISCONST(lp) )
  1812.             COMMUTE
  1813.                 goto addop;
  1814.  
  1815.     case OPMINUS:
  1816.         if( ICONEQ(lp, 0) )
  1817.         {
  1818.             frexpr(lp);
  1819.             return( mkexpr(OPNEG, rp, ENULL) );
  1820.         }
  1821.  
  1822.         if( ISCONST(rp) && is_negatable((Constp)rp))
  1823.         {
  1824.             opcode = OPPLUS;
  1825.             consnegop((Constp)rp);
  1826.         }
  1827.  
  1828. /* Group constants in an addition expression (also subtraction, since the
  1829.    subtracted value was negated above).  In particular,
  1830.  
  1831.     (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
  1832. */
  1833.  
  1834. addop:
  1835.         if( ISICON(rp) )
  1836.         {
  1837.             if(rp->constblock.Const.ci == 0)
  1838.                 goto retleft;
  1839.             if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
  1840.             {
  1841.                 e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
  1842.                 e1 = lp->exprblock.leftp;
  1843.                 free( (charptr) lp );
  1844.                 return( mkexpr(OPPLUS, e1, e) );
  1845.             }
  1846.         }
  1847.         if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
  1848.             /* check for (i [+const]) - (i [+const]) */
  1849.             if (lp->tag == TPRIM)
  1850.                 e = lp;
  1851.             else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
  1852.                     && lp->exprblock.rightp->tag == TCONST) {
  1853.                 e = lp->exprblock.leftp;
  1854.                 if (e->tag != TPRIM)
  1855.                     break;
  1856.                 }
  1857.             else
  1858.                 break;
  1859.             if (e->primblock.argsp)
  1860.                 break;
  1861.             if (rp->tag == TPRIM)
  1862.                 e1 = rp;
  1863.             else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
  1864.                     && rp->exprblock.rightp->tag == TCONST) {
  1865.                 e1 = rp->exprblock.leftp;
  1866.                 if (e1->tag != TPRIM)
  1867.                     break;
  1868.                 }
  1869.             else
  1870.                 break;
  1871.             if (e->primblock.namep != e1->primblock.namep
  1872.                     || e1->primblock.argsp)
  1873.                 break;
  1874.             L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
  1875.             if (e1 != rp)
  1876.                 L -= rp->exprblock.rightp->constblock.Const.ci;
  1877.             frexpr(lp);
  1878.             frexpr(rp);
  1879.             return ICON(L);
  1880.             }
  1881.  
  1882.         break;
  1883.  
  1884.  
  1885.     case OPPOWER:
  1886.         break;
  1887.  
  1888. /* Eliminate outermost double negations */
  1889.  
  1890.     case OPNEG:
  1891.     case OPNEG1:
  1892.         if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
  1893.         {
  1894.             e = lp->exprblock.leftp;
  1895.             free( (charptr) lp );
  1896.             return(e);
  1897.         }
  1898.         break;
  1899.  
  1900. /* Eliminate outermost double NOTs */
  1901.  
  1902.     case OPNOT:
  1903.         if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
  1904.         {
  1905.             e = lp->exprblock.leftp;
  1906.             free( (charptr) lp );
  1907.             return(e);
  1908.         }
  1909.         break;
  1910.  
  1911.     case OPCALL:
  1912.     case OPCCALL:
  1913.         etype = ltype;
  1914.         if(rp!=NULL && rp->listblock.listp==NULL)
  1915.         {
  1916.             free( (charptr) rp );
  1917.             rp = NULL;
  1918.         }
  1919.         break;
  1920.  
  1921.     case OPAND:
  1922.     case OPOR:
  1923.         if( ISCONST(lp) )
  1924.             COMMUTE
  1925.  
  1926.                 if( ISCONST(rp) )
  1927.             {
  1928.                 if(rp->constblock.Const.ci == 0)
  1929.                     if(opcode == OPOR)
  1930.                         goto retleft;
  1931.                     else
  1932.                         goto retright;
  1933.                 else if(opcode == OPOR)
  1934.                     goto retright;
  1935.                 else
  1936.                     goto retleft;
  1937.             }
  1938.     case OPEQV:
  1939.     case OPNEQV:
  1940.  
  1941.     case OPBITAND:
  1942.     case OPBITOR:
  1943.     case OPBITXOR:
  1944.     case OPBITNOT:
  1945.     case OPLSHIFT:
  1946.     case OPRSHIFT:
  1947.  
  1948.     case OPLT:
  1949.     case OPGT:
  1950.     case OPLE:
  1951.     case OPGE:
  1952.     case OPEQ:
  1953.     case OPNE:
  1954.  
  1955.     case OPCONCAT:
  1956.         break;
  1957.     case OPMIN:
  1958.     case OPMAX:
  1959.     case OPMIN2:
  1960.     case OPMAX2:
  1961.     case OPDMIN:
  1962.     case OPDMAX:
  1963.  
  1964.     case OPASSIGN:
  1965.     case OPASSIGNI:
  1966.     case OPPLUSEQ:
  1967.     case OPSTAREQ:
  1968.     case OPMINUSEQ:
  1969.     case OPSLASHEQ:
  1970.     case OPMODEQ:
  1971.     case OPLSHIFTEQ:
  1972.     case OPRSHIFTEQ:
  1973.     case OPBITANDEQ:
  1974.     case OPBITXOREQ:
  1975.     case OPBITOREQ:
  1976.  
  1977.     case OPCONV:
  1978.     case OPADDR:
  1979.     case OPWHATSIN:
  1980.  
  1981.     case OPCOMMA:
  1982.     case OPCOMMA_ARG:
  1983.     case OPQUEST:
  1984.     case OPCOLON:
  1985.     case OPDOT:
  1986.     case OPARROW:
  1987.     case OPIDENTITY:
  1988.     case OPCHARCAST:
  1989.     case OPABS:
  1990.     case OPDABS:
  1991.         break;
  1992.  
  1993.     default:
  1994.         badop("mkexpr", opcode);
  1995.     }
  1996.  
  1997.     e = (expptr) ALLOC(Exprblock);
  1998.     e->exprblock.tag = TEXPR;
  1999.     e->exprblock.opcode = opcode;
  2000.     e->exprblock.vtype = etype;
  2001.     e->exprblock.leftp = lp;
  2002.     e->exprblock.rightp = rp;
  2003.     if(ltag==TCONST && (rp==0 || rtag==TCONST) )
  2004.         e = fold(e);
  2005.     return(e);
  2006.  
  2007. retleft:
  2008.     frexpr(rp);
  2009.     return(lp);
  2010.  
  2011. retright:
  2012.     frexpr(lp);
  2013.     return(rp);
  2014.  
  2015. error:
  2016.     frexpr(lp);
  2017.     if(rp && opcode!=OPCALL && opcode!=OPCCALL)
  2018.         frexpr(rp);
  2019.     return( errnode() );
  2020. }
  2021.  
  2022. #define ERR(s)   { errs = s; goto error; }
  2023.  
  2024. /* cktype -- Check and return the type of the expression */
  2025.  
  2026. cktype(op, lt, rt)
  2027. register int op, lt, rt;
  2028. {
  2029.     char *errs;
  2030.  
  2031.     if(lt==TYERROR || rt==TYERROR)
  2032.         goto error1;
  2033.  
  2034.     if(lt==TYUNKNOWN)
  2035.         return(TYUNKNOWN);
  2036.     if(rt==TYUNKNOWN)
  2037.  
  2038. /* If not unary operation, return UNKNOWN */
  2039.  
  2040.         if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
  2041.             return(TYUNKNOWN);
  2042.  
  2043.     switch(op)
  2044.     {
  2045.     case OPPLUS:
  2046.     case OPMINUS:
  2047.     case OPSTAR:
  2048.     case OPSLASH:
  2049.     case OPPOWER:
  2050.     case OPMOD:
  2051.         if( ISNUMERIC(lt) && ISNUMERIC(rt) )
  2052.             return( maxtype(lt, rt) );
  2053.         ERR("nonarithmetic operand of arithmetic operator")
  2054.  
  2055.     case OPNEG:
  2056.     case OPNEG1:
  2057.         if( ISNUMERIC(lt) )
  2058.             return(lt);
  2059.         ERR("nonarithmetic operand of negation")
  2060.  
  2061.     case OPNOT:
  2062.         if(lt == TYLOGICAL)
  2063.             return(TYLOGICAL);
  2064.         ERR("NOT of nonlogical")
  2065.  
  2066.     case OPAND:
  2067.     case OPOR:
  2068.     case OPEQV:
  2069.     case OPNEQV:
  2070.         if(lt==TYLOGICAL && rt==TYLOGICAL)
  2071.             return(TYLOGICAL);
  2072.         ERR("nonlogical operand of logical operator")
  2073.  
  2074.     case OPLT:
  2075.     case OPGT:
  2076.     case OPLE:
  2077.     case OPGE:
  2078.     case OPEQ:
  2079.     case OPNE:
  2080.         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
  2081.         {
  2082.             if(lt != rt)
  2083.                 ERR("illegal comparison")
  2084.         }
  2085.  
  2086.         else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
  2087.         {
  2088.             if(op!=OPEQ && op!=OPNE)
  2089.                 ERR("order comparison of complex data")
  2090.         }
  2091.  
  2092.         else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
  2093.             ERR("comparison of nonarithmetic data")
  2094.                 return(TYLOGICAL);
  2095.  
  2096.     case OPCONCAT:
  2097.         if(lt==TYCHAR && rt==TYCHAR)
  2098.             return(TYCHAR);
  2099.         ERR("concatenation of nonchar data")
  2100.  
  2101.     case OPCALL:
  2102.     case OPCCALL:
  2103.     case OPIDENTITY:
  2104.         return(lt);
  2105.  
  2106.     case OPADDR:
  2107.     case OPCHARCAST:
  2108.         return(TYADDR);
  2109.  
  2110.     case OPCONV:
  2111.         if(rt == 0)
  2112.             return(0);
  2113.         if(lt==TYCHAR && ISINT(rt) )
  2114.             return(TYCHAR);
  2115.     case OPASSIGN:
  2116.     case OPASSIGNI:
  2117.     case OPMINUSEQ:
  2118.     case OPPLUSEQ:
  2119.     case OPSTAREQ:
  2120.     case OPSLASHEQ:
  2121.     case OPMODEQ:
  2122.     case OPLSHIFTEQ:
  2123.     case OPRSHIFTEQ:
  2124.     case OPBITANDEQ:
  2125.     case OPBITXOREQ:
  2126.     case OPBITOREQ:
  2127.         if( ISINT(lt) && rt==TYCHAR)
  2128.             return(lt);
  2129.         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
  2130.             if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
  2131.                 || (lt!=rt))
  2132.             {
  2133.                 ERR("impossible conversion")
  2134.             }
  2135.         return(lt);
  2136.  
  2137.     case OPMIN:
  2138.     case OPMAX:
  2139.     case OPDMIN:
  2140.     case OPDMAX:
  2141.     case OPMIN2:
  2142.     case OPMAX2:
  2143.     case OPBITOR:
  2144.     case OPBITAND:
  2145.     case OPBITXOR:
  2146.     case OPBITNOT:
  2147.     case OPLSHIFT:
  2148.     case OPRSHIFT:
  2149.     case OPWHATSIN:
  2150.     case OPABS:
  2151.     case OPDABS:
  2152.         return(lt);
  2153.  
  2154.     case OPCOMMA:
  2155.     case OPCOMMA_ARG:
  2156.     case OPQUEST:
  2157.     case OPCOLON:        /* Only checks the rightmost type because
  2158.                    of C language definition (rightmost
  2159.                    comma-expr is the value of the expr) */
  2160.         return(rt);
  2161.  
  2162.     case OPDOT:
  2163.     case OPARROW:
  2164.         return (lt);
  2165.         break;
  2166.     default:
  2167.         badop("cktype", op);
  2168.     }
  2169. error:
  2170.     err(errs);
  2171. error1:
  2172.     return(TYERROR);
  2173. }
  2174.  
  2175. /* fold -- simplifies constant expressions; it assumes that e -> leftp and
  2176.    e -> rightp are TCONST or NULL */
  2177.  
  2178.  LOCAL expptr
  2179. fold(e)
  2180.  register expptr e;
  2181. {
  2182.     Constp p;
  2183.     register expptr lp, rp;
  2184.     int etype, mtype, ltype, rtype, opcode;
  2185.     int i, bl, ll, lr;
  2186.     char *q, *s;
  2187.     struct Constblock lcon, rcon;
  2188.     long L;
  2189.     double d;
  2190.  
  2191.     opcode = e->exprblock.opcode;
  2192.     etype = e->exprblock.vtype;
  2193.  
  2194.     lp = e->exprblock.leftp;
  2195.     ltype = lp->headblock.vtype;
  2196.     rp = e->exprblock.rightp;
  2197.  
  2198.     if(rp == 0)
  2199.         switch(opcode)
  2200.         {
  2201.         case OPNOT:
  2202.             lp->constblock.Const.ci = ! lp->constblock.Const.ci;
  2203.  retlp:
  2204.             e->exprblock.leftp = 0;
  2205.             frexpr(e);
  2206.             return(lp);
  2207.  
  2208.         case OPBITNOT:
  2209.             lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
  2210.             goto retlp;
  2211.  
  2212.         case OPNEG:
  2213.         case OPNEG1:
  2214.             consnegop((Constp)lp);
  2215.             goto retlp;
  2216.  
  2217.         case OPCONV:
  2218.         case OPADDR:
  2219.             return(e);
  2220.  
  2221.         case OPABS:
  2222.         case OPDABS:
  2223.             switch(ltype) {
  2224.                 case TYSHORT:
  2225.                 case TYLONG:
  2226.                 if ((L = lp->constblock.Const.ci) < 0)
  2227.                     lp->constblock.Const.ci = -L;
  2228.                 goto retlp;
  2229.                 case TYREAL:
  2230.                 case TYDREAL:
  2231.                 if (lp->constblock.vstg) {
  2232.                     s = lp->constblock.Const.cds[0];
  2233.                     if (*s == '-')
  2234.                     lp->constblock.Const.cds[0] = s + 1;
  2235.                     goto retlp;
  2236.                 }
  2237.                 if ((d = lp->constblock.Const.cd[0]) < 0.)
  2238.                     lp->constblock.Const.cd[0] = -d;
  2239.                 case TYCOMPLEX:
  2240.                 case TYDCOMPLEX:
  2241.                 return e;    /* lazy way out */
  2242.                 }
  2243.         default:
  2244.             badop("fold", opcode);
  2245.         }
  2246.  
  2247.     rtype = rp->headblock.vtype;
  2248.  
  2249.     p = ALLOC(Constblock);
  2250.     p->tag = TCONST;
  2251.     p->vtype = etype;
  2252.     p->vleng = e->exprblock.vleng;
  2253.  
  2254.     switch(opcode)
  2255.     {
  2256.     case OPCOMMA:
  2257.     case OPCOMMA_ARG:
  2258.     case OPQUEST:
  2259.     case OPCOLON:
  2260.         return(e);
  2261.  
  2262.     case OPAND:
  2263.         p->Const.ci = lp->constblock.Const.ci &&
  2264.             rp->constblock.Const.ci;
  2265.         break;
  2266.  
  2267.     case OPOR:
  2268.         p->Const.ci = lp->constblock.Const.ci ||
  2269.             rp->constblock.Const.ci;
  2270.         break;
  2271.  
  2272.     case OPEQV:
  2273.         p->Const.ci = lp->constblock.Const.ci ==
  2274.             rp->constblock.Const.ci;
  2275.         break;
  2276.  
  2277.     case OPNEQV:
  2278.         p->Const.ci = lp->constblock.Const.ci !=
  2279.             rp->constblock.Const.ci;
  2280.         break;
  2281.  
  2282.     case OPBITAND:
  2283.         p->Const.ci = lp->constblock.Const.ci &
  2284.             rp->constblock.Const.ci;
  2285.         break;
  2286.  
  2287.     case OPBITOR:
  2288.         p->Const.ci = lp->constblock.Const.ci |
  2289.             rp->constblock.Const.ci;
  2290.         break;
  2291.  
  2292.     case OPBITXOR:
  2293.         p->Const.ci = lp->constblock.Const.ci ^
  2294.             rp->constblock.Const.ci;
  2295.         break;
  2296.  
  2297.     case OPLSHIFT:
  2298.         p->Const.ci = lp->constblock.Const.ci <<
  2299.             rp->constblock.Const.ci;
  2300.         break;
  2301.  
  2302.     case OPRSHIFT:
  2303.         p->Const.ci = lp->constblock.Const.ci >>
  2304.             rp->constblock.Const.ci;
  2305.         break;
  2306.  
  2307.     case OPCONCAT:
  2308.         ll = lp->constblock.vleng->constblock.Const.ci;
  2309.         lr = rp->constblock.vleng->constblock.Const.ci;
  2310.         bl = lp->constblock.Const.ccp1.blanks;
  2311.         p->Const.ccp = q = (char *) ckalloc(ll+lr+bl);
  2312.         p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks;
  2313.         p->vleng = ICON(ll+lr+bl);
  2314.         s = lp->constblock.Const.ccp;
  2315.         for(i = 0 ; i < ll ; ++i)
  2316.             *q++ = *s++;
  2317.         for(i = 0 ; i < bl ; i++)
  2318.             *q++ = ' ';
  2319.         s = rp->constblock.Const.ccp;
  2320.         for(i = 0; i < lr; ++i)
  2321.             *q++ = *s++;
  2322.         break;
  2323.  
  2324.  
  2325.     case OPPOWER:
  2326.         if( ! ISINT(rtype) )
  2327.             return(e);
  2328.         conspower(p, (Constp)lp, rp->constblock.Const.ci);
  2329.         break;
  2330.  
  2331.  
  2332.     default:
  2333.         if(ltype == TYCHAR)
  2334.         {
  2335.             lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
  2336.                 rp->constblock.Const.ccp,
  2337.                 lp->constblock.vleng->constblock.Const.ci,
  2338.                 rp->constblock.vleng->constblock.Const.ci);
  2339.             rcon.Const.ci = 0;
  2340.             mtype = tyint;
  2341.         }
  2342.         else    {
  2343.             mtype = maxtype(ltype, rtype);
  2344.             consconv(mtype, &lcon, &lp->constblock);
  2345.             consconv(mtype, &rcon, &rp->constblock);
  2346.         }
  2347.         consbinop(opcode, mtype, p, &lcon, &rcon);
  2348.         break;
  2349.     }
  2350.  
  2351.     frexpr(e);
  2352.     return( (expptr) p );
  2353. }
  2354.  
  2355.  
  2356.  
  2357. /* assign constant l = r , doing coercion */
  2358.  
  2359. consconv(lt, lc, rc)
  2360.  int lt;
  2361.  register Constp lc, rc;
  2362. {
  2363.     int rt = rc->vtype;
  2364.     register union Constant *lv = &lc->Const, *rv = &rc->Const;
  2365.  
  2366.     lc->vtype = lt;
  2367.     if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
  2368.         memcpy((char *)lv, (char *)rv, sizeof(union Constant));
  2369.         lc->vstg = rc->vstg;
  2370.         if (ISCOMPLEX(lt) && ISREAL(rt)) {
  2371.             if (rc->vstg)
  2372.                 lv->cds[1] = cds("0",CNULL);
  2373.             else
  2374.                 lv->cd[1] = 0.;
  2375.             }
  2376.         return;
  2377.         }
  2378.     lc->vstg = 0;
  2379.  
  2380.     switch(lt)
  2381.     {
  2382.  
  2383. /* Casting to character means just copying the first sizeof (character)
  2384.    bytes into a new 1 character string.  This is weird. */
  2385.  
  2386.     case TYCHAR:
  2387.         *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
  2388.         lv->ccp1.blanks = 0;
  2389.         break;
  2390.  
  2391.     case TYSHORT:
  2392.     case TYLONG:
  2393.         if(rt == TYCHAR)
  2394.             lv->ci = rv->ccp[0];
  2395.         else if( ISINT(rt) )
  2396.             lv->ci = rv->ci;
  2397.         else    lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
  2398.  
  2399.         break;
  2400.  
  2401.     case TYCOMPLEX:
  2402.     case TYDCOMPLEX:
  2403.         lv->cd[1] = 0.;
  2404.         lv->cd[0] = rv->ci;
  2405.         break;
  2406.  
  2407.     case TYREAL:
  2408.     case TYDREAL:
  2409.         lv->cd[0] = rv->ci;
  2410.         break;
  2411.  
  2412.     case TYLOGICAL:
  2413.         lv->ci = rv->ci;
  2414.         break;
  2415.     }
  2416. }
  2417.  
  2418.  
  2419.  
  2420. /* Negate constant value -- changes the input node's value */
  2421.  
  2422. consnegop(p)
  2423. register Constp p;
  2424. {
  2425.     register char *s;
  2426.  
  2427.     if (p->vstg) {
  2428.         if (ISCOMPLEX(p->vtype)) {
  2429.             s = p->Const.cds[1];
  2430.             p->Const.cds[1] = *s == '-' ? s+1
  2431.                     : *s == '0' ? s : s-1;
  2432.             }
  2433.         s = p->Const.cds[0];
  2434.         p->Const.cds[0] = *s == '-' ? s+1
  2435.                 : *s == '0' ? s : s-1;
  2436.         return;
  2437.         }
  2438.     switch(p->vtype)
  2439.     {
  2440.     case TYSHORT:
  2441.     case TYLONG:
  2442.         p->Const.ci = - p->Const.ci;
  2443.         break;
  2444.  
  2445.     case TYCOMPLEX:
  2446.     case TYDCOMPLEX:
  2447.         p->Const.cd[1] = - p->Const.cd[1];
  2448.         /* fall through and do the real parts */
  2449.     case TYREAL:
  2450.     case TYDREAL:
  2451.         p->Const.cd[0] = - p->Const.cd[0];
  2452.         break;
  2453.     default:
  2454.         badtype("consnegop", p->vtype);
  2455.     }
  2456. }
  2457.  
  2458.  
  2459.  
  2460. /* conspower -- Expand out an exponentiation */
  2461.  
  2462.  LOCAL void
  2463. conspower(p, ap, n)
  2464.  Constp p, ap;
  2465.  ftnint n;
  2466. {
  2467.     register union Constant *powp = &p->Const;
  2468.     register int type;
  2469.     struct Constblock x, x0;
  2470.  
  2471.     if (n == 1) {
  2472.         memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
  2473.         return;
  2474.         }
  2475.  
  2476.     switch(type = ap->vtype)    /* pow = 1 */
  2477.     {
  2478.     case TYSHORT:
  2479.     case TYLONG:
  2480.         powp->ci = 1;
  2481.         break;
  2482.     case TYCOMPLEX:
  2483.     case TYDCOMPLEX:
  2484.         powp->cd[1] = 0;
  2485.     case TYREAL:
  2486.     case TYDREAL:
  2487.         powp->cd[0] = 1;
  2488.         break;
  2489.     default:
  2490.         badtype("conspower", type);
  2491.     }
  2492.  
  2493.     if(n == 0)
  2494.         return;
  2495.     switch(type)    /* x0 = ap */
  2496.     {
  2497.     case TYSHORT:
  2498.     case TYLONG:
  2499.         x0.Const.ci = ap->Const.ci;
  2500.         break;
  2501.     case TYCOMPLEX:
  2502.     case TYDCOMPLEX:
  2503.         x0.Const.cd[1] =
  2504.             ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
  2505.     case TYREAL:
  2506.     case TYDREAL:
  2507.         x0.Const.cd[0] =
  2508.             ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
  2509.         break;
  2510.     }
  2511.     x0.vtype = type;
  2512.     x0.vstg = 0;
  2513.     if(n < 0)
  2514.     {
  2515.         if( ISINT(type) )
  2516.         {
  2517.             err("integer ** negative number");
  2518.             return;
  2519.         }
  2520.         else if (!x0.Const.cd[0]
  2521.                 && (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
  2522.             err("0.0 ** negative number");
  2523.             return;
  2524.             }
  2525.         n = -n;
  2526.         consbinop(OPSLASH, type, &x, p, &x0);
  2527.     }
  2528.     else
  2529.         consbinop(OPSTAR, type, &x, p, &x0);
  2530.  
  2531.     for( ; ; )
  2532.     {
  2533.         if(n & 01)
  2534.             consbinop(OPSTAR, type, p, p, &x);
  2535.         if(n >>= 1)
  2536.             consbinop(OPSTAR, type, &x, &x, &x);
  2537.         else
  2538.             break;
  2539.     }
  2540. }
  2541.  
  2542.  
  2543.  
  2544. /* do constant operation cp = a op b -- assumes that   ap and bp   have data
  2545.    matching the input   type */
  2546.  
  2547.  LOCAL void
  2548. zerodiv()
  2549. { Fatal("division by zero during constant evaluation; cannot recover"); }
  2550.  
  2551.  LOCAL void
  2552. consbinop(opcode, type, cpp, app, bpp)
  2553.  int opcode, type;
  2554.  Constp cpp, app, bpp;
  2555. {
  2556.     register union Constant *ap = &app->Const,
  2557.                 *bp = &bpp->Const,
  2558.                 *cp = &cpp->Const;
  2559.     int k;
  2560.     double ad[2], bd[2], temp;
  2561.  
  2562.     cpp->vstg = 0;
  2563.  
  2564.     if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
  2565.         ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
  2566.         bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
  2567.         if (ISCOMPLEX(type)) {
  2568.             ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
  2569.             bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
  2570.             }
  2571.         }
  2572.     switch(opcode)
  2573.     {
  2574.     case OPPLUS:
  2575.         switch(type)
  2576.         {
  2577.         case TYSHORT:
  2578.         case TYLONG:
  2579.             cp->ci = ap->ci + bp->ci;
  2580.             break;
  2581.         case TYCOMPLEX:
  2582.         case TYDCOMPLEX:
  2583.             cp->cd[1] = ad[1] + bd[1];
  2584.         case TYREAL:
  2585.         case TYDREAL:
  2586.             cp->cd[0] = ad[0] + bd[0];
  2587.             break;
  2588.         }
  2589.         break;
  2590.  
  2591.     case OPMINUS:
  2592.         switch(type)
  2593.         {
  2594.         case TYSHORT:
  2595.         case TYLONG:
  2596.             cp->ci = ap->ci - bp->ci;
  2597.             break;
  2598.         case TYCOMPLEX:
  2599.         case TYDCOMPLEX:
  2600.             cp->cd[1] = ad[1] - bd[1];
  2601.         case TYREAL:
  2602.         case TYDREAL:
  2603.             cp->cd[0] = ad[0] - bd[0];
  2604.             break;
  2605.         }
  2606.         break;
  2607.  
  2608.     case OPSTAR:
  2609.         switch(type)
  2610.         {
  2611.         case TYSHORT:
  2612.         case TYLONG:
  2613.             cp->ci = ap->ci * bp->ci;
  2614.             break;
  2615.         case TYREAL:
  2616.         case TYDREAL:
  2617.             cp->cd[0] = ad[0] * bd[0];
  2618.             break;
  2619.         case TYCOMPLEX:
  2620.         case TYDCOMPLEX:
  2621.             temp = ad[0] * bd[0]  -  ad[1] * bd[1] ;
  2622.             cp->cd[1] = ad[0] * bd[1]  +  ad[1] * bd[0] ;
  2623.             cp->cd[0] = temp;
  2624.             break;
  2625.         }
  2626.         break;
  2627.     case OPSLASH:
  2628.         switch(type)
  2629.         {
  2630.         case TYSHORT:
  2631.         case TYLONG:
  2632.             if (!bp->ci)
  2633.                 zerodiv();
  2634.             cp->ci = ap->ci / bp->ci;
  2635.             break;
  2636.         case TYREAL:
  2637.         case TYDREAL:
  2638.             if (!bd[0])
  2639.                 zerodiv();
  2640.             cp->cd[0] = ad[0] / bd[0];
  2641.             break;
  2642.         case TYCOMPLEX:
  2643.         case TYDCOMPLEX:
  2644.             if (!bd[0] && !bd[1])
  2645.                 zerodiv();
  2646.             zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
  2647.             break;
  2648.         }
  2649.         break;
  2650.  
  2651.     case OPMOD:
  2652.         if( ISINT(type) )
  2653.         {
  2654.             cp->ci = ap->ci % bp->ci;
  2655.             break;
  2656.         }
  2657.         else
  2658.             Fatal("inline mod of noninteger");
  2659.  
  2660.     case OPMIN2:
  2661.     case OPDMIN:
  2662.         switch(type)
  2663.         {
  2664.         case TYSHORT:
  2665.         case TYLONG:
  2666.             cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
  2667.             break;
  2668.         case TYREAL:
  2669.         case TYDREAL:
  2670.             cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
  2671.             break;
  2672.         default:
  2673.             Fatal("inline min of exected type");
  2674.         }
  2675.         break;
  2676.  
  2677.     case OPMAX2:
  2678.     case OPDMAX:
  2679.         switch(type)
  2680.         {
  2681.         case TYSHORT:
  2682.         case TYLONG:
  2683.             cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
  2684.             break;
  2685.         case TYREAL:
  2686.         case TYDREAL:
  2687.             cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
  2688.             break;
  2689.         default:
  2690.             Fatal("inline max of exected type");
  2691.         }
  2692.         break;
  2693.  
  2694.     default:      /* relational ops */
  2695.         switch(type)
  2696.         {
  2697.         case TYSHORT:
  2698.         case TYLONG:
  2699.             if(ap->ci < bp->ci)
  2700.                 k = -1;
  2701.             else if(ap->ci == bp->ci)
  2702.                 k = 0;
  2703.             else    k = 1;
  2704.             break;
  2705.         case TYREAL:
  2706.         case TYDREAL:
  2707.             if(ad[0] < bd[0])
  2708.                 k = -1;
  2709.             else if(ad[0] == bd[0])
  2710.                 k = 0;
  2711.             else    k = 1;
  2712.             break;
  2713.         case TYCOMPLEX:
  2714.         case TYDCOMPLEX:
  2715.             if(ad[0] == bd[0] &&
  2716.                 ad[1] == bd[1] )
  2717.                 k = 0;
  2718.             else    k = 1;
  2719.             break;
  2720.         }
  2721.  
  2722.         switch(opcode)
  2723.         {
  2724.         case OPEQ:
  2725.             cp->ci = (k == 0);
  2726.             break;
  2727.         case OPNE:
  2728.             cp->ci = (k != 0);
  2729.             break;
  2730.         case OPGT:
  2731.             cp->ci = (k == 1);
  2732.             break;
  2733.         case OPLT:
  2734.             cp->ci = (k == -1);
  2735.             break;
  2736.         case OPGE:
  2737.             cp->ci = (k >= 0);
  2738.             break;
  2739.         case OPLE:
  2740.             cp->ci = (k <= 0);
  2741.             break;
  2742.         }
  2743.         break;
  2744.     }
  2745. }
  2746.  
  2747.  
  2748.  
  2749. /* conssgn - returns the sign of a Fortran constant */
  2750.  
  2751. conssgn(p)
  2752. register expptr p;
  2753. {
  2754.     register char *s;
  2755.  
  2756.     if( ! ISCONST(p) )
  2757.         Fatal( "sgn(nonconstant)" );
  2758.  
  2759.     switch(p->headblock.vtype)
  2760.     {
  2761.     case TYSHORT:
  2762.     case TYLONG:
  2763.         if(p->constblock.Const.ci > 0) return(1);
  2764.         if(p->constblock.Const.ci < 0) return(-1);
  2765.         return(0);
  2766.  
  2767.     case TYREAL:
  2768.     case TYDREAL:
  2769.         if (p->constblock.vstg) {
  2770.             s = p->constblock.Const.cds[0];
  2771.             if (*s == '-')
  2772.                 return -1;
  2773.             if (*s == '0')
  2774.                 return 0;
  2775.             return 1;
  2776.             }
  2777.         if(p->constblock.Const.cd[0] > 0) return(1);
  2778.         if(p->constblock.Const.cd[0] < 0) return(-1);
  2779.         return(0);
  2780.  
  2781.  
  2782. /* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */
  2783.  
  2784.     case TYCOMPLEX:
  2785.     case TYDCOMPLEX:
  2786.         if (p->constblock.vstg)
  2787.             return *p->constblock.Const.cds[0] != '0'
  2788.                 && *p->constblock.Const.cds[1] != '0';
  2789.         return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
  2790.  
  2791.     default:
  2792.         badtype( "conssgn", p->constblock.vtype);
  2793.     }
  2794.     /* NOT REACHED */ return 0;
  2795. }
  2796.  
  2797. char *powint[ ] = {
  2798.     "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
  2799.  
  2800. LOCAL expptr mkpower(p)
  2801. register expptr p;
  2802. {
  2803.     register expptr q, lp, rp;
  2804.     int ltype, rtype, mtype, tyi;
  2805.  
  2806.     lp = p->exprblock.leftp;
  2807.     rp = p->exprblock.rightp;
  2808.     ltype = lp->headblock.vtype;
  2809.     rtype = rp->headblock.vtype;
  2810.  
  2811.     if(ISICON(rp))
  2812.     {
  2813.         if(rp->constblock.Const.ci == 0)
  2814.         {
  2815.             frexpr(p);
  2816.             if( ISINT(ltype) )
  2817.                 return( ICON(1) );
  2818.             else if (ISREAL (ltype))
  2819.                 return mkconv (ltype, ICON (1));
  2820.             else
  2821.                 return( (expptr) putconst((Constp)
  2822.                     mkconv(ltype, ICON(1))) );
  2823.         }
  2824.         if(rp->constblock.Const.ci < 0)
  2825.         {
  2826.             if( ISINT(ltype) )
  2827.             {
  2828.                 frexpr(p);
  2829.                 err("integer**negative");
  2830.                 return( errnode() );
  2831.             }
  2832.             rp->constblock.Const.ci = - rp->constblock.Const.ci;
  2833.             p->exprblock.leftp = lp
  2834.                 = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
  2835.         }
  2836.         if(rp->constblock.Const.ci == 1)
  2837.         {
  2838.             frexpr(rp);
  2839.             free( (charptr) p );
  2840.             return(lp);
  2841.         }
  2842.  
  2843.         if( ONEOF(ltype, MSKINT|MSKREAL) ) {
  2844.             p->exprblock.vtype = ltype;
  2845.             return(p);
  2846.         }
  2847.     }
  2848.     if( ISINT(rtype) )
  2849.     {
  2850.         if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
  2851.             q = call2(TYSHORT, "pow_hh", lp, rp);
  2852.         else    {
  2853.             if(ltype == TYSHORT)
  2854.             {
  2855.                 ltype = TYLONG;
  2856.                 lp = mkconv(TYLONG,lp);
  2857.             }
  2858.             rp = mkconv(TYLONG,rp);
  2859.             if (ISCONST(rp)) {
  2860.                 tyi = tyint;
  2861.                 tyint = TYLONG;
  2862.                 rp = (expptr)putconst((Constp)rp);
  2863.                 tyint = tyi;
  2864.                 }
  2865.             q = call2(ltype, powint[ltype-TYLONG], lp, rp);
  2866.         }
  2867.     }
  2868.     else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
  2869.         extern int callk_kludge;
  2870.         callk_kludge = TYDREAL;
  2871.         q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
  2872.         callk_kludge = 0;
  2873.         }
  2874.     else    {
  2875.         q  = call2(TYDCOMPLEX, "pow_zz",
  2876.             mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
  2877.         if(mtype == TYCOMPLEX)
  2878.             q = mkconv(TYCOMPLEX, q);
  2879.     }
  2880.     free( (charptr) p );
  2881.     return(q);
  2882. }
  2883.  
  2884.  
  2885. /* Complex Division.  Same code as in Runtime Library
  2886. */
  2887.  
  2888.  
  2889.  LOCAL void
  2890. zdiv(c, a, b)
  2891.  register dcomplex *a, *b, *c;
  2892. {
  2893.     double ratio, den;
  2894.     double abr, abi;
  2895.  
  2896.     if( (abr = b->dreal) < 0.)
  2897.         abr = - abr;
  2898.     if( (abi = b->dimag) < 0.)
  2899.         abi = - abi;
  2900.     if( abr <= abi )
  2901.     {
  2902.         if(abi == 0)
  2903.             Fatal("complex division by zero");
  2904.         ratio = b->dreal / b->dimag ;
  2905.         den = b->dimag * (1 + ratio*ratio);
  2906.         c->dreal = (a->dreal*ratio + a->dimag) / den;
  2907.         c->dimag = (a->dimag*ratio - a->dreal) / den;
  2908.     }
  2909.  
  2910.     else
  2911.     {
  2912.         ratio = b->dimag / b->dreal ;
  2913.         den = b->dreal * (1 + ratio*ratio);
  2914.         c->dreal = (a->dreal + a->dimag*ratio) / den;
  2915.         c->dimag = (a->dimag - a->dreal*ratio) / den;
  2916.     }
  2917. }
  2918.