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