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 / misc.c < prev    next >
C/C++ Source or Header  |  1993-04-28  |  18KB  |  1,055 lines
  1. /****************************************************************
  2. Copyright 1990, 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.  
  26. int oneof_stg (name, stg, mask)
  27.  Namep name;
  28.  int stg, mask;
  29. {
  30.     if (stg == STGCOMMON && name) {
  31.         if ((mask & M(STGEQUIV)))
  32.             return name->vcommequiv;
  33.         if ((mask & M(STGCOMMON)))
  34.             return !name->vcommequiv;
  35.         }
  36.     return ONEOF(stg, mask);
  37.     }
  38.  
  39.  
  40. /* op_assign -- given a binary opcode, return the associated assignment
  41.    operator */
  42.  
  43. int op_assign (opcode)
  44. int opcode;
  45. {
  46.     int retval = -1;
  47.  
  48.     switch (opcode) {
  49.         case OPPLUS: retval = OPPLUSEQ; break;
  50.     case OPMINUS: retval = OPMINUSEQ; break;
  51.     case OPSTAR: retval = OPSTAREQ; break;
  52.     case OPSLASH: retval = OPSLASHEQ; break;
  53.     case OPMOD: retval = OPMODEQ; break;
  54.     case OPLSHIFT: retval = OPLSHIFTEQ; break;
  55.     case OPRSHIFT: retval = OPRSHIFTEQ; break;
  56.     case OPBITAND: retval = OPBITANDEQ; break;
  57.     case OPBITXOR: retval = OPBITXOREQ; break;
  58.     case OPBITOR: retval = OPBITOREQ; break;
  59.     default:
  60.         erri ("op_assign:  bad opcode '%d'", opcode);
  61.         break;
  62.     } /* switch */
  63.  
  64.     return retval;
  65. } /* op_assign */
  66.  
  67.  
  68.  char *
  69. Alloc(n)    /* error-checking version of malloc */
  70.         /* ckalloc initializes memory to 0; Alloc does not */
  71.  int n;
  72. {
  73.     char errbuf[32];
  74.     register char *rv;
  75.  
  76.     rv = malloc(n);
  77.     if (!rv) {
  78.         sprintf(errbuf, "malloc(%d) failure!", n);
  79.         Fatal(errbuf);
  80.         }
  81.     return rv;
  82.     }
  83.  
  84.  
  85. cpn(n, a, b)
  86. register int n;
  87. register char *a, *b;
  88. {
  89.     while(--n >= 0)
  90.         *b++ = *a++;
  91. }
  92.  
  93.  
  94.  
  95. eqn(n, a, b)
  96. register int n;
  97. register char *a, *b;
  98. {
  99.     while(--n >= 0)
  100.         if(*a++ != *b++)
  101.             return(NO);
  102.     return(YES);
  103. }
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111. cmpstr(a, b, la, lb)    /* compare two strings */
  112. register char *a, *b;
  113. ftnint la, lb;
  114. {
  115.     register char *aend, *bend;
  116.     aend = a + la;
  117.     bend = b + lb;
  118.  
  119.  
  120.     if(la <= lb)
  121.     {
  122.         while(a < aend)
  123.             if(*a != *b)
  124.                 return( *a - *b );
  125.             else
  126.             {
  127.                 ++a;
  128.                 ++b;
  129.             }
  130.  
  131.         while(b < bend)
  132.             if(*b != ' ')
  133.                 return(' ' - *b);
  134.             else
  135.                 ++b;
  136.     }
  137.  
  138.     else
  139.     {
  140.         while(b < bend)
  141.             if(*a != *b)
  142.                 return( *a - *b );
  143.             else
  144.             {
  145.                 ++a;
  146.                 ++b;
  147.             }
  148.         while(a < aend)
  149.             if(*a != ' ')
  150.                 return(*a - ' ');
  151.             else
  152.                 ++a;
  153.     }
  154.     return(0);
  155. }
  156.  
  157.  
  158. /* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
  159.  
  160. chainp hookup(x,y)
  161. register chainp x, y;
  162. {
  163.     register chainp p;
  164.  
  165.     if(x == NULL)
  166.         return(y);
  167.  
  168.     for(p = x ; p->nextp ; p = p->nextp)
  169.         ;
  170.     p->nextp = y;
  171.     return(x);
  172. }
  173.  
  174.  
  175.  
  176. struct Listblock *mklist(p)
  177. chainp p;
  178. {
  179.     register struct Listblock *q;
  180.  
  181.     q = ALLOC(Listblock);
  182.     q->tag = TLIST;
  183.     q->listp = p;
  184.     return(q);
  185. }
  186.  
  187.  
  188. chainp mkchain(p,q)
  189. register char * p;
  190. register chainp q;
  191. {
  192.     register chainp r;
  193.  
  194.     if(chains)
  195.     {
  196.         r = chains;
  197.         chains = chains->nextp;
  198.     }
  199.     else
  200.         r = ALLOC(Chain);
  201.  
  202.     r->datap = p;
  203.     r->nextp = q;
  204.     return(r);
  205. }
  206.  
  207.  chainp
  208. revchain(next)
  209.  register chainp next;
  210. {
  211.     register chainp p, prev = 0;
  212.  
  213.     while(p = next) {
  214.         next = p->nextp;
  215.         p->nextp = prev;
  216.         prev = p;
  217.         }
  218.     return prev;
  219.     }
  220.  
  221.  
  222. /* addunder -- turn a cvarname into an external name */
  223. /* The cvarname may already end in _ (to avoid C keywords); */
  224. /* if not, it has room for appending an _. */
  225.  
  226.  char *
  227. addunder(s)
  228.  register char *s;
  229. {
  230.     register int c, i;
  231.     char *s0 = s;
  232.  
  233.     i = 0;
  234.     while(c = *s++)
  235.         if (c == '_')
  236.             i++;
  237.         else
  238.             i = 0;
  239.     if (!i) {
  240.         *s-- = 0;
  241.         *s = '_';
  242.         }
  243.     return( s0 );
  244.     }
  245.  
  246.  
  247. /* copyn -- return a new copy of the input Fortran-string */
  248.  
  249. char *copyn(n, s)
  250. register int n;
  251. register char *s;
  252. {
  253.     register char *p, *q;
  254.  
  255.     p = q = (char *) Alloc(n);
  256.     while(--n >= 0)
  257.         *q++ = *s++;
  258.     return(p);
  259. }
  260.  
  261.  
  262.  
  263. /* copys -- return a new copy of the input C-string */
  264.  
  265. char *copys(s)
  266. char *s;
  267. {
  268.     return( copyn( strlen(s)+1 , s) );
  269. }
  270.  
  271.  
  272.  
  273. /* convci -- Convert Fortran-string to integer; assumes that input is a
  274.    legal number, with no trailing blanks */
  275.  
  276. ftnint convci(n, s)
  277. register int n;
  278. register char *s;
  279. {
  280.     ftnint sum;
  281.     sum = 0;
  282.     while(n-- > 0)
  283.         sum = 10*sum + (*s++ - '0');
  284.     return(sum);
  285. }
  286.  
  287. /* convic - Convert Integer constant to string */
  288.  
  289. char *convic(n)
  290. ftnint n;
  291. {
  292.     static char s[20];
  293.     register char *t;
  294.  
  295.     s[19] = '\0';
  296.     t = s+19;
  297.  
  298.     do    {
  299.         *--t = '0' + n%10;
  300.         n /= 10;
  301.     } while(n > 0);
  302.  
  303.     return(t);
  304. }
  305.  
  306.  
  307.  
  308. /* mkname -- add a new identifier to the environment, including the closed
  309.    hash table. */
  310.  
  311. Namep mkname(s)
  312. register char *s;
  313. {
  314.     struct Hashentry *hp;
  315.     register Namep q;
  316.     register int c, hash, i;
  317.     register char *t;
  318.     char *s0;
  319.     char errbuf[64];
  320.  
  321.     hash = i = 0;
  322.     s0 = s;
  323.     while(c = *s++) {
  324.         hash += c;
  325.         if (c == '_')
  326.             i = 2;
  327.         }
  328.     if (!i && in_vector(s0,c_keywords,n_keywords) >= 0)
  329.         i = 1;
  330.     hash %= maxhash;
  331.  
  332. /* Add the name to the closed hash table */
  333.  
  334.     hp = hashtab + hash;
  335.  
  336.     while(q = hp->varp)
  337.         if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
  338.             return(q);
  339.         else if(++hp >= lasthash)
  340.             hp = hashtab;
  341.  
  342.     if(++nintnames >= maxhash-1)
  343.         many("names", 'n', maxhash);    /* Fatal error */
  344.     hp->varp = q = ALLOC(Nameblock);
  345.     hp->hashval = hash;
  346.     q->tag = TNAME;    /* TNAME means the tag type is NAME */
  347.     c = s - s0;
  348.     if (c > 7 && noextflag) {
  349.         sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
  350.             c > 36 ? "..." : "");
  351.         errext(errbuf);
  352.         }
  353.     q->fvarname = strcpy(mem(c,0), s0);
  354.     t = q->cvarname = mem(c + i + 1, 0);
  355.     s = s0;
  356.     /* add __ to the end of any name containing _ and to any C keyword */
  357.     while(*t = *s++)
  358.         t++;
  359.     if (i) {
  360.         do *t++ = '_';
  361.             while(--i > 0);
  362.         *t = 0;
  363.         }
  364.     return(q);
  365. }
  366.  
  367.  
  368. struct Labelblock *mklabel(l)
  369. ftnint l;
  370. {
  371.     register struct Labelblock *lp;
  372.  
  373.     if(l <= 0)
  374.         return(NULL);
  375.  
  376.     for(lp = labeltab ; lp < highlabtab ; ++lp)
  377.         if(lp->stateno == l)
  378.             return(lp);
  379.  
  380.     if(++highlabtab > labtabend)
  381.         many("statement labels", 's', maxstno);
  382.  
  383.     lp->stateno = l;
  384.     lp->labelno = newlabel();
  385.     lp->blklevel = 0;
  386.     lp->labused = NO;
  387.     lp->fmtlabused = NO;
  388.     lp->labdefined = NO;
  389.     lp->labinacc = NO;
  390.     lp->labtype = LABUNKNOWN;
  391.     lp->fmtstring = 0;
  392.     return(lp);
  393. }
  394.  
  395.  
  396. newlabel()
  397. {
  398.     return( ++lastlabno );
  399. }
  400.  
  401.  
  402. /* this label appears in a branch context */
  403.  
  404. struct Labelblock *execlab(stateno)
  405. ftnint stateno;
  406. {
  407.     register struct Labelblock *lp;
  408.  
  409.     if(lp = mklabel(stateno))
  410.     {
  411.         if(lp->labinacc)
  412.             warn1("illegal branch to inner block, statement label %s",
  413.                 convic(stateno) );
  414.         else if(lp->labdefined == NO)
  415.             lp->blklevel = blklevel;
  416.         if(lp->labtype == LABFORMAT)
  417.             err("may not branch to a format");
  418.         else
  419.             lp->labtype = LABEXEC;
  420.     }
  421.     else
  422.         execerr("illegal label %s", convic(stateno));
  423.  
  424.     return(lp);
  425. }
  426.  
  427.  
  428. /* find or put a name in the external symbol table */
  429.  
  430. Extsym *mkext(f,s)
  431. char *f, *s;
  432. {
  433.     Extsym *p;
  434.  
  435.     for(p = extsymtab ; p<nextext ; ++p)
  436.         if(!strcmp(s,p->cextname))
  437.             return( p );
  438.  
  439.     if(nextext >= lastext)
  440.         many("external symbols", 'x', maxext);
  441.  
  442.     nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
  443.     nextext->cextname = f == s
  444.                 ? nextext->fextname
  445.                 : strcpy(gmem(strlen(s)+1,0), s);
  446.     nextext->extstg = STGUNKNOWN;
  447.     nextext->extp = 0;
  448.     nextext->allextp = 0;
  449.     nextext->extleng = 0;
  450.     nextext->maxleng = 0;
  451.     nextext->extinit = 0;
  452.     nextext->curno = nextext->maxno = 0;
  453.     return( nextext++ );
  454. }
  455.  
  456.  
  457. Addrp builtin(t, s, dbi)
  458. int t, dbi;
  459. char *s;
  460. {
  461.     register Extsym *p;
  462.     register Addrp q;
  463.     extern chainp used_builtins;
  464.  
  465.     p = mkext(s,s);
  466.     if(p->extstg == STGUNKNOWN)
  467.         p->extstg = STGEXT;
  468.     else if