![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to misc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to misc.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 ! root 1: /**************************************************************** ! 2: Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore. ! 3: ! 4: Permission to use, copy, modify, and distribute this software ! 5: and its documentation for any purpose and without fee is hereby ! 6: granted, provided that the above copyright notice appear in all ! 7: copies and that both that the copyright notice and this ! 8: permission notice and warranty disclaimer appear in supporting ! 9: documentation, and that the names of AT&T Bell Laboratories or ! 10: Bellcore or any of their entities not be used in advertising or ! 11: publicity pertaining to distribution of the software without ! 12: specific, written prior permission. ! 13: ! 14: AT&T and Bellcore disclaim all warranties with regard to this ! 15: software, including all implied warranties of merchantability ! 16: and fitness. In no event shall AT&T or Bellcore be liable for ! 17: any special, indirect or consequential damages or any damages ! 18: whatsoever resulting from loss of use, data or profits, whether ! 19: in an action of contract, negligence or other tortious action, ! 20: arising out of or in connection with the use or performance of ! 21: this software. ! 22: ****************************************************************/ ! 23: ! 24: #include "defs.h" ! 25: ! 26: int oneof_stg (name, stg, mask) ! 27: Namep name; ! 28: int stg, mask; ! 29: { ! 30: if (stg == STGCOMMON && name) { ! 31: if ((mask & M(STGEQUIV))) ! 32: return name->vcommequiv; ! 33: if ((mask & M(STGCOMMON))) ! 34: return !name->vcommequiv; ! 35: } ! 36: return ONEOF(stg, mask); ! 37: } ! 38: ! 39: ! 40: /* op_assign -- given a binary opcode, return the associated assignment ! 41: operator */ ! 42: ! 43: int op_assign (opcode) ! 44: int opcode; ! 45: { ! 46: int retval = -1; ! 47: ! 48: switch (opcode) { ! 49: case OPPLUS: retval = OPPLUSEQ; break; ! 50: case OPMINUS: retval = OPMINUSEQ; break; ! 51: case OPSTAR: retval = OPSTAREQ; break; ! 52: case OPSLASH: retval = OPSLASHEQ; break; ! 53: case OPMOD: retval = OPMODEQ; break; ! 54: case OPLSHIFT: retval = OPLSHIFTEQ; break; ! 55: case OPRSHIFT: retval = OPRSHIFTEQ; break; ! 56: case OPBITAND: retval = OPBITANDEQ; break; ! 57: case OPBITXOR: retval = OPBITXOREQ; break; ! 58: case OPBITOR: retval = OPBITOREQ; break; ! 59: default: ! 60: erri ("op_assign: bad opcode '%d'", opcode); ! 61: break; ! 62: } /* switch */ ! 63: ! 64: return retval; ! 65: } /* op_assign */ ! 66: ! 67: ! 68: char * ! 69: Alloc(n) /* error-checking version of malloc */ ! 70: /* ckalloc initializes memory to 0; Alloc does not */ ! 71: int n; ! 72: { ! 73: char errbuf[32]; ! 74: register char *rv; ! 75: ! 76: rv = malloc(n); ! 77: if (!rv) { ! 78: sprintf(errbuf, "malloc(%d) failure!", n); ! 79: Fatal(errbuf); ! 80: } ! 81: return rv; ! 82: } ! 83: ! 84: ! 85: cpn(n, a, b) ! 86: register int n; ! 87: register char *a, *b; ! 88: { ! 89: while(--n >= 0) ! 90: *b++ = *a++; ! 91: } ! 92: ! 93: ! 94: ! 95: eqn(n, a, b) ! 96: register int n; ! 97: register char *a, *b; ! 98: { ! 99: while(--n >= 0) ! 100: if(*a++ != *b++) ! 101: return(NO); ! 102: return(YES); ! 103: } ! 104: ! 105: ! 106: ! 107: ! 108: ! 109: ! 110: ! 111: cmpstr(a, b, la, lb) /* compare two strings */ ! 112: register char *a, *b; ! 113: ftnint la, lb; ! 114: { ! 115: register char *aend, *bend; ! 116: aend = a + la; ! 117: bend = b + lb; ! 118: ! 119: ! 120: if(la <= lb) ! 121: { ! 122: while(a < aend) ! 123: if(*a != *b) ! 124: return( *a - *b ); ! 125: else ! 126: { ! 127: ++a; ! 128: ++b; ! 129: } ! 130: ! 131: while(b < bend) ! 132: if(*b != ' ') ! 133: return(' ' - *b); ! 134: else ! 135: ++b; ! 136: } ! 137: ! 138: else ! 139: { ! 140: while(b < bend) ! 141: if(*a != *b) ! 142: return( *a - *b ); ! 143: else ! 144: { ! 145: ++a; ! 146: ++b; ! 147: } ! 148: while(a < aend) ! 149: if(*a != ' ') ! 150: return(*a - ' '); ! 151: else ! 152: ++a; ! 153: } ! 154: return(0); ! 155: } ! 156: ! 157: ! 158: /* hookup -- Same as LISP NCONC, that is a destructive append of two lists */ ! 159: ! 160: chainp hookup(x,y) ! 161: register chainp x, y; ! 162: { ! 163: register chainp p; ! 164: ! 165: if(x == NULL) ! 166: return(y); ! 167: ! 168: for(p = x ; p->nextp ; p = p->nextp) ! 169: ; ! 170: p->nextp = y; ! 171: return(x); ! 172: } ! 173: ! 174: ! 175: ! 176: struct Listblock *mklist(p) ! 177: chainp p; ! 178: { ! 179: register struct Listblock *q; ! 180: ! 181: q = ALLOC(Listblock); ! 182: q->tag = TLIST; ! 183: q->listp = p; ! 184: return(q); ! 185: } ! 186: ! 187: ! 188: chainp mkchain(p,q) ! 189: register char * p; ! 190: register chainp q; ! 191: { ! 192: register chainp r; ! 193: ! 194: if(chains) ! 195: { ! 196: r = chains; ! 197: chains = chains->nextp; ! 198: } ! 199: else ! 200: r = ALLOC(Chain); ! 201: ! 202: r->datap = p; ! 203: r->nextp = q; ! 204: return(r); ! 205: } ! 206: ! 207: chainp ! 208: revchain(next) ! 209: register chainp next; ! 210: { ! 211: register chainp p, prev = 0; ! 212: ! 213: while(p = next) { ! 214: next = p->nextp; ! 215: p->nextp = prev; ! 216: prev = p; ! 217: } ! 218: return prev; ! 219: } ! 220: ! 221: ! 222: /* addunder -- turn a cvarname into an external name */ ! 223: /* The cvarname may already end in _ (to avoid C keywords); */ ! 224: /* if not, it has room for appending an _. */ ! 225: ! 226: char * ! 227: addunder(s) ! 228: register char *s; ! 229: { ! 230: register int c, i; ! 231: char *s0 = s; ! 232: ! 233: i = 0; ! 234: while(c = *s++) ! 235: if (c == '_') ! 236: i++; ! 237: else ! 238: i = 0; ! 239: if (!i) { ! 240: *s-- = 0; ! 241: *s = '_'; ! 242: } ! 243: return( s0 ); ! 244: } ! 245: ! 246: ! 247: /* copyn -- return a new copy of the input Fortran-string */ ! 248: ! 249: char *copyn(n, s) ! 250: register int n; ! 251: register char *s; ! 252: { ! 253: register char *p, *q; ! 254: ! 255: p = q = (char *) Alloc(n); ! 256: while(--n >= 0) ! 257: *q++ = *s++; ! 258: return(p); ! 259: } ! 260: ! 261: ! 262: ! 263: /* copys -- return a new copy of the input C-string */ ! 264: ! 265: char *copys(s) ! 266: char *s; ! 267: { ! 268: return( copyn( strlen(s)+1 , s) ); ! 269: } ! 270: ! 271: ! 272: ! 273: /* convci -- Convert Fortran-string to integer; assumes that input is a ! 274: legal number, with no trailing blanks */ ! 275: ! 276: ftnint convci(n, s) ! 277: register int n; ! 278: register char *s; ! 279: { ! 280: ftnint sum; ! 281: sum = 0; ! 282: while(n-- > 0) ! 283: sum = 10*sum + (*s++ - '0'); ! 284: return(sum); ! 285: } ! 286: ! 287: /* convic - Convert Integer constant to string */ ! 288: ! 289: char *convic(n) ! 290: ftnint n; ! 291: { ! 292: static char s[20]; ! 293: register char *t; ! 294: ! 295: s[19] = '\0'; ! 296: t = s+19; ! 297: ! 298: do { ! 299: *--t = '0' + n%10; ! 300: n /= 10; ! 301: } while(n > 0); ! 302: ! 303: return(t); ! 304: } ! 305: ! 306: ! 307: ! 308: /* mkname -- add a new identifier to the environment, including the closed ! 309: hash table. */ ! 310: ! 311: Namep mkname(s) ! 312: register char *s; ! 313: { ! 314: struct Hashentry *hp; ! 315: register Namep q; ! 316: register int c, hash, i; ! 317: register char *t; ! 318: char *s0; ! 319: char errbuf[64]; ! 320: ! 321: hash = i = 0; ! 322: s0 = s; ! 323: while(c = *s++) { ! 324: hash += c; ! 325: if (c == '_') ! 326: i = 2; ! 327: } ! 328: if (!i && in_vector(s0,c_keywords,n_keywords) >= 0) ! 329: i = 1; ! 330: hash %= maxhash; ! 331: ! 332: /* Add the name to the closed hash table */ ! 333: ! 334: hp = hashtab + hash; ! 335: ! 336: while(q = hp->varp) ! 337: if( hash == hp->hashval && !strcmp(s0,q->fvarname) ) ! 338: return(q); ! 339: else if(++hp >= lasthash) ! 340: hp = hashtab; ! 341: ! 342: if(++nintnames >= maxhash-1) ! 343: many("names", 'n', maxhash); /* Fatal error */ ! 344: hp->varp = q = ALLOC(Nameblock); ! 345: hp->hashval = hash; ! 346: q->tag = TNAME; /* TNAME means the tag type is NAME */ ! 347: c = s - s0; ! 348: if (c > 7 && noextflag) { ! 349: sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0, ! 350: c > 36 ? "..." : ""); ! 351: errext(errbuf); ! 352: } ! 353: q->fvarname = strcpy(mem(c,0), s0); ! 354: t = q->cvarname = mem(c + i + 1, 0); ! 355: s = s0; ! 356: /* add __ to the end of any name containing _ and to any C keyword */ ! 357: while(*t = *s++) ! 358: t++; ! 359: if (i) { ! 360: do *t++ = '_'; ! 361: while(--i > 0); ! 362: *t = 0; ! 363: } ! 364: return(q); ! 365: } ! 366: ! 367: ! 368: struct Labelblock *mklabel(l) ! 369: ftnint l; ! 370: { ! 371: register struct Labelblock *lp; ! 372: ! 373: if(l <= 0) ! 374: return(NULL); ! 375: ! 376: for(lp = labeltab ; lp < highlabtab ; ++lp) ! 377: if(lp->stateno == l) ! 378: return(lp); ! 379: ! 380: if(++highlabtab > labtabend) ! 381: many("statement labels", 's', maxstno); ! 382: ! 383: lp->stateno = l; ! 384: lp->labelno = newlabel(); ! 385: lp->blklevel = 0; ! 386: lp->labused = NO; ! 387: lp->fmtlabused = NO; ! 388: lp->labdefined = NO; ! 389: lp->labinacc = NO; ! 390: lp->labtype = LABUNKNOWN; ! 391: lp->fmtstring = 0; ! 392: return(lp); ! 393: } ! 394: ! 395: ! 396: newlabel() ! 397: { ! 398: return( ++lastlabno ); ! 399: } ! 400: ! 401: ! 402: /* this label appears in a branch context */ ! 403: ! 404: struct Labelblock *execlab(stateno) ! 405: ftnint stateno; ! 406: { ! 407: register struct Labelblock *lp; ! 408: ! 409: if(lp = mklabel(stateno)) ! 410: { ! 411: if(lp->labinacc) ! 412: warn1("illegal branch to inner block, statement label %s", ! 413: convic(stateno) ); ! 414: else if(lp->labdefined == NO) ! 415: lp->blklevel = blklevel; ! 416: if(lp->labtype == LABFORMAT) ! 417: err("may not branch to a format"); ! 418: else ! 419: lp->labtype = LABEXEC; ! 420: } ! 421: else ! 422: execerr("illegal label %s", convic(stateno)); ! 423: ! 424: return(lp); ! 425: } ! 426: ! 427: ! 428: /* find or put a name in the external symbol table */ ! 429: ! 430: Extsym *mkext(f,s) ! 431: char *f, *s; ! 432: { ! 433: Extsym *p; ! 434: ! 435: for(p = extsymtab ; p<nextext ; ++p) ! 436: if(!strcmp(s,p->cextname)) ! 437: return( p ); ! 438: ! 439: if(nextext >= lastext) ! 440: many("external symbols", 'x', maxext); ! 441: ! 442: nextext->fextname = strcpy(gmem(strlen(f)+1,0), f); ! 443: nextext->cextname = f == s ! 444: ? nextext->fextname ! 445: : strcpy(gmem(strlen(s)+1,0), s); ! 446: nextext->extstg = STGUNKNOWN; ! 447: nextext->extp = 0; ! 448: nextext->allextp = 0; ! 449: nextext->extleng = 0; ! 450: nextext->maxleng = 0; ! 451: nextext->extinit = 0; ! 452: nextext->curno = nextext->maxno = 0; ! 453: return( nextext++ ); ! 454: } ! 455: ! 456: ! 457: Addrp builtin(t, s, dbi) ! 458: int t, dbi; ! 459: char *s; ! 460: { ! 461: register Extsym *p; ! 462: register Addrp q; ! 463: extern chainp used_builtins; ! 464: ! 465: p = mkext(s,s); ! 466: if(p->extstg == STGUNKNOWN) ! 467: p->extstg = STGEXT; ! 468: else if(p->extstg != STGEXT) ! 469: { ! 470: errstr("improper use of builtin %s", s); ! 471: return(0); ! 472: } ! 473: ! 474: q = ALLOC(Addrblock); ! 475: q->tag = TADDR; ! 476: q->vtype = t; ! 477: q->vclass = CLPROC; ! 478: q->vstg = STGEXT; ! 479: q->memno = p - extsymtab; ! 480: q->dbl_builtin = dbi; ! 481: ! 482: /* A NULL pointer here tells you to use memno to check the external ! 483: symbol table */ ! 484: ! 485: q -> uname_tag = UNAM_EXTERN; ! 486: ! 487: /* Add to the list of used builtins */ ! 488: ! 489: if (dbi >= 0) ! 490: add_extern_to_list (q, &used_builtins); ! 491: return(q); ! 492: } ! 493: ! 494: ! 495: ! 496: add_extern_to_list (addr, list_store) ! 497: Addrp addr; ! 498: chainp *list_store; ! 499: { ! 500: chainp last = CHNULL; ! 501: chainp list; ! 502: int memno; ! 503: ! 504: if (list_store == (chainp *) NULL || addr == (Addrp) NULL) ! 505: return; ! 506: ! 507: list = *list_store; ! 508: memno = addr -> memno; ! 509: ! 510: for (;list; last = list, list = list -> nextp) { ! 511: Addrp this = (Addrp) (list -> datap); ! 512: ! 513: if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN && ! 514: this -> memno == memno) ! 515: return; ! 516: } /* for */ ! 517: ! 518: if (*list_store == CHNULL) ! 519: *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL); ! 520: else ! 521: last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL); ! 522: ! 523: } /* add_extern_to_list */ ! 524: ! 525: ! 526: frchain(p) ! 527: register chainp *p; ! 528: { ! 529: register chainp q; ! 530: ! 531: if(p==0 || *p==0) ! 532: return; ! 533: ! 534: for(q = *p; q->nextp ; q = q->nextp) ! 535: ; ! 536: q->nextp = chains; ! 537: chains = *p; ! 538: *p = 0; ! 539: } ! 540: ! 541: void ! 542: frexchain(p) ! 543: register chainp *p; ! 544: { ! 545: register chainp q, r; ! 546: ! 547: if (q = *p) { ! 548: for(;;q = r) { ! 549: frexpr((expptr)q->datap); ! 550: if (!(r = q->nextp)) ! 551: break; ! 552: } ! 553: q->nextp = chains; ! 554: chains = *p; ! 555: *p = 0; ! 556: } ! 557: } ! 558: ! 559: ! 560: tagptr cpblock(n,p) ! 561: register int n; ! 562: register char * p; ! 563: { ! 564: register ptr q; ! 565: ! 566: memcpy((char *)(q = ckalloc(n)), (char *)p, n); ! 567: return( (tagptr) q); ! 568: } ! 569: ! 570: ! 571: ! 572: ftnint lmax(a, b) ! 573: ftnint a, b; ! 574: { ! 575: return( a>b ? a : b); ! 576: } ! 577: ! 578: ftnint lmin(a, b) ! 579: ftnint a, b; ! 580: { ! 581: return(a < b ? a : b); ! 582: } ! 583: ! 584: ! 585: ! 586: ! 587: maxtype(t1, t2) ! 588: int t1, t2; ! 589: { ! 590: int t; ! 591: ! 592: t = t1 >= t2 ? t1 : t2; ! 593: if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) ) ! 594: t = TYDCOMPLEX; ! 595: return(t); ! 596: } ! 597: ! 598: ! 599: ! 600: /* return log base 2 of n if n a power of 2; otherwise -1 */ ! 601: log_2(n) ! 602: ftnint n; ! 603: { ! 604: int k; ! 605: ! 606: /* trick based on binary representation */ ! 607: ! 608: if(n<=0 || (n & (n-1))!=0) ! 609: return(-1); ! 610: ! 611: for(k = 0 ; n >>= 1 ; ++k) ! 612: ; ! 613: return(k); ! 614: } ! 615: ! 616: ! 617: ! 618: frrpl() ! 619: { ! 620: struct Rplblock *rp; ! 621: ! 622: while(rpllist) ! 623: { ! 624: rp = rpllist->rplnextp; ! 625: free( (charptr) rpllist); ! 626: rpllist = rp; ! 627: } ! 628: } ! 629: ! 630: ! 631: ! 632: /* Call a Fortran function with an arbitrary list of arguments */ ! 633: ! 634: int callk_kludge; ! 635: ! 636: expptr callk(type, name, args) ! 637: int type; ! 638: char *name; ! 639: chainp args; ! 640: { ! 641: register expptr p; ! 642: ! 643: p = mkexpr(OPCALL, ! 644: (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0), ! 645: (expptr)args); ! 646: p->exprblock.vtype = type; ! 647: return(p); ! 648: } ! 649: ! 650: ! 651: ! 652: expptr call4(type, name, arg1, arg2, arg3, arg4) ! 653: int type; ! 654: char *name; ! 655: expptr arg1, arg2, arg3, arg4; ! 656: { ! 657: struct Listblock *args; ! 658: args = mklist( mkchain((char *)arg1, ! 659: mkchain((char *)arg2, ! 660: mkchain((char *)arg3, ! 661: mkchain((char *)arg4, CHNULL)) ) ) ); ! 662: return( callk(type, name, (chainp)args) ); ! 663: } ! 664: ! 665: ! 666: ! 667: ! 668: expptr call3(type, name, arg1, arg2, arg3) ! 669: int type; ! 670: char *name; ! 671: expptr arg1, arg2, arg3; ! 672: { ! 673: struct Listblock *args; ! 674: args = mklist( mkchain((char *)arg1, ! 675: mkchain((char *)arg2, ! 676: mkchain((char *)arg3, CHNULL) ) ) ); ! 677: return( callk(type, name, (chainp)args) ); ! 678: } ! 679: ! 680: ! 681: ! 682: ! 683: ! 684: expptr call2(type, name, arg1, arg2) ! 685: int type; ! 686: char *name; ! 687: expptr arg1, arg2; ! 688: { ! 689: struct Listblock *args; ! 690: ! 691: args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) ); ! 692: return( callk(type,name, (chainp)args) ); ! 693: } ! 694: ! 695: ! 696: ! 697: ! 698: expptr call1(type, name, arg) ! 699: int type; ! 700: char *name; ! 701: expptr arg; ! 702: { ! 703: return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) )); ! 704: } ! 705: ! 706: ! 707: expptr call0(type, name) ! 708: int type; ! 709: char *name; ! 710: { ! 711: return( callk(type, name, CHNULL) ); ! 712: } ! 713: ! 714: ! 715: ! 716: struct Impldoblock *mkiodo(dospec, list) ! 717: chainp dospec, list; ! 718: { ! 719: register struct Impldoblock *q; ! 720: ! 721: q = ALLOC(Impldoblock); ! 722: q->tag = TIMPLDO; ! 723: q->impdospec = dospec; ! 724: q->datalist = list; ! 725: return(q); ! 726: } ! 727: ! 728: ! 729: ! 730: ! 731: /* ckalloc -- Allocate 1 memory unit of size n, checking for out of ! 732: memory error */ ! 733: ! 734: ptr ckalloc(n) ! 735: register int n; ! 736: { ! 737: register ptr p; ! 738: p = (ptr)calloc(1, (unsigned) n); ! 739: if (p || !n) ! 740: return(p); ! 741: fprintf(stderr, "failing to get %d bytes\n",n); ! 742: Fatal("out of memory"); ! 743: /* NOT REACHED */ return 0; ! 744: } ! 745: ! 746: ! 747: ! 748: isaddr(p) ! 749: register expptr p; ! 750: { ! 751: if(p->tag == TADDR) ! 752: return(YES); ! 753: if(p->tag == TEXPR) ! 754: switch(p->exprblock.opcode) ! 755: { ! 756: case OPCOMMA: ! 757: return( isaddr(p->exprblock.rightp) ); ! 758: ! 759: case OPASSIGN: ! 760: case OPASSIGNI: ! 761: case OPPLUSEQ: ! 762: case OPMINUSEQ: ! 763: case OPSLASHEQ: ! 764: case OPMODEQ: ! 765: case OPLSHIFTEQ: ! 766: case OPRSHIFTEQ: ! 767: case OPBITANDEQ: ! 768: case OPBITXOREQ: ! 769: case OPBITOREQ: ! 770: return( isaddr(p->exprblock.leftp) ); ! 771: } ! 772: return(NO); ! 773: } ! 774: ! 775: ! 776: ! 777: ! 778: isstatic(p) ! 779: register expptr p; ! 780: { ! 781: extern int useauto; ! 782: if(p->headblock.vleng && !ISCONST(p->headblock.vleng)) ! 783: return(NO); ! 784: ! 785: switch(p->tag) ! 786: { ! 787: case TCONST: ! 788: return(YES); ! 789: ! 790: case TADDR: ! 791: if(ONEOF(p->addrblock.vstg,MSKSTATIC) && ! 792: ISCONST(p->addrblock.memoffset) && !useauto) ! 793: return(YES); ! 794: ! 795: default: ! 796: return(NO); ! 797: } ! 798: } ! 799: ! 800: ! 801: ! 802: /* addressable -- return True iff it is a constant value, or can be ! 803: referenced by constant values */ ! 804: ! 805: addressable(p) ! 806: register expptr p; ! 807: { ! 808: switch(p->tag) ! 809: { ! 810: case TCONST: ! 811: return(YES); ! 812: ! 813: case TADDR: ! 814: return( addressable(p->addrblock.memoffset) ); ! 815: ! 816: default: ! 817: return(NO); ! 818: } ! 819: } ! 820: ! 821: ! 822: /* isnegative_const -- returns true if the constant is negative. Returns ! 823: false for imaginary and nonnumeric constants */ ! 824: ! 825: int isnegative_const (cp) ! 826: struct Constblock *cp; ! 827: { ! 828: int retval; ! 829: ! 830: if (cp == NULL) ! 831: return 0; ! 832: ! 833: switch (cp -> vtype) { ! 834: case TYINT1: ! 835: case TYSHORT: ! 836: case TYLONG: ! 837: #ifdef TYQUAD ! 838: case TYQUAD: ! 839: #endif ! 840: retval = cp -> Const.ci < 0; ! 841: break; ! 842: case TYREAL: ! 843: case TYDREAL: ! 844: retval = cp->vstg ? *cp->Const.cds[0] == '-' ! 845: : cp->Const.cd[0] < 0.0; ! 846: break; ! 847: default: ! 848: ! 849: retval = 0; ! 850: break; ! 851: } /* switch */ ! 852: ! 853: return retval; ! 854: } /* isnegative_const */ ! 855: ! 856: negate_const(cp) ! 857: Constp cp; ! 858: { ! 859: if (cp == (struct Constblock *) NULL) ! 860: return; ! 861: ! 862: switch (cp -> vtype) { ! 863: case TYINT1: ! 864: case TYSHORT: ! 865: case TYLONG: ! 866: #ifdef TYQUAD ! 867: case TYQUAD: ! 868: #endif ! 869: cp -> Const.ci = - cp -> Const.ci; ! 870: break; ! 871: case TYCOMPLEX: ! 872: case TYDCOMPLEX: ! 873: if (cp->vstg) ! 874: switch(*cp->Const.cds[1]) { ! 875: case '-': ! 876: ++cp->Const.cds[1]; ! 877: break; ! 878: case '0': ! 879: break; ! 880: default: ! 881: --cp->Const.cds[1]; ! 882: } ! 883: else ! 884: cp->Const.cd[1] = -cp->Const.cd[1]; ! 885: /* no break */ ! 886: case TYREAL: ! 887: case TYDREAL: ! 888: if (cp->vstg) ! 889: switch(*cp->Const.cds[0]) { ! 890: case '-': ! 891: ++cp->Const.cds[0]; ! 892: break; ! 893: case '0': ! 894: break; ! 895: default: ! 896: --cp->Const.cds[0]; ! 897: } ! 898: else ! 899: cp->Const.cd[0] = -cp->Const.cd[0]; ! 900: break; ! 901: case TYCHAR: ! 902: case TYLOGICAL1: ! 903: case TYLOGICAL2: ! 904: case TYLOGICAL: ! 905: erri ("negate_const: can't negate type '%d'", cp -> vtype); ! 906: break; ! 907: default: ! 908: erri ("negate_const: bad type '%d'", ! 909: cp -> vtype); ! 910: break; ! 911: } /* switch */ ! 912: } /* negate_const */ ! 913: ! 914: ffilecopy (infp, outfp) ! 915: FILE *infp, *outfp; ! 916: { ! 917: while (!feof (infp)) { ! 918: register c = getc (infp); ! 919: if (!feof (infp)) ! 920: putc (c, outfp); ! 921: } /* while */ ! 922: } /* ffilecopy */ ! 923: ! 924: ! 925: /* in_vector -- verifies whether str is in c_keywords. ! 926: If so, the index is returned else -1 is returned. ! 927: c_keywords must be in alphabetical order (as defined by strcmp). ! 928: */ ! 929: ! 930: int in_vector(str, keywds, n) ! 931: char *str; char **keywds; register int n; ! 932: { ! 933: register char **K = keywds; ! 934: register int n1, t; ! 935: ! 936: do { ! 937: n1 = n >> 1; ! 938: if (!(t = strcmp(str, K[n1]))) ! 939: return K - keywds + n1; ! 940: if (t < 0) ! 941: n = n1; ! 942: else { ! 943: n -= ++n1; ! 944: K += n1; ! 945: } ! 946: } ! 947: while(n > 0); ! 948: ! 949: return -1; ! 950: } /* in_vector */ ! 951: ! 952: ! 953: int is_negatable (Const) ! 954: Constp Const; ! 955: { ! 956: int retval = 0; ! 957: if (Const != (Constp) NULL) ! 958: switch (Const -> vtype) { ! 959: case TYINT1: ! 960: retval = Const -> Const.ci >= -BIGGEST_CHAR; ! 961: break; ! 962: case TYSHORT: ! 963: retval = Const -> Const.ci >= -BIGGEST_SHORT; ! 964: break; ! 965: case TYLONG: ! 966: #ifdef TYQUAD ! 967: case TYQUAD: ! 968: #endif ! 969: retval = Const -> Const.ci >= -BIGGEST_LONG; ! 970: break; ! 971: case TYREAL: ! 972: case TYDREAL: ! 973: case TYCOMPLEX: ! 974: case TYDCOMPLEX: ! 975: retval = 1; ! 976: break; ! 977: case TYLOGICAL1: ! 978: case TYLOGICAL2: ! 979: case TYLOGICAL: ! 980: case TYCHAR: ! 981: case TYSUBR: ! 982: default: ! 983: retval = 0; ! 984: break; ! 985: } /* switch */ ! 986: ! 987: return retval; ! 988: } /* is_negatable */ ! 989: ! 990: backup(fname, bname) ! 991: char *fname, *bname; ! 992: { ! 993: FILE *b, *f; ! 994: static char couldnt[] = "Couldn't open %.80s"; ! 995: ! 996: if (!(f = fopen(fname, binread))) { ! 997: warn1(couldnt, fname); ! 998: return; ! 999: } ! 1000: if (!(b = fopen(bname, binwrite))) { ! 1001: warn1(couldnt, bname); ! 1002: return; ! 1003: } ! 1004: ffilecopy(f, b); ! 1005: fclose(f); ! 1006: fclose(b); ! 1007: } ! 1008: ! 1009: ! 1010: /* struct_eq -- returns YES if structures have the same field names and ! 1011: types, NO otherwise */ ! 1012: ! 1013: int struct_eq (s1, s2) ! 1014: chainp s1, s2; ! 1015: { ! 1016: struct Dimblock *d1, *d2; ! 1017: Constp cp1, cp2; ! 1018: ! 1019: if (s1 == CHNULL && s2 == CHNULL) ! 1020: return YES; ! 1021: for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) { ! 1022: register Namep v1 = (Namep) s1 -> datap; ! 1023: register Namep v2 = (Namep) s2 -> datap; ! 1024: ! 1025: if (v1 == (Namep) NULL || v1 -> tag != TNAME || ! 1026: v2 == (Namep) NULL || v2 -> tag != TNAME) ! 1027: return NO; ! 1028: ! 1029: if (v1->vtype != v2->vtype || v1->vclass != v2->vclass ! 1030: || strcmp(v1->fvarname, v2->fvarname)) ! 1031: return NO; ! 1032: ! 1033: /* compare dimensions (needed for comparing COMMON blocks) */ ! 1034: ! 1035: if (d1 = v1->vdim) { ! 1036: if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST) ! 1037: return NO; ! 1038: if (!(d2 = v2->vdim)) ! 1039: if (cp1->Const.ci == 1) ! 1040: continue; ! 1041: else ! 1042: return NO; ! 1043: if (!(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST ! 1044: || cp1->Const.ci != cp2->Const.ci) ! 1045: return NO; ! 1046: } ! 1047: else if ((d2 = v2->vdim) && (!(cp2 = (Constp)d2->nelt) ! 1048: || cp2->tag != TCONST ! 1049: || cp2->Const.ci != 1)) ! 1050: return NO; ! 1051: } /* while s1 != CHNULL && s2 != CHNULL */ ! 1052: ! 1053: return s1 == CHNULL && s2 == CHNULL; ! 1054: } /* struct_eq */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.