00001 /****************************************************************
00002 Copyright 1990, 1992 - 1995 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "defs.h"
00025 #include "limits.h"
00026 
00027  int
00028 #ifdef KR_headers
00029 oneof_stg(name, stg, mask)
00030         Namep name;
00031         int stg;
00032         int mask;
00033 #else
00034 oneof_stg(Namep name, int stg, int mask)
00035 #endif
00036 {
00037         if (stg == STGCOMMON && name) {
00038                 if ((mask & M(STGEQUIV)))
00039                         return name->vcommequiv;
00040                 if ((mask & M(STGCOMMON)))
00041                         return !name->vcommequiv;
00042                 }
00043         return ONEOF(stg, mask);
00044         }
00045 
00046 
00047 /* op_assign -- given a binary opcode, return the associated assignment
00048    operator */
00049 
00050  int
00051 #ifdef KR_headers
00052 op_assign(opcode)
00053         int opcode;
00054 #else
00055 op_assign(int opcode)
00056 #endif
00057 {
00058     int retval = -1;
00059 
00060     switch (opcode) {
00061         case OPPLUS: retval = OPPLUSEQ; break;
00062         case OPMINUS: retval = OPMINUSEQ; break;
00063         case OPSTAR: retval = OPSTAREQ; break;
00064         case OPSLASH: retval = OPSLASHEQ; break;
00065         case OPMOD: retval = OPMODEQ; break;
00066         case OPLSHIFT: retval = OPLSHIFTEQ; break;
00067         case OPRSHIFT: retval = OPRSHIFTEQ; break;
00068         case OPBITAND: retval = OPBITANDEQ; break;
00069         case OPBITXOR: retval = OPBITXOREQ; break;
00070         case OPBITOR: retval = OPBITOREQ; break;
00071         default:
00072             erri ("op_assign:  bad opcode '%d'", opcode);
00073             break;
00074     } /* switch */
00075 
00076     return retval;
00077 } /* op_assign */
00078 
00079 
00080  char *
00081 #ifdef KR_headers
00082 Alloc(n)
00083         int n;
00084 #else
00085 Alloc(int n)
00086 #endif
00087                 /* error-checking version of malloc */
00088                 /* ckalloc initializes memory to 0; Alloc does not */
00089 {
00090         char errbuf[32];
00091         register char *rv;
00092 
00093         rv = (char*) malloc(n);
00094         if (!rv) {
00095                 sprintf(errbuf, "malloc(%d) failure!", n);
00096                 Fatal(errbuf);
00097                 }
00098         return rv;
00099         }
00100 
00101  void
00102 #ifdef KR_headers
00103 cpn(n, a, b)
00104         register int n;
00105         register char *a;
00106         register char *b;
00107 #else
00108 cpn(register int n, register char *a, register char *b)
00109 #endif
00110 {
00111         while(--n >= 0)
00112                 *b++ = *a++;
00113 }
00114 
00115 
00116  int
00117 #ifdef KR_headers
00118 eqn(n, a, b)
00119         register int n;
00120         register char *a;
00121         register char *b;
00122 #else
00123 eqn(register int n, register char *a, register char *b)
00124 #endif
00125 {
00126         while(--n >= 0)
00127                 if(*a++ != *b++)
00128                         return(NO);
00129         return(YES);
00130 }
00131 
00132 
00133 
00134 
00135 
00136 
00137  int
00138 #ifdef KR_headers
00139 cmpstr(a, b, la, lb)
00140         register char *a;
00141         register char *b;
00142         ftnint la;
00143         ftnint lb;
00144 #else
00145 cmpstr(register char *a, register char *b, ftnint la, ftnint lb)
00146 #endif
00147         /* compare two strings */
00148 {
00149         register char *aend, *bend;
00150         aend = a + la;
00151         bend = b + lb;
00152 
00153 
00154         if(la <= lb)
00155         {
00156                 while(a < aend)
00157                         if(*a != *b)
00158                                 return( *a - *b );
00159                         else
00160                         {
00161                                 ++a;
00162                                 ++b;
00163                         }
00164 
00165                 while(b < bend)
00166                         if(*b != ' ')
00167                                 return(' ' - *b);
00168                         else
00169                                 ++b;
00170         }
00171 
00172         else
00173         {
00174                 while(b < bend)
00175                         if(*a != *b)
00176                                 return( *a - *b );
00177                         else
00178                         {
00179                                 ++a;
00180                                 ++b;
00181                         }
00182                 while(a < aend)
00183                         if(*a != ' ')
00184                                 return(*a - ' ');
00185                         else
00186                                 ++a;
00187         }
00188         return(0);
00189 }
00190 
00191 
00192 /* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
00193 
00194  chainp
00195 #ifdef KR_headers
00196 hookup(x, y)
00197         register chainp x;
00198         register chainp y;
00199 #else
00200 hookup(register chainp x, register chainp y)
00201 #endif
00202 {
00203         register chainp p;
00204 
00205         if(x == NULL)
00206                 return(y);
00207 
00208         for(p = x ; p->nextp ; p = p->nextp)
00209                 ;
00210         p->nextp = y;
00211         return(x);
00212 }
00213 
00214 
00215 
00216  struct Listblock *
00217 #ifdef KR_headers
00218 mklist(p)
00219         chainp p;
00220 #else
00221 mklist(chainp p)
00222 #endif
00223 {
00224         register struct Listblock *q;
00225 
00226         q = ALLOC(Listblock);
00227         q->tag = TLIST;
00228         q->listp = p;
00229         return(q);
00230 }
00231 
00232 
00233  chainp
00234 #ifdef KR_headers
00235 mkchain(p, q)
00236         register char * p;
00237         register chainp q;
00238 #else
00239 mkchain(register char * p, register chainp q)
00240 #endif
00241 {
00242         register chainp r;
00243 
00244         if(chains)
00245         {
00246                 r = chains;
00247                 chains = chains->nextp;
00248         }
00249         else
00250                 r = ALLOC(Chain);
00251 
00252         r->datap = p;
00253         r->nextp = q;
00254         return(r);
00255 }
00256 
00257  chainp
00258 #ifdef KR_headers
00259 revchain(next)
00260         register chainp next;
00261 #else
00262 revchain(register chainp next)
00263 #endif
00264 {
00265         register chainp p, prev = 0;
00266 
00267         while(p = next) {
00268                 next = p->nextp;
00269                 p->nextp = prev;
00270                 prev = p;
00271                 }
00272         return prev;
00273         }
00274 
00275 
00276 /* addunder -- turn a cvarname into an external name */
00277 /* The cvarname may already end in _ (to avoid C keywords); */
00278 /* if not, it has room for appending an _. */
00279 
00280  char *
00281 #ifdef KR_headers
00282 addunder(s)
00283         register char *s;
00284 #else
00285 addunder(register char *s)
00286 #endif
00287 {
00288         register int c, i, j;
00289         char *s0 = s;
00290 
00291         i = j = 0;
00292         while(c = *s++)
00293                 if (c == '_')
00294                         i++, j++;
00295                 else
00296                         i = 0;
00297         if (!i) {
00298                 *s-- = 0;
00299                 *s = '_';
00300                 }
00301         else if (j == 2)
00302                 s[-2] = 0;
00303         return( s0 );
00304         }
00305 
00306 
00307 /* copyn -- return a new copy of the input Fortran-string */
00308 
00309  char *
00310 #ifdef KR_headers
00311 copyn(n, s)
00312         register int n;
00313         register char *s;
00314 #else
00315 copyn(register int n, register char *s)
00316 #endif
00317 {
00318         register char *p, *q;
00319 
00320         p = q = (char *) Alloc(n);
00321         while(--n >= 0)
00322                 *q++ = *s++;
00323         return(p);
00324 }
00325 
00326 
00327 
00328 /* copys -- return a new copy of the input C-string */
00329 
00330  char *
00331 #ifdef KR_headers
00332 copys(s)
00333         char *s;
00334 #else
00335 copys(char *s)
00336 #endif
00337 {
00338         return( copyn( strlen(s)+1 , s) );
00339 }
00340 
00341 
00342 
00343 /* convci -- Convert Fortran-string to integer; assumes that input is a
00344    legal number, with no trailing blanks */
00345 
00346  ftnint
00347 #ifdef KR_headers
00348 convci(n, s)
00349         register int n;
00350         register char *s;
00351 #else
00352 convci(register int n, register char *s)
00353 #endif
00354 {
00355         ftnint sum, t;
00356         char buff[100], *s0;
00357         int n0;
00358 
00359         s0 = s;
00360         n0 = n;
00361         sum = 0;
00362         while(n-- > 0) {
00363                 /* sum = 10*sum + (*s++ - '0'); */
00364                 t = *s++ - '0';
00365                 if (sum > LONG_MAX/10) {
00366  ovfl:
00367                         if (n0 > 60)
00368                                 n0 = 60;
00369                         sprintf(buff, "integer constant %.*s truncated.",
00370                                 n0, s0);
00371                         err(buff);
00372                         return LONG_MAX;
00373                         }
00374                 sum *= 10;
00375                 if (sum > LONG_MAX - t)
00376                         goto ovfl;
00377                 sum += t;
00378                 }
00379         return(sum);
00380         }
00381 
00382 /* convic - Convert Integer constant to string */
00383 
00384  char *
00385 #ifdef KR_headers
00386 convic(n)
00387         ftnint n;
00388 #else
00389 convic(ftnint n)
00390 #endif
00391 {
00392         static char s[20];
00393         register char *t;
00394 
00395         s[19] = '\0';
00396         t = s+19;
00397 
00398         do      {
00399                 *--t = '0' + n%10;
00400                 n /= 10;
00401         } while(n > 0);
00402 
00403         return(t);
00404 }
00405 
00406 
00407 
00408 /* mkname -- add a new identifier to the environment, including the closed
00409    hash table. */
00410 
00411  Namep
00412 #ifdef KR_headers
00413 mkname(s)
00414         register char *s;
00415 #else
00416 mkname(register char *s)
00417 #endif
00418 {
00419         struct Hashentry *hp;
00420         register Namep q;
00421         register int c, hash, i;
00422         register char *t;
00423         char *s0;
00424         char errbuf[64];
00425 
00426         hash = i = 0;
00427         s0 = s;
00428         while(c = *s++) {
00429                 hash += c;
00430                 if (c == '_')
00431                         i = 2;
00432                 }
00433         if (!i && in_vector(s0,c_keywords,n_keywords) >= 0)
00434                 i = 2;
00435         hash %= maxhash;
00436 
00437 /* Add the name to the closed hash table */
00438 
00439         hp = hashtab + hash;
00440 
00441         while(q = hp->varp)
00442                 if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
00443                         return(q);
00444                 else if(++hp >= lasthash)
00445                         hp = hashtab;
00446 
00447         if(++nintnames >= maxhash-1)
00448                 many("names", 'n', maxhash);    /* Fatal error */
00449         hp->varp = q = ALLOC(Nameblock);
00450         hp->hashval = hash;
00451         q->tag = TNAME; /* TNAME means the tag type is NAME */
00452         c = s - s0;
00453         if (c > 7 && noextflag) {
00454                 sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
00455                         c > 36 ? "..." : "");
00456                 errext(errbuf);
00457                 }
00458         q->fvarname = strcpy(mem(c,0), s0);
00459         t = q->cvarname = mem(c + i + 1, 0);
00460         s = s0;
00461         /* add __ to the end of any name containing _ and to any C keyword */
00462         while(*t = *s++)
00463                 t++;
00464         if (i) {
00465                 do *t++ = '_';
00466                         while(--i > 0);
00467                 *t = 0;
00468                 }
00469         return(q);
00470 }
00471 
00472 
00473  struct Labelblock *
00474 #ifdef KR_headers
00475 mklabel(l)
00476         ftnint l;
00477 #else
00478 mklabel(ftnint l)
00479 #endif
00480 {
00481         register struct Labelblock *lp;
00482 
00483         if(l <= 0)
00484                 return(NULL);
00485 
00486         for(lp = labeltab ; lp < highlabtab ; ++lp)
00487                 if(lp->stateno == l)
00488                         return(lp);
00489 
00490         if(++highlabtab > labtabend)
00491                 many("statement labels", 's', maxstno);
00492 
00493         lp->stateno = l;
00494         lp->labelno = (int)newlabel();
00495         lp->blklevel = 0;
00496         lp->labused = NO;
00497         lp->fmtlabused = NO;
00498         lp->labdefined = NO;
00499         lp->labinacc = NO;
00500         lp->labtype = LABUNKNOWN;
00501         lp->fmtstring = 0;
00502         return(lp);
00503 }
00504 
00505  long
00506 newlabel(Void)
00507 {
00508         return ++lastlabno;
00509 }
00510 
00511 
00512 /* this label appears in a branch context */
00513 
00514  struct Labelblock *
00515 #ifdef KR_headers
00516 execlab(stateno)
00517         ftnint stateno;
00518 #else
00519 execlab(ftnint stateno)
00520 #endif
00521 {
00522         register struct Labelblock *lp;
00523 
00524         if(lp = mklabel(stateno))
00525         {
00526                 if(lp->labinacc)
00527                         warn1("illegal branch to inner block, statement label %s",
00528                             convic(stateno) );
00529                 else if(lp->labdefined == NO)
00530                         lp->blklevel = blklevel;
00531                 if(lp->labtype == LABFORMAT)
00532                         err("may not branch to a format");
00533                 else
00534                         lp->labtype = LABEXEC;
00535         }
00536         else
00537                 execerr("illegal label %s", convic(stateno));
00538 
00539         return(lp);
00540 }
00541 
00542 
00543 /* find or put a name in the external symbol table */
00544 
00545  Extsym *
00546 #ifdef KR_headers
00547 mkext1(f, s)
00548         char *f;
00549         char *s;
00550 #else
00551 mkext1(char *f, char *s)
00552 #endif
00553 {
00554         Extsym *p;
00555 
00556         for(p = extsymtab ; p<nextext ; ++p)
00557                 if(!strcmp(s,p->cextname))
00558                         return( p );
00559 
00560         if(nextext >= lastext)
00561                 many("external symbols", 'x', maxext);
00562 
00563         nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
00564         nextext->cextname = f == s
00565                                 ? nextext->fextname
00566                                 : strcpy(gmem(strlen(s)+1,0), s);
00567         nextext->extstg = STGUNKNOWN;
00568         nextext->extp = 0;
00569         nextext->allextp = 0;
00570         nextext->extleng = 0;
00571         nextext->maxleng = 0;
00572         nextext->extinit = 0;
00573         nextext->curno = nextext->maxno = 0;
00574         return( nextext++ );
00575 }
00576 
00577 
00578  Extsym *
00579 #ifdef KR_headers
00580 mkext(f, s)
00581         char *f;
00582         char *s;
00583 #else
00584 mkext(char *f, char *s)
00585 #endif
00586 {
00587         Extsym *e = mkext1(f, s);
00588         if (e->extstg == STGCOMMON)
00589                 errstr("%.52s cannot be a subprogram: it is a common block.",f);
00590         return e;
00591         }
00592 
00593  Addrp
00594 #ifdef KR_headers
00595 builtin(t, s, dbi)
00596         int t;
00597         char *s;
00598         int dbi;
00599 #else
00600 builtin(int t, char *s, int dbi)
00601 #endif
00602 {
00603         register Extsym *p;
00604         register Addrp q;
00605         extern chainp used_builtins;
00606 
00607         p = mkext(s,s);
00608         if(p->extstg == STGUNKNOWN)
00609                 p->extstg = STGEXT;
00610         else if(p->extstg != STGEXT)
00611         {
00612                 errstr("improper use of builtin %s", s);
00613                 return(0);
00614         }
00615 
00616         q = ALLOC(Addrblock);
00617         q->tag = TADDR;
00618         q->vtype = t;
00619         q->vclass = CLPROC;
00620         q->vstg = STGEXT;
00621         q->memno = p - extsymtab;
00622         q->dbl_builtin = dbi;
00623 
00624 /* A NULL pointer here tells you to use   memno   to check the external
00625    symbol table */
00626 
00627         q -> uname_tag = UNAM_EXTERN;
00628 
00629 /* Add to the list of used builtins */
00630 
00631         if (dbi >= 0)
00632                 add_extern_to_list (q, &used_builtins);
00633         return(q);
00634 }
00635 
00636 
00637  void
00638 #ifdef KR_headers
00639 add_extern_to_list(addr, list_store)
00640         Addrp addr;
00641         chainp *list_store;
00642 #else
00643 add_extern_to_list(Addrp addr, chainp *list_store)
00644 #endif
00645 {
00646     chainp last = CHNULL;
00647     chainp list;
00648     int memno;
00649 
00650     if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
00651         return;
00652 
00653     list = *list_store;
00654     memno = addr -> memno;
00655 
00656     for (;list; last = list, list = list -> nextp) {
00657         Addrp thisAddr = (Addrp) (list -> datap);
00658 
00659         if (thisAddr -> tag == TADDR && thisAddr -> uname_tag == UNAM_EXTERN &&
00660                 thisAddr -> memno == memno)
00661             return;
00662     } /* for */
00663 
00664     if (*list_store == CHNULL)
00665         *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
00666     else
00667         last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
00668 
00669 } /* add_extern_to_list */
00670 
00671 
00672  void
00673 #ifdef KR_headers
00674 frchain(p)
00675         register chainp *p;
00676 #else
00677 frchain(register chainp *p)
00678 #endif
00679 {
00680         register chainp q;
00681 
00682         if(p==0 || *p==0)
00683                 return;
00684 
00685         for(q = *p; q->nextp ; q = q->nextp)
00686                 ;
00687         q->nextp = chains;
00688         chains = *p;
00689         *p = 0;
00690 }
00691 
00692  void
00693 #ifdef KR_headers
00694 frexchain(p)
00695         register chainp *p;
00696 #else
00697 frexchain(register chainp *p)
00698 #endif
00699 {
00700         register chainp q, r;
00701 
00702         if (q = *p) {
00703                 for(;;q = r) {
00704                         frexpr((expptr)q->datap);
00705                         if (!(r = q->nextp))
00706                                 break;
00707                         }
00708                 q->nextp = chains;
00709                 chains = *p;
00710                 *p = 0;
00711                 }
00712         }
00713 
00714 
00715  tagptr
00716 #ifdef KR_headers
00717 cpblock(n, p)
00718         register int n;
00719         register char *p;
00720 #else
00721 cpblock(register int n, register char *p)
00722 #endif
00723 {
00724         register ptr q;
00725 
00726         memcpy((char *)(q = ckalloc(n)), (char *)p, n);
00727         return( (tagptr) q);
00728 }
00729 
00730 
00731 
00732  ftnint
00733 #ifdef KR_headers
00734 lmax(a, b)
00735         ftnint a;
00736         ftnint b;
00737 #else
00738 lmax(ftnint a, ftnint b)
00739 #endif
00740 {
00741         return( a>b ? a : b);
00742 }
00743 
00744  ftnint
00745 #ifdef KR_headers
00746 lmin(a, b)
00747         ftnint a;
00748         ftnint b;
00749 #else
00750 lmin(ftnint a, ftnint b)
00751 #endif
00752 {
00753         return(a < b ? a : b);
00754 }
00755 
00756 
00757 
00758 
00759 #ifdef KR_headers
00760 maxtype(t1, t2)
00761         int t1;
00762         int t2;
00763 #else
00764 maxtype(int t1, int t2)
00765 #endif
00766 {
00767         int t;
00768 
00769         t = t1 >= t2 ? t1 : t2;
00770         if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
00771                 t = TYDCOMPLEX;
00772         return(t);
00773 }
00774 
00775 
00776 
00777 /* return log base 2 of n if n a power of 2; otherwise -1 */
00778  int
00779 #ifdef KR_headers
00780 log_2(n)
00781         ftnint n;
00782 #else
00783 log_2(ftnint n)
00784 #endif
00785 {
00786         int k;
00787 
00788         /* trick based on binary representation */
00789 
00790         if(n<=0 || (n & (n-1))!=0)
00791                 return(-1);
00792 
00793         for(k = 0 ;  n >>= 1  ; ++k)
00794                 ;
00795         return(k);
00796 }
00797 
00798 
00799  void
00800 frrpl(Void)
00801 {
00802         struct Rplblock *rp;
00803 
00804         while(rpllist)
00805         {
00806                 rp = rpllist->rplnextp;
00807                 free( (charptr) rpllist);
00808                 rpllist = rp;
00809         }
00810 }
00811 
00812 
00813 
00814 /* Call a Fortran function with an arbitrary list of arguments */
00815 
00816 int callk_kludge;
00817 
00818  expptr
00819 #ifdef KR_headers
00820 callk(type, name, args)
00821         int type;
00822         char *name;
00823         chainp args;
00824 #else
00825 callk(int type, char *name, chainp args)
00826 #endif
00827 {
00828         register expptr p;
00829 
00830         p = mkexpr(OPCALL,
00831                 (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
00832                 (expptr)args);
00833         p->exprblock.vtype = type;
00834         return(p);
00835 }
00836 
00837 
00838 
00839  expptr
00840 #ifdef KR_headers
00841 call4(type, name, arg1, arg2, arg3, arg4)
00842         int type;
00843         char *name;
00844         expptr arg1;
00845         expptr arg2;
00846         expptr arg3;
00847         expptr arg4;
00848 #else
00849 call4(int type, char *name, expptr arg1, expptr arg2, expptr arg3, expptr arg4)
00850 #endif
00851 {
00852         struct Listblock *args;
00853         args = mklist( mkchain((char *)arg1,
00854                         mkchain((char *)arg2,
00855                                 mkchain((char *)arg3,
00856                                         mkchain((char *)arg4, CHNULL)) ) ) );
00857         return( callk(type, name, (chainp)args) );
00858 }
00859 
00860 
00861 
00862 
00863  expptr
00864 #ifdef KR_headers
00865 call3(type, name, arg1, arg2, arg3)
00866         int type;
00867         char *name;
00868         expptr arg1;
00869         expptr arg2;
00870         expptr arg3;
00871 #else
00872 call3(int type, char *name, expptr arg1, expptr arg2, expptr arg3)
00873 #endif
00874 {
00875         struct Listblock *args;
00876         args = mklist( mkchain((char *)arg1,
00877                         mkchain((char *)arg2,
00878                                 mkchain((char *)arg3, CHNULL) ) ) );
00879         return( callk(type, name, (chainp)args) );
00880 }
00881 
00882 
00883 
00884 
00885 
00886  expptr
00887 #ifdef KR_headers
00888 call2(type, name, arg1, arg2)
00889         int type;
00890         char *name;
00891         expptr arg1;
00892         expptr arg2;
00893 #else
00894 call2(int type, char *name, expptr arg1, expptr arg2)
00895 #endif
00896 {
00897         struct Listblock *args;
00898 
00899         args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
00900         return( callk(type,name, (chainp)args) );
00901 }
00902 
00903 
00904 
00905 
00906  expptr
00907 #ifdef KR_headers
00908 call1(type, name, arg)
00909         int type;
00910         char *name;
00911         expptr arg;
00912 #else
00913 call1(int type, char *name, expptr arg)
00914 #endif
00915 {
00916         return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
00917 }
00918 
00919 
00920  expptr
00921 #ifdef KR_headers
00922 call0(type, name)
00923         int type;
00924         char *name;
00925 #else
00926 call0(int type, char *name)
00927 #endif
00928 {
00929         return( callk(type, name, CHNULL) );
00930 }
00931 
00932 
00933 
00934  struct Impldoblock *
00935 #ifdef KR_headers
00936 mkiodo(dospec, list)
00937         chainp dospec;
00938         chainp list;
00939 #else
00940 mkiodo(chainp dospec, chainp list)
00941 #endif
00942 {
00943         register struct Impldoblock *q;
00944 
00945         q = ALLOC(Impldoblock);
00946         q->tag = TIMPLDO;
00947         q->impdospec = dospec;
00948         q->datalist = list;
00949         return(q);
00950 }
00951 
00952 
00953 
00954 
00955 /* ckalloc -- Allocate 1 memory unit of size   n,   checking for out of
00956    memory error */
00957 
00958  ptr
00959 #ifdef KR_headers
00960 ckalloc(n)
00961         register int n;
00962 #else
00963 ckalloc(register int n)
00964 #endif
00965 {
00966         register ptr p;
00967         p = (ptr)calloc(1, (unsigned) n);
00968         if (p || !n)
00969                 return(p);
00970         fprintf(stderr, "failing to get %d bytes\n",n);
00971         Fatal("out of memory");
00972         /* NOT REACHED */ return 0;
00973 }
00974 
00975 
00976  int
00977 #ifdef KR_headers
00978 isaddr(p)
00979         register expptr p;
00980 #else
00981 isaddr(register expptr p)
00982 #endif
00983 {
00984         if(p->tag == TADDR)
00985                 return(YES);
00986         if(p->tag == TEXPR)
00987                 switch(p->exprblock.opcode)
00988                 {
00989                 case OPCOMMA:
00990                         return( isaddr(p->exprblock.rightp) );
00991 
00992                 case OPASSIGN:
00993                 case OPASSIGNI:
00994                 case OPPLUSEQ:
00995                 case OPMINUSEQ:
00996                 case OPSLASHEQ:
00997                 case OPMODEQ:
00998                 case OPLSHIFTEQ:
00999                 case OPRSHIFTEQ:
01000                 case OPBITANDEQ:
01001                 case OPBITXOREQ:
01002                 case OPBITOREQ:
01003                         return( isaddr(p->exprblock.leftp) );
01004                 }
01005         return(NO);
01006 }
01007 
01008 
01009 
01010  int
01011 #ifdef KR_headers
01012 isstatic(p)
01013         register expptr p;
01014 #else
01015 isstatic(register expptr p)
01016 #endif
01017 {
01018         extern int useauto;
01019         if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
01020                 return(NO);
01021 
01022         switch(p->tag)
01023         {
01024         case TCONST:
01025                 return(YES);
01026 
01027         case TADDR:
01028                 if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
01029                     ISCONST(p->addrblock.memoffset) && !useauto)
01030                         return(YES);
01031 
01032         default:
01033                 return(NO);
01034         }
01035 }
01036 
01037 
01038 
01039 /* addressable -- return True iff it is a constant value, or can be
01040    referenced by constant values */
01041 
01042  int
01043 #ifdef KR_headers
01044 addressable(p)
01045         register expptr p;
01046 #else
01047 addressable(register expptr p)
01048 #endif
01049 {
01050         switch(p->tag)
01051         {
01052         case TCONST:
01053                 return(YES);
01054 
01055         case TADDR:
01056                 return( addressable(p->addrblock.memoffset) );
01057 
01058         default:
01059                 return(NO);
01060         }
01061 }
01062 
01063 
01064 /* isnegative_const -- returns true if the constant is negative.  Returns
01065    false for imaginary and nonnumeric constants */
01066 
01067  int
01068 #ifdef KR_headers
01069 isnegative_const(cp)
01070         struct Constblock *cp;
01071 #else
01072 isnegative_const(struct Constblock *cp)
01073 #endif
01074 {
01075     int retval;
01076 
01077     if (cp == NULL)
01078         return 0;
01079 
01080     switch (cp -> vtype) {
01081         case TYINT1:
01082         case TYSHORT:
01083         case TYLONG:
01084 #ifdef TYQUAD
01085         case TYQUAD:
01086 #endif
01087             retval = cp -> Const.ci < 0;
01088             break;
01089         case TYREAL:
01090         case TYDREAL:
01091                 retval = cp->vstg ? *cp->Const.cds[0] == '-'
01092                                   :  cp->Const.cd[0] < 0.0;
01093             break;
01094         default:
01095 
01096             retval = 0;
01097             break;
01098     } /* switch */
01099 
01100     return retval;
01101 } /* isnegative_const */
01102 
01103  void
01104 #ifdef KR_headers
01105 negate_const(cp)
01106         Constp cp;
01107 #else
01108 negate_const(Constp cp)
01109 #endif
01110 {
01111     if (cp == (struct Constblock *) NULL)
01112         return;
01113 
01114     switch (cp -> vtype) {
01115         case TYINT1:
01116         case TYSHORT:
01117         case TYLONG:
01118 #ifdef TYQUAD
01119         case TYQUAD:
01120 #endif
01121             cp -> Const.ci = - cp -> Const.ci;
01122             break;
01123         case TYCOMPLEX:
01124         case TYDCOMPLEX:
01125                 if (cp->vstg)
01126                     switch(*cp->Const.cds[1]) {
01127                         case '-':
01128                                 ++cp->Const.cds[1];
01129                                 break;
01130                         case '0':
01131                                 break;
01132                         default:
01133                                 --cp->Const.cds[1];
01134                         }
01135                 else
01136                         cp->Const.cd[1] = -cp->Const.cd[1];
01137                 /* no break */
01138         case TYREAL:
01139         case TYDREAL:
01140                 if (cp->vstg)
01141                     switch(*cp->Const.cds[0]) {
01142                         case '-':
01143                                 ++cp->Const.cds[0];
01144                                 break;
01145                         case '0':
01146                                 break;
01147                         default:
01148                                 --cp->Const.cds[0];
01149                         }
01150                 else
01151                         cp->Const.cd[0] = -cp->Const.cd[0];
01152             break;
01153         case TYCHAR:
01154         case TYLOGICAL1:
01155         case TYLOGICAL2:
01156         case TYLOGICAL:
01157             erri ("negate_const:  can't negate type '%d'", cp -> vtype);
01158             break;
01159         default:
01160             erri ("negate_const:  bad type '%d'",
01161                     cp -> vtype);
01162             break;
01163     } /* switch */
01164 } /* negate_const */
01165 
01166  void
01167 #ifdef KR_headers
01168 ffilecopy(infp, outfp)
01169         FILE *infp;
01170         FILE *outfp;
01171 #else
01172 ffilecopy(FILE *infp, FILE *outfp)
01173 #endif
01174 {
01175     while (!feof (infp)) {
01176         register c = getc (infp);
01177         if (!feof (infp))
01178         putc (c, outfp);
01179     } /* while */
01180 } /* ffilecopy */
01181 
01182 
01183 /* in_vector -- verifies whether   str   is in c_keywords.
01184    If so, the index is returned else  -1  is returned.
01185    c_keywords must be in alphabetical order (as defined by strcmp).
01186 */
01187 
01188  int
01189 #ifdef KR_headers
01190 in_vector(str, keywds, n)
01191         char *str;
01192         char **keywds;
01193         register int n;
01194 #else
01195 in_vector(char *str, char **keywds, register int n)
01196 #endif
01197 {
01198         register char **K = keywds;
01199         register int n1, t;
01200 
01201         do {
01202                 n1 = n >> 1;
01203                 if (!(t = strcmp(str, K[n1])))
01204                         return K - keywds + n1;
01205                 if (t < 0)
01206                         n = n1;
01207                 else {
01208                         n -= ++n1;
01209                         K += n1;
01210                         }
01211                 }
01212                 while(n > 0);
01213 
01214         return -1;
01215         } /* in_vector */
01216 
01217 
01218  int
01219 #ifdef KR_headers
01220 is_negatable(Const)
01221         Constp Const;
01222 #else
01223 is_negatable(Constp Const)
01224 #endif
01225 {
01226     int retval = 0;
01227     if (Const != (Constp) NULL)
01228         switch (Const -> vtype) {
01229             case TYINT1:
01230                 retval = Const -> Const.ci >= -BIGGEST_CHAR;
01231                 break;
01232             case TYSHORT:
01233                 retval = Const -> Const.ci >= -BIGGEST_SHORT;
01234                 break;
01235             case TYLONG:
01236 #ifdef TYQUAD
01237             case TYQUAD:
01238 #endif
01239                 retval = Const -> Const.ci >= -BIGGEST_LONG;
01240                 break;
01241             case TYREAL:
01242             case TYDREAL:
01243             case TYCOMPLEX:
01244             case TYDCOMPLEX:
01245                 retval = 1;
01246                 break;
01247             case TYLOGICAL1:
01248             case TYLOGICAL2:
01249             case TYLOGICAL:
01250             case TYCHAR:
01251             case TYSUBR:
01252             default:
01253                 retval = 0;
01254                 break;
01255         } /* switch */
01256 
01257     return retval;
01258 } /* is_negatable */
01259 
01260  void
01261 #ifdef KR_headers
01262 backup(fname, bname)
01263         char *fname;
01264         char *bname;
01265 #else
01266 backup(char *fname, char *bname)
01267 #endif
01268 {
01269         FILE *b, *f;
01270         static char couldnt[] = "Couldn't open %.80s";
01271 
01272         if (!(f = fopen(fname, binread))) {
01273                 warn1(couldnt, fname);
01274                 return;
01275                 }
01276         if (!(b = fopen(bname, binwrite))) {
01277                 warn1(couldnt, bname);
01278                 return;
01279                 }
01280         ffilecopy(f, b);
01281         fclose(f);
01282         fclose(b);
01283         }
01284 
01285 
01286 /* struct_eq -- returns YES if structures have the same field names and
01287    types, NO otherwise */
01288 
01289  int
01290 #ifdef KR_headers
01291 struct_eq(s1, s2)
01292         chainp s1;
01293         chainp s2;
01294 #else
01295 struct_eq(chainp s1, chainp s2)
01296 #endif
01297 {
01298     struct Dimblock *d1, *d2;
01299     Constp cp1, cp2;
01300 
01301     if (s1 == CHNULL && s2 == CHNULL)
01302         return YES;
01303     for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
01304         register Namep v1 = (Namep) s1 -> datap;
01305         register Namep v2 = (Namep) s2 -> datap;
01306 
01307         if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
01308                 v2 == (Namep) NULL || v2 -> tag != TNAME)
01309             return NO;
01310 
01311         if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
01312                 || strcmp(v1->fvarname, v2->fvarname))
01313             return NO;
01314 
01315         /* compare dimensions (needed for comparing COMMON blocks) */
01316 
01317         if (d1 = v1->vdim) {
01318                 if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST
01319                 ||  !(d2 = v2->vdim)
01320                 ||  !(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
01321                 ||  cp1->Const.ci != cp2->Const.ci)
01322                         return NO;
01323                 }
01324         else if (v2->vdim)
01325                 return NO;
01326     } /* while s1 != CHNULL && s2 != CHNULL */
01327 
01328     return s1 == CHNULL && s2 == CHNULL;
01329 } /* struct_eq */