1 #include "v3p_f2c.h"
2 #include "fio.h"
3 #include "fmt.h"
4 #ifdef __cplusplus
5 extern "C" {
6 #endif
7 #define skip(s) while(*s==' ') s++
8 #ifdef interdata
9 #define SYLMX 300
10 #endif
11 #ifdef pdp11
12 #define SYLMX 300
13 #endif
14 #ifdef vax
15 #define SYLMX 300
16 #endif
17 #ifndef SYLMX
18 #define SYLMX 300
19 #endif
20 #define GLITCH '\2'
21         /* special quote character for stu */
22 extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/
23 static struct syl f__syl[SYLMX];
24 int f__parenlvl,f__pc,f__revloc;
25 
26  static
27 #ifdef KR_headers
ap_end(s)28 char *ap_end(s) char *s;
29 #else
30 char *ap_end(char *s)
31 #endif
32 {       char quote;
33         quote= *s++;
34         for(;*s;s++)
35         {       if(*s!=quote) continue;
36                 if(*++s!=quote) return(s);
37         }
38         if(f__elist->cierr) {
39                 errno = 100;
40                 return(NULL);
41         }
42         f__fatal(100, "bad string");
43         /*NOTREACHED*/ return 0;
44 }
45  static int
46 #ifdef KR_headers
op_gen(a,b,c,d)47 op_gen(a,b,c,d)
48 #else
49 op_gen(int a, int b, int c, int d)
50 #endif
51 {       struct syl *p= &f__syl[f__pc];
52         if(f__pc>=SYLMX)
53         {       fprintf(stderr,"format too complicated:\n");
54                 sig_die(f__fmtbuf, 1);
55         }
56         p->op=a;
57         p->p1=b;
58         p->p2.i[0]=c;
59         p->p2.i[1]=d;
60         return(f__pc++);
61 }
62 #ifdef KR_headers
63 static char *f_list();
gt_num(s,n,n1)64 static char *gt_num(s,n,n1) char *s; int *n, n1;
65 #else
66 static char *f_list(char*);
67 static char *gt_num(char *s, int *n, int n1)
68 #endif
69 {       int m=0,f__cnt=0;
70         char c;
71         for(c= *s;;c = *s)
72         {       if(c==' ')
73                 {       s++;
74                         continue;
75                 }
76                 if(c>'9' || c<'0') break;
77                 m=10*m+c-'0';
78                 f__cnt++;
79                 s++;
80         }
81         if(f__cnt==0) {
82                 if (!n1)
83                         s = 0;
84                 *n=n1;
85                 }
86         else *n=m;
87         return(s);
88 }
89 
90  static
91 #ifdef KR_headers
f_s(s,curloc)92 char *f_s(s,curloc) char *s;
93 #else
94 char *f_s(char *s, int curloc)
95 #endif
96 {
97         skip(s);
98         if(*s++!='(')
99         {
100                 return(NULL);
101         }
102         if(f__parenlvl++ ==1) f__revloc=curloc;
103         if(op_gen(RET1,curloc,0,0)<0 ||
104                 (s=f_list(s))==NULL)
105         {
106                 return(NULL);
107         }
108         skip(s);
109         return(s);
110 }
111 
112  static int
113 #ifdef KR_headers
ne_d(s,p)114 ne_d(s,p) char *s,**p;
115 #else
116 ne_d(char *s, char **p)
117 #endif
118 {       int n,x,sign=0;
119         struct syl *sp;
120         switch(*s)
121         {
122         default:
123                 return(0);
124         case ':': (void) op_gen(COLON,0,0,0); break;
125         case '$':
126                 (void) op_gen(NONL, 0, 0, 0); break;
127         case 'B':
128         case 'b':
129                 if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
130                 else (void) op_gen(BN,0,0,0);
131                 break;
132         case 'S':
133         case 's':
134                 if(*(s+1)=='s' || *(s+1) == 'S')
135                 {       x=SS;
136                         s++;
137                 }
138                 else if(*(s+1)=='p' || *(s+1) == 'P')
139                 {       x=SP;
140                         s++;
141                 }
142                 else x=S;
143                 (void) op_gen(x,0,0,0);
144                 break;
145         case '/': (void) op_gen(SLASH,0,0,0); break;
146         case '-': sign=1;
147         case '+':       s++;    /*OUTRAGEOUS CODING TRICK*/
148         case '0': case '1': case '2': case '3': case '4':
149         case '5': case '6': case '7': case '8': case '9':
150                 if (!(s=gt_num(s,&n,0))) {
151  bad:                   *p = 0;
152                         return 1;
153                         }
154                 switch(*s)
155                 {
156                 default:
157                         return(0);
158                 case 'P':
159                 case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
160                 case 'X':
161                 case 'x': (void) op_gen(X,n,0,0); break;
162                 case 'H':
163                 case 'h':
164                         sp = &f__syl[op_gen(H,n,0,0)];
165                         sp->p2.s = s + 1;
166                         s+=n;
167                         break;
168                 }
169                 break;
170         case GLITCH:
171         case '"':
172         case '\'':
173                 sp = &f__syl[op_gen(APOS,0,0,0)];
174                 sp->p2.s = s;
175                 if((*p = ap_end(s)) == NULL)
176                         return(0);
177                 return(1);
178         case 'T':
179         case 't':
180                 if(*(s+1)=='l' || *(s+1) == 'L')
181                 {       x=TL;
182                         s++;
183                 }
184                 else if(*(s+1)=='r'|| *(s+1) == 'R')
185                 {       x=TR;
186                         s++;
187                 }
188                 else x=T;
189                 if (!(s=gt_num(s+1,&n,0)))
190                         goto bad;
191                 s--;
192                 (void) op_gen(x,n,0,0);
193                 break;
194         case 'X':
195         case 'x': (void) op_gen(X,1,0,0); break;
196         case 'P':
197         case 'p': (void) op_gen(P,1,0,0); break;
198         }
199         s++;
200         *p=s;
201         return(1);
202 }
203 
204  static int
205 #ifdef KR_headers
e_d(s,p)206 e_d(s,p) char *s,**p;
207 #else
208 e_d(char *s, char **p)
209 #endif
210 {       int i,im,n,w,d,e,found=0,x=0;
211         char *sv=s;
212         s=gt_num(s,&n,1);
213         (void) op_gen(STACK,n,0,0);
214         switch(*s++)
215         {
216         default: break;
217         case 'E':
218         case 'e':       x=1;
219         case 'G':
220         case 'g':
221                 found=1;
222                 if (!(s=gt_num(s,&w,0))) {
223  bad:
224                         *p = 0;
225                         return 1;
226                         }
227                 if(w==0) break;
228                 if(*s=='.') {
229                         if (!(s=gt_num(s+1,&d,0)))
230                                 goto bad;
231                         }
232                 else d=0;
233                 if(*s!='E' && *s != 'e')
234                         (void) op_gen(x==1?E:G,w,d,0);  /* default is Ew.dE2 */
235                 else {
236                         if (!(s=gt_num(s+1,&e,0)))
237                                 goto bad;
238                         (void) op_gen(x==1?EE:GE,w,d,e);
239                         }
240                 break;
241         case 'O':
242         case 'o':
243                 i = O;
244                 im = OM;
245                 goto finish_I;
246         case 'Z':
247         case 'z':
248                 i = Z;
249                 im = ZM;
250                 goto finish_I;
251         case 'L':
252         case 'l':
253                 found=1;
254                 if (!(s=gt_num(s,&w,0)))
255                         goto bad;
256                 if(w==0) break;
257                 (void) op_gen(L,w,0,0);
258                 break;
259         case 'A':
260         case 'a':
261                 found=1;
262                 skip(s);
263                 if(*s>='0' && *s<='9')
264                 {       s=gt_num(s,&w,1);
265                         if(w==0) break;
266                         (void) op_gen(AW,w,0,0);
267                         break;
268                 }
269                 (void) op_gen(A,0,0,0);
270                 break;
271         case 'F':
272         case 'f':
273                 if (!(s=gt_num(s,&w,0)))
274                         goto bad;
275                 found=1;
276                 if(w==0) break;
277                 if(*s=='.') {
278                         if (!(s=gt_num(s+1,&d,0)))
279                                 goto bad;
280                         }
281                 else d=0;
282                 (void) op_gen(F,w,d,0);
283                 break;
284         case 'D':
285         case 'd':
286                 found=1;
287                 if (!(s=gt_num(s,&w,0)))
288                         goto bad;
289                 if(w==0) break;
290                 if(*s=='.') {
291                         if (!(s=gt_num(s+1,&d,0)))
292                                 goto bad;
293                         }
294                 else d=0;
295                 (void) op_gen(D,w,d,0);
296                 break;
297         case 'I':
298         case 'i':
299                 i = I;
300                 im = IM;
301  finish_I:
302                 if (!(s=gt_num(s,&w,0)))
303                         goto bad;
304                 found=1;
305                 if(w==0) break;
306                 if(*s!='.')
307                 {       (void) op_gen(i,w,0,0);
308                         break;
309                 }
310                 if (!(s=gt_num(s+1,&d,0)))
311                         goto bad;
312                 (void) op_gen(im,w,d,0);
313                 break;
314         }
315         if(found==0)
316         {       f__pc--; /*unSTACK*/
317                 *p=sv;
318                 return(0);
319         }
320         *p=s;
321         return(1);
322 }
323  static
324 #ifdef KR_headers
i_tem(s)325 char *i_tem(s) char *s;
326 #else
327 char *i_tem(char *s)
328 #endif
329 {       char *t;
330         int n,curloc;
331         if(*s==')') return(s);
332         if(ne_d(s,&t)) return(t);
333         if(e_d(s,&t)) return(t);
334         s=gt_num(s,&n,1);
335         if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
336         return(f_s(s,curloc));
337 }
338 
339  static
340 #ifdef KR_headers
f_list(s)341 char *f_list(s) char *s;
342 #else
343 char *f_list(char *s)
344 #endif
345 {
346         for(;*s!=0;)
347         {       skip(s);
348                 if((s=i_tem(s))==NULL) return(NULL);
349                 skip(s);
350                 if(*s==',') s++;
351                 else if(*s==')')
352                 {       if(--f__parenlvl==0)
353                         {
354                                 (void) op_gen(REVERT,f__revloc,0,0);
355                                 return(++s);
356                         }
357                         (void) op_gen(GOTO,0,0,0);
358                         return(++s);
359                 }
360         }
361         return(NULL);
362 }
363 
364  int
365 #ifdef KR_headers
pars_f(s)366 pars_f(s) char *s;
367 #else
368 pars_f(char *s)
369 #endif
370 {
371         f__parenlvl=f__revloc=f__pc=0;
372         if(f_s(s,0) == NULL)
373         {
374                 return(-1);
375         }
376         return(0);
377 }
378 #define STKSZ 10
379 int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
380 flag f__workdone, f__nonl;
381 
382  static int
383 #ifdef KR_headers
type_f(n)384 type_f(n)
385 #else
386 type_f(int n)
387 #endif
388 {
389         switch(n)
390         {
391         default:
392                 return(n);
393         case RET1:
394                 return(RET1);
395         case REVERT: return(REVERT);
396         case GOTO: return(GOTO);
397         case STACK: return(STACK);
398         case X:
399         case SLASH:
400         case APOS: case H:
401         case T: case TL: case TR:
402                 return(NED);
403         case F:
404         case I:
405         case IM:
406         case A: case AW:
407         case O: case OM:
408         case L:
409         case E: case EE: case D:
410         case G: case GE:
411         case Z: case ZM:
412                 return(ED);
413         }
414 }
415 #ifdef KR_headers
do_fio(number,ptr,len)416 integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
417 #else
418 integer do_fio(ftnint *number, char *ptr, ftnlen len)
419 #endif
420 {       struct syl *p;
421         int n,i;
422         for(i=0;i<*number;i++,ptr+=len)
423         {
424 loop:   switch(type_f((p= &f__syl[f__pc])->op))
425         {
426         default:
427                 fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
428                         p->op,f__fmtbuf);
429                 err(f__elist->cierr,100,"do_fio");
430         case NED:
431                 if((*f__doned)(p))
432                 {       f__pc++;
433                         goto loop;
434                 }
435                 f__pc++;
436                 continue;
437         case ED:
438                 if(f__cnt[f__cp]<=0)
439                 {       f__cp--;
440                         f__pc++;
441                         goto loop;
442                 }
443                 if(ptr==NULL)
444                         return((*f__doend)());
445                 f__cnt[f__cp]--;
446                 f__workdone=1;
447                 if((n=(*f__doed)(p,ptr,len))>0)
448                         errfl(f__elist->cierr,errno,"fmt");
449                 if(n<0)
450                         err(f__elist->ciend,(EOF),"fmt");
451                 continue;
452         case STACK:
453                 f__cnt[++f__cp]=p->p1;
454                 f__pc++;
455                 goto loop;
456         case RET1:
457                 f__ret[++f__rp]=p->p1;
458                 f__pc++;
459                 goto loop;
460         case GOTO:
461                 if(--f__cnt[f__cp]<=0)
462                 {       f__cp--;
463                         f__rp--;
464                         f__pc++;
465                         goto loop;
466                 }
467                 f__pc=1+f__ret[f__rp--];
468                 goto loop;
469         case REVERT:
470                 f__rp=f__cp=0;
471                 f__pc = p->p1;
472                 if(ptr==NULL)
473                         return((*f__doend)());
474                 if(!f__workdone) return(0);
475                 if((n=(*f__dorevert)()) != 0) return(n);
476                 goto loop;
477         case COLON:
478                 if(ptr==NULL)
479                         return((*f__doend)());
480                 f__pc++;
481                 goto loop;
482         case NONL:
483                 f__nonl = 1;
484                 f__pc++;
485                 goto loop;
486         case S:
487         case SS:
488                 f__cplus=0;
489                 f__pc++;
490                 goto loop;
491         case SP:
492                 f__cplus = 1;
493                 f__pc++;
494                 goto loop;
495         case P: f__scale=p->p1;
496                 f__pc++;
497                 goto loop;
498         case BN:
499                 f__cblank=0;
500                 f__pc++;
501                 goto loop;
502         case BZ:
503                 f__cblank=1;
504                 f__pc++;
505                 goto loop;
506         }
507         }
508         return(0);
509 }
510 
511  int
en_fio(Void)512 en_fio(Void)
513 {       ftnint one=1;
514         return(do_fio(&one,(char *)NULL,(ftnint)0));
515 }
516 
517  VOID
fmt_bg(Void)518 fmt_bg(Void)
519 {
520         f__workdone=f__cp=f__rp=f__pc=f__cursor=0;
521         f__cnt[0]=f__ret[0]=0;
522 }
523 #ifdef __cplusplus
524 }
525 #endif
526