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