1: #ifndef lint 2: static char sccsid[] = "@(#)1.fort.c 4.1 (Berkeley) 2/11/83"; 3: #endif not lint 4: 5: #include <stdio.h> 6: #include "1.incl.h" 7: #include "1.defs.h" 8: #include "def.h" 9: 10: char *remtilda(); 11: 12: act(k,c,bufptr) 13: int k,bufptr; 14: char c; 15: { 16: long ftemp; 17: struct lablist *makelab(); 18: switch(k) 19: /*handle labels */ 20: {case 1: 21: if (c != ' ') 22: { 23: ftemp = c - '0'; 24: newlab->labelt = 10L * newlab->labelt + ftemp; 25: 26: if (newlab->labelt > 99999L) 27: { 28: error("in syntax:\n","",""); 29: fprintf(stderr,"line %d: label beginning %D too long\n%s\n", 30: begline,newlab->labelt,buffer); 31: fprintf(stderr,"treating line as straight line code\n"); 32: return(ABORT); 33: } 34: } 35: break; 36: 37: case 3: nlabs++; 38: newlab = newlab->nxtlab = makelab(0L); 39: break; 40: 41: /* handle labsw- switches and labels */ 42: /* handle if statements */ 43: case 30: counter++; break; 44: 45: case 31: 46: counter--; 47: if (counter) return(_if1); 48: else 49: { 50: pred = remtilda(stralloc(&buffer[p1],bufptr - p1)); 51: p3 = bufptr + 1; /* p3 pts. to 1st symbol after ) */ 52: flag = 1; 53: return(_if2); } 54: 55: case 45: /* set p1 to pt.to 1st symbol of pred */ 56: p1 = bufptr + 1; 57: act(30,c,bufptr); break; 58: 59: /* handle do loops */ 60: case 61: p1 = bufptr; break; /* p1 pts. to 1st symbol of increment string */ 61: 62: case 62: counter ++; break; 63: 64: case 63: counter --; break; 65: 66: case 64: 67: if (counter != 0) break; 68: act(162,c,bufptr); 69: return(ABORT); 70: 71: case 70: if (counter) return(_rwp); 72: r1 = bufptr; 73: return(_rwlab); 74: 75: case 72: exp = remtilda( stralloc(&buffer[r1+1],bufptr - r1 - 1)); break; 76: 77: case 73: endlab = newlab; 78: break; 79: 80: case 74: errlab = newlab; 81: break; 82: 83: case 75: reflab = newlab; 84: act(3,c,bufptr); 85: break; 86: 87: case 76: r1 = bufptr; break; 88: 89: case 77: 90: if (!counter) 91: { 92: act(111,c,bufptr); 93: return(ABORT); 94: } 95: counter--; 96: break; 97: /* generate nodes of all types */ 98: case 111: /* st. line code */ 99: stcode = remtilda(stralloc(&buffer[p3],endbuf - p3)); 100: recognize(STLNVX,flag); 101: return(ABORT); 102: 103: case 122: /* uncond. goto */ 104: recognize(ungo,flag); 105: break; 106: 107: case 123: /* assigned goto */ 108: act(72,c,bufptr); 109: faterr("in parsing:\n","assigned goto must have list of labels",""); 110: 111: case 124: /* ass. goto, labels */ 112: recognize(ASGOVX, flag); 113: break; 114: 115: case 125: /* computed goto*/ 116: exp = remtilda( stralloc(&buffer[r1+1],bufptr - r1 - 1)); 117: recognize(COMPVX, flag); 118: return(ABORT); 119: 120: case 133: /* if() = is a simple statement, so reset flag to 0 */ 121: flag = 0; 122: act(111,c,bufptr); 123: return(ABORT); 124: 125: case 141: /* arith. if */ 126: recognize(arithif, 0); 127: break; 128: 129: case 150: /* label assignment */ 130: exp = remtilda( stralloc(&buffer[r1+1],bufptr - r1 - 1)); 131: recognize(ASVX, flag); 132: break; 133: 134: case 162: /* do node */ 135: inc = remtilda(stralloc(&buffer[p1],endbuf - p1)); 136: recognize(DOVX, 0); 137: break; 138: 139: case 180: /* continue statement */ 140: recognize(contst, 0); 141: break; 142: 143: case 200: /* function or subroutine statement */ 144: progtype = sub; 145: nameline = begline; 146: recognize(STLNVX,0); 147: break; 148: 149: 150: case 210: /* block data statement */ 151: progtype = blockdata; 152: act(111,c,bufptr); 153: return(ABORT); 154: 155: case 300: /* return statement */ 156: recognize(RETVX,flag); 157: break; 158: 159: 160: case 350: /* stop statement */ 161: recognize(STOPVX, flag); 162: break; 163: 164: 165: case 400: /* end statement */ 166: if (progtype == sub) 167: act(300, c, bufptr); 168: else 169: act(350, c, bufptr); 170: return(endrt); 171: 172: case 500: 173: prerw = remtilda(stralloc(&buffer[p3],r1 - p3 + 1)); 174: postrw = remtilda(stralloc(&buffer[r2],endbuf - r2)); 175: if (reflab || endlab || errlab) recognize(IOVX,flag); 176: else recognize(STLNVX,flag); 177: return(ABORT); 178: 179: case 510: r2 = bufptr; 180: act(3,c,bufptr); 181: act(500,c,bufptr); 182: return(ABORT); 183: 184: case 520: r2 = bufptr; 185: reflab = newlab; 186: act(3,c,bufptr); 187: act(500,c,bufptr); 188: return(ABORT); 189: 190: 191: case 600: 192: recognize(FMTVX,0); return(ABORT); 193: 194: case 700: 195: stcode = remtilda(stralloc(&buffer[p3],endbuf - p3)); 196: recognize(entry,0); return(ABORT); 197: /* error */ 198: case 999: 199: printf("error: symbol '%c' should not occur as %d'th symbol of: \n%s\n", 200: c,bufptr, buffer); 201: return(ABORT); 202: } 203: return(nulls); 204: } 205: 206: 207: 208: struct lablist *makelab(x) 209: long x; 210: { 211: struct lablist *p; 212: p = (struct lablist *)challoc (sizeof(*p)); 213: p->labelt = x; 214: p->nxtlab = 0; 215: return(p); 216: } 217: 218: 219: long label(i) 220: int i; 221: { 222: struct lablist *j; 223: for (j = linelabs; i > 0; i--) 224: { 225: if (j == 0) return(0L); 226: j = j->nxtlab; 227: } 228: if (j) 229: return(j->labelt); 230: else 231: return(0L); 232: } 233: 234: 235: freelabs() 236: { 237: struct lablist *j,*k; 238: j = linelabs; 239: while(j != 0) 240: { 241: k = j->nxtlab; 242: chfree(j,sizeof(*j)); 243: j = k; 244: } 245: } 246: 247: 248: stralloc(ad,n) /* allocate space, copy n chars from address ad, add '0' */ 249: int n; char *ad; 250: { 251: char *cp; 252: cp = (char *)galloc(n+1); 253: copycs(ad,cp,n); 254: return((int)cp); 255: } 256: 257: 258: char * 259: remtilda(s) /* change ~ to blank */ 260: char *s; 261: { 262: int i; 263: for (i = 0; s[i] != '\0'; i++) 264: if (s[i] == '~') s[i] = ' '; 265: return(s); 266: }