00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
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
00048
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 }
00075
00076 return retval;
00077 }
00078
00079
00080 char *
00081 #ifdef KR_headers
00082 Alloc(n)
00083 int n;
00084 #else
00085 Alloc(int n)
00086 #endif
00087
00088
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
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
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
00277
00278
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
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
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
00344
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
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
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
00409
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
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);
00449 hp->varp = q = ALLOC(Nameblock);
00450 hp->hashval = hash;
00451 q->tag = TNAME;
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
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
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
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
00625
00626
00627 q -> uname_tag = UNAM_EXTERN;
00628
00629
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 }
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 }
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
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
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
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
00956
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 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
01040
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
01065
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 }
01099
01100 return retval;
01101 }
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
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 }
01164 }
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 }
01180 }
01181
01182
01183
01184
01185
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 }
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 }
01256
01257 return retval;
01258 }
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
01287
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
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 }
01327
01328 return s1 == CHNULL && s2 == CHNULL;
01329 }