lang/fortran/lib/libI77/fmt.c

   1 #include "f2c.h"
   2 #include "fio.h"
   3 #include "fmt.h"
   4 #define skip(s) while(*s==' ') s++
   5 #ifdef interdata
   6 #define SYLMX 300
   7 #endif
   8 #ifdef pdp11
   9 #define SYLMX 300
  10 #endif
  11 #ifdef vax
  12 #define SYLMX 300
  13 #endif
  14 #ifndef SYLMX
  15 #define SYLMX 300
  16 #endif
  17 #define GLITCH '\2'
  18         /* special quote character for stu */
  19 extern int cursor,scale;
  20 extern flag cblank,cplus;       /*blanks in I and compulsory plus*/
  21 struct syl syl[SYLMX];
  22 int parenlvl,pc,revloc;
  23
  24 char *f_s(),*f_list(),*i_tem(),*gt_num();
  25
  26 pars_f(s) char *s;
  27 {
  28         parenlvl=revloc=pc=0;
  29         if(f_s(s,0) == NULL)
  30         {
  31                 return(-1);
  32         }
  33         return(0);
  34 }
  35 char *f_s(s,curloc) char *s;
  36 {
  37         skip(s);
  38         if(*s++!='(')
  39         {
  40                 return(NULL);
  41         }
  42         if(parenlvl++ ==1) revloc=curloc;
  43         if(op_gen(RET,curloc,0,0)<0 ||
  44                 (s=f_list(s))==NULL)
  45         {
  46                 return(NULL);
  47         }
  48         skip(s);
  49         return(s);
  50 }
  51 char *f_list(s) char *s;
  52 {
  53         for(;*s!=0;)
  54         {       skip(s);
  55                 if((s=i_tem(s))==NULL) return(NULL);
  56                 skip(s);
  57                 if(*s==',') s++;
  58                 else if(*s==')')
  59                 {       if(--parenlvl==0)
  60                         {
  61                                 (void) op_gen(REVERT,revloc,0,0);
  62                                 return(++s);
  63                         }
  64                         (void) op_gen(GOTO,0,0,0);
  65                         return(++s);
  66                 }
  67         }
  68         return(NULL);
  69 }
  70 char *i_tem(s) char *s;
  71 {       char *t;
  72         int n,curloc;
  73         if(*s==')') return(s);
  74         if(ne_d(s,&t)) return(t);
  75         if(e_d(s,&t)) return(t);
  76         s=gt_num(s,&n);
  77         if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
  78         return(f_s(s,curloc));
  79 }
  80 ne_d(s,p) char *s,**p;
  81 {       int n,x,sign=0;
  82         char *ap_end();
  83         struct syl *sp;
  84         switch(*s)
  85         {
  86         default:
  87                 return(0);
  88         case ':': (void) op_gen(COLON,0,0,0); break;
  89         case '$':
  90                 (void) op_gen(NONL, 0, 0, 0); break;
  91         case 'B':
  92         case 'b':
  93                 if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
  94                 else (void) op_gen(BN,0,0,0);
  95                 break;
  96         case 'S':
  97         case 's':
  98                 if(*(s+1)=='s' || *(s+1) == 'S')
  99                 {       x=SS;
 100                         s++;
 101                 }
 102                 else if(*(s+1)=='p' || *(s+1) == 'P')
 103                 {       x=SP;
 104                         s++;
 105                 }
 106                 else x=S;
 107                 (void) op_gen(x,0,0,0);
 108                 break;
 109         case '/': (void) op_gen(SLASH,0,0,0); break;
 110         case '-': sign=1;
 111         case '+':       s++;    /*OUTRAGEOUS CODING TRICK*/
 112         case '0': case '1': case '2': case '3': case '4':
 113         case '5': case '6': case '7': case '8': case '9':
 114                 s=gt_num(s,&n);
 115                 switch(*s)
 116                 {
 117                 default:
 118                         return(0);
 119                 case 'P':
 120                 case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
 121                 case 'X':
 122                 case 'x': (void) op_gen(X,n,0,0); break;
 123                 case 'H':
 124                 case 'h':
 125                         sp = &syl[op_gen(H,n,0,0)];
 126                         *(char **)&sp->p2 = s + 1;
 127                         s+=n;
 128                         break;
 129                 }
 130                 break;
 131         case GLITCH:
 132         case '"':
 133         case '\'':
 134                 sp = &syl[op_gen(APOS,0,0,0)];
 135                 *(char **)&sp->p2 = s;
 136                 if((*p = ap_end(s)) == NULL)
 137                         return(0);
 138                 return(1);
 139         case 'T':
 140         case 't':
 141                 if(*(s+1)=='l' || *(s+1) == 'L')
 142                 {       x=TL;
 143                         s++;
 144                 }
 145                 else if(*(s+1)=='r'|| *(s+1) == 'R')
 146                 {       x=TR;
 147                         s++;
 148                 }
 149                 else x=T;
 150                 s=gt_num(s+1,&n);
 151                 s--;
 152                 (void) op_gen(x,n,0,0);
 153                 break;
 154         case 'X':
 155         case 'x': (void) op_gen(X,1,0,0); break;
 156         case 'P':
 157         case 'p': (void) op_gen(P,1,0,0); break;
 158         }
 159         s++;
 160         *p=s;
 161         return(1);
 162 }
 163 e_d(s,p) char *s,**p;
 164 {       int n,w,d,e,found=0,x=0;
 165         char *sv=s;
 166         s=gt_num(s,&n);
 167         (void) op_gen(STACK,n,0,0);
 168         switch(*s++)
 169         {
 170         default: break;
 171         case 'E':
 172         case 'e':       x=1;
 173         case 'G':
 174         case 'g':
 175                 found=1;
 176                 s=gt_num(s,&w);
 177                 if(w==0) break;
 178                 if(*s=='.')
 179                 {       s++;
 180                         s=gt_num(s,&d);
 181                 }
 182                 else d=0;
 183                 if(*s!='E' && *s != 'e')
 184                         (void) op_gen(x==1?E:G,w,d,0);  /* default is Ew.dE2 */
 185                 else
 186                 {       s++;
 187                         s=gt_num(s,&e);
 188                         (void) op_gen(x==1?EE:GE,w,d,e);
 189                 }
 190                 break;
 191         case 'O':
 192         case 'o':
 193                 found = 1;
 194                 s = gt_num(s, &w);
 195                 if(w==0) break;
 196                 (void) op_gen(O, w, 0, 0);
 197                 break;
 198         case 'L':
 199         case 'l':
 200                 found=1;
 201                 s=gt_num(s,&w);
 202                 if(w==0) break;
 203                 (void) op_gen(L,w,0,0);
 204                 break;
 205         case 'A':
 206         case 'a':
 207                 found=1;
 208                 skip(s);
 209                 if(*s>='0' && *s<='9')
 210                 {       s=gt_num(s,&w);
 211                         if(w==0) break;
 212                         (void) op_gen(AW,w,0,0);
 213                         break;
 214                 }
 215                 (void) op_gen(A,0,0,0);
 216                 break;
 217         case 'F':
 218         case 'f':
 219                 found=1;
 220                 s=gt_num(s,&w);
 221                 if(w==0) break;
 222                 if(*s=='.')
 223                 {       s++;
 224                         s=gt_num(s,&d);
 225                 }
 226                 else d=0;
 227                 (void) op_gen(F,w,d,0);
 228                 break;
 229         case 'D':
 230         case 'd':
 231                 found=1;
 232                 s=gt_num(s,&w);
 233                 if(w==0) break;
 234                 if(*s=='.')
 235                 {       s++;
 236                         s=gt_num(s,&d);
 237                 }
 238                 else d=0;
 239                 (void) op_gen(D,w,d,0);
 240                 break;
 241         case 'I':
 242         case 'i':
 243                 found=1;
 244                 s=gt_num(s,&w);
 245                 if(w==0) break;
 246                 if(*s!='.')
 247                 {       (void) op_gen(I,w,0,0);
 248                         break;
 249                 }
 250                 s++;
 251                 s=gt_num(s,&d);
 252                 (void) op_gen(IM,w,d,0);
 253                 break;
 254         }
 255         if(found==0)
 256         {       pc--; /*unSTACK*/
 257                 *p=sv;
 258                 return(0);
 259         }
 260         *p=s;
 261         return(1);
 262 }
 263 op_gen(a,b,c,d)
 264 {       struct syl *p= &syl[pc];
 265         if(pc>=SYLMX)
 266         {       fprintf(stderr,"format too complicated:\n");
 267                 sig_die(fmtbuf, 1);
 268         }
 269         p->op=a;
 270         p->p1=b;
 271         p->p2=c;
 272         p->p3=d;
 273         return(pc++);
 274 }
 275 char *gt_num(s,n) char *s; int *n;
 276 {       int m=0,cnt=0;
 277         char c;
 278         for(c= *s;;c = *s)
 279         {       if(c==' ')
 280                 {       s++;
 281                         continue;
 282                 }
 283                 if(c>'9' || c<'0') break;
 284                 m=10*m+c-'0';
 285                 cnt++;
 286                 s++;
 287         }
 288         if(cnt==0) *n=1;
 289         else *n=m;
 290         return(s);
 291 }
 292 #define STKSZ 10
 293 int cnt[STKSZ],ret[STKSZ],cp,rp;
 294 flag workdone, nonl;
 295
 296 integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
 297 {       struct syl *p;
 298         int n,i;
 299         for(i=0;i<*number;i++,ptr+=len)
 300         {
 301 loop:   switch(type_f((p= &syl[pc])->op))
 302         {
 303         default:
 304                 fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
 305                         p->op,fmtbuf);
 306                 err(elist->cierr,100,"do_fio");
 307         case NED:
 308                 if((*doned)(p))
 309                 {       pc++;
 310                         goto loop;
 311                 }
 312                 pc++;
 313                 continue;
 314         case ED:
 315                 if(cnt[cp]<=0)
 316                 {       cp--;
 317                         pc++;
 318                         goto loop;
 319                 }
 320                 if(ptr==NULL)
 321                         return((*doend)());
 322                 cnt[cp]--;
 323                 workdone=1;
 324                 if((n=(*doed)(p,ptr,len))>0) err(elist->cierr,errno,"fmt");
 325                 if(n<0) err(elist->ciend,(EOF),"fmt");
 326                 continue;
 327         case STACK:
 328                 cnt[++cp]=p->p1;
 329                 pc++;
 330                 goto loop;
 331         case RET:
 332                 ret[++rp]=p->p1;
 333                 pc++;
 334                 goto loop;
 335         case GOTO:
 336                 if(--cnt[cp]<=0)
 337                 {       cp--;
 338                         rp--;
 339                         pc++;
 340                         goto loop;
 341                 }
 342                 pc=1+ret[rp--];
 343                 goto loop;
 344         case REVERT:
 345                 rp=cp=0;
 346                 pc = p->p1;
 347                 if(ptr==NULL)
 348                         return((*doend)());
 349                 if(!workdone) return(0);
 350                 if((n=(*dorevert)()) != 0) return(n);
 351                 goto loop;
 352         case COLON:
 353                 if(ptr==NULL)
 354                         return((*doend)());
 355                 pc++;
 356                 goto loop;
 357         case NONL:
 358                 nonl = 1;
 359                 pc++;
 360                 goto loop;
 361         case S:
 362         case SS:
 363                 cplus=0;
 364                 pc++;
 365                 goto loop;
 366         case SP:
 367                 cplus = 1;
 368                 pc++;
 369                 goto loop;
 370         case P: scale=p->p1;
 371                 pc++;
 372                 goto loop;
 373         case BN:
 374                 cblank=0;
 375                 pc++;
 376                 goto loop;
 377         case BZ:
 378                 cblank=1;
 379                 pc++;
 380                 goto loop;
 381         }
 382         }
 383         return(0);
 384 }
 385 en_fio()
 386 {       ftnint one=1;
 387         return(do_fio(&one,(char *)NULL,(ftnint)0));
 388 }
 389 fmt_bg()
 390 {
 391         workdone=cp=rp=pc=cursor=0;
 392         cnt[0]=ret[0]=0;
 393 }
 394 type_f(n)
 395 {
 396         switch(n)
 397         {
 398         default:
 399                 return(n);
 400         case RET:
 401                 return(RET);
 402         case REVERT: return(REVERT);
 403         case GOTO: return(GOTO);
 404         case STACK: return(STACK);
 405         case X:
 406         case SLASH:
 407         case APOS: case H:
 408         case T: case TL: case TR:
 409                 return(NED);
 410         case F:
 411         case I:
 412         case IM:
 413         case A: case AW:
 414         case O:
 415         case L:
 416         case E: case EE: case D:
 417         case G: case GE:
 418                 return(ED);
 419         }
 420 }
 421 char *ap_end(s) char *s;
 422 {       char quote;
 423         quote= *s++;
 424         for(;*s;s++)
 425         {       if(*s!=quote) continue;
 426                 if(*++s!=quote) return(s);
 427         }
 428         if(elist->cierr) {
 429                 errno = 100;
 430                 return(NULL);
 431         }
 432         fatal(100, "bad string");
 433         /*NOTREACHED*/ return 0;
 434 }