5 #define skip(s) while(*s==' ') s++
19 /* special quote character for stu */
20 extern int f__cursor
,f__scale
;
21 extern flag f__cblank
,f__cplus
; /*blanks in I and compulsory plus*/
22 static struct syl f__syl
[SYLMX
];
23 int f__parenlvl
,f__pc
,f__revloc
;
27 char *ap_end(s
) char *s
;
34 { if(*s
!=quote
) continue;
35 if(*++s
!=quote
) return(s
);
41 f__fatal(100, "bad string");
42 /*NOTREACHED*/ return 0;
48 op_gen(int a
, int b
, int c
, int d
)
50 { struct syl
*p
= &f__syl
[f__pc
];
52 { fprintf(stderr
,"format too complicated:\n");
53 sig_die(f__fmtbuf
, 1);
62 static char *f_list();
63 static char *gt_num(s
,n
,n1
) char *s
; int *n
, n1
;
65 static char *f_list(char*);
66 static char *gt_num(char *s
, int *n
, int n1
)
75 if(c
>'9' || c
<'0') break;
91 char *f_s(s
,curloc
) char *s
;
93 char *f_s(char *s
, int curloc
)
101 if(f__parenlvl
++ ==1) f__revloc
=curloc
;
102 if(op_gen(RET1
,curloc
,0,0)<0 ||
112 ne_d(s
,p
) char *s
,**p
;
114 ne_d(char *s
, char **p
)
122 case ':': (void) op_gen(COLON
,0,0,0); break;
124 (void) op_gen(NONL
, 0, 0, 0); break;
127 if(*++s
=='z' || *s
== 'Z') (void) op_gen(BZ
,0,0,0);
128 else (void) op_gen(BN
,0,0,0);
132 if(*(s
+1)=='s' || *(s
+1) == 'S')
136 else if(*(s
+1)=='p' || *(s
+1) == 'P')
141 (void) op_gen(x
,0,0,0);
143 case '/': (void) op_gen(SLASH
,0,0,0); break;
145 case '+': s
++; /*OUTRAGEOUS CODING TRICK*/
146 case '0': case '1': case '2': case '3': case '4':
147 case '5': case '6': case '7': case '8': case '9':
148 if (!(s
=gt_num(s
,&n
,0))) {
157 case 'p': if(sign
) n
= -n
; (void) op_gen(P
,n
,0,0); break;
159 case 'x': (void) op_gen(X
,n
,0,0); break;
162 sp
= &f__syl
[op_gen(H
,n
,0,0)];
171 sp
= &f__syl
[op_gen(APOS
,0,0,0)];
173 if((*p
= ap_end(s
)) == NULL
)
178 if(*(s
+1)=='l' || *(s
+1) == 'L')
182 else if(*(s
+1)=='r'|| *(s
+1) == 'R')
187 if (!(s
=gt_num(s
+1,&n
,0)))
190 (void) op_gen(x
,n
,0,0);
193 case 'x': (void) op_gen(X
,1,0,0); break;
195 case 'p': (void) op_gen(P
,1,0,0); break;
204 e_d(s
,p
) char *s
,**p
;
206 e_d(char *s
, char **p
)
208 { int i
,im
,n
,w
,d
,e
,found
=0,x
=0;
211 (void) op_gen(STACK
,n
,0,0);
220 if (!(s
=gt_num(s
,&w
,0))) {
227 if (!(s
=gt_num(s
+1,&d
,0)))
231 if(*s
!='E' && *s
!= 'e')
232 (void) op_gen(x
==1?E
:G
,w
,d
,0); /* default is Ew.dE2 */
234 if (!(s
=gt_num(s
+1,&e
,0)))
236 (void) op_gen(x
==1?EE
:GE
,w
,d
,e
);
252 if (!(s
=gt_num(s
,&w
,0)))
255 (void) op_gen(L
,w
,0,0);
261 if(*s
>='0' && *s
<='9')
264 (void) op_gen(AW
,w
,0,0);
267 (void) op_gen(A
,0,0,0);
271 if (!(s
=gt_num(s
,&w
,0)))
276 if (!(s
=gt_num(s
+1,&d
,0)))
280 (void) op_gen(F
,w
,d
,0);
285 if (!(s
=gt_num(s
,&w
,0)))
289 if (!(s
=gt_num(s
+1,&d
,0)))
293 (void) op_gen(D
,w
,d
,0);
300 if (!(s
=gt_num(s
,&w
,0)))
305 { (void) op_gen(i
,w
,0,0);
308 if (!(s
=gt_num(s
+1,&d
,0)))
310 (void) op_gen(im
,w
,d
,0);
314 { f__pc
--; /*unSTACK*/
323 char *i_tem(s
) char *s
;
329 if(*s
==')') return(s
);
330 if(ne_d(s
,&t
)) return(t
);
331 if(e_d(s
,&t
)) return(t
);
333 if((curloc
=op_gen(STACK
,n
,0,0))<0) return(NULL
);
334 return(f_s(s
,curloc
));
339 char *f_list(s
) char *s
;
341 char *f_list(char *s
)
346 if((s
=i_tem(s
))==NULL
) return(NULL
);
350 { if(--f__parenlvl
==0)
352 (void) op_gen(REVERT
,f__revloc
,0,0);
355 (void) op_gen(GOTO
,0,0,0);
370 f__parenlvl
=f__revloc
=f__pc
=0;
371 if((e
=f_s(s
,0)) == NULL
)
373 /* Try and delimit the format string. Parens within
374 hollerith and quoted strings have to match for this
375 to work, but it's probably adequate for most needs.
376 Note that this is needed because a valid CHARACTER
377 variable passed for FMT= can contain '(I)garbage',
378 where `garbage' is billions and billions of junk
379 characters, and it's up to the run-time library to
380 know where the format string ends by counting parens.
381 Meanwhile, still treat NUL byte as "hard stop", since
382 f2c still appends that at end of FORMAT-statement
388 ((*s
!=')') || (--level
> 0))
404 int f__cnt
[STKSZ
],f__ret
[STKSZ
],f__cp
,f__rp
;
405 flag f__workdone
, f__nonl
;
420 case REVERT
: return(REVERT
);
421 case GOTO
: return(GOTO
);
422 case STACK
: return(STACK
);
426 case T
: case TL
: case TR
:
434 case E
: case EE
: case D
:
441 integer
do_fio(number
,ptr
,len
) ftnint
*number
; ftnlen len
; char *ptr
;
443 integer
do_fio(ftnint
*number
, char *ptr
, ftnlen len
)
447 for(i
=0;i
<*number
;i
++,ptr
+=len
)
449 loop
: switch(type_f((p
= &f__syl
[f__pc
])->op
))
452 fprintf(stderr
,"unknown code in do_fio: %d\n%.*s\n",
453 p
->op
,f__fmtlen
,f__fmtbuf
);
454 err(f__elist
->cierr
,100,"do_fio");
469 return((*f__doend
)());
472 if((n
=(*f__doed
)(p
,ptr
,len
))>0)
473 errfl(f__elist
->cierr
,errno
,"fmt");
475 err(f__elist
->ciend
,(EOF
),"fmt");
478 f__cnt
[++f__cp
]=p
->p1
;
482 f__ret
[++f__rp
]=p
->p1
;
486 if(--f__cnt
[f__cp
]<=0)
492 f__pc
=1+f__ret
[f__rp
--];
498 return((*f__doend
)());
499 if(!f__workdone
) return(0);
500 if((n
=(*f__dorevert
)()) != 0) return(n
);
504 return((*f__doend
)());
520 case P
: f__scale
=p
->p1
;
537 return(do_fio(&one
,(char *)NULL
,(ftnint
)0));
542 f__workdone
=f__cp
=f__rp
=f__pc
=f__cursor
=0;
543 f__cnt
[0]=f__ret
[0]=0;