|
|
1.1 ! root 1: #include "defs" ! 2: #include <ctype.h> ! 3: ! 4: static int indent; ! 5: ! 6: char *verb[] = { " ", " ", "continue", "call ", "do ", "if ", "if ", ! 7: "goto ", "return", "read ", "write ", "format ", "stop ", ! 8: "data ", "equivalence ", "common ", "external ", ! 9: "rewind", "backspace", "endfile", ! 10: "subroutine ", "function ", "program", "blockdata", "end", CNULL }; ! 11: ! 12: extern char *ops[]; ! 13: ptr getsii(); ! 14: ! 15: /* generate code */ ! 16: ! 17: pass2() ! 18: { ! 19: exnull(); ! 20: if(comments) putcomment(); ! 21: if(verbose) ! 22: fprintf(diagfile, " Pass 2\n"); ! 23: ! 24: dclsect = 0; ! 25: indent = 0; ! 26: ! 27: namegen(); ! 28: dclgen(); ! 29: body(iefile); ! 30: datas(); ! 31: body(icfile); ! 32: ! 33: p2stmt(0); ! 34: p2key(FEND); ! 35: p2flush(); ! 36: if(verbose) ! 37: fprintf(diagfile, " Pass 2 done\n"); ! 38: } ! 39: ! 40: datas() ! 41: { ! 42: register int c, n; ! 43: int n1; ! 44: ! 45: rewii(idfile); ! 46: swii(idfile); ! 47: ! 48: for( ; ; ) ! 49: { ! 50: c = getic(&n1); ! 51: n = n1; ! 52: switch(c) ! 53: { ! 54: case ICEOF: ! 55: return; ! 56: ! 57: case ICMARK: ! 58: break; ! 59: ! 60: case ICBLANK: ! 61: putblank(n); ! 62: break; ! 63: ! 64: case ICNAME: ! 65: if(*ftnames[n] == '\0') ! 66: fatal1("no name for n=%d", n); ! 67: p2stmt(0); ! 68: p2key(FDATA); ! 69: p2str( ftnames[n] ); ! 70: break; ! 71: ! 72: case ICOP: ! 73: p2str( ops[n] ); ! 74: break; ! 75: ! 76: case ICCONST: ! 77: p2str( getsii(n) ); ! 78: break; ! 79: ! 80: default: ! 81: fatal1("datas: invalid intermediate tag %d", c); ! 82: } ! 83: } ! 84: } ! 85: ! 86: body(fileadd) ! 87: struct fileblock **fileadd; ! 88: { ! 89: int n1; ! 90: register int n; ! 91: register int c; ! 92: int prevc; ! 93: int ifn; ! 94: ! 95: rewii(fileadd); ! 96: swii(fileadd); ! 97: ! 98: prevc = 0; ! 99: ifn = 0; ! 100: ! 101: for(;;) ! 102: { ! 103: c = getic(&n1); ! 104: n = n1; ! 105: switch(c) ! 106: { ! 107: case ICEOF: ! 108: return; ! 109: ! 110: case ICBEGIN: ! 111: if(n != 0) ! 112: { ! 113: if(prevc) ! 114: p2key(FCONTINUE); ! 115: else prevc = 1; ! 116: p2stmt( stnos[n] ); ! 117: } ! 118: else if(!prevc) p2stmt(0); ! 119: break; ! 120: ! 121: case ICKEYWORD: ! 122: p2key(n); ! 123: if(n != FIF2) ! 124: break; ! 125: getic(&ifn); ! 126: if( indifs[ifn] ) ! 127: skipuntil(ICMARK) ; ! 128: break; ! 129: ! 130: case ICOP: ! 131: p2str( ops[n] ); ! 132: break; ! 133: ! 134: case ICNAME: ! 135: if(*ftnames[n]=='\0') ! 136: fatal1("no name for n=%d", n); ! 137: p2str( ftnames[n] ); ! 138: break; ! 139: ! 140: case ICCOMMENT: ! 141: if(prevc) ! 142: p2key(FCONTINUE); ! 143: p2com(n); ! 144: break; ! 145: ! 146: case ICBLANK: ! 147: putblank(n); ! 148: break; ! 149: ! 150: case ICCONST: ! 151: p2str( getsii(n) ); ! 152: break; ! 153: ! 154: case ICINDPTR: ! 155: n = indifs[n]; ! 156: ! 157: case ICLABEL: ! 158: p2str(" "); ! 159: p2int( stnos[n] ); ! 160: break; ! 161: ! 162: case ICMARK: ! 163: if( indifs[ifn] ) ! 164: { ! 165: p2str(" "); ! 166: p2key(FGOTO); ! 167: p2int( stnos[ indifs[ifn] ] ); ! 168: } ! 169: else ! 170: { ! 171: skipuntil(ICINDENT); ! 172: p2str(" "); ! 173: } ! 174: break; ! 175: ! 176: case ICINDENT: ! 177: indent = n * INDENTSPACES; ! 178: p2indent(indent); ! 179: break; ! 180: ! 181: default: ! 182: sprintf(msg, "Bad pass2 value %o,%o", c,n); ! 183: fatal(msg); ! 184: break; ! 185: } ! 186: if(c!=ICBEGIN && c!=ICINDENT) ! 187: prevc = 0; ! 188: } ! 189: } ! 190: ! 191: putname(p) ! 192: register ptr p; ! 193: { ! 194: register int i; ! 195: ! 196: if(p->vextbase) ! 197: { ! 198: putic(ICNAME, p->vextbase); ! 199: return; ! 200: } ! 201: ! 202: for(i=0 ; i<NFTNTYPES ; ++i) ! 203: if(p->vbase[i]) ! 204: { ! 205: putic(ICNAME, p->vbase[i]); ! 206: return; ! 207: } ! 208: if(strlen(p->sthead->namep) <= XL) ! 209: fatal1("no fortran slot for name %s", p->sthead->namep); ! 210: } ! 211: ! 212: ! 213: ! 214: putconst(ty, p) ! 215: int ty; ! 216: char *p; ! 217: { ! 218: ptr mkchcon(); ! 219: ! 220: if(ty != TYCHAR) ! 221: putsii(ICCONST,p); ! 222: else /* change character constant to a variable */ ! 223: putname( mkchcon(p) ); ! 224: } ! 225: ! 226: ! 227: putzcon(p) ! 228: register ptr p; ! 229: { ! 230: char buff[100]; ! 231: sprintf(buff, "(%s,%s)", p->leftp, p->rightp); ! 232: putsii(ICCONST,buff); ! 233: } ! 234: ! 235: ! 236: ! 237: ! 238: ! 239: ! 240: putcomment() ! 241: { ! 242: register ptr p; ! 243: ! 244: for(p = comments ; p ; p = p->nextp) ! 245: { ! 246: putsii(ICCOMMENT, p->datap); ! 247: cfree(p->datap); ! 248: } ! 249: frchain(&comments); ! 250: } ! 251: ! 252: ! 253: putblank(n) ! 254: int n; ! 255: { ! 256: while(n-- > 0) ! 257: p2putc(' '); ! 258: } ! 259: ! 260: ! 261: ! 262: skipuntil(k) ! 263: int k; ! 264: { ! 265: register int i; ! 266: int n; ! 267: ! 268: while( (i = getic(&n))!=k && i!=ICEOF) ! 269: if(i==ICCOMMENT || i==ICCONST) ! 270: getsii(n); ! 271: } ! 272: ! 273: ! 274: p2int(n) /* put an integer constant in the output */ ! 275: int n; ! 276: { ! 277: p2str( convic(n) ); ! 278: } ! 279: ! 280: ! 281: ! 282: ! 283: p2key(n) /* print a keyword */ ! 284: int n; ! 285: { ! 286: p2str( verb[n] ); ! 287: } ! 288: ! 289: ! 290: ! 291: p2str(s) /* write a character string on the output */ ! 292: char *s; ! 293: { ! 294: int n; ! 295: ! 296: n = strlen(s); ! 297: if(nftnch==LINESPACES-1 && (n==1 || (n==2 && s[1]==' ')) ) ! 298: p2putc(s[0]); ! 299: ! 300: else { ! 301: if( n<=LINESPACES && nftnch+n>LINESPACES-1 ) ! 302: p2line( min(LINESPACES-n , indent+INDENTSPACES) ); ! 303: ! 304: while(*s) ! 305: p2putc(*s++); ! 306: } ! 307: } ! 308: ! 309: ! 310: ! 311: p2stmt(n) /* start a statement with label n */ ! 312: int n; ! 313: { ! 314: if(n > 0) ! 315: fprintf(codefile,"\n%4d ", n); ! 316: else fprintf(codefile,"\n "); ! 317: ! 318: nftnch = 0; ! 319: nftncont = 0; ! 320: } ! 321: ! 322: ! 323: p2com(n) /* copy a comment */ ! 324: int n; ! 325: { ! 326: register int k; ! 327: register char *q; ! 328: ! 329: q = getsii(n); ! 330: if(q[0] == '%') /* a literal escape line */ ! 331: { ! 332: putc('\n', codefile); ! 333: while(--n > 0) ! 334: putc(*++q, codefile); ! 335: } ! 336: else /* actually a comment line */ ! 337: { ! 338: ++q; ! 339: --n; ! 340: ! 341: do { ! 342: k = (n>71 ? 71 : n); ! 343: fprintf(codefile, "\n"); ! 344: putc( tailor.ftnsys==CRAY ? 'C' : 'c' , codefile); ! 345: while(k-- > 0) ! 346: putc(*q++, codefile); ! 347: n -= 71; ! 348: } ! 349: while(n > 0); ! 350: } ! 351: } ! 352: ! 353: ! 354: ! 355: ! 356: p2flush() ! 357: { ! 358: if(nftnch > 0) ! 359: { ! 360: fprintf(codefile, "\n"); ! 361: nftnch = 0; ! 362: } ! 363: } ! 364: ! 365: ! 366: ! 367: ! 368: p2putc(c) ! 369: char c; ! 370: { ! 371: if(nftnch >= LINESPACES) /* end of line */ ! 372: p2line(0); ! 373: if(tailor.ftnsys == CRAY) ! 374: putc( islower(c) ? toupper(c) : c , codefile); ! 375: else ! 376: putc(c, codefile); ! 377: ++nftnch; ! 378: } ! 379: ! 380: ! 381: ! 382: p2line(in) ! 383: int in; ! 384: { ! 385: register char contchar; ! 386: ! 387: if(++nftncont > 19) ! 388: { ! 389: execerr("too many continuation lines", CNULL); ! 390: contchar = 'X'; ! 391: } ! 392: if(tailor.ftncontnu == 1) ! 393: fprintf(codefile, "\n&"); ! 394: else { /* standard column-6 continuation */ ! 395: if(nftncont < 20) ! 396: contchar = "0123456789ABCDEFGHIJ" [nftncont]; ! 397: fprintf(codefile, "\n %c", contchar); ! 398: } ! 399: ! 400: nftnch = 0; ! 401: if(in > 0) ! 402: p2indent(in); ! 403: } ! 404: ! 405: ! 406: ! 407: p2indent(n) ! 408: register int n; ! 409: { ! 410: while(n-- > 0) ! 411: p2putc(' '); ! 412: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.