libf2c/libI77/fmt.c

   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;
  24
  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);
  36         }
  37         if(f__elist->cierr) {
  38                 errno = 100;
  39                 return(NULL);
  40         }
  41         f__fatal(100, "bad string");
  42         /*NOTREACHED*/ return 0;
  43 }
  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);
  54         }
  55         p->op=a;
  56         p->p1=b;
  57         p->p2.i[0]=c;
  58         p->p2.i[1]=d;
  59         return(f__pc++);
  60 }
  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;
  74                 }
  75                 if(c>'9' || c<'0') break;
  76                 m=10*m+c-'0';
  77                 f__cnt++;
  78                 s++;
  79         }
  80         if(f__cnt==0) {
  81                 if (!n1)
  82                         s = 0;
  83                 *n=n1;
  84                 }
  85         else *n=m;
  86         return(s);
  87 }
  88
  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
  95 {
  96         skip(s);
  97         if(*s++!='(')
  98         {
  99                 return(NULL);
 100         }
 101         if(f__parenlvl++ ==1) f__revloc=curloc;
 102         if(op_gen(RET1,curloc,0,0)<0 ||
 103                 (s=f_list(s))==NULL)
 104         {
 105                 return(NULL);
 106         }
 107         return(s);
 108 }
 109
 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)
 119         {
 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++;
 135                 }
 136                 else if(*(s+1)=='p' || *(s+1) == 'P')
 137                 {       x=SP;
 138                         s++;
 139                 }
 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;
 151                         }
 152                 switch(*s)
 153                 {
 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;
 166                 }
 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++;
 181                 }
 182                 else if(*(s+1)=='r'|| *(s+1) == 'R')
 183                 {       x=TR;
 184                         s++;
 185                 }
 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;
 196         }
 197         s++;
 198         *p=s;
 199         return(1);
 200 }
 201
 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++)
 213         {
 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;
 224                         }
 225                 if(w==0) break;
 226                 if(*s=='.') {
 227                         if (!(s=gt_num(s+1,&d,0)))
 228                                 goto bad;
 229                         }
 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);
 237                         }
 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;
 266                 }
 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;
 278                         }
 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;
 291                         }
 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;
 307                 }
 308                 if (!(s=gt_num(s+1,&d,0)))
 309                         goto bad;
 310                 (void) op_gen(im,w,d,0);
 311                 break;
 312         }
 313         if(found==0)
 314         {       f__pc--; /*unSTACK*/
 315                 *p=sv;
 316                 return(0);
 317         }
 318         *p=s;
 319         return(1);
 320 }
 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));
 335 }
 336
 337  static
 338 #ifdef KR_headers
 339 char *f_list(s) char *s;
 340 #else
 341 char *f_list(char *s)
 342 #endif
 343 {
 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)
 351                         {
 352                                 (void) op_gen(REVERT,f__revloc,0,0);
 353                                 return(++s);
 354                         }
 355                         (void) op_gen(GOTO,0,0,0);
 356                         return(++s);
 357                 }
 358         }
 359         return(NULL);
 360 }
 361
 362 #ifdef KR_headers
 363 pars_f(s) char *s;
 364 #else
 365 pars_f(char *s)
 366 #endif
 367 {
 368         char *e;
 369
 370         f__parenlvl=f__revloc=f__pc=0;
 371         if((e=f_s(s,0)) == NULL)
 372         {
 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.  */
 384
 385                 int level=0;
 386
 387                 for (f__fmtlen=0;
 388                         ((*s!=')') || (--level > 0))
 389                                 && (*s!='\0')
 390                                 && (f__fmtlen<80);
 391                         ++s, ++f__fmtlen)
 392                 {
 393                         if (*s=='(')
 394                                 ++level;
 395                 }
 396                 if (*s==')')
 397                         ++f__fmtlen;
 398                 return(-1);
 399         }
 400         f__fmtlen = e - s;
 401         return(0);
 402 }
 403 #define STKSZ 10
 404 int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
 405 flag f__workdone, f__nonl;
 406
 407  static
 408 #ifdef KR_headers
 409 type_f(n)
 410 #else
 411 type_f(int n)
 412 #endif
 413 {
 414         switch(n)
 415         {
 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);
 438         }
 439 }
 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)
 448         {
 449 loop:   switch(type_f((p= &f__syl[f__pc])->op))
 450         {
 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;
 459                 }
 460                 f__pc++;
 461                 continue;
 462         case ED:
 463                 if(f__cnt[f__cp]<=0)
 464                 {       f__cp--;
 465                         f__pc++;
 466                         goto loop;
 467                 }
 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;
 491                 }
 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;
 531         }
 532         }
 533         return(0);
 534 }
 535 en_fio(Void)
 536 {       ftnint one=1;
 537         return(do_fio(&one,(char *)NULL,(ftnint)0));
 538 }
 539  VOID
 540 fmt_bg(Void)
 541 {
 542         f__workdone=f__cp=f__rp=f__pc=f__cursor=0;
 543         f__cnt[0]=f__ret[0]=0;
 544 }