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