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