Scilab [trunk]: scilab/libs/f2c/libf2c/fmt.c Source File

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