00001 #include "f2c.h"
00002 #include "fio.h"
00003 #include "fmt.h"
00004 #ifdef __cplusplus
00005 extern "C" {
00006 #endif
00007 #define skip(s) while(*s==' ') s++
00008 #ifdef interdata
00009 #define SYLMX 300
00010 #endif
00011 #ifdef pdp11
00012 #define SYLMX 300
00013 #endif
00014 #ifdef vax
00015 #define SYLMX 300
00016 #endif
00017 #ifndef SYLMX
00018 #define SYLMX 5
00019 #endif
00020 #define GLITCH '\2'
00021
00022 extern flag f__cblank,f__cplus;
00023 static struct syl f__syl[SYLMX];
00024 int f__parenlvl,f__pc,f__revloc;
00025 #ifdef KR_headers
00026 #define Const
00027 #else
00028 #define Const const
00029 #endif
00030
00031 static
00032 #ifdef KR_headers
00033 char *ap_end(s) char *s;
00034 #else
00035 const char *ap_end(const char *s)
00036 #endif
00037 { char quote;
00038 quote= *s++;
00039 for(;*s;s++)
00040 { if(*s!=quote) continue;
00041 if(*++s!=quote) return(s);
00042 }
00043 if(f__elist->cierr) {
00044 errno = 100;
00045 return(NULL);
00046 }
00047 f__fatal(100, "bad string");
00048 return 0;
00049 }
00050 static int
00051 #ifdef KR_headers
00052 op_gen(a,b,c,d)
00053 #else
00054 op_gen(int a, int b, int c, int d)
00055 #endif
00056 { struct syl *p= &f__syl[f__pc];
00057 if(f__pc>=SYLMX)
00058 { fprintf(stderr,"format too complicated:\n");
00059 sig_die(f__fmtbuf, 1);
00060 }
00061 p->op=a;
00062 p->p1=b;
00063 p->p2.i[0]=c;
00064 p->p2.i[1]=d;
00065 return(f__pc++);
00066 }
00067 #ifdef KR_headers
00068 static char *f_list();
00069 static char *gt_num(s,n,n1) char *s; int *n, n1;
00070 #else
00071 static const char *f_list(const char*);
00072 static const char *gt_num(const char *s, int *n, int n1)
00073 #endif
00074 { int m=0,f__cnt=0;
00075 char c;
00076 for(c= *s;;c = *s)
00077 { if(c==' ')
00078 { s++;
00079 continue;
00080 }
00081 if(c>'9' || c<'0') break;
00082 m=10*m+c-'0';
00083 f__cnt++;
00084 s++;
00085 }
00086 if(f__cnt==0) {
00087 if (!n1)
00088 s = 0;
00089 *n=n1;
00090 }
00091 else *n=m;
00092 return(s);
00093 }
00094
00095 static
00096 #ifdef KR_headers
00097 char *f_s(s,curloc) char *s;
00098 #else
00099 const char *f_s(const char *s, int curloc)
00100 #endif
00101 {
00102 skip(s);
00103 if(*s++!='(')
00104 {
00105 return(NULL);
00106 }
00107 if(f__parenlvl++ ==1) f__revloc=curloc;
00108 if(op_gen(RET1,curloc,0,0)<0 ||
00109 (s=f_list(s))==NULL)
00110 {
00111 return(NULL);
00112 }
00113 skip(s);
00114 return(s);
00115 }
00116
00117 static int
00118 #ifdef KR_headers
00119 ne_d(s,p) char *s,**p;
00120 #else
00121 ne_d(const char *s, const char **p)
00122 #endif
00123 { int n,x,sign=0;
00124 struct syl *sp;
00125 switch(*s)
00126 {
00127 default:
00128 return(0);
00129 case ':': (void) op_gen(COLON,0,0,0); break;
00130 case '$':
00131 (void) op_gen(NONL, 0, 0, 0); break;
00132 case 'B':
00133 case 'b':
00134 if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
00135 else (void) op_gen(BN,0,0,0);
00136 break;
00137 case 'S':
00138 case 's':
00139 if(*(s+1)=='s' || *(s+1) == 'S')
00140 { x=SS;
00141 s++;
00142 }
00143 else if(*(s+1)=='p' || *(s+1) == 'P')
00144 { x=SP;
00145 s++;
00146 }
00147 else x=S;
00148 (void) op_gen(x,0,0,0);
00149 break;
00150 case '/': (void) op_gen(SLASH,0,0,0); break;
00151 case '-': sign=1;
00152 case '+': s++;
00153 case '0': case '1': case '2': case '3': case '4':
00154 case '5': case '6': case '7': case '8': case '9':
00155 if (!(s=gt_num(s,&n,0))) {
00156 bad: *p = 0;
00157 return 1;
00158 }
00159 switch(*s)
00160 {
00161 default:
00162 return(0);
00163 case 'P':
00164 case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
00165 case 'X':
00166 case 'x': (void) op_gen(X,n,0,0); break;
00167 case 'H':
00168 case 'h':
00169 sp = &f__syl[op_gen(H,n,0,0)];
00170 sp->p2.s = (char*)s + 1;
00171 s+=n;
00172 break;
00173 }
00174 break;
00175 case GLITCH:
00176 case '"':
00177 case '\'':
00178 sp = &f__syl[op_gen(APOS,0,0,0)];
00179 sp->p2.s = (char*)s;
00180 if((*p = ap_end(s)) == NULL)
00181 return(0);
00182 return(1);
00183 case 'T':
00184 case 't':
00185 if(*(s+1)=='l' || *(s+1) == 'L')
00186 { x=TL;
00187 s++;
00188 }
00189 else if(*(s+1)=='r'|| *(s+1) == 'R')
00190 { x=TR;
00191 s++;
00192 }
00193 else x=T;
00194 if (!(s=gt_num(s+1,&n,0)))
00195 goto bad;
00196 s--;
00197 (void) op_gen(x,n,0,0);
00198 break;
00199 case 'X':
00200 case 'x': (void) op_gen(X,1,0,0); break;
00201 case 'P':
00202 case 'p': (void) op_gen(P,1,0,0); break;
00203 }
00204 s++;
00205 *p=s;
00206 return(1);
00207 }
00208
00209 static int
00210 #ifdef KR_headers
00211 e_d(s,p) char *s,**p;
00212 #else
00213 e_d(const char *s, const char **p)
00214 #endif
00215 { int i,im,n,w,d,e,found=0,x=0;
00216 Const char *sv=s;
00217 s=gt_num(s,&n,1);
00218 (void) op_gen(STACK,n,0,0);
00219 switch(*s++)
00220 {
00221 default: break;
00222 case 'E':
00223 case 'e': x=1;
00224 case 'G':
00225 case 'g':
00226 found=1;
00227 if (!(s=gt_num(s,&w,0))) {
00228 bad:
00229 *p = 0;
00230 return 1;
00231 }
00232 if(w==0) break;
00233 if(*s=='.') {
00234 if (!(s=gt_num(s+1,&d,0)))
00235 goto bad;
00236 }
00237 else d=0;
00238 if(*s!='E' && *s != 'e')
00239 (void) op_gen(x==1?E:G,w,d,0);
00240 else {
00241 if (!(s=gt_num(s+1,&e,0)))
00242 goto bad;
00243 (void) op_gen(x==1?EE:GE,w,d,e);
00244 }
00245 break;
00246 case 'O':
00247 case 'o':
00248 i = O;
00249 im = OM;
00250 goto finish_I;
00251 case 'Z':
00252 case 'z':
00253 i = Z;
00254 im = ZM;
00255 goto finish_I;
00256 case 'L':
00257 case 'l':
00258 found=1;
00259 if (!(s=gt_num(s,&w,0)))
00260 goto bad;
00261 if(w==0) break;
00262 (void) op_gen(L,w,0,0);
00263 break;
00264 case 'A':
00265 case 'a':
00266 found=1;
00267 skip(s);
00268 if(*s>='0' && *s<='9')
00269 { s=gt_num(s,&w,1);
00270 if(w==0) break;
00271 (void) op_gen(AW,w,0,0);
00272 break;
00273 }
00274 (void) op_gen(A,0,0,0);
00275 break;
00276 case 'F':
00277 case 'f':
00278 if (!(s=gt_num(s,&w,0)))
00279 goto bad;
00280 found=1;
00281 if(w==0) break;
00282 if(*s=='.') {
00283 if (!(s=gt_num(s+1,&d,0)))
00284 goto bad;
00285 }
00286 else d=0;
00287 (void) op_gen(F,w,d,0);
00288 break;
00289 case 'D':
00290 case 'd':
00291 found=1;
00292 if (!(s=gt_num(s,&w,0)))
00293 goto bad;
00294 if(w==0) break;
00295 if(*s=='.') {
00296 if (!(s=gt_num(s+1,&d,0)))
00297 goto bad;
00298 }
00299 else d=0;
00300 (void) op_gen(D,w,d,0);
00301 break;
00302 case 'I':
00303 case 'i':
00304 i = I;
00305 im = IM;
00306 finish_I:
00307 if (!(s=gt_num(s,&w,0)))
00308 goto bad;
00309 found=1;
00310 if(w==0) break;
00311 if(*s!='.')
00312 { (void) op_gen(i,w,0,0);
00313 break;
00314 }
00315 if (!(s=gt_num(s+1,&d,0)))
00316 goto bad;
00317 (void) op_gen(im,w,d,0);
00318 break;
00319 }
00320 if(found==0)
00321 { f__pc--;
00322 *p=sv;
00323 return(0);
00324 }
00325 *p=s;
00326 return(1);
00327 }
00328 static
00329 #ifdef KR_headers
00330 char *i_tem(s) char *s;
00331 #else
00332 const char *i_tem(const char *s)
00333 #endif
00334 { const char *t;
00335 int n,curloc;
00336 if(*s==')') return(s);
00337 if(ne_d(s,&t)) return(t);
00338 if(e_d(s,&t)) return(t);
00339 s=gt_num(s,&n,1);
00340 if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
00341 return(f_s(s,curloc));
00342 }
00343
00344 static
00345 #ifdef KR_headers
00346 char *f_list(s) char *s;
00347 #else
00348 const char *f_list(const char *s)
00349 #endif
00350 {
00351 for(;*s!=0;)
00352 { skip(s);
00353 if((s=i_tem(s))==NULL) return(NULL);
00354 skip(s);
00355 if(*s==',') s++;
00356 else if(*s==')')
00357 { if(--f__parenlvl==0)
00358 {
00359 (void) op_gen(REVERT,f__revloc,0,0);
00360 return(++s);
00361 }
00362 (void) op_gen(GOTO,0,0,0);
00363 return(++s);
00364 }
00365 }
00366 return(NULL);
00367 }
00368
00369 int
00370 #ifdef KR_headers
00371 pars_f(s) char *s;
00372 #else
00373 pars_f(const char *s)
00374 #endif
00375 {
00376 f__parenlvl=f__revloc=f__pc=0;
00377 if(f_s(s,0) == NULL)
00378 {
00379 return(-1);
00380 }
00381 return(0);
00382 }
00383 #define STKSZ 10
00384 int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
00385 flag f__workdone, f__nonl;
00386
00387 static int
00388 #ifdef KR_headers
00389 type_f(n)
00390 #else
00391 type_f(int n)
00392 #endif
00393 {
00394 switch(n)
00395 {
00396 default:
00397 return(n);
00398 case RET1:
00399 return(RET1);
00400 case REVERT: return(REVERT);
00401 case GOTO: return(GOTO);
00402 case STACK: return(STACK);
00403 case X:
00404 case SLASH:
00405 case APOS: case H:
00406 case T: case TL: case TR:
00407 return(NED);
00408 case F:
00409 case I:
00410 case IM:
00411 case A: case AW:
00412 case O: case OM:
00413 case L:
00414 case E: case EE: case D:
00415 case G: case GE:
00416 case Z: case ZM:
00417 return(ED);
00418 }
00419 }
00420 #ifdef KR_headers
00421 integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
00422 #else
00423 integer do_fio(ftnint *number, char *ptr, ftnlen len)
00424 #endif
00425 { struct syl *p;
00426 int n,i;
00427 for(i=0;i<*number;i++,ptr+=len)
00428 {
00429 loop: switch(type_f((p= &f__syl[f__pc])->op))
00430 {
00431 default:
00432 fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
00433 p->op,f__fmtbuf);
00434 err(f__elist->cierr,100,"do_fio");
00435 case NED:
00436 if((*f__doned)(p))
00437 { f__pc++;
00438 goto loop;
00439 }
00440 f__pc++;
00441 continue;
00442 case ED:
00443 if(f__cnt[f__cp]<=0)
00444 { f__cp--;
00445 f__pc++;
00446 goto loop;
00447 }
00448 if(ptr==NULL)
00449 return((*f__doend)());
00450 f__cnt[f__cp]--;
00451 f__workdone=1;
00452 if((n=(*f__doed)(p,ptr,len))>0)
00453 errfl(f__elist->cierr,errno,"fmt");
00454 if(n<0)
00455 err(f__elist->ciend,(EOF),"fmt");
00456 continue;
00457 case STACK:
00458 f__cnt[++f__cp]=p->p1;
00459 f__pc++;
00460 goto loop;
00461 case RET1:
00462 f__ret[++f__rp]=p->p1;
00463 f__pc++;
00464 goto loop;
00465 case GOTO:
00466 if(--f__cnt[f__cp]<=0)
00467 { f__cp--;
00468 f__rp--;
00469 f__pc++;
00470 goto loop;
00471 }
00472 f__pc=1+f__ret[f__rp--];
00473 goto loop;
00474 case REVERT:
00475 f__rp=f__cp=0;
00476 f__pc = p->p1;
00477 if(ptr==NULL)
00478 return((*f__doend)());
00479 if(!f__workdone) return(0);
00480 if((n=(*f__dorevert)()) != 0) return(n);
00481 goto loop;
00482 case COLON:
00483 if(ptr==NULL)
00484 return((*f__doend)());
00485 f__pc++;
00486 goto loop;
00487 case NONL:
00488 f__nonl = 1;
00489 f__pc++;
00490 goto loop;
00491 case S:
00492 case SS:
00493 f__cplus=0;
00494 f__pc++;
00495 goto loop;
00496 case SP:
00497 f__cplus = 1;
00498 f__pc++;
00499 goto loop;
00500 case P: f__scale=p->p1;
00501 f__pc++;
00502 goto loop;
00503 case BN:
00504 f__cblank=0;
00505 f__pc++;
00506 goto loop;
00507 case BZ:
00508 f__cblank=1;
00509 f__pc++;
00510 goto loop;
00511 }
00512 }
00513 return(0);
00514 }
00515
00516 int
00517 en_fio(Void)
00518 { ftnint one=1;
00519 return(do_fio(&one,(char *)NULL,(ftnint)0));
00520 }
00521
00522 VOID
00523 fmt_bg(Void)
00524 {
00525 f__workdone=f__cp=f__rp=f__pc=f__cursor=0;
00526 f__cnt[0]=f__ret[0]=0;
00527 }
00528 #ifdef __cplusplus
00529 }
00530 #endif