libf2c/libI77/lread.c

   1 #include <ctype.h>
   2 #include "f2c.h"
   3 #include "fio.h"
   4
   5 /* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
   6 /* marks in namelist input a la the Fortran 8X Draft published in  */
   7 /* the May 1989 issue of Fortran Forum. */
   8
   9
  10 extern char *f__fmtbuf;
  11 extern int f__fmtlen;
  12
  13 #ifdef Allow_TYQUAD
  14 static longint f__llx;
  15 static int quad_read;
  16 #endif
  17
  18 #ifdef KR_headers
  19 extern double atof();
  20 extern char *malloc(), *realloc();
  21 int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
  22 #else
  23 #undef abs
  24 #undef min
  25 #undef max
  26 #include <stdlib.h>
  27 #endif
  28
  29 #include "fmt.h"
  30 #include "lio.h"
  31 #include "fp.h"
  32
  33 #ifndef KR_headers
  34 int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
  35         (*l_ungetc)(int,FILE*);
  36 #endif
  37
  38 int l_eof;
  39
  40 #define isblnk(x) (f__ltab[x+1]&B)
  41 #define issep(x) (f__ltab[x+1]&SX)
  42 #define isapos(x) (f__ltab[x+1]&AX)
  43 #define isexp(x) (f__ltab[x+1]&EX)
  44 #define issign(x) (f__ltab[x+1]&SG)
  45 #define iswhit(x) (f__ltab[x+1]&WH)
  46 #define SX 1
  47 #define B 2
  48 #define AX 4
  49 #define EX 8
  50 #define SG 16
  51 #define WH 32
  52 char f__ltab[128+1] = { /* offset one for EOF */
  53         0,
  54         0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
  55         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  56         SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
  57         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  58         0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  59         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  60         AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  61         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  62 };
  63
  64 #ifdef ungetc
  65  static int
  66 #ifdef KR_headers
  67 un_getc(x,f__cf) int x; FILE *f__cf;
  68 #else
  69 un_getc(int x, FILE *f__cf)
  70 #endif
  71 { return ungetc(x,f__cf); }
  72 #else
  73 #define un_getc ungetc
  74 #ifdef KR_headers
  75  extern int ungetc();
  76 #else
  77 extern int ungetc(int, FILE*);  /* for systems with a buggy stdio.h */
  78 #endif
  79 #endif
  80
  81 t_getc(Void)
  82 {       int ch;
  83         if(f__curunit->uend) return(EOF);
  84         if((ch=getc(f__cf))!=EOF) return(ch);
  85         if(feof(f__cf))
  86                 f__curunit->uend = l_eof = 1;
  87         return(EOF);
  88 }
  89 integer e_rsle(Void)
  90 {
  91         int ch;
  92         f__init = 1;
  93         if(f__curunit->uend) return(0);
  94         while((ch=t_getc())!='\n')
  95                 if (ch == EOF) {
  96                         if(feof(f__cf))
  97                                 f__curunit->uend = l_eof = 1;
  98                         return EOF;
  99                         }
 100         return(0);
 101 }
 102
 103 flag f__lquit;
 104 int f__lcount,f__ltype,nml_read;
 105 char *f__lchar;
 106 double f__lx,f__ly;
 107 #define ERR(x) if(n=(x)) {f__init &= ~2; return(n);}
 108 #define GETC(x) (x=(*l_getc)())
 109 #define Ungetc(x,y) (*l_ungetc)(x,y)
 110
 111  static int
 112 #ifdef KR_headers
 113 l_R(poststar, reqint) int poststar, reqint;
 114 #else
 115 l_R(int poststar, int reqint)
 116 #endif
 117 {
 118         char s[FMAX+EXPMAXDIGS+4];
 119         register int ch;
 120         register char *sp, *spe, *sp1;
 121         long e, exp;
 122         int havenum, havestar, se;
 123
 124         if (!poststar) {
 125                 if (f__lcount > 0)
 126                         return(0);
 127                 f__lcount = 1;
 128                 }
 129 #ifdef Allow_TYQUAD
 130         f__llx = 0;
 131 #endif
 132         f__ltype = 0;
 133         exp = 0;
 134         havestar = 0;
 135 retry:
 136         sp1 = sp = s;
 137         spe = sp + FMAX;
 138         havenum = 0;
 139
 140         switch(GETC(ch)) {
 141                 case '-': *sp++ = ch; sp1++; spe++;
 142                 case '+':
 143                         GETC(ch);
 144                 }
 145         while(ch == '0') {
 146                 ++havenum;
 147                 GETC(ch);
 148                 }
 149         while(isdigit(ch)) {
 150                 if (sp < spe) *sp++ = ch;
 151                 else ++exp;
 152                 GETC(ch);
 153                 }
 154         if (ch == '*' && !poststar) {
 155                 if (sp == sp1 || exp || *s == '-') {
 156                         errfl(f__elist->cierr,112,"bad repetition count");
 157                         }
 158                 poststar = havestar = 1;
 159                 *sp = 0;
 160                 f__lcount = atoi(s);
 161                 goto retry;
 162                 }
 163         if (ch == '.') {
 164 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
 165                 if (reqint)
 166                         errfl(f__elist->cierr,115,"invalid integer");
 167 #endif
 168                 GETC(ch);
 169                 if (sp == sp1)
 170                         while(ch == '0') {
 171                                 ++havenum;
 172                                 --exp;
 173                                 GETC(ch);
 174                                 }
 175                 while(isdigit(ch)) {
 176                         if (sp < spe)
 177                                 { *sp++ = ch; --exp; }
 178                         GETC(ch);
 179                         }
 180                 }
 181         havenum += sp - sp1;
 182         se = 0;
 183         if (issign(ch))
 184                 goto signonly;
 185         if (havenum && isexp(ch)) {
 186 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
 187                 if (reqint)
 188                         errfl(f__elist->cierr,115,"invalid integer");
 189 #endif
 190                 GETC(ch);
 191                 if (issign(ch)) {
 192 signonly:
 193                         if (ch == '-') se = 1;
 194                         GETC(ch);
 195                         }
 196                 if (!isdigit(ch)) {
 197 bad:
 198                         errfl(f__elist->cierr,112,"exponent field");
 199                         }
 200
 201                 e = ch - '0';
 202                 while(isdigit(GETC(ch))) {
 203                         e = 10*e + ch - '0';
 204                         if (e > EXPMAX)
 205                                 goto bad;
 206                         }
 207                 if (se)
 208                         exp -= e;
 209                 else
 210                         exp += e;
 211                 }
 212         (void) Ungetc(ch, f__cf);
 213         if (sp > sp1) {
 214                 ++havenum;
 215                 while(*--sp == '0')
 216                         ++exp;
 217                 if (exp)
 218                         sprintf(sp+1, "e%ld", exp);
 219                 else
 220                         sp[1] = 0;
 221                 f__lx = atof(s);
 222 #ifdef Allow_TYQUAD
 223                 if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
 224                         /* Assuming 64-bit longint and 32-bit long. */
 225                         if (exp < 0)
 226                                 sp += exp;
 227                         if (sp1 <= sp) {
 228                                 f__llx = *sp1 - '0';
 229                                 while(++sp1 <= sp)
 230                                         f__llx = 10*f__llx + (*sp1 - '0');
 231                                 }
 232                         while(--exp >= 0)
 233                                 f__llx *= 10;
 234                         if (*s == '-')
 235                                 f__llx = -f__llx;
 236                         }
 237 #endif
 238                 }
 239         else
 240                 f__lx = 0.;
 241         if (havenum)
 242                 f__ltype = TYLONG;
 243         else
 244                 switch(ch) {
 245                         case ',':
 246                         case '/':
 247                                 break;
 248                         default:
 249                                 if (havestar && ( ch == ' '
 250                                                 ||ch == '\t'
 251                                                 ||ch == '\n'))
 252                                         break;
 253                                 if (nml_read > 1) {
 254                                         f__lquit = 2;
 255                                         return 0;
 256                                         }
 257                                 errfl(f__elist->cierr,112,"invalid number");
 258                         }
 259         return 0;
 260         }
 261
 262  static int
 263 #ifdef KR_headers
 264 rd_count(ch) register int ch;
 265 #else
 266 rd_count(register int ch)
 267 #endif
 268 {
 269         if (ch < '0' || ch > '9')
 270                 return 1;
 271         f__lcount = ch - '0';
 272         while(GETC(ch) >= '0' && ch <= '9')
 273                 f__lcount = 10*f__lcount + ch - '0';
 274         Ungetc(ch,f__cf);
 275         return f__lcount <= 0;
 276         }
 277
 278  static int
 279 l_C(Void)
 280 {       int ch, nml_save;
 281         double lz;
 282         if(f__lcount>0) return(0);
 283         f__ltype=0;
 284         GETC(ch);
 285         if(ch!='(')
 286         {
 287                 if (nml_read > 1 && (ch < '0' || ch > '9')) {
 288                         Ungetc(ch,f__cf);
 289                         f__lquit = 2;
 290                         return 0;
 291                         }
 292                 if (rd_count(ch))
 293                         if(!f__cf || !feof(f__cf))
 294                                 errfl(f__elist->cierr,112,"complex format");
 295                         else
 296                                 err(f__elist->cierr,(EOF),"lread");
 297                 if(GETC(ch)!='*')
 298                 {
 299                         if(!f__cf || !feof(f__cf))
 300                                 errfl(f__elist->cierr,112,"no star");
 301                         else
 302                                 err(f__elist->cierr,(EOF),"lread");
 303                 }
 304                 if(GETC(ch)!='(')
 305                 {       Ungetc(ch,f__cf);
 306                         return(0);
 307                 }
 308         }
 309         else
 310                 f__lcount = 1;
 311         while(iswhit(GETC(ch)));
 312         Ungetc(ch,f__cf);
 313         nml_save = nml_read;
 314         nml_read = 0;
 315         if (ch = l_R(1,0))
 316                 return ch;
 317         if (!f__ltype)
 318                 errfl(f__elist->cierr,112,"no real part");
 319         lz = f__lx;
 320         while(iswhit(GETC(ch)));
 321         if(ch!=',')
 322         {       (void) Ungetc(ch,f__cf);
 323                 errfl(f__elist->cierr,112,"no comma");
 324         }
 325         while(iswhit(GETC(ch)));
 326         (void) Ungetc(ch,f__cf);
 327         if (ch = l_R(1,0))
 328                 return ch;
 329         if (!f__ltype)
 330                 errfl(f__elist->cierr,112,"no imaginary part");
 331         while(iswhit(GETC(ch)));
 332         if(ch!=')') errfl(f__elist->cierr,112,"no )");
 333         f__ly = f__lx;
 334         f__lx = lz;
 335 #ifdef Allow_TYQUAD
 336         f__llx = 0;
 337 #endif
 338         nml_read = nml_save;
 339         return(0);
 340 }
 341
 342  static int
 343 l_L(Void)
 344 {
 345         int ch;
 346         if(f__lcount>0) return(0);
 347         f__lcount = 1;
 348         f__ltype=0;
 349         GETC(ch);
 350         if(isdigit(ch))
 351         {
 352                 rd_count(ch);
 353                 if(GETC(ch)!='*')
 354                         if(!f__cf || !feof(f__cf))
 355                                 errfl(f__elist->cierr,112,"no star");
 356                         else
 357                                 err(f__elist->cierr,(EOF),"lread");
 358                 GETC(ch);
 359         }
 360         if(ch == '.') GETC(ch);
 361         switch(ch)
 362         {
 363         case 't':
 364         case 'T':
 365                 f__lx=1;
 366                 break;
 367         case 'f':
 368         case 'F':
 369                 f__lx=0;
 370                 break;
 371         default:
 372                 if(isblnk(ch) || issep(ch) || ch==EOF)
 373                 {       (void) Ungetc(ch,f__cf);
 374                         return(0);
 375                 }
 376                 if (nml_read > 1) {
 377                         Ungetc(ch,f__cf);
 378                         f__lquit = 2;
 379                         return 0;
 380                         }
 381                 errfl(f__elist->cierr,112,"logical");
 382         }
 383         f__ltype=TYLONG;
 384         while(!issep(GETC(ch)) && ch!=EOF);
 385         (void) Ungetc(ch, f__cf);
 386         return(0);
 387 }
 388
 389 #define BUFSIZE 128
 390
 391  static int
 392 l_CHAR(Void)
 393 {       int ch,size,i;
 394         static char rafail[] = "realloc failure";
 395         char quote,*p;
 396         if(f__lcount>0) return(0);
 397         f__ltype=0;
 398         if(f__lchar!=NULL) free(f__lchar);
 399         size=BUFSIZE;
 400         p=f__lchar = (char *)malloc((unsigned int)size);
 401         if(f__lchar == NULL)
 402                 errfl(f__elist->cierr,113,"no space");
 403
 404         GETC(ch);
 405         if(isdigit(ch)) {
 406                 /* allow Fortran 8x-style unquoted string...    */
 407                 /* either find a repetition count or the string */
 408                 f__lcount = ch - '0';
 409                 *p++ = ch;
 410                 for(i = 1;;) {
 411                         switch(GETC(ch)) {
 412                                 case '*':
 413                                         if (f__lcount == 0) {
 414                                                 f__lcount = 1;
 415 #ifndef F8X_NML_ELIDE_QUOTES
 416                                                 if (nml_read)
 417                                                         goto no_quote;
 418 #endif
 419                                                 goto noquote;
 420                                                 }
 421                                         p = f__lchar;
 422                                         goto have_lcount;
 423                                 case ',':
 424                                 case ' ':
 425                                 case '\t':
 426                                 case '\n':
 427                                 case '/':
 428                                         Ungetc(ch,f__cf);
 429                                         /* no break */
 430                                 case EOF:
 431                                         f__lcount = 1;
 432                                         f__ltype = TYCHAR;
 433                                         return *p = 0;
 434                                 }
 435                         if (!isdigit(ch)) {
 436                                 f__lcount = 1;
 437 #ifndef F8X_NML_ELIDE_QUOTES
 438                                 if (nml_read) {
 439  no_quote:
 440                                         errfl(f__elist->cierr,112,
 441                                                 "undelimited character string");
 442                                         }
 443 #endif
 444                                 goto noquote;
 445                                 }
 446                         *p++ = ch;
 447                         f__lcount = 10*f__lcount + ch - '0';
 448                         if (++i == size) {
 449                                 f__lchar = (char *)realloc(f__lchar,
 450                                         (unsigned int)(size += BUFSIZE));
 451                                 if(f__lchar == NULL)
 452                                         errfl(f__elist->cierr,113,rafail);
 453                                 p = f__lchar + i;
 454                                 }
 455                         }
 456                 }
 457         else    (void) Ungetc(ch,f__cf);
 458  have_lcount:
 459         if(GETC(ch)=='\'' || ch=='"') quote=ch;
 460         else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
 461                 Ungetc(ch,f__cf);
 462                 return 0;
 463                 }
 464 #ifndef F8X_NML_ELIDE_QUOTES
 465         else if (nml_read > 1) {
 466                 Ungetc(ch,f__cf);
 467                 f__lquit = 2;
 468                 return 0;
 469                 }
 470 #endif
 471         else {
 472                 /* Fortran 8x-style unquoted string */
 473                 *p++ = ch;
 474                 for(i = 1;;) {
 475                         switch(GETC(ch)) {
 476                                 case ',':
 477                                 case ' ':
 478                                 case '\t':
 479                                 case '\n':
 480                                 case '/':
 481                                         Ungetc(ch,f__cf);
 482                                         /* no break */
 483                                 case EOF:
 484                                         f__ltype = TYCHAR;
 485                                         return *p = 0;
 486                                 }
 487  noquote:
 488                         *p++ = ch;
 489                         if (++i == size) {
 490                                 f__lchar = (char *)realloc(f__lchar,
 491                                         (unsigned int)(size += BUFSIZE));
 492                                 if(f__lchar == NULL)
 493                                         errfl(f__elist->cierr,113,rafail);
 494                                 p = f__lchar + i;
 495                                 }
 496                         }
 497                 }
 498         f__ltype=TYCHAR;
 499         for(i=0;;)
 500         {       while(GETC(ch)!=quote && ch!='\n'
 501                         && ch!=EOF && ++i<size) *p++ = ch;
 502                 if(i==size)
 503                 {
 504                 newone:
 505                         f__lchar= (char *)realloc(f__lchar,
 506                                         (unsigned int)(size += BUFSIZE));
 507                         if(f__lchar == NULL)
 508                                 errfl(f__elist->cierr,113,rafail);
 509                         p=f__lchar+i-1;
 510                         *p++ = ch;
 511                 }
 512                 else if(ch==EOF) return(EOF);
 513                 else if(ch=='\n')
 514                 {       if(*(p-1) != '\\') continue;
 515                         i--;
 516                         p--;
 517                         if(++i<size) *p++ = ch;
 518                         else goto newone;
 519                 }
 520                 else if(GETC(ch)==quote)
 521                 {       if(++i<size) *p++ = ch;
 522                         else goto newone;
 523                 }
 524                 else
 525                 {       (void) Ungetc(ch,f__cf);
 526                         *p = 0;
 527                         return(0);
 528                 }
 529         }
 530 }
 531 #ifdef KR_headers
 532 c_le(a) cilist *a;
 533 #else
 534 c_le(cilist *a)
 535 #endif
 536 {
 537         if(f__init != 1) f_init();
 538         f__init = 3;
 539         f__fmtbuf="list io";
 540         f__curunit = &f__units[a->ciunit];
 541         f__fmtlen=7;
 542         if(a->ciunit>=MXUNIT || a->ciunit<0)
 543                 err(a->cierr,101,"stler");
 544         f__scale=f__recpos=0;
 545         f__elist=a;
 546         if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
 547                 err(a->cierr,102,"lio");
 548         f__cf=f__curunit->ufd;
 549         if(!f__curunit->ufmt) err(a->cierr,103,"lio");
 550         return(0);
 551 }
 552 #ifdef KR_headers
 553 l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
 554 #else
 555 l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
 556 #endif
 557 {
 558 #define Ptr ((flex *)ptr)
 559         int i,n,ch;
 560         doublereal *yy;
 561         real *xx;
 562         for(i=0;i<*number;i++)
 563         {
 564                 if(f__lquit) return(0);
 565                 if(l_eof)
 566                         err(f__elist->ciend, EOF, "list in");
 567                 if(f__lcount == 0) {
 568                         f__ltype = 0;
 569                         for(;;)  {
 570                                 GETC(ch);
 571                                 switch(ch) {
 572                                 case EOF:
 573                                         err(f__elist->ciend,(EOF),"list in");
 574                                 case ' ':
 575                                 case '\t':
 576                                 case '\n':
 577                                         continue;
 578                                 case '/':
 579                                         f__lquit = 1;
 580                                         goto loopend;
 581                                 case ',':
 582                                         f__lcount = 1;
 583                                         goto loopend;
 584                                 default:
 585                                         (void) Ungetc(ch, f__cf);
 586                                         goto rddata;
 587                                 }
 588                         }
 589                 }
 590         rddata:
 591                 switch((int)type)
 592                 {
 593                 case TYINT1:
 594                 case TYSHORT:
 595                 case TYLONG:
 596 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
 597                         ERR(l_R(0,1));
 598                         break;
 599 #endif
 600                 case TYREAL:
 601                 case TYDREAL:
 602                         ERR(l_R(0,0));
 603                         break;
 604 #ifdef TYQUAD
 605                 case TYQUAD:
 606                         n = l_R(0,2);
 607                         if (n)
 608                                 return n;
 609                         break;
 610 #endif
 611                 case TYCOMPLEX:
 612                 case TYDCOMPLEX:
 613                         ERR(l_C());
 614                         break;
 615                 case TYLOGICAL1:
 616                 case TYLOGICAL2:
 617                 case TYLOGICAL:
 618                         ERR(l_L());
 619                         break;
 620                 case TYCHAR:
 621                         ERR(l_CHAR());
 622                         break;
 623                 }
 624         while (GETC(ch) == ' ' || ch == '\t');
 625         if (ch != ',' || f__lcount > 1)
 626                 Ungetc(ch,f__cf);
 627         loopend:
 628                 if(f__lquit) return(0);
 629                 if(f__cf && ferror(f__cf)) {
 630                         clearerr(f__cf);
 631                         errfl(f__elist->cierr,errno,"list in");
 632                         }
 633                 if(f__ltype==0) goto bump;
 634                 switch((int)type)
 635                 {
 636                 case TYINT1:
 637                 case TYLOGICAL1:
 638                         Ptr->flchar = (char)f__lx;
 639                         break;
 640                 case TYLOGICAL2:
 641                 case TYSHORT:
 642                         Ptr->flshort = (short)f__lx;
 643                         break;
 644                 case TYLOGICAL:
 645                 case TYLONG:
 646                         Ptr->flint = (ftnint)f__lx;
 647                         break;
 648 #ifdef Allow_TYQUAD
 649                 case TYQUAD:
 650                         if (!(Ptr->fllongint = f__llx))
 651                                 Ptr->fllongint = f__lx;
 652                         break;
 653 #endif
 654                 case TYREAL:
 655                         Ptr->flreal=f__lx;
 656                         break;
 657                 case TYDREAL:
 658                         Ptr->fldouble=f__lx;
 659                         break;
 660                 case TYCOMPLEX:
 661                         xx=(real *)ptr;
 662                         *xx++ = f__lx;
 663                         *xx = f__ly;
 664                         break;
 665                 case TYDCOMPLEX:
 666                         yy=(doublereal *)ptr;
 667                         *yy++ = f__lx;
 668                         *yy = f__ly;
 669                         break;
 670                 case TYCHAR:
 671                         b_char(f__lchar,ptr,len);
 672                         break;
 673                 }
 674         bump:
 675                 if(f__lcount>0) f__lcount--;
 676                 ptr += len;
 677                 if (nml_read)
 678                         nml_read++;
 679         }
 680         return(0);
 681 #undef Ptr
 682 }
 683 #ifdef KR_headers
 684 integer s_rsle(a) cilist *a;
 685 #else
 686 integer s_rsle(cilist *a)
 687 #endif
 688 {
 689         int n;
 690
 691         f__reading=1;
 692         f__external=1;
 693         f__formatted=1;
 694         if(n=c_le(a)) return(n);
 695         f__lioproc = l_read;
 696         f__lquit = 0;
 697         f__lcount = 0;
 698         l_eof = 0;
 699         if(f__curunit->uwrt && f__nowreading(f__curunit))
 700                 err(a->cierr,errno,"read start");
 701         if(f__curunit->uend)
 702                 err(f__elist->ciend,(EOF),"read start");
 703         l_getc = t_getc;
 704         l_ungetc = un_getc;
 705         f__doend = xrd_SL;
 706         return(0);
 707 }