home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD2.bin / bbs / gnu / f2c-1993.04.28-src.lha / f2c-1993.04.28 / src / expr.c < prev    next >
C/C++ Source or Header  |  1993-04-28  |  61KB  |  3,043 lines
  1. /****************************************************************
  2. Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "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. extern int htype;
  38.  
  39. /* little routines to create constant blocks */
  40.  
  41. Constp mkconst(t)
  42. register int t;
  43. {
  44.     register Constp p;
  45.  
  46.     p = ALLOC(Constblock);
  47.     p->tag = TCONST;
  48.     p->vtype = t;
  49.     return(p);
  50. }
  51.  
  52.  
  53. /* mklogcon -- Make Logical Constant */
  54.  
  55. expptr mklogcon(l)
  56. register int l;
  57. {
  58.     register Constp  p;
  59.  
  60.     p = mkconst(tylog);
  61.     p->Const.ci = l;
  62.     return( (expptr) p );
  63. }
  64.  
  65.  
  66.  
  67. /* mkintcon -- Make Integer Constant */
  68.  
  69. expptr mkintcon(l)
  70. ftnint l;
  71. {
  72.     register Constp p;
  73.  
  74.     p = mkconst(tyint);
  75.     p->Const.ci = l;
  76.     return( (expptr) p );
  77. }
  78.  
  79.  
  80.  
  81.  
  82. /* mkaddcon -- Make Address Constant, given integer value */
  83.  
  84. expptr mkaddcon(l)
  85. register long l;
  86. {
  87.     register Constp p;
  88.  
  89.     p = mkconst(TYADDR);
  90.     p->Const.ci = l;
  91.     return( (expptr) p );
  92. }
  93.  
  94.  
  95.  
  96. /* mkrealcon -- Make Real Constant.  The type t is assumed
  97.    to be TYREAL or TYDREAL */
  98.  
  99. expptr mkrealcon(t, d)
  100.  register int t;
  101.  char *d;
  102. {
  103.     register Constp p;
  104.  
  105.     p = mkconst(t);
  106.     p->Const.cds[0] = cds(d,CNULL);
  107.     p->vstg = 1;
  108.     return( (expptr) p );
  109. }
  110.  
  111.  
  112. /* mkbitcon -- Make bit constant.  Reads the input string, which is
  113.    assumed to correctly specify a number in base 2^shift (where   shift
  114.    is the input parameter).   shift   may not exceed 4, i.e. only binary,
  115.    quad, octal and hex bases may be input.  Constants may not exceed 32
  116.    bits, or whatever the size of (struct Constblock).ci may be. */
  117.  
  118. expptr mkbitcon(shift, leng, s)
  119. int shift;
  120. int leng;
  121. char *s;
  122. {
  123.     register Constp p;
  124.     register long x;
  125.  
  126.     p = mkconst(TYLONG);
  127.     x = 0;
  128.     while(--leng >= 0)
  129.         if(*s != ' ')
  130.             x = (x << shift) | hextoi(*s++);
  131.     /* mwm wanted to change the type to short for short constants,
  132.      * but this is dangerous -- there is no syntax for long constants
  133.      * with small values.
  134.      */
  135.     p->Const.ci = x;
  136.     return( (expptr) p );
  137. }
  138.  
  139.  
  140.  
  141.  
  142.  
  143. /* mkstrcon -- Make string constant.  Allocates storage and initializes
  144.    the memory for a copy of the input Fortran-string. */
  145.  
  146. expptr mkstrcon(l,v)
  147. int l;
  148. register char *v;
  149. {
  150.     register Constp p;
  151.     register char *s;
  152.  
  153.     p = mkconst(TYCHAR);
  154.     p->vleng = ICON(l);
  155.     p->Const.ccp = s = (char *) ckalloc(l+1);
  156.     p->Const.ccp1.blanks = 0;
  157.     while(--l >= 0)
  158.         *s++ = *v++;
  159.     *s = '\0';
  160.     return( (expptr) p );
  161. }
  162.  
  163.  
  164.  
  165. /* mkcxcon -- Make complex contsant.  A complex number is a pair of
  166.    values, each of which may be integer, real or double. */
  167.  
  168. expptr mkcxcon(realp,imagp)
  169. register expptr realp, imagp;
  170. {
  171.     int rtype, itype;
  172.     register Constp p;
  173.     expptr errnode();
  174.  
  175.     rtype = realp->headblock.vtype;
  176.     itype = imagp->headblock.vtype;
  177.  
  178.     if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
  179.     {
  180.         p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
  181.                 ? TYDCOMPLEX : tycomplex);
  182.         if (realp->constblock.vstg || imagp->constblock.vstg) {
  183.             p->vstg = 1;
  184.             p->Const.cds[0] = ISINT(rtype)
  185.                 ? string_num("", realp->constblock.Const.ci)
  186.                 : realp->constblock.vstg
  187.                     ? realp->constblock.Const.cds[0]
  188.                     : dtos(realp->constblock.Const.cd[0]);
  189.             p->Const.cds[1] = ISINT(itype)
  190.                 ? string_num("", imagp->constblock.Const.ci)
  191.                 : imagp->constblock.vstg
  192.                     ? imagp->constblock.Const.cds[0]
  193.                     : dtos(imagp->constblock.Const.cd[0]);
  194.             }
  195.         else {
  196.             p->Const.cd[0] = ISINT(rtype)
  197.                 ? realp->constblock.Const.ci
  198.                 : realp->constblock.Const.cd[0];
  199.             p->Const.cd[1] = ISINT(itype)
  200.                 ? imagp->constblock.Const.ci
  201.                 : imagp->constblock.Const.cd[0];
  202.             }
  203.     }
  204.     else
  205.     {
  206.         err("invalid complex constant");
  207.         p = (Constp)errnode();
  208.     }
  209.  
  210.     frexpr(realp);
  211.     frexpr(imagp);
  212.     return( (expptr) p );
  213. }
  214.  
  215.  
  216. /* errnode -- Allocate a new error block */
  217.  
  218. expptr errnode()
  219. {
  220.     struct Errorblock *p;
  221.     p = ALLOC(Errorblock);
  222.     p->tag = TERROR;
  223.     p->vtype = TYERROR;
  224.     return( (expptr) p );
  225. }
  226.  
  227.  
  228.  
  229.  
  230.  
  231. /* mkconv -- Make type conversion.  Cast expression   p   into type   t.
  232.    Note that casting to a character copies only the first sizeof(char)
  233.    bytes. */
  234.  
  235. expptr mkconv(t, p)
  236. register int t;
  237. register expptr p;
  238. {
  239.     register expptr q;
  240.     register int pt, charwarn = 1;
  241.     expptr opconv();
  242.  
  243.     if (t >= 100) {
  244.         t -= 100;
  245.         charwarn = 0;
  246.         }
  247.     if(t==TYUNKNOWN || t==TYERROR)
  248.         badtype("mkconv", t);
  249.     pt = p->headblock.vtype;
  250.  
  251. /* Casting to the same type is a no-op */
  252.  
  253.     if(t == pt)
  254.         return(p);
  255.  
  256. /* If we're casting a constant which is not in the literal table ... */
  257.  
  258.     else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR)
  259.     {
  260.         if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
  261.             /* avoid trouble with -i2 */
  262.             p->headblock.vtype = t;
  263.             return p;
  264.             }
  265.         q = (expptr) mkconst(t);
  266.         consconv(t, &q->constblock, &p->constblock );
  267.         frexpr(p);
  268.     }
  269.     else {
  270.         if (pt == TYCHAR && t != TYADDR && charwarn
  271.                 && (!halign || p->tag != TADDR
  272.                 || p->addrblock.uname_tag != UNAM_CONST))
  273.             warn(
  274.          "ichar([first char. of] char. string) assumed for conversion to numeric");
  275.         q = opconv(p, t);
  276.         }
  277.  
  278.     if(t == TYCHAR)
  279.         q->constblock.vleng = ICON(1);
  280.     return(q);
  281. }
  282.  
  283.  
  284.  
  285. /* opconv -- Convert expression   p   to type   t   using the main
  286.    expression evaluator; returns an OPCONV expression, I think  14-jun-88 mwm */
  287.  
  288. expptr opconv(p, t)
  289. expptr p;
  290. int t;
  291. {
  292.     register expptr q;
  293.  
  294.     if (t == TYSUBR)
  295.         err("illegal use of subroutine name");
  296.     q = mkexpr(OPCONV, p, ENULL);
  297.     q->headblock.vtype = t;
  298.     return(q);
  299. }
  300.  
  301.  
  302.  
  303. /* addrof -- Create an ADDR expression operation */
  304.  
  305. expptr addrof(p)
  306. expptr p;
  307. {
  308.     return( mkexpr(OPADDR, p, ENULL) );
  309. }
  310.  
  311.  
  312.  
  313. /* cpexpr - Returns a new copy of input expression   p   */
  314.  
  315. tagptr cpexpr(p)
  316. register tagptr p;
  317. {
  318.     register tagptr e;
  319.     int tag;
  320.     register chainp ep, pp;
  321.     tagptr cpblock();
  322.  
  323. /* This table depends on the ordering of the T macros, e.g. TNAME */
  324.  
  325.     static int blksize[ ] =
  326.     {
  327.         0,
  328.         sizeof(struct Nameblock),
  329.         sizeof(struct Constblock),
  330.         sizeof(struct Exprblock),
  331.         sizeof(struct Addrblock),
  332.         sizeof(struct Primblock),
  333.         sizeof(struct Listblock),
  334.         sizeof(struct Impldoblock),
  335.         sizeof(struct Errorblock)
  336.     };
  337.  
  338.     if(p == NULL)
  339.         return(NULL);
  340.  
  341. /* TNAMEs are special, and don't get copied.  Each name in the current
  342.    symbol table has a unique TNAME structure. */
  343.  
  344.     if( (tag = p->tag) == TNAME)
  345.         return(p);
  346.  
  347.     e = cpblock(blksize[p->tag], (char *)p);
  348.  
  349.     switch(tag)
  350.     {
  351.     case TCONST:
  352.         if(e->constblock.vtype == TYCHAR)
  353.         {
  354.             e->constblock.Const.ccp =
  355.                 copyn((int)e->constblock.vleng->constblock.Const.ci+1,
  356.                 e->constblock.Const.ccp);
  357.             e->constblock.vleng =
  358.                 (expptr) cpexpr(e->constblock.vleng);
  359.         }
  360.     case TERROR:
  361.         break;
  362.  
  363.     case TEXPR:
  364.         e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
  365.         e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
  366.         break;
  367.  
  368.     case TLIST:
  369.         if(pp = p->listblock.listp)
  370.         {
  371.             ep = e->listblock.listp =
  372.                 mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
  373.             for(pp = pp->nextp ; pp ; pp = pp->nextp)
  374.                 ep = ep->nextp =
  375.                     mkchain((char *)cpexpr((tagptr)pp->datap),
  376.                         CHNULL);
  377.         }
  378.         break;
  379.  
  380.     case TADDR:
  381.         e->a