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