1 /*-
2 * %sccs.include.proprietary.c%
3 */
4
5 #ifndef lint
6 static char sccsid[] = "@(#)r1.c 8.1 (Berkeley) 06/06/93";
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
repcode()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
untils(p1,un)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
ifcode()55 ifcode() {
56 transfer = 0;
57 outtab();
58 outcode("if(.not.");
59 balpar();
60 outcode(")");
61 outgoto(yyval=genlab(2));
62 indent++;
63 }
64
elsecode(p1)65 elsecode(p1) {
66 outgoto(p1+1);
67 indent--;
68 putcom("else");
69 indent++;
70 outcont(p1);
71 }
72
whilecode()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
whilestat(p1)89 whilestat(p1) int p1; {
90 outgoto(p1);
91 indent--;
92 putcom("endwhile");
93 outcont(p1+1);
94 brkptr--;
95 }
96
balpar()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
genlab(n)133 genlab(n){
134 labval += n;
135 return(labval-n);
136 }
137
gokcode(p1)138 gokcode(p1) {
139 transfer = 0;
140 outtab();
141 outcode(p1);
142 eatup();
143 outdon();
144 }
145
eatup()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
forcode()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
forstat(p1)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
retcode()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
docode()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
dostat(p1)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
breakcode()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
nextcode()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
nonblank(s)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
error(s1)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
errcode()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