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