4 #define skip(s) while(*s==' ') s++
18 /* special quote character for stu */
19 extern int f__cursor
,f__scale
;
20 extern flag f__cblank
,f__cplus
; /*blanks in I and compulsory plus*/
21 static struct syl f__syl
[SYLMX
];
22 int f__parenlvl
,f__pc
,f__revloc
;
26 char *ap_end(s
) char *s
;
33 { if(*s
!=quote
) continue;
34 if(*++s
!=quote
) return(s
);
40 f__fatal(100, "bad string");
41 /*NOTREACHED*/ return 0;
47 op_gen(int a
, int b
, int c
, int d
)
49 { struct syl
*p
= &f__syl
[f__pc
];
51 { fprintf(stderr
,"format too complicated:\n");
52 sig_die(f__fmtbuf
, 1);
61 static char *f_list();
62 static char *gt_num(s
,n
,n1
) char *s
; int *n
, n1
;
64 static char *f_list(char*);
65 static char *gt_num(char *s
, int *n
, int n1
)
74 if(c
>'9' || c
<'0') break;
90 char *f_s(s
,curloc
) char *s
;
92 char *f_s(char *s
, int curloc
)
100 if(f__parenlvl
++ ==1) f__revloc
=curloc
;
101 if(op_gen(RET1
,curloc
,0,0)<0 ||
111 ne_d(s
,p
) char *s
,**p
;
113 ne_d(char *s
, char **p
)
121 case ':': (void) op_gen(COLON
,0,0,0); break;
123 (void) op_gen(NONL
, 0, 0, 0); break;
126 if(*++s
=='z' || *s
== 'Z') (void) op_gen(BZ
,0,0,0);
127 else (void) op_gen(BN
,0,0,0);
131 if(*(s
+1)=='s' || *(s
+1) == 'S')
135 else if(*(s
+1)=='p' || *(s
+1) == 'P')
140 (void) op_gen(x
,0,0,0);
142 case '/': (void) op_gen(SLASH
,0,0,0); break;
144 case '+': s
++; /*OUTRAGEOUS CODING TRICK*/
145 case '0': case '1': case '2': case '3': case '4':
146 case '5': case '6': case '7': case '8': case '9':
147 if (!(s
=gt_num(s
,&n
,0))) {
156 case 'p': if(sign
) n
= -n
; (void) op_gen(P
,n
,0,0); break;
158 case 'x': (void) op_gen(X
,n
,0,0); break;
161 sp
= &f__syl
[op_gen(H
,n
,0,0)];
170 sp
= &f__syl
[op_gen(APOS
,0,0,0)];
172 if((*p
= ap_end(s
)) == NULL
)
177 if(*(s
+1)=='l' || *(s
+1) == 'L')
181 else if(*(s
+1)=='r'|| *(s
+1) == 'R')
186 if (!(s
=gt_num(s
+1,&n
,0)))
189 (void) op_gen(x
,n
,0,0);
192 case 'x': (void) op_gen(X
,1,0,0); break;
194 case 'p': (void) op_gen(P
,1,0,0); break;
203 e_d(s
,p
) char *s
,**p
;
205 e_d(char *s
, char **p
)
207 { int i
,im
,n
,w
,d
,e
,found
=0,x
=0;
210 (void) op_gen(STACK
,n
,0,0);
219 if (!(s
=gt_num(s
,&w
,0))) {
226 if (!(s
=gt_num(s
+1,&d
,0)))
230 if(*s
!='E' && *s
!= 'e')
231 (void) op_gen(x
==1?E
:G
,w
,d
,0); /* default is Ew.dE2 */
233 if (!(s
=gt_num(s
+1,&e
,0)))
235 (void) op_gen(x
==1?EE
:GE
,w
,d
,e
);
251 if (!(s
=gt_num(s
,&w
,0)))
254 (void) op_gen(L
,w
,0,0);
260 if(*s
>='0' && *s
<='9')
263 (void) op_gen(AW
,w
,0,0);
266 (void) op_gen(A
,0,0,0);
270 if (!(s
=gt_num(s
,&w
,0)))
275 if (!(s
=gt_num(s
+1,&d
,0)))
279 (void) op_gen(F
,w
,d
,0);
284 if (!(s
=gt_num(s
,&w
,0)))
288 if (!(s
=gt_num(s
+1,&d
,0)))
292 (void) op_gen(D
,w
,d
,0);
299 if (!(s
=gt_num(s
,&w
,0)))
304 { (void) op_gen(i
,w
,0,0);
307 if (!(s
=gt_num(s
+1,&d
,0)))
309 (void) op_gen(im
,w
,d
,0);
313 { f__pc
--; /*unSTACK*/
322 char *i_tem(s
) char *s
;
328 if(*s
==')') return(s
);
329 if(ne_d(s
,&t
)) return(t
);
330 if(e_d(s
,&t
)) return(t
);
332 if((curloc
=op_gen(STACK
,n
,0,0))<0) return(NULL
);
333 return(f_s(s
,curloc
));
338 char *f_list(s
) char *s
;
340 char *f_list(char *s
)
345 if((s
=i_tem(s
))==NULL
) return(NULL
);
349 { if(--f__parenlvl
==0)
351 (void) op_gen(REVERT
,f__revloc
,0,0);
354 (void) op_gen(GOTO
,0,0,0);
369 f__parenlvl
=f__revloc
=f__pc
=0;
370 if((e
=f_s(s
,0)) == NULL
)
372 /* Try and delimit the format string. Parens within
373 hollerith and quoted strings have to match for this
374 to work, but it's probably adequate for most needs.
375 Note that this is needed because a valid CHARACTER
376 variable passed for FMT= can contain '(I)garbage',
377 where `garbage' is billions and billions of junk
378 characters, and it's up to the run-time library to
379 know where the format string ends by counting parens.
380 Meanwhile, still treat NUL byte as "hard stop", since
381 f2c still appends that at end of FORMAT-statement
387 ((*s
!=')') || (--level
> 0))
403 int f__cnt
[STKSZ
],f__ret
[STKSZ
],f__cp
,f__rp
;
404 flag f__workdone
, f__nonl
;
419 case REVERT
: return(REVERT
);
420 case GOTO
: return(GOTO
);
421 case STACK
: return(STACK
);
425 case T
: case TL
: case TR
:
433 case E
: case EE
: case D
:
440 integer
do_fio(number
,ptr
,len
) ftnint
*number
; ftnlen len
; char *ptr
;
442 integer
do_fio(ftnint
*number
, char *ptr
, ftnlen len
)
446 for(i
=0;i
<*number
;i
++,ptr
+=len
)
448 loop
: switch(type_f((p
= &f__syl
[f__pc
])->op
))
451 fprintf(stderr
,"unknown code in do_fio: %d\n%.*s\n",
452 p
->op
,f__fmtlen
,f__fmtbuf
);
453 err(f__elist
->cierr
,100,"do_fio");
468 return((*f__doend
)());
471 if((n
=(*f__doed
)(p
,ptr
,len
))>0)
472 errfl(f__elist
->cierr
,errno
,"fmt");
474 err(f__elist
->ciend
,(EOF
),"fmt");
477 f__cnt
[++f__cp
]=p
->p1
;
481 f__ret
[++f__rp
]=p
->p1
;
485 if(--f__cnt
[f__cp
]<=0)
491 f__pc
=1+f__ret
[f__rp
--];
497 return((*f__doend
)());
498 if(!f__workdone
) return(0);
499 if((n
=(*f__dorevert
)()) != 0) return(n
);
503 return((*f__doend
)());
519 case P
: f__scale
=p
->p1
;
536 return(do_fio(&one
,(char *)NULL
,(ftnint
)0));
541 f__workdone
=f__cp
=f__rp
=f__pc
=f__cursor
=0;
542 f__cnt
[0]=f__ret
[0]=0;