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