home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / f2csrc.zip / f2csrc / src / misc.c < prev    next >
C/C++ Source or Header  |  1994-03-04  |  23KB  |  1,315 lines
  1. /****************************************************************
  2. Copyright 1990, 1992 - 1994 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
  27. #ifdef KR_headers
  28. oneof_stg(name, stg, mask)
  29.     Namep name;
  30.     int stg;
  31.     int mask;
  32. #else
  33. oneof_stg(Namep name, int stg, int mask)
  34. #endif
  35. {
  36.     if (stg == STGCOMMON && name) {
  37.         if ((mask & M(STGEQUIV)))
  38.             return name->vcommequiv;
  39.         if ((mask & M(STGCOMMON)))
  40.             return !name->vcommequiv;
  41.         }
  42.     return ONEOF(stg, mask);
  43.     }
  44.  
  45.  
  46. /* op_assign -- given a binary opcode, return the associated assignment
  47.    operator */
  48.  
  49.  int
  50. #ifdef KR_headers
  51. op_assign(opcode)
  52.     int opcode;
  53. #else
  54. op_assign(int opcode)
  55. #endif
  56. {
  57.     int retval = -1;
  58.  
  59.     switch (opcode) {
  60.         case OPPLUS: retval = OPPLUSEQ; break;
  61.     case OPMINUS: retval = OPMINUSEQ; break;
  62.     case OPSTAR: retval = OPSTAREQ; break;
  63.     case OPSLASH: retval = OPSLASHEQ; break;
  64.     case OPMOD: retval = OPMODEQ; break;
  65.     case OPLSHIFT: retval = OPLSHIFTEQ; break;
  66.     case OPRSHIFT: retval = OPRSHIFTEQ; break;
  67.     case OPBITAND: retval = OPBITANDEQ; break;
  68.     case OPBITXOR: retval = OPBITXOREQ; break;
  69.     case OPBITOR: retval = OPBITOREQ; break;
  70.     default:
  71.         erri ("op_assign:  bad opcode '%d'", opcode);
  72.         break;
  73.     } /* switch */
  74.  
  75.     return retval;
  76. } /* op_assign */
  77.  
  78.  
  79.  char *
  80. #ifdef KR_headers
  81. Alloc(n)
  82.     int n;
  83. #else
  84. Alloc(int n)
  85. #endif
  86.         /* error-checking version of malloc */
  87.         /* ckalloc initializes memory to 0; Alloc does not */
  88. {
  89.     char errbuf[32];
  90.     register char *rv;
  91.  
  92.     rv = malloc(n);
  93.     if (!rv) {
  94.         sprintf(errbuf, "malloc(%d) failure!", n);
  95.         Fatal(errbuf);
  96.         }
  97.     return rv;
  98.     }
  99.  
  100.  void
  101. #ifdef KR_headers
  102. cpn(n, a, b)
  103.     register int n;
  104.     register char *a;
  105.     register char *b;
  106. #else
  107. cpn(register int n, register char *a, register char *b)
  108. #endif
  109. {
  110.     while(--n >= 0)
  111.         *b++ = *a++;
  112. }
  113.  
  114.  
  115.  int
  116. #ifdef KR_headers
  117. eqn(n, a, b)
  118.     register int n;
  119.     register char *a;
  120.     register char *b;
  121. #else
  122. eqn(register int n, register char *a, register char *b)
  123. #endif
  124. {
  125.     while(--n >= 0)
  126.         if(*a++ != *b++)
  127.             return(NO);
  128.     return(YES);
  129. }
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  int
  137. #ifdef KR_headers
  138. cmpstr(a, b, la, lb)
  139.     register char *a;
  140.     register char *b;
  141.     ftnint la;
  142.     ftnint lb;
  143. #else
  144. cmpstr(register char *a, register char *b, ftnint la, ftnint lb)
  145. #endif
  146.     /* compare two strings */
  147. {
  148.     register char *aend, *bend;
  149.     aend = a + la;
  150.     bend = b + lb;
  151.  
  152.  
  153.     if(la <= lb)
  154.     {
  155.         while(a < aend)
  156.             if(*a != *b)
  157.                 return( *a - *b );
  158.             else
  159.             {
  160.                 ++a;
  161.                 ++b;
  162.             }
  163.  
  164.         while(b < bend)
  165.             if(*b != ' ')
  166.                 return(' ' - *b);
  167.             else
  168.                 ++b;
  169.     }
  170.  
  171.     else
  172.     {
  173.         while(b < bend)
  174.             if(*a != *b)
  175.                 return( *a - *b );
  176.             else
  177.             {
  178.                 ++a;
  179.                 ++b;
  180.             }
  181.         while(a < aend)
  182.             if(*a != ' ')
  183.                 return(*a - ' ');
  184.             else
  185.                 ++a;
  186.     }
  187.     return(0);
  188. }
  189.  
  190.  
  191. /* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
  192.  
  193.  chainp
  194. #ifdef KR_headers
  195. hookup(x, y)
  196.     register chainp x;
  197.     register chainp y;
  198. #else
  199. hookup(register chainp x, register chainp y)
  200. #endif
  201. {
  202.     register chainp p;
  203.  
  204.     if(x == NULL)
  205.         return(y);
  206.  
  207.     for(p = x ; p->nextp ; p = p->nextp)
  208.         ;
  209.     p->nextp = y;
  210.     return(x);
  211. }
  212.  
  213.  
  214.  
  215.  struct Listblock *
  216. #ifdef KR_headers
  217. mklist(p)
  218.     chainp p;
  219. #else
  220. mklist(chainp p)
  221. #endif
  222. {
  223.     register struct Listblock *q;
  224.  
  225.     q = ALLOC(Listblock);
  226.     q->tag = TLIST;
  227.     q->listp = p;
  228.     return(q);
  229. }
  230.  
  231.  
  232.  chainp
  233. #ifdef KR_headers
  234. mkchain(p, q)
  235.     register char * p;
  236.     register chainp q;
  237. #else
  238. mkchain(register char * p, register chainp q)
  239. #endif
  240. {
  241.     register chainp r;
  242.  
  243.     if(chains)
  244.     {
  245.         r = chains;
  246.         chains = chains->nextp;
  247.     }
  248.     else
  249.         r = ALLOC(Chain);
  250.  
  251.     r->datap = p;
  252.     r->nextp = q;
  253.     return(r);
  254. }
  255.  
  256.  chainp
  257. #ifdef KR_headers
  258. revchain(next)
  259.     register chainp next;
  260. #else
  261. revchain(register chainp next)
  262. #endif
  263. {
  264.     register chainp p, prev = 0;
  265.  
  266.     while(p = next) {
  267.         next = p->nextp;
  268.         p->nextp = prev;
  269.         prev = p;
  270.         }
  271.     return prev;
  272.     }
  273.  
  274.  
  275. /* addunder -- turn a cvarname into an external name */
  276. /* The cvarname may already end in _ (to avoid C keywords); */
  277. /* if not, it has room for appending an _. */
  278.  
  279.  char *
  280. #ifdef KR_headers
  281. addunder(s)
  282.     register char *s;
  283. #else
  284. addunder(register char *s)
  285. #endif
  286. {
  287.     register int c, i;
  288.     char *s0 = s;
  289.  
  290.     i = 0;
  291.     while(c = *s++)
  292.         if (c == '_')
  293.             i++;
  294.         else
  295.             i = 0;
  296.     if (!i) {
  297.         *s-- = 0;
  298.         *s = '_';
  299.         }
  300.     return( s0 );
  301.     }
  302.  
  303.  
  304. /* copyn -- return a new copy of the input Fortran-string */
  305.  
  306.  char *
  307. #ifdef KR_headers
  308. copyn(n, s)
  309.     register int n;
  310.     register char *s;
  311. #else
  312. copyn(register int n, register char *s)
  313. #endif
  314. {
  315.     register char *p, *q;
  316.  
  317.     p = q = (char *) Alloc(n);
  318.     while(--n >= 0)
  319.         *q++ = *s++;
  320.     return(p);
  321. }
  322.  
  323.  
  324.  
  325. /* copys -- return a new copy of the input C-string */
  326.  
  327.  char *
  328. #ifdef KR_headers
  329. copys(s)
  330.     char *s;
  331. #else
  332. copys(char *s)
  333. #endif
  334. {
  335.     return( copyn( strlen(s)+1 , s) );
  336. }
  337.  
  338.  
  339.  
  340. /* convci -- Convert Fortran-string to integer; assumes that input is a
  341.    legal number, with no trailing blanks */
  342.  
  343.  ftnint
  344. #ifdef KR_headers
  345. convci(n, s)
  346.     register int n;
  347.     register char *s;
  348. #else
  349. convci(register int n, register char *s)
  350. #endif
  351. {
  352.     ftnint sum;
  353.     sum = 0;
  354.     while(n-- > 0)
  355.         sum = 10*sum + (*s++ - '0');
  356.     return(sum);
  357. }
  358.  
  359. /* convic - Convert Integer constant to string */
  360.  
  361.  char *
  362. #ifdef KR_headers
  363. convic(n)
  364.     ftnint n;
  365. #else
  366. convic(ftnint n)
  367. #endif
  368. {
  369.     static char s[20];
  370.     register char *t;
  371.  
  372.     s[19] = '\0';
  373.     t = s+19;
  374.  
  375.     do    {
  376.         *--t = '0' + n%10;
  377.         n /= 10;
  378.     } while(n > 0);
  379.  
  380.     return(t);
  381. }
  382.  
  383.  
  384.  
  385. /* mkname -- add a new identifier to the environment, including the closed
  386.    hash table. */
  387.  
  388.  Namep
  389. #ifdef KR_headers
  390. mkname(s)
  391.     register char *s;
  392. #else
  393. mkname(register char *s)
  394. #endif
  395. {
  396.     struct Hashentry *hp;
  397.     register Namep q;
  398.     register int c, hash, i;
  399.     register char *t;
  400.     char *s0;
  401.     char errbuf[64];
  402.  
  403.     hash = i = 0;
  404.     s0 = s;
  405.     while(c = *s++) {
  406.         hash += c;
  407.         if (c == '_')
  408.             i = 2;
  409.         }
  410.     if (!i && in_vector(s0,c_keywords,n_keywords) >= 0)
  411.         i = 1;
  412.     hash %= maxhash;
  413.  
  414. /* Add the name to the closed hash table */
  415.  
  416.     hp = hashtab + hash;
  417.  
  418.     while(q = hp->varp)
  419.         if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
  420.             return(q);
  421.         else if(++hp >= lasthash)
  422.             hp = hashtab;
  423.  
  424.     if(++nintnames >= maxhash-1)
  425.         many("names", 'n', maxhash);    /* Fatal error */
  426.     hp->varp = q = ALLOC(Nameblock);
  427.     hp->hashval = hash;
  428.     q->tag = TNAME;    /* TNAME means the tag type is NAME */
  429.     c = s - s0;
  430.     if (c > 7 && noextflag) {
  431.         sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
  432.             c > 36 ? "..." : "");
  433.         errext(errbuf);
  434.         }
  435.     q->fvarname = strcpy(mem(c,0), s0);
  436.     t = q->cvarname = mem(c + i + 1, 0);
  437.     s = s0;
  438.     /* add __ to the end of any name containing _ and to any C keyword */
  439.     while(*t = *s++)
  440.         t++;
  441.     if (i) {
  442.         do *t++ = '_';
  443.             while(--i > 0);
  444.         *t = 0;
  445.         }
  446.     return(q);
  447. }
  448.  
  449.  
  450.  struct Labelblock *
  451. #ifdef KR_headers
  452. mklabel(l)
  453.     ftnint l;
  454. #else
  455. mklabel(ftnint l)
  456. #endif
  457. {
  458.     register struct Labelblock *lp;
  459.  
  460.     if(l <= 0)
  461.         return(NULL);
  462.  
  463.     for(lp = labeltab ; lp < highlabtab ; ++lp)
  464.         if(lp->stateno == l)
  465.             return(lp);
  466.  
  467.     if(++highlabtab > labtabend)
  468.         many("statement labels", 's', maxstno);
  469.  
  470.     lp->stateno = l;
  471.     lp->labelno = newlabel();
  472.     lp->blklevel = 0;
  473.     lp->labused = NO;
  474.     lp->fmtlabused = NO;
  475.     lp->labdefined = NO;
  476.     lp->labinacc = NO;
  477.     lp->labtype = LABUNKNOWN;
  478.     lp->fmtstring = 0;
  479.     return(lp);
  480. }
  481.  
  482.  
  483.  int
  484. newlabel(Void)
  485. {
  486.     return( ++lastlabno );
  487. }
  488.  
  489.  
  490. /* this label appears in a branch context */
  491.  
  492.  struct Labelblock *
  493. #ifdef KR_headers
  494. execlab(stateno)
  495.     ftnint stateno;
  496. #else
  497. execlab(ftnint stateno)
  498. #endif
  499. {
  500.     register struct Labelblock *lp;
  501.  
  502.     if(lp = mklabel(stateno))
  503.     {
  504.         if(lp->labinacc)
  505.             warn1("illegal branch to inner block, statement label %s",
  506.                 convic(stateno) );
  507.         else if(lp->labdefined == NO)
  508.             lp->blklevel = blklevel;
  509.         if(lp->labtype == LABFORMAT)
  510.             err("may not branch to a format");
  511.         else
  512.             lp->labtype = LABEXEC;
  513.     }
  514.     else
  515.         execerr("illegal label %s", convic(stateno));
  516.  
  517.     return(lp);
  518. }
  519.  
  520.  
  521. /* find or put a name in the external symbol table */
  522.  
  523.  Extsym *
  524. #ifdef KR_headers
  525. mkext1(f, s)
  526.     char *f;
  527.     char *s;
  528. #else
  529. mkext1(char *f, char *s)
  530. #endif
  531. {
  532.     Extsym *p;
  533.  
  534.     for(p = extsymtab ; p<nextext ; ++p)
  535.         if(!strcmp(s,p->cextname))
  536.             return( p );
  537.  
  538.     if(nextext >= lastext)
  539.         many("external symbols", 'x', maxext);
  540.  
  541.     nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
  542.     nextext->cextname = f == s
  543.                 ? nextext->fextname
  544.                 : strcpy(gmem(strlen(s)+1,0), s);
  545.     nextext->extstg = STGUNKNOWN;
  546.     nextext->extp = 0;
  547.     nextext->allextp = 0;
  548.     nextext->extleng = 0;
  549.     nextext->maxleng = 0;
  550.     nextext->extinit = 0;
  551.     nextext->curno = nextext->maxno = 0;
  552.     return( nextext++ );
  553. }
  554.  
  555.  
  556.  Extsym *
  557. #ifdef KR_headers
  558. mkext(f, s)
  559.     char *f;
  560.     char *s;
  561. #else
  562. mkext(char *f, char *s)
  563. #endif
  564. {
  565.     Extsym *e = mkext1(f, s);
  566.     if (e->extstg == STGCOMMON)
  567.         errstr("%.52s cannot be a subprogram: it is a common block.",f);
  568.     return e;
  569.     }
  570.  
  571.  Addrp
  572. #ifdef KR_headers
  573. builtin(t, s, dbi)
  574.     int t;
  575.     char *s;
  576.     int dbi;
  577. #else
  578. builtin(int t, char *s, int dbi)
  579. #endif
  580. {
  581.     register Extsym *p;
  582.     register Addrp q;
  583.     extern chainp used_builtins;
  584.  
  585.     p = mkext(s,s);
  586.     if(p->extstg == STGUNKNOWN)
  587.         p->extstg = STGEXT;
  588.     else if(p->extstg != STGEXT)
  589.     {
  590.         errstr("improper use of builtin %s", s);
  591.         return(0);
  592.     }
  593.  
  594.     q = ALLOC(Addrblock);
  595.     q->tag = TADDR;
  596.     q->vtype = t;
  597.     q->vclass = CLPROC;
  598.     q->vstg = STGEXT;
  599.     q->memno = p - extsymtab;
  600.     q->dbl_builtin = dbi;
  601.  
  602. /* A NULL pointer here tells you to use   memno   to check the external
  603.    symbol table */
  604.  
  605.     q -> uname_tag = UNAM_EXTERN;
  606.  
  607. /* Add to the list of used builtins */
  608.  
  609.     if (dbi >= 0)
  610.         add_extern_to_list (q, &used_builtins);
  611.     return(q);
  612. }
  613.  
  614.  
  615.  void
  616. #ifdef KR_headers
  617. add_extern_to_list(addr, list_store)
  618.     Addrp addr;
  619.     chainp *list_store;
  620. #else
  621. add_extern_to_list(Addrp addr, chainp *list_store)
  622. #endif
  623. {
  624.     chainp last = CHNULL;
  625.     chainp list;
  626.     int memno;
  627.  
  628.     if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
  629.     return;
  630.  
  631.     list = *list_store;
  632.     memno = addr -> memno;
  633.  
  634.     for (;list; last = list, list = list -> nextp) {
  635.     Addrp this = (Addrp) (list -> datap);
  636.  
  637.     if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN &&
  638.         this -> memno == memno)
  639.         return;
  640.     } /* for */
  641.  
  642.     if (*list_store == CHNULL)
  643.     *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
  644.     else
  645.     last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
  646.  
  647. } /* add_extern_to_list */
  648.  
  649.  
  650.  void
  651. #ifdef KR_headers
  652. frchain(p)
  653.     register chainp *p;
  654. #else
  655. frchain(register chainp *p)
  656. #endif
  657. {
  658.     register chainp q;
  659.  
  660.     if(p==0 || *p==0)
  661.         return;
  662.  
  663.     for(q = *p; q->nextp ; q = q->nextp)
  664.         ;
  665.     q->nextp = chains;
  666.     chains = *p;
  667.     *p = 0;
  668. }
  669.  
  670.  void
  671. #ifdef KR_headers
  672. frexchain(p)
  673.     register chainp *p;
  674. #else
  675. frexchain(register chainp *p)
  676. #endif
  677. {
  678.     register chainp q, r;
  679.  
  680.     if (q = *p) {
  681.         for(;;q = r) {
  682.             frexpr((expptr)q->datap);
  683.             if (!(r = q->nextp))
  684.                 break;
  685.             }
  686.         q->nextp = chains;
  687.         chains = *p;
  688.         *p = 0;
  689.         }
  690.     }
  691.  
  692.  
  693.  tagptr
  694. #ifdef KR_headers
  695. cpblock(n, p)
  696.     register int n;
  697.     register char *p;
  698. #else
  699. cpblock(register int n, register char *p)
  700. #endif
  701. {
  702.     register ptr q;
  703.  
  704.     memcpy((char *)(q = ckalloc(n)), (char *)p, n);
  705.     return( (tagptr) q);
  706. }
  707.  
  708.  
  709.  
  710.  ftnint
  711. #ifdef KR_headers
  712. lmax(a, b)
  713.     ftnint a;
  714.     ftnint b;
  715. #else
  716. lmax(ftnint a, ftnint b)
  717. #endif
  718. {
  719.     return( a>b ? a : b);
  720. }
  721.  
  722.  ftnint
  723. #ifdef KR_headers
  724. lmin(a, b)
  725.     ftnint a;
  726.     ftnint b;
  727. #else
  728. lmin(ftnint a, ftnint b)
  729. #endif
  730. {
  731.     return(a < b ? a : b);
  732. }
  733.  
  734.  
  735.  
  736.  
  737. #ifdef KR_headers
  738. maxtype(t1, t2)
  739.     int t1;
  740.     int t2;
  741. #else
  742. maxtype(int t1, int t2)
  743. #endif
  744. {
  745.     int t;
  746.  
  747.     t = t1 >= t2 ? t1 : t2;
  748.     if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
  749.         t = TYDCOMPLEX;
  750.     return(t);
  751. }
  752.  
  753.  
  754.  
  755. /* return log base 2 of n if n a power of 2; otherwise -1 */
  756.  int
  757. #ifdef KR_headers
  758. log_2(n)
  759.     ftnint n;
  760. #else
  761. log_2(ftnint n)
  762. #endif
  763. {
  764.     int k;
  765.  
  766.     /* trick based on binary representation */
  767.  
  768.     if(n<=0 || (n & (n-1))!=0)
  769.         return(-1);
  770.  
  771.     for(k = 0 ;  n >>= 1  ; ++k)
  772.         ;
  773.     return(k);
  774. }
  775.  
  776.  
  777.  void
  778. frrpl(Void)
  779. {
  780.     struct Rplblock *rp;
  781.  
  782.     while(rpllist)
  783.     {
  784.         rp = rpllist->rplnextp;
  785.         free( (charptr) rpllist);
  786.         rpllist = rp;
  787.     }
  788. }
  789.  
  790.  
  791.  
  792. /* Call a Fortran function with an arbitrary list of arguments */
  793.  
  794. int callk_kludge;
  795.  
  796.  expptr
  797. #ifdef KR_headers
  798. callk(type, name, args)
  799.     int type;
  800.     char *name;
  801.     chainp args;
  802. #else
  803. callk(int type, char *name, chainp args)
  804. #endif
  805. {
  806.     register expptr p;
  807.  
  808.     p = mkexpr(OPCALL,
  809.         (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
  810.         (expptr)args);
  811.     p->exprblock.vtype = type;
  812.     return(p);
  813. }
  814.  
  815.  
  816.  
  817.  expptr
  818. #ifdef KR_headers
  819. call4(type, name, arg1, arg2, arg3, arg4)
  820.     int type;
  821.     char *name;
  822.     expptr arg1;
  823.     expptr arg2;
  824.     expptr arg3;
  825.     expptr arg4;
  826. #else
  827. call4(int type, char *name, expptr arg1, expptr arg2, expptr arg3, expptr arg4)
  828. #endif
  829. {
  830.     struct Listblock *args;
  831.     args = mklist( mkchain((char *)arg1,
  832.             mkchain((char *)arg2,
  833.                 mkchain((char *)arg3,
  834.                         mkchain((char *)arg4, CHNULL)) ) ) );
  835.     return( callk(type, name, (chainp)args) );
  836. }
  837.  
  838.  
  839.  
  840.  
  841.  expptr
  842. #ifdef KR_headers
  843. call3(type, name, arg1, arg2, arg3)
  844.     int type;
  845.     char *name;
  846.     expptr arg1;
  847.     expptr arg2;
  848.     expptr arg3;
  849. #else
  850. call3(int type, char *name, expptr arg1, expptr arg2, expptr arg3)
  851. #endif
  852. {
  853.     struct Listblock *args;
  854.     args = mklist( mkchain((char *)arg1,
  855.             mkchain((char *)arg2,
  856.                 mkchain((char *)arg3, CHNULL) ) ) );
  857.     return( callk(type, name, (chainp)args) );
  858. }
  859.  
  860.  
  861.  
  862.  
  863.  
  864.  expptr
  865. #ifdef KR_headers
  866. call2(type, name, arg1, arg2)
  867.     int type;
  868.     char *name;
  869.     expptr arg1;
  870.     expptr arg2;
  871. #else
  872. call2(int type, char *name, expptr arg1, expptr arg2)
  873. #endif
  874. {
  875.     struct Listblock *args;
  876.  
  877.     args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
  878.     return( callk(type,name, (chainp)args) );
  879. }
  880.  
  881.  
  882.  
  883.  
  884.  expptr
  885. #ifdef KR_headers
  886. call1(type, name, arg)
  887.     int type;
  888.     char *name;
  889.     expptr arg;
  890. #else
  891. call1(int type, char *name, expptr arg)
  892. #endif
  893. {
  894.     return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
  895. }
  896.  
  897.  
  898.  expptr
  899. #ifdef KR_headers
  900. call0(type, name)
  901.     int type;
  902.     char *name;
  903. #else
  904. call0(int type, char *name)
  905. #endif
  906. {
  907.     return( callk(type, name, CHNULL) );
  908. }
  909.  
  910.  
  911.  
  912.  struct Impldoblock *
  913. #ifdef KR_headers
  914. mkiodo(dospec, list)
  915.     chainp dospec;
  916.     chainp list;
  917. #else
  918. mkiodo(chainp dospec, chainp list)
  919. #endif
  920. {
  921.     register struct Impldoblock *q;
  922.  
  923.     q = ALLOC(Impldoblock);
  924.     q->tag = TIMPLDO;
  925.     q->impdospec = dospec;
  926.     q->datalist = list;
  927.     return(q);
  928. }
  929.  
  930.  
  931.  
  932.  
  933. /* ckalloc -- Allocate 1 memory unit of size   n,   checking for out of
  934.    memory error */
  935.  
  936.  ptr
  937. #ifdef KR_headers
  938. ckalloc(n)
  939.     register int n;
  940. #else
  941. ckalloc(register int n)
  942. #endif
  943. {
  944.     register ptr p;
  945.     p = (ptr)calloc(1, (unsigned) n);
  946.     if (p || !n)
  947.         return(p);
  948.     fprintf(stderr, "failing to get %d bytes\n",n);
  949.     Fatal("out of memory");
  950.     /* NOT REACHED */ return 0;
  951. }
  952.  
  953.  
  954.  int
  955. #ifdef KR_headers
  956. isaddr(p)
  957.     register expptr p;
  958. #else
  959. isaddr(register expptr p)
  960. #endif
  961. {
  962.     if(p->tag == TADDR)
  963.         return(YES);
  964.     if(p->tag == TEXPR)
  965.         switch(p->exprblock.opcode)
  966.         {
  967.         case OPCOMMA:
  968.             return( isaddr(p->exprblock.rightp) );
  969.  
  970.         case OPASSIGN:
  971.         case OPASSIGNI:
  972.         case OPPLUSEQ:
  973.         case OPMINUSEQ:
  974.         case OPSLASHEQ:
  975.         case OPMODEQ:
  976.         case OPLSHIFTEQ:
  977.         case OPRSHIFTEQ:
  978.         case OPBITANDEQ:
  979.         case OPBITXOREQ:
  980.         case OPBITOREQ:
  981.             return( isaddr(p->exprblock.leftp) );
  982.         }
  983.     return(NO);
  984. }
  985.  
  986.  
  987.  
  988.  int
  989. #ifdef KR_headers
  990. isstatic(p)
  991.     register expptr p;
  992. #else
  993. isstatic(register expptr p)
  994. #endif
  995. {
  996.     extern int useauto;
  997.     if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
  998.         return(NO);
  999.  
  1000.     switch(p->tag)
  1001.     {
  1002.     case TCONST:
  1003.         return(YES);
  1004.  
  1005.     case TADDR:
  1006.         if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
  1007.             ISCONST(p->addrblock.memoffset) && !useauto)
  1008.             return(YES);
  1009.  
  1010.     default:
  1011.         return(NO);
  1012.     }
  1013. }
  1014.  
  1015.  
  1016.  
  1017. /* addressable -- return True iff it is a constant value, or can be
  1018.    referenced by constant values */
  1019.  
  1020.  int
  1021. #ifdef KR_headers
  1022. addressable(p)
  1023.     register expptr p;
  1024. #else
  1025. addressable(register expptr p)
  1026. #endif
  1027. {
  1028.     switch(p->tag)
  1029.     {
  1030.     case TCONST:
  1031.         return(YES);
  1032.  
  1033.     case TADDR:
  1034.         return( addressable(p->addrblock.memoffset) );
  1035.  
  1036.     default:
  1037.         return(NO);
  1038.     }
  1039. }
  1040.  
  1041.  
  1042. /* isnegative_const -- returns true if the constant is negative.  Returns
  1043.    false for imaginary and nonnumeric constants */
  1044.  
  1045.  int
  1046. #ifdef KR_headers
  1047. isnegative_const(cp)
  1048.     struct Constblock *cp;
  1049. #else
  1050. isnegative_const(struct Constblock *cp)
  1051. #endif
  1052. {
  1053.     int retval;
  1054.  
  1055.     if (cp == NULL)
  1056.     return 0;
  1057.  
  1058.     switch (cp -> vtype) {
  1059.     case TYINT1:
  1060.         case TYSHORT:
  1061.     case TYLONG:
  1062. #ifdef TYQUAD
  1063.     case TYQUAD:
  1064. #endif
  1065.         retval = cp -> Const.ci < 0;
  1066.         break;
  1067.     case TYREAL:
  1068.     case TYDREAL:
  1069.         retval = cp->vstg ? *cp->Const.cds[0] == '-'
  1070.                   :  cp->Const.cd[0] < 0.0;
  1071.         break;
  1072.     default:
  1073.  
  1074.         retval = 0;
  1075.         break;
  1076.     } /* switch */
  1077.  
  1078.     return retval;
  1079. } /* isnegative_const */
  1080.  
  1081.  void
  1082. #ifdef KR_headers
  1083. negate_const(cp)
  1084.     Constp cp;
  1085. #else
  1086. negate_const(Constp cp)
  1087. #endif
  1088. {
  1089.     if (cp == (struct Constblock *) NULL)
  1090.     return;
  1091.  
  1092.     switch (cp -> vtype) {
  1093.     case TYINT1:
  1094.     case TYSHORT:
  1095.     case TYLONG:
  1096. #ifdef TYQUAD
  1097.     case TYQUAD:
  1098. #endif
  1099.         cp -> Const.ci = - cp -> Const.ci;
  1100.         break;
  1101.     case TYCOMPLEX:
  1102.     case TYDCOMPLEX:
  1103.         if (cp->vstg)
  1104.             switch(*cp->Const.cds[1]) {
  1105.             case '-':
  1106.                 ++cp->Const.cds[1];
  1107.                 break;
  1108.             case '0':
  1109.                 break;
  1110.             default:
  1111.                 --cp->Const.cds[1];
  1112.             }
  1113.         else
  1114.                 cp->Const.cd[1] = -cp->Const.cd[1];
  1115.         /* no break */
  1116.     case TYREAL:
  1117.     case TYDREAL:
  1118.         if (cp->vstg)
  1119.             switch(*cp->Const.cds[0]) {
  1120.             case '-':
  1121.                 ++cp->Const.cds[0];
  1122.                 break;
  1123.             case '0':
  1124.                 break;
  1125.             default:
  1126.                 --cp->Const.cds[0];
  1127.             }
  1128.         else
  1129.                 cp->Const.cd[0] = -cp->Const.cd[0];
  1130.         break;
  1131.     case TYCHAR:
  1132.     case TYLOGICAL1:
  1133.     case TYLOGICAL2:
  1134.     case TYLOGICAL:
  1135.         erri ("negate_const:  can't negate type '%d'", cp -> vtype);
  1136.         break;
  1137.     default:
  1138.         erri ("negate_const:  bad type '%d'",
  1139.             cp -> vtype);
  1140.         break;
  1141.     } /* switch */
  1142. } /* negate_const */
  1143.  
  1144.  void
  1145. #ifdef KR_headers
  1146. ffilecopy(infp, outfp)
  1147.     FILE *infp;
  1148.     FILE *outfp;
  1149. #else
  1150. ffilecopy(FILE *infp, FILE *outfp)
  1151. #endif
  1152. {
  1153.     while (!feof (infp)) {
  1154.     register c = getc (infp);
  1155.     if (!feof (infp))
  1156.     putc (c, outfp);
  1157.     } /* while */
  1158. } /* ffilecopy */
  1159.  
  1160.  
  1161. /* in_vector -- verifies whether   str   is in c_keywords.
  1162.    If so, the index is returned else  -1  is returned.
  1163.    c_keywords must be in alphabetical order (as defined by strcmp).
  1164. */
  1165.  
  1166.  int
  1167. #ifdef KR_headers
  1168. in_vector(str, keywds, n)
  1169.     char *str;
  1170.     char **keywds;
  1171.     register int n;
  1172. #else
  1173. in_vector(char *str, char **keywds, register int n)
  1174. #endif
  1175. {
  1176.     register char **K = keywds;
  1177.     register int n1, t;
  1178.  
  1179.     do {
  1180.         n1 = n >> 1;
  1181.         if (!(t = strcmp(str, K[n1])))
  1182.             return K - keywds + n1;
  1183.         if (t < 0)
  1184.             n = n1;
  1185.         else {
  1186.             n -= ++n1;
  1187.             K += n1;
  1188.             }
  1189.         }
  1190.         while(n > 0);
  1191.  
  1192.     return -1;
  1193.     } /* in_vector */
  1194.  
  1195.  
  1196.  int
  1197. #ifdef KR_headers
  1198. is_negatable(Const)
  1199.     Constp Const;
  1200. #else
  1201. is_negatable(Constp Const)
  1202. #endif
  1203. {
  1204.     int retval = 0;
  1205.     if (Const != (Constp) NULL)
  1206.     switch (Const -> vtype) {
  1207.         case TYINT1:
  1208.         retval = Const -> Const.ci >= -BIGGEST_CHAR;
  1209.         break;
  1210.         case TYSHORT:
  1211.             retval = Const -> Const.ci >= -BIGGEST_SHORT;
  1212.             break;
  1213.         case TYLONG:
  1214. #ifdef TYQUAD
  1215.         case TYQUAD:
  1216. #endif
  1217.             retval = Const -> Const.ci >= -BIGGEST_LONG;
  1218.             break;
  1219.         case TYREAL:
  1220.         case TYDREAL:
  1221.         case TYCOMPLEX:
  1222.         case TYDCOMPLEX:
  1223.             retval = 1;
  1224.             break;
  1225.         case TYLOGICAL1:
  1226.         case TYLOGICAL2:
  1227.         case TYLOGICAL:
  1228.         case TYCHAR:
  1229.         case TYSUBR:
  1230.         default:
  1231.             retval = 0;
  1232.             break;
  1233.     } /* switch */
  1234.  
  1235.     return retval;
  1236. } /* is_negatable */
  1237.  
  1238.  void
  1239. #ifdef KR_headers
  1240. backup(fname, bname)
  1241.     char *fname;
  1242.     char *bname;
  1243. #else
  1244. backup(char *fname, char *bname)
  1245. #endif
  1246. {
  1247.     FILE *b, *f;
  1248.     static char couldnt[] = "Couldn't open %.80s";
  1249.  
  1250.     if (!(f = fopen(fname, binread))) {
  1251.         warn1(couldnt, fname);
  1252.         return;
  1253.         }
  1254.     if (!(b = fopen(bname, binwrite))) {
  1255.         warn1(couldnt, bname);
  1256.         return;
  1257.         }
  1258.     ffilecopy(f, b);
  1259.     fclose(f);
  1260.     fclose(b);
  1261.     }
  1262.  
  1263.  
  1264. /* struct_eq -- returns YES if structures have the same field names and
  1265.    types, NO otherwise */
  1266.  
  1267.  int
  1268. #ifdef KR_headers
  1269. struct_eq(s1, s2)
  1270.     chainp s1;
  1271.     chainp s2;
  1272. #else
  1273. struct_eq(chainp s1, chainp s2)
  1274. #endif
  1275. {
  1276.     struct Dimblock *d1, *d2;
  1277.     Constp cp1, cp2;
  1278.  
  1279.     if (s1 == CHNULL && s2 == CHNULL)
  1280.     return YES;
  1281.     for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
  1282.     register Namep v1 = (Namep) s1 -> datap;
  1283.     register Namep v2 = (Namep) s2 -> datap;
  1284.  
  1285.     if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
  1286.         v2 == (Namep) NULL || v2 -> tag != TNAME)
  1287.         return NO;
  1288.  
  1289.     if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
  1290.         || strcmp(v1->fvarname, v2->fvarname))
  1291.         return NO;
  1292.  
  1293.     /* compare dimensions (needed for comparing COMMON blocks) */
  1294.  
  1295.     if (d1 = v1->vdim) {
  1296.         if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST)
  1297.             return NO;
  1298.         if (!(d2 = v2->vdim))
  1299.             if (cp1->Const.ci == 1)
  1300.                 continue;
  1301.             else
  1302.                 return NO;
  1303.         if (!(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
  1304.         ||  cp1->Const.ci != cp2->Const.ci)
  1305.             return NO;
  1306.         }
  1307.     else if ((d2 = v2->vdim) && (!(cp2 = (Constp)d2->nelt)
  1308.                 || cp2->tag != TCONST
  1309.                 || cp2->Const.ci != 1))
  1310.         return NO;
  1311.     } /* while s1 != CHNULL && s2 != CHNULL */
  1312.  
  1313.     return s1 == CHNULL && s2 == CHNULL;
  1314. } /* struct_eq */
  1315.