1 /*- 2 * %sccs.include.proprietary.c% 3 */ 4 5 #ifndef lint 6 static char sccsid[] = "@(#)r1.c 1.4 (Berkeley) 04/16/91"; 7 #endif /* not lint */ 8 9 #include "r.h" 10 11 #define wasbreak brkused[brkptr]==1 || brkused[brkptr]==3 12 #define wasnext brkused[brkptr]==2 || brkused[brkptr]==3 13 14 int transfer = 0; /* 1 if just finished retrun, break, next */ 15 16 char fcname[10]; 17 char scrat[500]; 18 19 int brkptr = -1; 20 int brkstk[10]; /* break label */ 21 int typestk[10]; /* type of loop construct */ 22 int brkused[10]; /* loop contains BREAK or NEXT */ 23 24 int forptr = 0; 25 char *forstk[10]; 26 27 repcode() { 28 transfer = 0; 29 outcont(0); 30 putcom("repeat"); 31 yyval = genlab(3); 32 indent++; 33 outcont(yyval); 34 brkstk[++brkptr] = yyval+1; 35 typestk[brkptr] = REPEAT; 36 brkused[brkptr] = 0; 37 } 38 39 untils(p1,un) int p1,un; { 40 outnum(p1+1); 41 outtab(); 42 if (un > 0) { 43 outcode("if(.not."); 44 balpar(); 45 outcode(")"); 46 } 47 transfer = 0; 48 outgoto(p1); 49 indent--; 50 if (wasbreak) 51 outcont(p1+2); 52 brkptr--; 53 } 54 55 ifcode() { 56 transfer = 0; 57 outtab(); 58 outcode("if(.not."); 59 balpar(); 60 outcode(")"); 61 outgoto(yyval=genlab(2)); 62 indent++; 63 } 64 65 elsecode(p1) { 66 outgoto(p1+1); 67 indent--; 68 putcom("else"); 69 indent++; 70 outcont(p1); 71 } 72 73 whilecode() { 74 transfer = 0; 75 outcont(0); 76 putcom("while"); 77 brkstk[++brkptr] = yyval = genlab(2); 78 typestk[brkptr] = WHILE; 79 brkused[brkptr] = 0; 80 outnum(yyval); 81 outtab(); 82 outcode("if(.not."); 83 balpar(); 84 outcode(")"); 85 outgoto(yyval+1); 86 indent++; 87 } 88 89 whilestat(p1) int p1; { 90 outgoto(p1); 91 indent--; 92 putcom("endwhile"); 93 outcont(p1+1); 94 brkptr--; 95 } 96 97 balpar() { 98 register c, lpar; 99 while ((c=gtok(scrat)) == ' ' || c == '\t') 100 ; 101 if (c != '(') { 102 error("missing left paren"); 103 return; 104 } 105 outcode(scrat); 106 lpar = 1; 107 do { 108 c = gtok(scrat); 109 if (c==';' || c=='{' || c=='}' || c==EOF) { 110 pbstr(scrat); 111 break; 112 } 113 if (c=='(') 114 lpar++; 115 else if (c==')') 116 lpar--; 117 else if (c == '\n') { 118 while ((c = gtok(scrat)) == ' ' || c=='\t' || c=='\n') 119 ; 120 pbstr(scrat); 121 continue; 122 } 123 else if (c == '=' && scrat[1] == '\0') 124 error("assigment inside conditional"); 125 outcode(scrat); 126 } while (lpar > 0); 127 if (lpar != 0) 128 error("missing parenthesis"); 129 } 130 131 int labval = 23000; 132 133 genlab(n){ 134 labval += n; 135 return(labval-n); 136 } 137 138 gokcode(p1) { 139 transfer = 0; 140 outtab(); 141 outcode(p1); 142 eatup(); 143 outdon(); 144 } 145 146 eatup() { 147 int t, lpar; 148 char temp[100]; 149 lpar = 0; 150 do { 151 if ((t = gtok(scrat)) == ';' || t == '\n') 152 break; 153 if (t == '{' || t == '}' || t == EOF) { 154 pbstr(scrat); 155 break; 156 } 157 if (t == ',' || t == '+' || t == '-' || t == '*' || t == '(' 158 || t == '&' || t == '|' || t == '=') { 159 while (gtok(temp) == '\n') 160 ; 161 pbstr(temp); 162 } 163 if (t == '(') 164 lpar++; 165 else if (t==')') { 166 lpar--; 167 if (lpar < 0) { 168 error("missing left paren"); 169 return(1); 170 } 171 } 172 outcode(scrat); 173 } while (lpar >= 0); 174 if (lpar > 0) { 175 error("missing right paren"); 176 return(1); 177 } 178 return(0); 179 } 180 181 forcode(){ 182 int lpar, t; 183 char *ps, *qs; 184 185 transfer = 0; 186 outcont(0); 187 putcom("for"); 188 yyval = genlab(3); 189 brkstk[++brkptr] = yyval+1; 190 typestk[brkptr] = FOR; 191 brkused[brkptr] = 0; 192 forstk[forptr++] = malloc(1); 193 if ((t = gnbtok(scrat)) != '(') { 194 error("missing left paren in FOR"); 195 pbstr(scrat); 196 return; 197 } 198 if (gnbtok(scrat) != ';') { /* real init clause */ 199 pbstr(scrat); 200 outtab(); 201 if (eatup() > 0) { 202 error("illegal FOR clause"); 203 return; 204 } 205 outdon(); 206 } 207 if (gnbtok(scrat) == ';') /* empty condition */ 208 outcont(yyval); 209 else { /* non-empty condition */ 210 pbstr(scrat); 211 outnum(yyval); 212 outtab(); 213 outcode("if(.not.("); 214 for (lpar=0; lpar >= 0;) { 215 if ((t = gnbtok(scrat)) == ';') 216 break; 217 if (t == '(') 218 lpar++; 219 else if (t == ')') { 220 lpar--; 221 if (lpar < 0) { 222 error("missing left paren in FOR clause"); 223 return; 224 } 225 } 226 if (t != '\n') 227 outcode(scrat); 228 } 229 outcode("))"); 230 outgoto(yyval+2); 231 if (lpar < 0) 232 error("invalid FOR clause"); 233 } 234 ps = scrat; 235 for (lpar=0; lpar >= 0;) { 236 if ((t = gtok(ps)) == '(') 237 lpar++; 238 else if (t == ')') 239 lpar--; 240 if (lpar >= 0 && t != '\n') 241 while(*ps) 242 ps++; 243 } 244 *ps = '\0'; 245 qs = forstk[forptr-1] = malloc((unsigned)(ps-scrat+1)); 246 ps = scrat; 247 while (*qs++ = *ps++) 248 ; 249 indent++; 250 } 251 252 forstat(p1) int p1; { 253 char *bp, *q; 254 bp = forstk[--forptr]; 255 if (wasnext) { 256 outnum(p1+1); 257 transfer = 0; 258 } 259 if (nonblank(bp)){ 260 outtab(); 261 outcode(bp); 262 outdon(); 263 } 264 outgoto(p1); 265 indent--; 266 putcom("endfor"); 267 outcont(p1+2); 268 for (q=bp; *q++;); 269 free(bp); 270 brkptr--; 271 } 272 273 retcode() { 274 register c; 275 if ((c = gnbtok(scrat)) != '\n' && c != ';' && c != '}') { 276 pbstr(scrat); 277 outtab(); 278 outcode(fcname); 279 outcode(" = "); 280 eatup(); 281 outdon(); 282 } 283 else if (c == '}') 284 pbstr(scrat); 285 outtab(); 286 outcode("return"); 287 outdon(); 288 transfer = 1; 289 } 290 291 docode() { 292 transfer = 0; 293 outtab(); 294 outcode("do "); 295 yyval = genlab(2); 296 brkstk[++brkptr] = yyval; 297 typestk[brkptr] = DO; 298 brkused[brkptr] = 0; 299 outnum(yyval); 300 eatup(); 301 outdon(); 302 indent++; 303 } 304 305 dostat(p1) int p1; { 306 outcont(p1); 307 indent--; 308 if (wasbreak) 309 outcont(p1+1); 310 brkptr--; 311 } 312 313 #ifdef gcos 314 #define atoi(s) (*s-'0') /* crude!!! */ 315 #endif 316 317 breakcode() { 318 int level, t; 319 320 level = 0; 321 if ((t=gnbtok(scrat)) == DIG) 322 level = atoi(scrat) - 1; 323 else if (t != ';') 324 pbstr(scrat); 325 if (brkptr-level < 0) 326 error("illegal BREAK"); 327 else { 328 outgoto(brkstk[brkptr-level]+1); 329 brkused[brkptr-level] |= 1; 330 } 331 transfer = 1; 332 } 333 334 nextcode() { 335 int level, t; 336 337 level = 0; 338 if ((t=gnbtok(scrat)) == DIG) 339 level = atoi(scrat) - 1; 340 else if (t != ';') 341 pbstr(scrat); 342 if (brkptr-level < 0) 343 error("illegal NEXT"); 344 else { 345 outgoto(brkstk[brkptr-level]); 346 brkused[brkptr-level] |= 2; 347 } 348 transfer = 1; 349 } 350 351 nonblank(s) char *s; { 352 int c; 353 while (c = *s++) 354 if (c!=' ' && c!='\t' && c!='\n') 355 return(1); 356 return(0); 357 } 358 359 int errorflag = 0; 360 361 error(s1) char *s1; { 362 if (errorflag == 0) 363 fprintf(stderr, "ratfor:"); 364 fprintf(stderr, "error at line %d, file %s: ",linect[infptr],curfile[infptr]); 365 fprintf(stderr, s1); 366 fprintf(stderr, "\n"); 367 errorflag = 1; 368 } 369 370 errcode() { 371 int c; 372 if (errorflag == 0) 373 fprintf(stderr, "******\n"); 374 fprintf(stderr, "*****F ratfor:"); 375 fprintf(stderr, "syntax error, line %d, file %s\n", linect[infptr], curfile[infptr]); 376 while ((c=getchr())!=';' && c!='}' && c!='\n' && c!=EOF && c!='\0') 377 ; 378 if (c == EOF || c == '\0') 379 putbak(c); 380 errorflag = 1; 381 } 382